content: -----------------------------------------------------------------------------
  -- |
  -- Module      :  Distribution.PackageDescription.PrettyPrint
  -- Copyright   :  Jürgen Nicklisch-Franken 2010
  -- License     :  BSD3
  --
  -- Maintainer  : cabal-devel@haskell.org
  -- Stability   : provisional
  -- Portability : portable
  --
  -- Pretty printing for cabal files
  --
  -----------------------------------------------------------------------------
  
  module Distribution.PackageDescription.PrettyPrint (
      -- * Generic package descriptions
      writeGenericPackageDescription,
      showGenericPackageDescription,
  
      -- * Package descriptions
       writePackageDescription,
       showPackageDescription,
  
       -- ** Supplementary build information
       writeHookedBuildInfo,
       showHookedBuildInfo,
  ) where
  
  import Prelude ()
  import Distribution.Compat.Prelude
  
  import Distribution.Types.Dependency
  import Distribution.Types.ForeignLib
  import Distribution.Types.UnqualComponentName
  import Distribution.Types.CondTree
  
  import Distribution.PackageDescription
  import Distribution.Simple.Utils
  import Distribution.ParseUtils
  import Distribution.PackageDescription.Parse
  import Distribution.Text
  import Distribution.ModuleName
  
  import Text.PrettyPrint
         (hsep, space, parens, char, nest, isEmpty, ($$), (<+>),
          colon, text, vcat, ($+$), Doc, render)
  
  import qualified Data.ByteString.Lazy.Char8 as BS.Char8
  
  -- | Recompile with false for regression testing
  simplifiedPrinting :: Bool
  simplifiedPrinting = False
  
  -- | Writes a .cabal file from a generic package description
  writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> NoCallStackIO ()
  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)
          $+$ ppCondLibrary (condLibrary gpd)
          $+$ ppCondSubLibraries (condSubLibraries gpd)
          $+$ ppCondExecutables (condExecutables gpd)
          $+$ ppCondTestSuites (condTestSuites gpd)
          $+$ ppCondBenchmarks (condBenchmarks gpd)
  
  ppPackageDescription :: PackageDescription -> Doc
  ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd
                                                  $+$ ppCustomFields (customFieldsPD pd)
                                                  $+$ ppSourceRepos (sourceRepos pd)
  
  ppSourceRepos :: [SourceRepo] -> Doc
  ppSourceRepos []                         = mempty
  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"]
  
  -- TODO: this is a temporary hack. Ideally, fields containing default values
  -- would be filtered out when the @FieldDescr a@ list is generated.
  ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc
  ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x
    where
      nondefault (FieldDescr name getter _) =
          maybe True (render (getter x) /=) (lookup name removable)
  
  binfoDefaults :: [(String, String)]
  binfoDefaults = [("buildable", "True")]
  
  libDefaults :: [(String, String)]
  libDefaults = ("exposed", "True") : binfoDefaults
  
  flagDefaults :: [(String, String)]
  flagDefaults = [("default", "True"), ("manual", "False")]
  
  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 flag@(MkFlag name _ _ _)    =
      emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields
    where
      fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag
  
  ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc
  ppCondLibrary Nothing = mempty
  ppCondLibrary (Just condTree) =
      emptyLine $ text "library"
          $+$ nest indentWith (ppCondTree condTree Nothing ppLib) 
  ppCondSubLibraries :: [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> Doc
  ppCondSubLibraries libs                           =
      vcat [emptyLine $ (text "library " <+> disp n)
                $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs]
  
  ppLib :: Library -> Maybe Library -> Doc
  ppLib lib Nothing     = ppFieldsFiltered libDefaults libFieldDescrs lib
                          $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
  ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
                          $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
  
  ppCondExecutables :: [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> Doc
  ppCondExecutables exes                       =
      vcat [emptyLine $ (text "executable " <+> disp n)
                $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]
    where
      ppExe (Executable _ modulePath' buildInfo') Nothing =
          (if modulePath' == "" then mempty else text "main-is:" <+> text modulePath')
              $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo'
              $+$  ppCustomFields (customFieldsBI buildInfo')
      ppExe (Executable _ modulePath' buildInfo')
              (Just (Executable _ modulePath2 buildInfo2)) =
              (if modulePath' == "" || modulePath' == modulePath2
                  then mempty else text "main-is:" <+> text modulePath')
              $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
              $+$ ppCustomFields (customFieldsBI buildInfo')
  
  ppCondTestSuites :: [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> Doc
  ppCondTestSuites suites =
      emptyLine $ vcat [     (text "test-suite " <+> disp n)
                         $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)
                       | (n,condTree) <- suites]
    where
      ppTestSuite testsuite Nothing =
                  maybe mempty (\t -> text "type:"        <+> disp t)
                              maybeTestType
              $+$ maybe mempty (\f -> text "main-is:"     <+> text f)
                              (testSuiteMainIs testsuite)
              $+$ maybe mempty (\m -> text "test-module:" <+> disp m)
                              (testSuiteModule testsuite)
              $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)
              $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
        where
          maybeTestType | testInterface testsuite == mempty = Nothing
                        | otherwise = Just (testType testsuite)
  
      ppTestSuite test' (Just test2) =
              ppDiffFields binfoFieldDescrs
                  (testBuildInfo test') (testBuildInfo test2)
              $+$ ppCustomFields (customFieldsBI (testBuildInfo test'))
  
      testSuiteMainIs test = case testInterface test of
        TestSuiteExeV10 _ f -> Just f
        _                   -> Nothing
  
      testSuiteModule test = case testInterface test of
        TestSuiteLibV09 _ m -> Just m
        _                   -> Nothing
  
  ppCondBenchmarks :: [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> Doc
  ppCondBenchmarks suites =
      emptyLine $ vcat [     (text "benchmark " <+> disp n)
                         $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)
                       | (n,condTree) <- suites]
    where
      ppBenchmark benchmark Nothing =
                  maybe mempty (\t -> text "type:"        <+> disp t)
                              maybeBenchmarkType
              $+$ maybe mempty (\f -> text "main-is:"     <+> text f)
                              (benchmarkMainIs benchmark)
              $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)
              $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))
        where
          maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
                             | otherwise = Just (benchmarkType benchmark)
  
      ppBenchmark bench' (Just bench2) =
              ppDiffFields binfoFieldDescrs
                  (benchmarkBuildInfo bench') (benchmarkBuildInfo bench2)
              $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo bench'))
  
      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                               = text . unFlagName
  
  ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc
  ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =
      let res = (vcat $ map ppIf ifs)
                  $+$ ppIt it mbIt
      in if isJust mbIt && isEmpty res
          then ppCondTree ct Nothing ppIt
          else res
    where
      -- TODO: this ends up printing trailing spaces when combined with nest.
      ppIf (CondBranch c thenTree (Just elseTree)) = ppIfElse it ppIt c thenTree elseTree
      ppIf (CondBranch c thenTree Nothing)         = ppIf' it ppIt c thenTree
  
  ppIfCondition :: (Condition ConfVar) -> Doc
  ppIfCondition c = (emptyLine $ text "if" <+> ppCondition c)
  
  ppIf' :: a -> (a -> Maybe a -> Doc)
             -> Condition ConfVar
             -> CondTree ConfVar [Dependency] a
             -> Doc
  ppIf' it ppIt c thenTree =
    if isEmpty thenDoc
       then mempty
       else ppIfCondition c $$ nest indentWith thenDoc
    where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
  
  ppIfElse :: a -> (a -> Maybe a -> Doc)
                -> Condition ConfVar
                -> CondTree ConfVar [Dependency] a
                -> CondTree ConfVar [Dependency] a
                -> Doc
  ppIfElse it ppIt c thenTree elseTree =
    case (isEmpty thenDoc, isEmpty elseDoc) of
      (True,  True)  -> mempty
      (False, True)  -> ppIfCondition c $$ nest indentWith thenDoc
      (True,  False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc
      (False, False) -> (ppIfCondition c $$ nest indentWith thenDoc)
                        $+$ (text "else" $$ nest indentWith elseDoc)
    where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
          elseDoc = ppCondTree elseTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
  
  emptyLine :: Doc -> Doc
  emptyLine d                              = text "" $+$ d
  
  -- | @since 1.26.0.0@
  writePackageDescription :: FilePath -> PackageDescription -> NoCallStackIO ()
  writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
  
  --TODO: make this use section syntax
  -- add equivalent for GenericPackageDescription
  
  -- | @since 1.26.0.0@
  showPackageDescription :: PackageDescription -> String
  showPackageDescription pkg = render $
       ppPackageDescription pkg
       $+$ ppMaybeLibrary (library pkg)
       $+$ ppSubLibraries (subLibraries pkg)
       $+$ ppForeignLibs  (foreignLibs pkg)
       $+$ ppExecutables  (executables pkg)
       $+$ ppTestSuites   (testSuites pkg)
       $+$ ppBenchmarks   (benchmarks pkg)
  
  ppMaybeLibrary :: Maybe Library -> Doc
  ppMaybeLibrary Nothing = mempty
  ppMaybeLibrary (Just lib) =
      emptyLine $ text "library"
          $+$ nest indentWith (ppFields libFieldDescrs lib)
  
  ppSubLibraries :: [Library] -> Doc
  ppSubLibraries libs = vcat [
      emptyLine $ text "library" <+> disp libname
          $+$ nest indentWith (ppFields libFieldDescrs lib)
      | lib@Library{ libName = Just libname } <- libs ]
  
  ppForeignLibs :: [ForeignLib] -> Doc
  ppForeignLibs flibs = vcat [
      emptyLine $ text "foreign library" <+> disp flibname
          $+$ nest indentWith (ppFields foreignLibFieldDescrs flib)
      | flib@ForeignLib{ foreignLibName = flibname } <- flibs ]
  
  ppExecutables :: [Executable] -> Doc
  ppExecutables exes = vcat [
      emptyLine $ text "executable" <+> disp (exeName exe)
          $+$ nest indentWith (ppFields executableFieldDescrs exe)
      | exe <- exes ]
  
  ppTestSuites :: [TestSuite] -> Doc
  ppTestSuites tests = vcat [
      emptyLine $ text "test-suite" <+> disp (testName test)
          $+$ nest indentWith (ppFields testSuiteFieldDescrs test_stanza)
      | test <- tests
      , let test_stanza
              = TestSuiteStanza {
                  testStanzaTestType = Just (testSuiteInterfaceToTestType (testInterface test)),
                  testStanzaMainIs = testSuiteInterfaceToMaybeMainIs (testInterface test),
                  testStanzaTestModule = testSuiteInterfaceToMaybeModule (testInterface test),
                  testStanzaBuildInfo = testBuildInfo test
              }
      ]
  
  testSuiteInterfaceToTestType :: TestSuiteInterface -> TestType
  testSuiteInterfaceToTestType (TestSuiteExeV10 ver _) = TestTypeExe ver
  testSuiteInterfaceToTestType (TestSuiteLibV09 ver _) = TestTypeLib ver
  testSuiteInterfaceToTestType (TestSuiteUnsupported ty) = ty
  
  testSuiteInterfaceToMaybeMainIs :: TestSuiteInterface -> Maybe FilePath
  testSuiteInterfaceToMaybeMainIs (TestSuiteExeV10 _ fp) = Just fp
  testSuiteInterfaceToMaybeMainIs TestSuiteLibV09{} = Nothing
  testSuiteInterfaceToMaybeMainIs TestSuiteUnsupported{} = Nothing
  
  testSuiteInterfaceToMaybeModule :: TestSuiteInterface -> Maybe ModuleName
  testSuiteInterfaceToMaybeModule (TestSuiteLibV09 _ mod_name) = Just mod_name
  testSuiteInterfaceToMaybeModule TestSuiteExeV10{} = Nothing
  testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing
  
  ppBenchmarks :: [Benchmark] -> Doc
  ppBenchmarks benchs = vcat [
      emptyLine $ text "benchmark" <+> disp (benchmarkName bench)
          $+$ nest indentWith (ppFields benchmarkFieldDescrs bench_stanza)
      | bench <- benchs
      , let bench_stanza = BenchmarkStanza {
                  benchmarkStanzaBenchmarkType = Just (benchmarkInterfaceToBenchmarkType (benchmarkInterface bench)),
                  benchmarkStanzaMainIs = benchmarkInterfaceToMaybeMainIs (benchmarkInterface bench),
                  benchmarkStanzaBenchmarkModule = Nothing,
                  benchmarkStanzaBuildInfo = benchmarkBuildInfo bench
              }]
  
  benchmarkInterfaceToBenchmarkType :: BenchmarkInterface -> BenchmarkType
  benchmarkInterfaceToBenchmarkType (BenchmarkExeV10 ver _)   = BenchmarkTypeExe ver
  benchmarkInterfaceToBenchmarkType (BenchmarkUnsupported ty) = ty
  
  benchmarkInterfaceToMaybeMainIs :: BenchmarkInterface -> Maybe FilePath
  benchmarkInterfaceToMaybeMainIs (BenchmarkExeV10 _ fp) = Just fp
  benchmarkInterfaceToMaybeMainIs BenchmarkUnsupported{} = Nothing
  
  
  -- | @since 1.26.0.0@
  writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> NoCallStackIO ()
  writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
                               . showHookedBuildInfo
  
  -- | @since 1.26.0.0@
  showHookedBuildInfo :: HookedBuildInfo -> String
  showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
       (case mb_lib_bi of
          Nothing -> mempty
          Just bi -> ppBuildInfo bi)
     $$ vcat [    space
               $$ (text "executable:" <+> disp name)
               $$ ppBuildInfo bi
             | (name, bi) <- ex_bis ]
    where
       ppBuildInfo bi = ppFields binfoFieldDescrs bi
                     $$ ppCustomFields (customFieldsBI bi)
  