PrettyPrint.hs 10.9 KB
Newer Older
jutaro's avatar
jutaro committed
1
-----------------------------------------------------------------------------
Ian D. Bollinger's avatar
Ian D. Bollinger committed
2
-- |
jutaro's avatar
jutaro committed
3
4
-- Module      :  Distribution.PackageDescription.PrettyPrint
-- Copyright   :  Jürgen Nicklisch-Franken 2010
5
-- License     :  BSD3
jutaro's avatar
jutaro committed
6
7
8
9
10
--
-- Maintainer  : cabal-devel@haskell.org
-- Stability   : provisional
-- Portability : portable
--
Ian D. Bollinger's avatar
Ian D. Bollinger committed
11
-- Pretty printing for cabal files
jutaro's avatar
jutaro committed
12
13
14
15
16
17
18
19
--
-----------------------------------------------------------------------------

module Distribution.PackageDescription.PrettyPrint (
    writeGenericPackageDescription,
    showGenericPackageDescription,
) where

20
import Data.Monoid (Monoid(mempty))
jutaro's avatar
jutaro committed
21
import Distribution.PackageDescription
tibbe's avatar
tibbe committed
22
23
       ( Benchmark(..), BenchmarkInterface(..), benchmarkType
       , TestSuite(..), TestSuiteInterface(..), testType
24
25
26
27
       , SourceRepo(..),
        customFieldsBI, CondTree(..), Condition(..),
        FlagName(..), ConfVar(..), Executable(..), Library(..),
        Flag(..), PackageDescription(..),
jutaro's avatar
jutaro committed
28
29
        GenericPackageDescription(..))
import Text.PrettyPrint
30
       (hsep, comma, punctuate, parens, char, nest, empty,
31
        isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
jutaro's avatar
jutaro committed
32
import Distribution.Simple.Utils (writeUTF8File)
33
import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields)
jutaro's avatar
jutaro committed
34
import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
35
       sourceRepoFieldDescrs,flagFieldDescrs)
jutaro's avatar
jutaro committed
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
import Distribution.Package (Dependency(..))
import Distribution.Text (Text(..))
import Data.Maybe (isJust, fromJust, isNothing)

-- | 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)
tibbe's avatar
tibbe committed
59
        $+$ ppBenchmarks (condBenchmarks gpd)
jutaro's avatar
jutaro committed
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

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"]

77
78
-- TODO: this is a temporary hack. Ideally, fields containing default values
-- would be filtered out when the @FieldDescr a@ list is generated.
79
ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc
Ian D. Bollinger's avatar
Ian D. Bollinger committed
80
81
82
ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x
  where
    nondefault (FieldDescr name getter _) =
83
84
85
86
87
88
89
90
91
92
        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")]
Ian D. Bollinger's avatar
Ian D. Bollinger committed
93

jutaro's avatar
jutaro committed
94
95
ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
ppDiffFields fields x y                  =
96
97
98
99
   vcat [ ppField name (getter x)
        | FieldDescr name getter _ <- fields
        , render (getter x) /= render (getter y)
        ]
jutaro's avatar
jutaro committed
100
101
102
103
104
105
106
107
108
109
110

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
111
ppFlag flag@(MkFlag name _ _ _)    =
112
    emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields
113
114
  where
    fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag
jutaro's avatar
jutaro committed
115
116
117
118
119
120

ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc
ppLibrary Nothing                        = empty
ppLibrary (Just condTree)                =
    emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)
  where
121
    ppLib lib Nothing     = ppFieldsFiltered libDefaults libFieldDescrs lib
jutaro's avatar
jutaro committed
122
123
124
125
126
127
128
129
130
131
132
                            $$  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')
133
            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs buildInfo'
jutaro's avatar
jutaro committed
134
135
136
137
138
139
140
141
142
143
            $+$  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 =
144
145
146
    emptyLine $ vcat [     text ("test-suite " ++ n)
                       $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)
                     | (n,condTree) <- suites]
jutaro's avatar
jutaro committed
147
  where
148
    ppTestSuite testsuite Nothing =
149
150
                maybe empty (\t -> text "type:"        <+> disp t)
                            maybeTestType
151
152
153
154
            $+$ maybe empty (\f -> text "main-is:"     <+> text f)
                            (testSuiteMainIs testsuite)
            $+$ maybe empty (\m -> text "test-module:" <+> disp m)
                            (testSuiteModule testsuite)
155
            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)
156
            $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
157
158
159
      where
        maybeTestType | testInterface testsuite == mempty = Nothing
                      | otherwise = Just (testType testsuite)
160

161
162
    ppTestSuite (TestSuite _ _ buildInfo' _)
                    (Just (TestSuite _ _ buildInfo2 _)) =
jutaro's avatar
jutaro committed
163
164
165
            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
            $+$ ppCustomFields (customFieldsBI buildInfo')

166
167
168
169
170
171
172
173
    testSuiteMainIs test = case testInterface test of
      TestSuiteExeV10 _ f -> Just f
      _                   -> Nothing

    testSuiteModule test = case testInterface test of
      TestSuiteLibV09 _ m -> Just m
      _                   -> Nothing

tibbe's avatar
tibbe committed
174
175
176
177
178
179
180
181
182
183
184
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)
185
            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)
tibbe's avatar
tibbe committed
186
187
188
189
190
191
192
193
194
195
196
197
198
199
            $+$ 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

jutaro's avatar
jutaro committed
200
201
202
ppCondition :: Condition ConfVar -> Doc
ppCondition (Var x)                      = ppConfVar x
ppCondition (Lit b)                      = text (show b)
203
204
205
206
207
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])
jutaro's avatar
jutaro committed
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
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
Ian D. Bollinger's avatar
Ian D. Bollinger committed
226
    -- TODO: this ends up printing trailing spaces when combined with nest.
jutaro's avatar
jutaro committed
227
228
229
230
231
232
233
234
235
236
237
238
239
    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                              =
240
    text "build-depends:" $+$ nest indentWith (vcat (punctuate comma (map disp deps)))
jutaro's avatar
jutaro committed
241
242

emptyLine :: Doc -> Doc
Ian D. Bollinger's avatar
Ian D. Bollinger committed
243
emptyLine d                              = text "" $+$ d
jutaro's avatar
jutaro committed
244
245
246