Cabal/Distribution/PackageDescription/PrettyPrint.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Module      :  Distribution.PackageDescription.PrettyPrint
   4 -- Copyright   :  Jürgen Nicklisch-Franken 2010
   5 -- License     :  BSD3
   6 --
   7 -- Maintainer  : cabal-devel@haskell.org
   8 -- Stability   : provisional
   9 -- Portability : portable
  10 --
  11 -- | Pretty printing for cabal files
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Distribution.PackageDescription.PrettyPrint (
  16     writeGenericPackageDescription,
  17     showGenericPackageDescription,
  18 ) where
  19
  20 import Data.Monoid (Monoid(mempty))
  21 import Distribution.PackageDescription
  22        ( Benchmark(..), BenchmarkInterface(..), benchmarkType
  23        , TestSuite(..), TestSuiteInterface(..), testType
  24        , SourceRepo(..),
  25         customFieldsBI, CondTree(..), Condition(..),
  26         FlagName(..), ConfVar(..), Executable(..), Library(..),
  27         Flag(..), PackageDescription(..),
  28         GenericPackageDescription(..))
  29 import Text.PrettyPrint
  30        (hsep, comma, punctuate, parens, char, nest, empty,
  31         isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
  32 import Distribution.Simple.Utils (writeUTF8File)
  33 import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields)
  34 import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
  35        sourceRepoFieldDescrs)
  36 import Distribution.Package (Dependency(..))
  37 import Distribution.Text (Text(..))
  38 import Data.Maybe (isJust, fromJust, isNothing)
  39
  40 -- | Recompile with false for regression testing
  41 simplifiedPrinting :: Bool
  42 simplifiedPrinting = False
  43
  44 -- | Writes a .cabal file from a generic package description
  45 writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
  46 writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)
  47
  48 -- | Writes a generic package description to a string
  49 showGenericPackageDescription :: GenericPackageDescription -> String
  50 showGenericPackageDescription            = render . ppGenericPackageDescription
  51
  52 ppGenericPackageDescription :: GenericPackageDescription -> Doc
  53 ppGenericPackageDescription gpd          =
  54         ppPackageDescription (packageDescription gpd)
  55         $+$ ppGenPackageFlags (genPackageFlags gpd)
  56         $+$ ppLibrary (condLibrary gpd)
  57         $+$ ppExecutables (condExecutables gpd)
  58         $+$ ppTestSuites (condTestSuites gpd)
  59         $+$ ppBenchmarks (condBenchmarks gpd)
  60
  61 ppPackageDescription :: PackageDescription -> Doc
  62 ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd
  63                                                 $+$ ppCustomFields (customFieldsPD pd)
  64                                                 $+$ ppSourceRepos (sourceRepos pd)
  65
  66 ppSourceRepos :: [SourceRepo] -> Doc
  67 ppSourceRepos []                         = empty
  68 ppSourceRepos (hd:tl)                    = ppSourceRepo hd $+$ ppSourceRepos tl
  69
  70 ppSourceRepo :: SourceRepo -> Doc
  71 ppSourceRepo repo                        =
  72     emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$
  73         (nest indentWith (ppFields sourceRepoFieldDescrs' repo))
  74   where
  75     sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]
  76
  77 ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
  78 ppDiffFields fields x y                  =
  79    vcat [ ppField name (getter x)
  80         | FieldDescr name getter _ <- fields
  81         , render (getter x) /= render (getter y)
  82         ]
  83
  84 ppCustomFields :: [(String,String)] -> Doc
  85 ppCustomFields flds                      = vcat [ppCustomField f | f <- flds]
  86
  87 ppCustomField :: (String,String) -> Doc
  88 ppCustomField (name,val)                 = text name <> colon <+> showFreeText val
  89
  90 ppGenPackageFlags :: [Flag] -> Doc
  91 ppGenPackageFlags flds                   = vcat [ppFlag f | f <- flds]
  92
  93 ppFlag :: Flag -> Doc
  94 ppFlag (MkFlag name desc dflt manual)    =
  95     emptyLine $ text "flag" <+> ppFlagName name $+$
  96             (nest indentWith ((if null desc
  97                                 then empty
  98                                 else  text "Description: " <+> showFreeText desc) $+$
  99                      (if dflt then empty else text "Default: False") $+$
 100                      (if manual then text "Manual: True" else empty)))
 101
 102 ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc
 103 ppLibrary Nothing                        = empty
 104 ppLibrary (Just condTree)                =
 105     emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)
 106   where
 107     ppLib lib Nothing     = ppFields libFieldDescrs lib
 108                             $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
 109     ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
 110                             $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
 111
 112 ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc
 113 ppExecutables exes                       =
 114     vcat [emptyLine $ text ("executable " ++ n)
 115               $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]
 116   where
 117     ppExe (Executable _ modulePath' buildInfo') Nothing =
 118         (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')
 119             $+$ ppFields binfoFieldDescrs buildInfo'
 120             $+$  ppCustomFields (customFieldsBI buildInfo')
 121     ppExe (Executable _ modulePath' buildInfo')
 122             (Just (Executable _ modulePath2 buildInfo2)) =
 123             (if modulePath' == "" || modulePath' == modulePath2
 124                 then empty else text "main-is:" <+> text modulePath')
 125             $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
 126             $+$ ppCustomFields (customFieldsBI buildInfo')
 127
 128 ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc
 129 ppTestSuites suites =
 130     emptyLine $ vcat [     text ("test-suite " ++ n)
 131                        $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)
 132                      | (n,condTree) <- suites]
 133   where
 134     ppTestSuite testsuite Nothing =
 135                 maybe empty (\t -> text "type:"        <+> disp t)
 136                             maybeTestType
 137             $+$ maybe empty (\f -> text "main-is:"     <+> text f)
 138                             (testSuiteMainIs testsuite)
 139             $+$ maybe empty (\m -> text "test-module:" <+> disp m)
 140                             (testSuiteModule testsuite)
 141             $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
 142             $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
 143       where
 144         maybeTestType | testInterface testsuite == mempty = Nothing
 145                       | otherwise = Just (testType testsuite)
 146
 147     ppTestSuite (TestSuite _ _ buildInfo' _)
 148                     (Just (TestSuite _ _ buildInfo2 _)) =
 149             ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
 150             $+$ ppCustomFields (customFieldsBI buildInfo')
 151
 152     testSuiteMainIs test = case testInterface test of
 153       TestSuiteExeV10 _ f -> Just f
 154       _                   -> Nothing
 155
 156     testSuiteModule test = case testInterface test of
 157       TestSuiteLibV09 _ m -> Just m
 158       _                   -> Nothing
 159
 160 ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc
 161 ppBenchmarks suites =
 162     emptyLine $ vcat [     text ("benchmark " ++ n)
 163                        $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)
 164                      | (n,condTree) <- suites]
 165   where
 166     ppBenchmark benchmark Nothing =
 167                 maybe empty (\t -> text "type:"        <+> disp t)
 168                             maybeBenchmarkType
 169             $+$ maybe empty (\f -> text "main-is:"     <+> text f)
 170                             (benchmarkMainIs benchmark)
 171             $+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)
 172             $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))
 173       where
 174         maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing
 175                            | otherwise = Just (benchmarkType benchmark)
 176
 177     ppBenchmark (Benchmark _ _ buildInfo' _)
 178                     (Just (Benchmark _ _ buildInfo2 _)) =
 179             ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
 180             $+$ ppCustomFields (customFieldsBI buildInfo')
 181
 182     benchmarkMainIs benchmark = case benchmarkInterface benchmark of
 183       BenchmarkExeV10 _ f -> Just f
 184       _                   -> Nothing
 185
 186 ppCondition :: Condition ConfVar -> Doc
 187 ppCondition (Var x)                      = ppConfVar x
 188 ppCondition (Lit b)                      = text (show b)
 189 ppCondition (CNot c)                     = char '!' <> (ppCondition c)
 190 ppCondition (COr c1 c2)                  = parens (hsep [ppCondition c1, text "||"
 191                                                          <+> ppCondition c2])
 192 ppCondition (CAnd c1 c2)                 = parens (hsep [ppCondition c1, text "&&"
 193                                                          <+> ppCondition c2])
 194 ppConfVar :: ConfVar -> Doc
 195 ppConfVar (OS os)                        = text "os"   <> parens (disp os)
 196 ppConfVar (Arch arch)                    = text "arch" <> parens (disp arch)
 197 ppConfVar (Flag name)                    = text "flag" <> parens (ppFlagName name)
 198 ppConfVar (Impl c v)                     = text "impl" <> parens (disp c <+> disp v)
 199
 200 ppFlagName :: FlagName -> Doc
 201 ppFlagName (FlagName name)               = text name
 202
 203 ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc
 204 ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
 205     let res = ppDeps deps
 206                 $+$ (vcat $ map ppIf ifs)
 207                 $+$ ppIt it mbIt
 208     in if isJust mbIt && isEmpty res
 209         then ppCondTree ct Nothing ppIt
 210         else res
 211   where
 212     ppIf (c,thenTree,mElseTree)          =
 213         ((emptyLine $ text "if" <+> ppCondition c) $$
 214           nest indentWith (ppCondTree thenTree
 215                     (if simplifiedPrinting then (Just it) else Nothing) ppIt))
 216         $+$ (if isNothing mElseTree
 217                 then empty
 218                 else text "else"
 219                     $$ nest indentWith (ppCondTree (fromJust mElseTree)
 220                         (if simplifiedPrinting then (Just it) else Nothing) ppIt))
 221
 222 ppDeps :: [Dependency] -> Doc
 223 ppDeps []                                = empty
 224 ppDeps deps                              =
 225     text "build-depends:" $+$ nest indentWith (vcat (punctuate comma (map disp deps)))
 226
 227 emptyLine :: Doc -> Doc
 228 emptyLine d                              = text " " $+$ d
 229
 230
 231