----------------------------------------------------------------------------- -- | -- 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' exeScope' buildInfo') Nothing = (if modulePath' == "" then mempty else text "main-is:" <+> text modulePath') $+$ if exeScope' == mempty then mempty else text "scope:" <+> disp exeScope' $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo' $+$ ppCustomFields (customFieldsBI buildInfo') ppExe (Executable _ modulePath' exeScope' buildInfo') (Just (Executable _ modulePath2 exeScope2 buildInfo2)) = (if modulePath' == "" || modulePath' == modulePath2 then mempty else text "main-is:" <+> text modulePath') $+$ if exeScope' == exeScope2 then mempty else text "scope:" <+> disp exeScope' $+$ 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)