never executed always true always false
1 {-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Distribution.Client.ParseUtils
6 -- Maintainer : cabal-devel@haskell.org
7 -- Portability : portable
8 --
9 -- Parsing utilities.
10 -----------------------------------------------------------------------------
11
12 module Distribution.Client.ParseUtils (
13
14 -- * Fields and field utilities
15 FieldDescr(..),
16 liftField,
17 liftFields,
18 filterFields,
19 mapFieldNames,
20 commandOptionToField,
21 commandOptionsToFields,
22
23 -- * Sections and utilities
24 SectionDescr(..),
25 liftSection,
26
27 -- * FieldGrammar sections
28 FGSectionDescr(..),
29
30 -- * Parsing and printing flat config
31 parseFields,
32 ppFields,
33 ppSection,
34
35 -- * Parsing and printing config with sections and subsections
36 parseFieldsAndSections,
37 ppFieldsAndSections,
38
39 -- ** Top level of config files
40 parseConfig,
41 showConfig,
42 )
43 where
44
45 import Distribution.Client.Compat.Prelude hiding (empty, get)
46 import Prelude ()
47
48 import Distribution.Deprecated.ParseUtils
49 ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
50 , Field(..), liftField, readFields )
51 import Distribution.Deprecated.ViewAsFieldDescr
52 ( viewAsFieldDescr )
53
54 import Distribution.Simple.Command
55 ( OptionField )
56
57 import Text.PrettyPrint ( ($+$) )
58 import qualified Data.ByteString as BS
59 import qualified Data.Map as Map
60 import qualified Text.PrettyPrint as Disp
61 ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )
62
63 -- For new parser stuff
64 import Distribution.CabalSpecVersion (cabalSpecLatest)
65 import Distribution.FieldGrammar (partitionFields, parseFieldGrammar)
66 import Distribution.Fields.ParseResult (runParseResult)
67 import Distribution.Parsec.Error (showPError)
68 import Distribution.Parsec.Position (Position (..))
69 import Distribution.Parsec.Warning (showPWarning)
70 import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)
71 import qualified Distribution.Fields as F
72 import qualified Distribution.FieldGrammar as FG
73
74
75 -------------------------
76 -- FieldDescr utilities
77 --
78
79 liftFields :: (b -> a)
80 -> (a -> b -> b)
81 -> [FieldDescr a]
82 -> [FieldDescr b]
83 liftFields get set = map (liftField get set)
84
85
86 -- | Given a collection of field descriptions, keep only a given list of them,
87 -- identified by name.
88 --
89 filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]
90 filterFields includeFields = filter ((`elem` includeFields) . fieldName)
91
92 -- | Apply a name mangling function to the field names of all the field
93 -- descriptions. The typical use case is to apply some prefix.
94 --
95 mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]
96 mapFieldNames mangleName =
97 map (\descr -> descr { fieldName = mangleName (fieldName descr) })
98
99
100 -- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.
101 --
102 commandOptionToField :: OptionField a -> FieldDescr a
103 commandOptionToField = viewAsFieldDescr
104
105 -- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.
106 --
107 commandOptionsToFields :: [OptionField a] -> [FieldDescr a]
108 commandOptionsToFields = map viewAsFieldDescr
109
110
111 ------------------------------------------
112 -- SectionDescr definition and utilities
113 --
114
115 -- | The description of a section in a config file. It can contain both
116 -- fields and optionally further subsections. See also 'FieldDescr'.
117 --
118 data SectionDescr a = forall b. SectionDescr {
119 sectionName :: String,
120 sectionFields :: [FieldDescr b],
121 sectionSubsections :: [SectionDescr b],
122 sectionGet :: a -> [(String, b)],
123 sectionSet :: LineNo -> String -> b -> a -> ParseResult a,
124 sectionEmpty :: b
125 }
126
127 -- | 'FieldGrammar' section description
128 data FGSectionDescr g a = forall s. FGSectionDescr
129 { fgSectionName :: String
130 , fgSectionGrammar :: g s s
131 -- todo: add subsections?
132 , fgSectionGet :: a -> [(String, s)]
133 , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a
134 }
135
136 -- | To help construction of config file descriptions in a modular way it is
137 -- useful to define fields and sections on local types and then hoist them
138 -- into the parent types when combining them in bigger descriptions.
139 --
140 -- This is essentially a lens operation for 'SectionDescr' to help embedding
141 -- one inside another.
142 --
143 liftSection :: (b -> a)
144 -> (a -> b -> b)
145 -> SectionDescr a
146 -> SectionDescr b
147 liftSection get' set' (SectionDescr name fields sections get set empty) =
148 let sectionGet' = get . get'
149 sectionSet' lineno param x y = do
150 x' <- set lineno param x (get' y)
151 return (set' x' y)
152 in SectionDescr name fields sections sectionGet' sectionSet' empty
153
154
155 -------------------------------------
156 -- Parsing and printing flat config
157 --
158
159 -- | Parse a bunch of semi-parsed 'Field's according to a set of field
160 -- descriptions. It accumulates the result on top of a given initial value.
161 --
162 -- This only covers the case of flat configuration without subsections. See
163 -- also 'parseFieldsAndSections'.
164 --
165 parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
166 parseFields fieldDescrs =
167 foldM setField
168 where
169 fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
170
171 setField accum (F line name value) =
172 case Map.lookup name fieldMap of
173 Just (FieldDescr _ _ set) -> set line value accum
174 Nothing -> do
175 warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
176 return accum
177
178 setField accum f = do
179 warning $ "Unrecognized stanza on line " ++ show (lineNo f)
180 return accum
181
182 -- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils
183 -- that also optionally print default values for empty fields as comments.
184 --
185 ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
186 ppFields fields def cur =
187 Disp.vcat [ ppField name (fmap getter def) (getter cur)
188 | FieldDescr name getter _ <- fields]
189
190 ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc
191 ppField name mdef cur
192 | Disp.isEmpty cur = maybe Disp.empty
193 (\def -> Disp.text "--" <+> Disp.text name
194 Disp.<> Disp.colon <+> def) mdef
195 | otherwise = Disp.text name Disp.<> Disp.colon <+> cur
196
197 -- | Pretty print a section.
198 --
199 -- Since 'ppFields' does not cover subsections you can use this to add them.
200 -- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.
201 --
202 ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
203 ppSection name arg fields def cur
204 | Disp.isEmpty fieldsDoc = Disp.empty
205 | otherwise = Disp.text name <+> argDoc
206 $+$ (Disp.nest 2 fieldsDoc)
207 where
208 fieldsDoc = ppFields fields def cur
209 argDoc | arg == "" = Disp.empty
210 | otherwise = Disp.text arg
211
212
213 -----------------------------------------
214 -- Parsing and printing non-flat config
215 --
216
217 -- | Much like 'parseFields' but it also allows subsections. The permitted
218 -- subsections are given by a list of 'SectionDescr's.
219 --
220 parseFieldsAndSections
221 :: [FieldDescr a] -- ^ field
222 -> [SectionDescr a] -- ^ legacy sections
223 -> [FGSectionDescr FG.ParsecFieldGrammar a] -- ^ FieldGrammar sections
224 -> a
225 -> [Field] -> ParseResult a
226 parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
227 foldM setField
228 where
229 fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
230 sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]
231 fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ]
232
233 setField a (F line name value) =
234 case Map.lookup name fieldMap of
235 Just (FieldDescr _ _ set) -> set line value a
236 Nothing -> do
237 warning $ "Unrecognized field '" ++ name
238 ++ "' on line " ++ show line
239 return a
240
241 setField a (Section line name param fields) =
242 case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of
243 Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do
244 b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields
245 set line param b a
246 Just (Right (FGSectionDescr _ grammar _getter setter)) -> do
247 let fields1 = map convertField fields
248 (fields2, sections) = partitionFields fields1
249 -- TODO: recurse into sections
250 for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->
251 warning $ "Unrecognized section '" ++ fromUTF8BS name'
252 ++ "' on line " ++ show line'
253 case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of
254 (warnings, Right b) -> do
255 for_ warnings $ \w -> warning $ showPWarning "???" w
256 setter line param b a
257 (warnings, Left (_, errs)) -> do
258 for_ warnings $ \w -> warning $ showPWarning "???" w
259 case errs of
260 err :| _errs -> fail $ showPError "???" err
261 Nothing -> do
262 warning $ "Unrecognized section '" ++ name
263 ++ "' on line " ++ show line
264 return a
265
266 convertField :: Field -> F.Field Position
267 convertField (F line name str) =
268 F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]
269 where
270 pos = Position line 0
271 -- arguments omitted
272 convertField (Section line name _arg fields) =
273 F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields)
274 where
275 pos = Position line 0
276
277 -- | Much like 'ppFields' but also pretty prints any subsections. Subsection
278 -- are only shown if they are non-empty.
279 --
280 -- Note that unlike 'ppFields', at present it does not support printing
281 -- default values. If needed, adding such support would be quite reasonable.
282 --
283 ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
284 ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =
285 ppFields fieldDescrs Nothing val
286 $+$
287 Disp.vcat (
288 [ Disp.text "" $+$ sectionDoc
289 | SectionDescr {
290 sectionName, sectionGet,
291 sectionFields, sectionSubsections
292 } <- sectionDescrs
293 , (param, x) <- sectionGet val
294 , let sectionDoc = ppSectionAndSubsections
295 sectionName param
296 sectionFields sectionSubsections [] x
297 , not (Disp.isEmpty sectionDoc)
298 ] ++
299 [ Disp.text "" $+$ sectionDoc
300 | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs
301 , (param, x) <- fgSectionGet val
302 , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x
303 , not (Disp.isEmpty sectionDoc)
304 ])
305
306 -- | Unlike 'ppSection' which has to be called directly, this gets used via
307 -- 'ppFieldsAndSections' and so does not need to be exported.
308 --
309 ppSectionAndSubsections :: String -> String
310 -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
311 ppSectionAndSubsections name arg fields sections fgSections cur
312 | Disp.isEmpty fieldsDoc = Disp.empty
313 | otherwise = Disp.text name <+> argDoc
314 $+$ (Disp.nest 2 fieldsDoc)
315 where
316 fieldsDoc = showConfig fields sections fgSections cur
317 argDoc | arg == "" = Disp.empty
318 | otherwise = Disp.text arg
319
320 -- |
321 --
322 -- TODO: subsections
323 -- TODO: this should simply build 'PrettyField'
324 ppFgSection
325 :: String -- ^ section name
326 -> String -- ^ parameter
327 -> FG.PrettyFieldGrammar a a
328 -> a
329 -> Disp.Doc
330 ppFgSection secName arg grammar x
331 | null prettyFields = Disp.empty
332 | otherwise =
333 Disp.text secName <+> argDoc
334 $+$ (Disp.nest 2 fieldsDoc)
335 where
336 prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x
337
338 argDoc | arg == "" = Disp.empty
339 | otherwise = Disp.text arg
340
341 fieldsDoc = Disp.vcat
342 [ Disp.text fname' <<>> Disp.colon <<>> doc
343 | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections
344 , let fname' = fromUTF8BS fname
345 ]
346
347
348 -----------------------------------------------
349 -- Top level config file parsing and printing
350 --
351
352 -- | Parse a string in the config file syntax into a value, based on a
353 -- description of the configuration file in terms of its fields and sections.
354 --
355 -- It accumulates the result on top of a given initial (typically empty) value.
356 --
357 parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a
358 -> BS.ByteString -> ParseResult a
359 parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
360 parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty
361 =<< readFields str
362
363 -- | Render a value in the config file syntax, based on a description of the
364 -- configuration file in terms of its fields and sections.
365 --
366 showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
367 showConfig = ppFieldsAndSections
368