hackport-0.5.1: cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
-----------------------------------------------------------------------------
-- |
-- 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.ForeignLib
import Distribution.PackageDescription
import Distribution.Simple.Utils
import Distribution.ParseUtils
import Distribution.PackageDescription.Parse
import Distribution.Package
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 (c, thenTree, Just elseTree) = ppIfElse it ppIt c thenTree elseTree
ppIf (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)