1 -----------------------------------------------------------------------------
3 -- Module : Distribution.ParseUtils
4 -- Copyright : (c) The University of Glasgow 2004
7 -- Maintainer : cabal-devel@haskell.org
8 -- Portability : portable
10 -- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.
12 -- The @.cabal@ file format is not trivial, especially with the introduction
13 -- of configurations and the section syntax that goes with that. This module
14 -- has a bunch of parsing functions that is used by the @.cabal@ parser and a
15 -- couple others. It has the parsing framework code and also little parsers for
16 -- many of the formats we get in various @.cabal@ file fields, like module
17 -- names, comma separated lists etc.
19 -- This module is meant to be local-only to Distribution...
21 {-# OPTIONS_HADDOCK hide #-}
22 {-# LANGUAGE Rank2Types #-}
23 module Distribution
.ParseUtils
(
24 LineNo
, PError
(..), PWarning
(..), locatedErrorMsg
, syntaxError
, warning
,
25 runP
, runE
, ParseResult
(..), catchParseError
, parseFail
, showPWarning
,
26 Field
(..), fName
, lineNo
,
27 FieldDescr
(..), ppField
, ppFields
, readFields
, readFieldsFlat
,
28 showFields
, showSingleNamedField
, showSimpleSingleNamedField
,
29 parseFields
, parseFieldsFlat
,
30 parseFilePathQ
, parseTokenQ
, parseTokenQ
',
32 parseOptVersion
, parsePackageNameQ
,
33 parseTestedWithQ
, parseLicenseQ
, parseLanguageQ
, parseExtensionQ
,
34 parseSepList
, parseCommaList
, parseOptCommaList
,
35 showFilePath
, showToken
, showTestedWith
, showFreeText
, parseFreeText
,
36 field
, simpleField
, listField
, listFieldWithSep
, spaceListField
,
37 commaListField
, commaListFieldWithSep
, commaNewLineListField
,
38 optsField
, liftField
, boolField
, parseQuoted
, parseMaybeQuoted
, indentWith
,
40 UnrecFieldParser
, warnUnrec
, ignoreUnrec
,
44 import Distribution
.Compat
.Prelude
hiding (get
)
46 import Distribution
.Compiler
47 import Distribution
.License
48 import Distribution
.Version
49 import Distribution
.Package
50 import Distribution
.ModuleName
51 import qualified Distribution
.Compat
.MonadFail
as Fail
52 import Distribution
.Compat
.ReadP
as ReadP
hiding (get
)
53 import Distribution
.ReadE
54 import Distribution
.Text
55 import Distribution
.Simple
.Utils
56 import Distribution
.PrettyUtils
57 import Language
.Haskell
.Extension
59 import Text
.PrettyPrint
60 ( Doc
, render
, style, renderStyle
61 , text
, colon
, nest
, punctuate
, comma
, sep
62 , fsep
, hsep
, isEmpty
, vcat
, mode
, Mode
(..)
65 import Data
.Tree
as Tree
(Tree
(..), flatten
)
66 import qualified Data
.Map
as Map
67 import System
.FilePath (normalise
)
69 -- -----------------------------------------------------------------------------
73 data PError
= AmbiguousParse
String LineNo
74 | NoParse
String LineNo
76 | FromString
String (Maybe LineNo
)
79 data PWarning
= PWarning
String
80 | UTFWarning LineNo
String
83 showPWarning
:: FilePath -> PWarning
-> String
84 showPWarning fpath
(PWarning msg
) =
85 normalise fpath
++ ": " ++ msg
86 showPWarning fpath
(UTFWarning line fname
) =
87 normalise fpath
++ ":" ++ show line
88 ++ ": Invalid UTF-8 text in the '" ++ fname
++ "' field."
90 data ParseResult a
= ParseFailed PError | ParseOk
[PWarning
] a
93 instance Functor ParseResult
where
94 fmap _
(ParseFailed err
) = ParseFailed err
95 fmap f
(ParseOk ws x
) = ParseOk ws
$ f x
97 instance Applicative ParseResult
where
102 instance Monad ParseResult
where
104 ParseFailed err
>>= _
= ParseFailed err
105 ParseOk ws x
>>= f
= case f x
of
106 ParseFailed err
-> ParseFailed err
107 ParseOk ws
' x
' -> ParseOk
(ws
'++ws
) x
'
110 instance Fail
.MonadFail ParseResult
where
111 fail s
= ParseFailed
(FromString s Nothing
)
113 catchParseError
:: ParseResult a
-> (PError
-> ParseResult a
)
115 p
@(ParseOk _ _
) `catchParseError` _
= p
116 ParseFailed e `catchParseError` k
= k e
118 parseFail
:: PError
-> ParseResult a
119 parseFail
= ParseFailed
121 runP
:: LineNo
-> String -> ReadP a a
-> String -> ParseResult a
122 runP line fieldname p s
=
123 case [ x |
(x
,"") <- results
] of
124 [a
] -> ParseOk
(utf8Warnings line fieldname s
) a
125 --TODO: what is this double parse thing all about?
126 -- Can't we just do the all isSpace test the first time?
127 [] -> case [ x |
(x
,ys
) <- results
, all isSpace ys
] of
128 [a
] -> ParseOk
(utf8Warnings line fieldname s
) a
129 [] -> ParseFailed
(NoParse fieldname line
)
130 _
-> ParseFailed
(AmbiguousParse fieldname line
)
131 _
-> ParseFailed
(AmbiguousParse fieldname line
)
132 where results
= readP_to_S p s
134 runE
:: LineNo
-> String -> ReadE a
-> String -> ParseResult a
135 runE line fieldname p s
=
137 Right a
-> ParseOk
(utf8Warnings line fieldname s
) a
138 Left e
-> syntaxError line
$
139 "Parse of field '" ++ fieldname
++ "' failed (" ++ e
++ "): " ++ s
141 utf8Warnings
:: LineNo
-> String -> String -> [PWarning
]
142 utf8Warnings line fieldname s
=
143 take 1 [ UTFWarning n fieldname
144 |
(n
,l
) <- zip [line
..] (lines s
)
145 , '\xfffd
' `
elem` l
]
147 locatedErrorMsg
:: PError
-> (Maybe LineNo
, String)
148 locatedErrorMsg
(AmbiguousParse f n
) = (Just n
,
149 "Ambiguous parse in field '"++f
++"'.")
150 locatedErrorMsg
(NoParse f n
) = (Just n
,
151 "Parse of field '"++f
++"' failed.")
152 locatedErrorMsg
(TabsError n
) = (Just n
, "Tab used as indentation.")
153 locatedErrorMsg
(FromString s n
) = (n
, s
)
155 syntaxError
:: LineNo
-> String -> ParseResult a
156 syntaxError n s
= ParseFailed
$ FromString s
(Just n
)
158 tabsError
:: LineNo
-> ParseResult a
159 tabsError ln
= ParseFailed
$ TabsError ln
161 warning
:: String -> ParseResult
()
162 warning s
= ParseOk
[PWarning s
] ()
164 -- | Field descriptor. The parameter @a@ parameterizes over where the field's
165 -- value is stored in.
168 { fieldName
:: String
169 , fieldGet
:: a
-> Doc
170 , fieldSet
:: LineNo
-> String -> a
-> ParseResult a
171 -- ^ @fieldSet n str x@ Parses the field value from the given input
172 -- string @str@ and stores the result in @x@ if the parse was
173 -- successful. Otherwise, reports an error on line number @n@.
176 field
:: String -> (a
-> Doc
) -> ReadP a a
-> FieldDescr a
177 field name showF readF
=
178 FieldDescr name showF
(\line val _st
-> runP line name readF val
)
180 -- Lift a field descriptor storing into an 'a' to a field descriptor storing
182 liftField
:: (b
-> a
) -> (a
-> b
-> b
) -> FieldDescr a
-> FieldDescr b
183 liftField get set
(FieldDescr name showF parseF
)
184 = FieldDescr name
(showF
. get
)
186 a
<- parseF line str
(get b
)
189 -- Parser combinator for simple fields. Takes a field name, a pretty printer,
190 -- a parser function, an accessor, and a setter, returns a FieldDescr over the
191 -- compoid structure.
192 simpleField
:: String -> (a
-> Doc
) -> ReadP a a
193 -> (b
-> a
) -> (a
-> b
-> b
) -> FieldDescr b
194 simpleField name showF readF get set
195 = liftField get set
$ field name showF readF
197 commaListFieldWithSep
:: Separator
-> String -> (a
-> Doc
) -> ReadP
[a
] a
198 -> (b
-> [a
]) -> ([a
] -> b
-> b
) -> FieldDescr b
199 commaListFieldWithSep separator name showF readF get set
=
201 field name showF
' (parseCommaList readF
)
203 set
' xs b
= set
(get b
++ xs
) b
204 showF
' = separator
. punctuate comma
. map showF
206 commaListField
:: String -> (a
-> Doc
) -> ReadP
[a
] a
207 -> (b
-> [a
]) -> ([a
] -> b
-> b
) -> FieldDescr b
208 commaListField
= commaListFieldWithSep fsep
210 commaNewLineListField
:: String -> (a
-> Doc
) -> ReadP
[a
] a
211 -> (b
-> [a
]) -> ([a
] -> b
-> b
) -> FieldDescr b
212 commaNewLineListField
= commaListFieldWithSep sep
214 spaceListField
:: String -> (a
-> Doc
) -> ReadP
[a
] a
215 -> (b
-> [a
]) -> ([a
] -> b
-> b
) -> FieldDescr b
216 spaceListField name showF readF get set
=
218 field name showF
' (parseSpaceList readF
)
220 set
' xs b
= set
(get b
++ xs
) b
221 showF
' = fsep
. map showF
223 listFieldWithSep
:: Separator
-> String -> (a
-> Doc
) -> ReadP
[a
] a
224 -> (b
-> [a
]) -> ([a
] -> b
-> b
) -> FieldDescr b
225 listFieldWithSep separator name showF readF get set
=
227 field name showF
' (parseOptCommaList readF
)
229 set
' xs b
= set
(get b
++ xs
) b
230 showF
' = separator
. map showF
232 listField
:: String -> (a
-> Doc
) -> ReadP
[a
] a
233 -> (b
-> [a
]) -> ([a
] -> b
-> b
) -> FieldDescr b
234 listField
= listFieldWithSep fsep
236 optsField
:: String -> CompilerFlavor
-> (b
-> [(CompilerFlavor
,[String])])
237 -> ([(CompilerFlavor
,[String])] -> b
-> b
) -> FieldDescr b
238 optsField name flavor get set
=
239 liftField
(fromMaybe [] . lookup flavor
. get
)
240 (\opts b
-> set
(reorder
(update flavor opts
(get b
))) b
) $
241 field name showF
(sepBy parseTokenQ
' (munch1
isSpace))
243 update _ opts l |
all null opts
= l
--empty opts as if no opts
244 update f opts
[] = [(f
,opts
)]
245 update f opts
((f
',opts
'):rest
)
246 | f
== f
' = (f
, opts
' ++ opts
) : rest
247 |
otherwise = (f
',opts
') : update f opts rest
248 reorder
= sortBy (comparing
fst)
249 showF
= hsep
. map text
251 -- TODO: this is a bit smelly hack. It's because we want to parse bool fields
252 -- liberally but not accept new parses. We cannot do that with ReadP
253 -- because it does not support warnings. We need a new parser framework!
254 boolField
:: String -> (b
-> Bool) -> (Bool -> b
-> b
) -> FieldDescr b
255 boolField name get set
= liftField get set
(FieldDescr name showF readF
)
259 | str
== "True" = ParseOk
[] True
260 | str
== "False" = ParseOk
[] False
261 | lstr
== "true" = ParseOk
[caseWarning
] True
262 | lstr
== "false" = ParseOk
[caseWarning
] False
263 |
otherwise = ParseFailed
(NoParse name line
)
266 caseWarning
= PWarning
$
267 "The '" ++ name
++ "' field is case sensitive, use 'True' or 'False'."
269 ppFields
:: [FieldDescr a
] -> a
-> Doc
271 vcat
[ ppField name
(getter x
) | FieldDescr name getter _
<- fields
]
273 ppField
:: String -> Doc
-> Doc
274 ppField name fielddoc
275 | isEmpty fielddoc
= mempty
276 | name `
elem` nestedFields
= text name
<<>> colon
$+$ nest indentWith fielddoc
277 |
otherwise = text name
<<>> colon
<+> fielddoc
283 , "extra-source-files"
296 showFields
:: [FieldDescr a
] -> a
-> String
297 showFields fields
= render
. ($+$ text
"") . ppFields fields
299 showSingleNamedField
:: [FieldDescr a
] -> String -> Maybe (a
-> String)
300 showSingleNamedField fields f
=
301 case [ get |
(FieldDescr f
' get _
) <- fields
, f
' == f
] of
303 (get
:_
) -> Just
(render
. ppField f
. get
)
305 showSimpleSingleNamedField
:: [FieldDescr a
] -> String -> Maybe (a
-> String)
306 showSimpleSingleNamedField fields f
=
307 case [ get |
(FieldDescr f
' get _
) <- fields
, f
' == f
] of
309 (get
:_
) -> Just
(renderStyle myStyle
. get
)
310 where myStyle
= style { mode
= LeftMode
}
312 parseFields
:: [FieldDescr a
] -> a
-> String -> ParseResult a
313 parseFields fields initial str
=
314 readFields str
>>= accumFields fields initial
316 parseFieldsFlat
:: [FieldDescr a
] -> a
-> String -> ParseResult a
317 parseFieldsFlat fields initial str
=
318 readFieldsFlat str
>>= accumFields fields initial
320 accumFields
:: [FieldDescr a
] -> a
-> [Field
] -> ParseResult a
321 accumFields fields
= foldM setField
323 fieldMap
= Map
.fromList
324 [ (name
, f
) | f
@(FieldDescr name _ _
) <- fields
]
325 setField
accum (F line name
value) = case Map
.lookup name fieldMap
of
326 Just
(FieldDescr _ _ set
) -> set line
value accum
328 warning
("Unrecognized field " ++ name
++ " on line " ++ show line
)
330 setField
accum f
= do
331 warning
("Unrecognized stanza on line " ++ show (lineNo f
))
334 -- | The type of a function which, given a name-value pair of an
335 -- unrecognized field, and the current structure being built,
336 -- decides whether to incorporate the unrecognized field
337 -- (by returning Just x, where x is a possibly modified version
338 -- of the structure being built), or not (by returning Nothing).
339 type UnrecFieldParser a
= (String,String) -> a
-> Maybe a
341 -- | A default unrecognized field parser which simply returns Nothing,
342 -- i.e. ignores all unrecognized fields, so warnings will be generated.
343 warnUnrec
:: UnrecFieldParser a
344 warnUnrec _ _
= Nothing
346 -- | A default unrecognized field parser which silently (i.e. no
347 -- warnings will be generated) ignores unrecognized fields, by
348 -- returning the structure being built unmodified.
349 ignoreUnrec
:: UnrecFieldParser a
352 ------------------------------------------------------------------------------
354 -- The data type for our three syntactic categories
356 = F LineNo
String String
357 -- ^ A regular @<property>: <value>@ field
358 | Section LineNo
String String [Field
]
359 -- ^ A section with a name and possible parameter. The syntactic
363 -- <sectionname> <arg> {
367 | IfBlock LineNo
String [Field
] [Field
]
368 -- ^ A conditional block with an optional else branch:
380 lineNo
:: Field
-> LineNo
382 lineNo
(Section n _ _ _
) = n
383 lineNo
(IfBlock n _ _ _
) = n
385 fName
:: Field
-> String
387 fName
(Section _ n _ _
) = n
388 fName _
= error "fname: not a field or section"
390 readFields
:: String -> ParseResult
[Field
]
391 readFields input
= ifelse
392 =<< traverse
(mkField
0)
395 where ls
= (lines . normaliseLineEndings
) input
396 tokens
= (concatMap tokeniseLine
. trimLines
) ls
398 readFieldsFlat
:: String -> ParseResult
[Field
]
399 readFieldsFlat input
= traverse
(mkField
0)
401 where ls
= (lines . normaliseLineEndings
) input
402 tokens
= (concatMap tokeniseLineFlat
. trimLines
) ls
404 -- attach line number and determine indentation
405 trimLines
:: [String] -> [(LineNo
, Indent
, HasTabs
, String)]
406 trimLines ls
= [ (lineno
, indent
, hastabs
, trimTrailing l
')
407 |
(lineno
, l
) <- zip [1..] ls
408 , let (sps
, l
') = span
isSpace l
410 hastabs
= '\t' `
elem` sps
412 where validLine
('-':'-':_
) = False -- Comment
413 validLine
[] = False -- blank line
416 -- | We parse generically based on indent level and braces '{' '}'. To do that
417 -- we split into lines and then '{' '}' tokens and other spans within a line.
419 -- | The 'Line' token is for bits that /start/ a line, eg:
421 -- > "\n blah blah { blah"
425 -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]
427 -- so lines are the only ones that can have nested layout, since they
428 -- have a known indentation level.
430 -- eg: we can't have this:
436 -- because other cannot nest under else, since else doesn't start a line
437 -- so cannot have nested layout. It'd have to be:
444 -- but that's not so common, people would normally use layout or
445 -- brackets not both in a single @if else@ construct.
447 -- > if ... { foo : bar }
452 Line LineNo Indent HasTabs
String
453 | Span LineNo
String -- ^ span in a line, following brackets
454 | OpenBracket LineNo | CloseBracket LineNo
459 -- | Tokenise a single line, splitting on '{' '}' and the spans in between.
460 -- Also trims leading & trailing space on those spans within the line.
461 tokeniseLine
:: (LineNo
, Indent
, HasTabs
, String) -> [Token
]
462 tokeniseLine
(n0
, i
, t
, l
) = case split n0 l
of
463 (Span _ l
':ss
) -> Line n0 i t l
' :ss
465 where split _
"" = []
466 split n s
= case span
(\c
-> c
/='}' && c
/= '{') s
of
467 ("", '{' : s
') -> OpenBracket n
: split n s
'
468 (w
, '{' : s
') -> mkspan n w
(OpenBracket n
: split n s
')
469 ("", '}' : s
') -> CloseBracket n
: split n s
'
470 (w
, '}' : s
') -> mkspan n w
(CloseBracket n
: split n s
')
471 (w
, _
) -> mkspan n w
[]
473 mkspan n s ss |
null s
' = ss
474 |
otherwise = Span n s
' : ss
475 where s
' = trimTrailing
(trimLeading s
)
477 tokeniseLineFlat
:: (LineNo
, Indent
, HasTabs
, String) -> [Token
]
478 tokeniseLineFlat
(n0
, i
, t
, l
)
480 |
otherwise = [Line n0 i t l
']
482 l
' = trimTrailing
(trimLeading l
)
484 trimLeading
, trimTrailing
:: String -> String
485 trimLeading
= dropWhile isSpace
486 trimTrailing
= dropWhileEndLE
isSpace
489 type SyntaxTree
= Tree
(LineNo
, HasTabs
, String)
491 -- | Parse the stream of tokens into a tree of them, based on indent \/ layout
492 mkTree
:: [Token
] -> ParseResult
[SyntaxTree
]
494 layout
0 [] toks
>>= \(trees
, trailing
) -> case trailing
of
496 OpenBracket n
:_
-> syntaxError n
"mismatched brackets, unexpected {"
497 CloseBracket n
:_
-> syntaxError n
"mismatched brackets, unexpected }"
498 -- the following two should never happen:
499 Span n l
:_
-> syntaxError n
$ "unexpected span: " ++ show l
500 Line n _ _ l
:_
-> syntaxError n
$ "unexpected line: " ++ show l
503 -- | Parse the stream of tokens into a tree of them, based on indent
504 -- This parse state expect to be in a layout context, though possibly
505 -- nested within a braces context so we may still encounter closing braces.
506 layout
:: Indent
-- ^ indent level of the parent\/previous line
507 -> [SyntaxTree
] -- ^ accumulating param, trees in this level
508 -> [Token
] -- ^ remaining tokens
509 -> ParseResult
([SyntaxTree
], [Token
])
510 -- ^ collected trees on this level and trailing tokens
511 layout _ a
[] = return (reverse a
, [])
512 layout i a
(s
@(Line _ i
' _ _
):ss
) | i
' < i
= return (reverse a
, s
:ss
)
513 layout i a
(Line n _ t l
:OpenBracket n
':ss
) = do
514 (sub
, ss
') <- braces n
' [] ss
515 layout i
(Node
(n
,t
,l
) sub
:a
) ss
'
517 layout i a
(Span n l
:OpenBracket n
':ss
) = do
518 (sub
, ss
') <- braces n
' [] ss
519 layout i
(Node
(n
,False,l
) sub
:a
) ss
'
521 -- look ahead to see if following lines are more indented, giving a sub-tree
522 layout i a
(Line n i
' t l
:ss
) = do
523 lookahead
<- layout
(i
'+1) [] ss
525 ([], _
) -> layout i
(Node
(n
,t
,l
) [] :a
) ss
526 (ts
, ss
') -> layout i
(Node
(n
,t
,l
) ts
:a
) ss
'
528 layout _ _
( OpenBracket n
:_
) = syntaxError n
"unexpected '{'"
529 layout _ a
(s
@(CloseBracket _
):ss
) = return (reverse a
, s
:ss
)
530 layout _ _
( Span n l
: _
) = syntaxError n
$ "unexpected span: "
533 -- | Parse the stream of tokens into a tree of them, based on explicit braces
534 -- This parse state expects to find a closing bracket.
535 braces
:: LineNo
-- ^ line of the '{', used for error messages
536 -> [SyntaxTree
] -- ^ accumulating param, trees in this level
537 -> [Token
] -- ^ remaining tokens
538 -> ParseResult
([SyntaxTree
],[Token
])
539 -- ^ collected trees on this level and trailing tokens
540 braces m a
(Line n _ t l
:OpenBracket n
':ss
) = do
541 (sub
, ss
') <- braces n
' [] ss
542 braces m
(Node
(n
,t
,l
) sub
:a
) ss
'
544 braces m a
(Span n l
:OpenBracket n
':ss
) = do
545 (sub
, ss
') <- braces n
' [] ss
546 braces m
(Node
(n
,False,l
) sub
:a
) ss
'
548 braces m a
(Line n i t l
:ss
) = do
549 lookahead
<- layout
(i
+1) [] ss
551 ([], _
) -> braces m
(Node
(n
,t
,l
) [] :a
) ss
552 (ts
, ss
') -> braces m
(Node
(n
,t
,l
) ts
:a
) ss
'
554 braces m a
(Span n l
:ss
) = braces m
(Node
(n
,False,l
) []:a
) ss
555 braces _ a
(CloseBracket _
:ss
) = return (reverse a
, ss
)
556 braces n _
[] = syntaxError n
$ "opening brace '{'"
557 ++ "has no matching closing brace '}'"
558 braces _ _
(OpenBracket n
:_
) = syntaxError n
"unexpected '{'"
560 -- | Convert the parse tree into the Field AST
561 -- Also check for dodgy uses of tabs in indentation.
562 mkField
:: Int -> SyntaxTree
-> ParseResult Field
563 mkField d
(Node
(n
,t
,_
) _
) | d
>= 1 && t
= tabsError n
564 mkField d
(Node
(n
,_
,l
) ts
) = case span
(\c
-> isAlphaNum c || c
== '-') l
of
565 ([], _
) -> syntaxError n
$ "unrecognised field or section: " ++ show l
566 (name
, rest
) -> case trimLeading rest
of
567 (':':rest
') -> do let followingLines
= concatMap Tree
.flatten ts
568 tabs
= not (null [()|
(_
,True,_
) <- followingLines
])
571 else return $ F n
(map toLower name
)
572 (fieldValue rest
' followingLines
)
573 rest
' -> do ts
' <- traverse
(mkField
(d
+1)) ts
574 return (Section n
(map toLower name
) rest
' ts
')
575 where fieldValue firstLine followingLines
=
576 let firstLine
' = trimLeading firstLine
577 followingLines
' = map (\(_
,_
,s
) -> stripDot s
) followingLines
578 allLines |
null firstLine
' = followingLines
'
579 |
otherwise = firstLine
' : followingLines
'
580 in intercalate
"\n" allLines
584 -- | Convert if/then/else 'Section's to 'IfBlock's
585 ifelse
:: [Field
] -> ParseResult
[Field
]
586 ifelse
[] = return []
587 ifelse
(Section n
"if" cond thenpart
588 :Section _
"else" as elsepart
:fs
)
589 |
null cond
= syntaxError n
"'if' with missing condition"
590 |
null thenpart
= syntaxError n
"'then' branch of 'if' is empty"
591 |
not (null as) = syntaxError n
"'else' takes no arguments"
592 |
null elsepart
= syntaxError n
"'else' branch of 'if' is empty"
593 |
otherwise = do tp
<- ifelse thenpart
594 ep
<- ifelse elsepart
596 return (IfBlock n cond tp ep
:fs
')
597 ifelse
(Section n
"if" cond thenpart
:fs
)
598 |
null cond
= syntaxError n
"'if' with missing condition"
599 |
null thenpart
= syntaxError n
"'then' branch of 'if' is empty"
600 |
otherwise = do tp
<- ifelse thenpart
602 return (IfBlock n cond tp
[]:fs
')
603 ifelse
(Section n
"else" _ _
:_
) = syntaxError n
604 "stray 'else' with no preceding 'if'"
605 ifelse
(Section n s a fs
':fs
) = do fs
'' <- ifelse fs
'
607 return (Section n s a fs
'' : fs
''')
608 ifelse
(f
:fs
) = do fs
' <- ifelse fs
611 ------------------------------------------------------------------------------
613 -- |parse a module name
614 parseModuleNameQ
:: ReadP r ModuleName
615 parseModuleNameQ
= parseMaybeQuoted parse
617 parseFilePathQ
:: ReadP r
FilePath
618 parseFilePathQ
= parseTokenQ
619 -- removed until normalise is no longer broken, was:
620 -- liftM normalise parseTokenQ
622 betweenSpaces
:: ReadP r a
-> ReadP r a
623 betweenSpaces act
= do skipSpaces
628 parsePackageNameQ
:: ReadP r PackageName
629 parsePackageNameQ
= parseMaybeQuoted parse
631 parseOptVersion
:: ReadP r Version
632 parseOptVersion
= parseMaybeQuoted ver
633 where ver
:: ReadP r Version
634 ver
= parse
<++ return nullVersion
636 parseTestedWithQ
:: ReadP r
(CompilerFlavor
,VersionRange
)
637 parseTestedWithQ
= parseMaybeQuoted tw
639 tw
:: ReadP r
(CompilerFlavor
,VersionRange
)
640 tw
= do compiler
<- parseCompilerFlavorCompat
641 version
<- betweenSpaces
$ parse
<++ return anyVersion
642 return (compiler
,version
)
644 parseLicenseQ
:: ReadP r License
645 parseLicenseQ
= parseMaybeQuoted parse
647 -- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a
648 -- because the "compat" version of ReadP isn't quite powerful enough. In
649 -- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a
650 -- Hence the trick above to make 'lic' polymorphic.
652 parseLanguageQ
:: ReadP r Language
653 parseLanguageQ
= parseMaybeQuoted parse
655 parseExtensionQ
:: ReadP r Extension
656 parseExtensionQ
= parseMaybeQuoted parse
658 parseHaskellString
:: ReadP r
String
659 parseHaskellString
= readS_to_P
reads
661 parseTokenQ
:: ReadP r
String
662 parseTokenQ
= parseHaskellString
<++ munch1
(\x
-> not (isSpace x
) && x
/= ',')
664 parseTokenQ
' :: ReadP r
String
665 parseTokenQ
' = parseHaskellString
<++ munch1
(not . isSpace)
667 parseSepList
:: ReadP r b
668 -> ReadP r a
-- ^The parser for the stuff between commas
670 parseSepList sepr p
= sepBy p separator
671 where separator
= betweenSpaces sepr
673 parseSpaceList
:: ReadP r a
-- ^The parser for the stuff between commas
675 parseSpaceList p
= sepBy p skipSpaces
677 parseCommaList
:: ReadP r a
-- ^The parser for the stuff between commas
679 parseCommaList
= parseSepList
(ReadP
.char
',')
681 parseOptCommaList
:: ReadP r a
-- ^The parser for the stuff between commas
683 parseOptCommaList
= parseSepList
(optional
(ReadP
.char
','))
685 parseQuoted
:: ReadP r a
-> ReadP r a
686 parseQuoted
= between
(ReadP
.char
'"') (ReadP.char '"')
688 parseMaybeQuoted
:: (forall r
. ReadP r a
) -> ReadP r
' a
689 parseMaybeQuoted p
= parseQuoted p
<++ p
691 parseFreeText
:: ReadP
.ReadP s
String
692 parseFreeText
= ReadP
.munch
(const True)