content: -----------------------------------------------------------------------------
  --
  -- Module      :  Distribution.PackageDescription.PrettyPrint
  -- Copyright   :  Jürgen Nicklisch-Franken 2010
  -- License     :  AllRightsReserved
  --
  -- Maintainer  : cabal-devel@haskell.org
  -- Stability   : provisional
  -- Portability : portable
  --
  -- | Pretty printing for cabal files
  --
  -----------------------------------------------------------------------------
  {- All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are
  met:
  
      * Redistributions of source code must retain the above copyright
        notice, this list of conditions and the following disclaimer.
  
      * Redistributions in binary form must reproduce the above
        copyright notice, this list of conditions and the following
        disclaimer in the documentation and/or other materials provided
        with the distribution.
  
      * Neither the name of Isaac Jones nor the names of other
        contributors may be used to endorse or promote products derived
        from this software without specific prior written permission.
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
  
  module Distribution.PackageDescription.PrettyPrint (
      writeGenericPackageDescription,
      showGenericPackageDescription,
  ) where
  
  import Data.Monoid (Monoid(mempty))
  import Distribution.PackageDescription
         ( Benchmark(..), BenchmarkInterface(..), benchmarkType
         , TestSuite(..), TestSuiteInterface(..), testType
         , SourceRepo(..),
          customFieldsBI, CondTree(..), Condition(..),
          FlagName(..), ConfVar(..), Executable(..), Library(..),
          Flag(..), PackageDescription(..),
          GenericPackageDescription(..))
  import Text.PrettyPrint
         (hsep, comma, punctuate, fsep, parens, char, nest, empty,
          isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
  import Distribution.Simple.Utils (writeUTF8File)
  import Distribution.ParseUtils (showFreeText, FieldDescr(..))
  import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
         sourceRepoFieldDescrs)
  import Distribution.Package (Dependency(..))
  import Distribution.Text (Text(..))
  import Data.Maybe (isJust, fromJust, isNothing)
  
  indentWith :: Int
  indentWith = 4
  
  -- | Recompile with false for regression testing
  simplifiedPrinting :: Bool
  simplifiedPrinting = False
  
  -- | Writes a .cabal file from a generic package description
  writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
  writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)
  
  -- | Writes a generic package description to a string
  showGenericPackageDescription :: GenericPackageDescription -> String
  showGenericPackageDescription            = render . ppGenericPackageDescription
  
  ppGenericPackageDescription :: GenericPackageDescription -> Doc
  ppGenericPackageDescription gpd          =
          ppPackageDescription (packageDescription gpd)
          $+$ ppGenPackageFlags (genPackageFlags gpd)
          $+$ ppLibrary (condLibrary gpd)
          $+$ ppExecutables (condExecutables gpd)
          $+$ ppTestSuites (condTestSuites gpd)
          $+$ ppBenchmarks (condBenchmarks gpd)
  
  ppPackageDescription :: PackageDescription -> Doc
  ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd
                                                  $+$ ppCustomFields (customFieldsPD pd)
                                                  $+$ ppSourceRepos (sourceRepos pd)
  
  ppSourceRepos :: [SourceRepo] -> Doc
  ppSourceRepos []                         = empty
  ppSourceRepos (hd:tl)                    = ppSourceRepo hd $+$ ppSourceRepos tl
  
  ppSourceRepo :: SourceRepo -> Doc
  ppSourceRepo repo                        =
      emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$
          (nest indentWith (ppFields sourceRepoFieldDescrs' repo))
    where
      sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]
  
  ppFields :: [FieldDescr a] -> a -> Doc
  ppFields fields x                        =
      vcat [ ppField name (getter x)
                           | FieldDescr name getter _ <- fields]
  
  ppField :: String -> Doc -> Doc
  ppField name fielddoc | isEmpty fielddoc = empty
                        | otherwise        = text name <> colon <+> fielddoc
  
  ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
  ppDiffFields fields x y                  =
      vcat [ ppField name (getter x)
                           | FieldDescr name getter _ <- fields,
                              render (getter x) /= render (getter y)]
  
  ppCustomFields :: [(String,String)] -> Doc
  ppCustomFields flds                      = vcat [ppCustomField f | f <- flds]
  
  ppCustomField :: (String,String) -> Doc
  ppCustomField (name,val)                 = text name <> colon <+> showFreeText val
  
  ppGenPackageFlags :: [Flag] -> Doc
  ppGenPackageFlags flds                   = vcat [ppFlag f | f <- flds]
  
  ppFlag :: Flag -> Doc
  ppFlag (MkFlag name desc dflt manual)    =
      emptyLine $ text "flag" <+> ppFlagName name $+$
              (nest indentWith ((if null desc
                                  then empty
                                  else  text "Description: " <+> showFreeText desc) $+$
                       (if dflt then empty else text "Default: False") $+$
                       (if manual then text "Manual: True" else empty)))
  
  ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc
  ppLibrary Nothing                        = empty
  ppLibrary (Just condTree)                =
      emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)
    where
      ppLib lib Nothing     = ppFields libFieldDescrs lib
                              $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
      ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
                              $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
  
  ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc
  ppExecutables exes                       =
      vcat [emptyLine $ text ("executable " ++ n)
                $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]
    where
      ppExe (Executable _ modulePath' buildInfo') Nothing =
          (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')
              $+$ ppFields binfoFieldDescrs buildInfo'
              $+$  ppCustomFields (customFieldsBI buildInfo')
      ppExe (Executable _ modulePath' buildInfo')
              (Just (Executable _ modulePath2 buildInfo2)) =
              (if modulePath' == "" || modulePath' == modulePath2
                  then empty else text "main-is:" <+> text modulePath')
              $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
              $+$ ppCustomFields (customFieldsBI buildInfo')
  
  ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc
  ppTestSuites suites =
      emptyLine $ vcat [     text ("test-suite " ++ n)
                         $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)
                       | (n,condTree) <- suites]
    where
      ppTestSuite testsuite Nothing =
                  maybe empty (\t -> text "type:"        <+> disp t)
                              maybeTestType
              $+$ maybe empty (\f -> text "main-is:"     <+> text f)
                              (testSuiteMainIs testsuite)
              $+$ maybe empty (\m -> text "test-module:" <+> disp m)
                              (testSuiteModule testsuite)
              $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
              $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
        where
          maybeTestType | testInterface testsuite == mempty = Nothing
                        | otherwise = Just (testType testsuite)
  
      ppTestSuite (TestSuite _ _ buildInfo' _)
                      (Just (TestSuite _ _ buildInfo2 _)) =
              ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
              $+$ ppCustomFields (customFieldsBI buildInfo')
  
      testSuiteMainIs test = case testInterface test of
        TestSuiteExeV10 _ f -> Just f
        _                   -> Nothing
  
      testSuiteModule test = case testInterface test of
        TestSuiteLibV09 _ m -> Just m
        _                   -> Nothing
  
  ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc
  ppBenchmarks suites =
      emptyLine $ vcat [     text ("benchmark " ++ n)
                         $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)
                       | (n,condTree) <- suites]
    where
      ppBenchmark benchmark Nothing =
                  maybe empty (\t -> text "type:"        <+> disp t)
                              maybeBenchmarkType
              $+$ maybe empty (\f -> text "main-is:"     <+> text f)
                              (benchmarkMainIs benchmark)
              $+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)
              $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))
        where
          maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
                             | otherwise = Just (benchmarkType benchmark)
  
      ppBenchmark (Benchmark _ _ buildInfo' _)
                      (Just (Benchmark _ _ buildInfo2 _)) =
              ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
              $+$ ppCustomFields (customFieldsBI buildInfo')
  
      benchmarkMainIs benchmark = case benchmarkInterface benchmark of
        BenchmarkExeV10 _ f -> Just f
        _                   -> Nothing
  
  ppCondition :: Condition ConfVar -> Doc
  ppCondition (Var x)                      = ppConfVar x
  ppCondition (Lit b)                      = text (show b)
  ppCondition (CNot c)                     = char '!' <> (ppCondition c)
  ppCondition (COr c1 c2)                  = parens (hsep [ppCondition c1, text "||"
                                                           <+> ppCondition c2])
  ppCondition (CAnd c1 c2)                 = parens (hsep [ppCondition c1, text "&&"
                                                           <+> ppCondition c2])
  ppConfVar :: ConfVar -> Doc
  ppConfVar (OS os)                        = text "os"   <> parens (disp os)
  ppConfVar (Arch arch)                    = text "arch" <> parens (disp arch)
  ppConfVar (Flag name)                    = text "flag" <> parens (ppFlagName name)
  ppConfVar (Impl c v)                     = text "impl" <> parens (disp c <+> disp v)
  
  ppFlagName :: FlagName -> Doc
  ppFlagName (FlagName name)               = text name
  
  ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc
  ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
      let res = ppDeps deps
                  $+$ (vcat $ map ppIf ifs)
                  $+$ ppIt it mbIt
      in if isJust mbIt && isEmpty res
          then ppCondTree ct Nothing ppIt
          else res
    where
      ppIf (c,thenTree,mElseTree)          =
          ((emptyLine $ text "if" <+> ppCondition c) $$
            nest indentWith (ppCondTree thenTree
                      (if simplifiedPrinting then (Just it) else Nothing) ppIt))
          $+$ (if isNothing mElseTree
                  then empty
                  else text "else"
                      $$ nest indentWith (ppCondTree (fromJust mElseTree)
                          (if simplifiedPrinting then (Just it) else Nothing) ppIt))
  
  ppDeps :: [Dependency] -> Doc
  ppDeps []                                = empty
  ppDeps deps                              =
      text "build-depends:" <+> fsep (punctuate comma (map disp deps))
  
  emptyLine :: Doc -> Doc
  emptyLine d                              = text " " $+$ d
  
  
  
  