Cabal/Distribution/ParseUtils.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Distribution.ParseUtils
   4 -- Copyright   :  (c) The University of Glasgow 2004
   5 -- License     :  BSD3
   6 --
   7 -- Maintainer  :  cabal-devel@haskell.org
   8 -- Portability :  portable
   9 --
  10 -- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.
  11 --
  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.
  18
  19 -- This module is meant to be local-only to Distribution...
  20
  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',
  31         parseModuleNameQ,
  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,
  39
  40         UnrecFieldParser, warnUnrec, ignoreUnrec,
  41   ) where
  42
  43 import Prelude ()
  44 import Distribution.Compat.Prelude hiding (get)
  45
  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
  58
  59 import Text.PrettyPrint
  60     ( Doc, render, style, renderStyle
  61     , text, colon, nest, punctuate, comma, sep
  62     , fsep, hsep, isEmpty, vcat, mode, Mode (..)
  63     , ($+$), (<+>)
  64     )
  65 import Data.Tree as Tree (Tree(..), flatten)
  66 import qualified Data.Map as Map
  67 import System.FilePath (normalise)
  68
  69 -- -----------------------------------------------------------------------------
  70
  71 type LineNo    = Int
  72
  73 data PError = AmbiguousParse String LineNo
  74             | NoParse String LineNo
  75             | TabsError LineNo
  76             | FromString String (Maybe LineNo)
  77         deriving (Eq, Show)
  78
  79 data PWarning = PWarning String
  80               | UTFWarning LineNo String
  81         deriving (Eq, Show)
  82
  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."
  89
  90 data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
  91         deriving Show
  92
  93 instance Functor ParseResult where
  94         fmap _ (ParseFailed err) = ParseFailed err
  95         fmap f (ParseOk ws x) = ParseOk ws $ f x
  96
  97 instance Applicative ParseResult where
  98         pure = ParseOk []
  99         (<*>) = ap
 100
 101
 102 instance Monad ParseResult where
 103         return = pure
 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'
 108         fail = Fail.fail
 109
 110 instance Fail.MonadFail ParseResult where
 111         fail s = ParseFailed (FromString s Nothing)
 112
 113 catchParseError :: ParseResult a -> (PError -> ParseResult a)
 114                 -> ParseResult a
 115 p@(ParseOk _ _) `catchParseError` _ = p
 116 ParseFailed e `catchParseError` k   = k e
 117
 118 parseFail :: PError -> ParseResult a
 119 parseFail = ParseFailed
 120
 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
 133
 134 runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
 135 runE line fieldname p s =
 136     case runReadE p s of
 137       Right a -> ParseOk (utf8Warnings line fieldname s) a
 138       Left  e -> syntaxError line $
 139         "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s
 140
 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 ]
 146
 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)
 154
 155 syntaxError :: LineNo -> String -> ParseResult a
 156 syntaxError n s = ParseFailed $ FromString s (Just n)
 157
 158 tabsError :: LineNo -> ParseResult a
 159 tabsError ln = ParseFailed $ TabsError ln
 160
 161 warning :: String -> ParseResult ()
 162 warning s = ParseOk [PWarning s] ()
 163
 164 -- | Field descriptor.  The parameter @a@ parameterizes over where the field's
 165 --   value is stored in.
 166 data FieldDescr a
 167   = FieldDescr
 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@.
 174       }
 175
 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)
 179
 180 -- Lift a field descriptor storing into an 'a' to a field descriptor storing
 181 -- into a 'b'.
 182 liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
 183 liftField get set (FieldDescr name showF parseF)
 184  = FieldDescr name (showF . get)
 185         (\line str b -> do
 186             a <- parseF line str (get b)
 187             return (set a b))
 188
 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
 196
 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 =
 200    liftField get set' $
 201      field name showF' (parseCommaList readF)
 202    where
 203      set' xs b = set (get b ++ xs) b
 204      showF'    = separator . punctuate comma . map showF
 205
 206 commaListField :: String -> (a -> Doc) -> ReadP [a] a
 207                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
 208 commaListField = commaListFieldWithSep fsep
 209
 210 commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a
 211                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
 212 commaNewLineListField = commaListFieldWithSep sep
 213
 214 spaceListField :: String -> (a -> Doc) -> ReadP [a] a
 215                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
 216 spaceListField name showF readF get set =
 217   liftField get set' $
 218     field name showF' (parseSpaceList readF)
 219   where
 220     set' xs b = set (get b ++ xs) b
 221     showF'    = fsep . map showF
 222
 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 =
 226   liftField get set' $
 227     field name showF' (parseOptCommaList readF)
 228   where
 229     set' xs b = set (get b ++ xs) b
 230     showF'    = separator . map showF
 231
 232 listField :: String -> (a -> Doc) -> ReadP [a] a
 233           -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
 234 listField = listFieldWithSep fsep
 235
 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))
 242   where
 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
 250
 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)
 256   where
 257     showF = text . show
 258     readF line str _
 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)
 264       where
 265         lstr = lowercase str
 266         caseWarning = PWarning $
 267           "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
 268
 269 ppFields :: [FieldDescr a] -> a -> Doc
 270 ppFields fields x =
 271    vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ]
 272
 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
 278    where
 279       nestedFields =
 280          [ "description"
 281          , "build-depends"
 282          , "data-files"
 283          , "extra-source-files"
 284          , "extra-tmp-files"
 285          , "exposed-modules"
 286          , "c-sources"
 287          , "js-sources"
 288          , "extra-libraries"
 289          , "includes"
 290          , "install-includes"
 291          , "other-modules"
 292          , "autogen-modules"
 293          , "depends"
 294          ]
 295
 296 showFields :: [FieldDescr a] -> a -> String
 297 showFields fields = render . ($+$ text "") . ppFields fields
 298
 299 showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
 300 showSingleNamedField fields f =
 301   case [ get | (FieldDescr f' get _) <- fields, f' == f ] of
 302     []      -> Nothing
 303     (get:_) -> Just (render . ppField f . get)
 304
 305 showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
 306 showSimpleSingleNamedField fields f =
 307   case [ get | (FieldDescr f' get _) <- fields, f' == f ] of
 308     []      -> Nothing
 309     (get:_) -> Just (renderStyle myStyle . get)
 310  where myStyle = style { mode = LeftMode }
 311
 312 parseFields :: [FieldDescr a] -> a -> String -> ParseResult a
 313 parseFields fields initial str =
 314   readFields str >>= accumFields fields initial
 315
 316 parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a
 317 parseFieldsFlat fields initial str =
 318   readFieldsFlat str >>= accumFields fields initial
 319
 320 accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
 321 accumFields fields = foldM setField
 322   where
 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
 327       Nothing -> do
 328         warning ("Unrecognized field " ++ name ++ " on line " ++ show line)
 329         return accum
 330     setField accum f = do
 331       warning ("Unrecognized stanza on line " ++ show (lineNo f))
 332       return accum
 333
 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
 340
 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
 345
 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
 350 ignoreUnrec _ = Just
 351
 352 ------------------------------------------------------------------------------
 353
 354 -- The data type for our three syntactic categories
 355 data Field
 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
 360       -- structure is:
 361       --
 362       -- @
 363       --   <sectionname> <arg> {
 364       --     <field>*
 365       --   }
 366       -- @
 367     | IfBlock LineNo String [Field] [Field]
 368       -- ^ A conditional block with an optional else branch:
 369       --
 370       -- @
 371       --  if <condition> {
 372       --    <field>*
 373       --  } else {
 374       --    <field>*
 375       --  }
 376       -- @
 377       deriving (Show
 378                ,Eq)   -- for testing
 379
 380 lineNo :: Field -> LineNo
 381 lineNo (F n _ _) = n
 382 lineNo (Section n _ _ _) = n
 383 lineNo (IfBlock n _ _ _) = n
 384
 385 fName :: Field -> String
 386 fName (F _ n _) = n
 387 fName (Section _ n _ _) = n
 388 fName _ = error "fname: not a field or section"
 389
 390 readFields :: String -> ParseResult [Field]
 391 readFields input = ifelse
 392                =<< traverse (mkField 0)
 393                =<< mkTree tokens
 394
 395   where ls = (lines . normaliseLineEndings) input
 396         tokens = (concatMap tokeniseLine . trimLines) ls
 397
 398 readFieldsFlat :: String -> ParseResult [Field]
 399 readFieldsFlat input = traverse (mkField 0)
 400                    =<< mkTree tokens
 401   where ls = (lines . normaliseLineEndings) input
 402         tokens = (concatMap tokeniseLineFlat . trimLines) ls
 403
 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
 409                      indent    = length sps
 410                      hastabs   = '\t' `elem` sps
 411                , validLine l' ]
 412   where validLine ('-':'-':_) = False      -- Comment
 413         validLine []          = False      -- blank line
 414         validLine _           = True
 415
 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.
 418 data Token =
 419        -- | The 'Line' token is for bits that /start/ a line, eg:
 420        --
 421        -- > "\n  blah blah { blah"
 422        --
 423        -- tokenises to:
 424        --
 425        -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]
 426        --
 427        -- so lines are the only ones that can have nested layout, since they
 428        -- have a known indentation level.
 429        --
 430        -- eg: we can't have this:
 431        --
 432        -- > if ... {
 433        -- > } else
 434        -- >     other
 435        --
 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:
 438        --
 439        -- > if ... {
 440        -- > }
 441        -- >   else
 442        -- >     other
 443        --
 444        -- but that's not so common, people would normally use layout or
 445        -- brackets not both in a single @if else@ construct.
 446        --
 447        -- > if ... { foo : bar }
 448        -- > else
 449        -- >    other
 450        --
 451        -- this is OK
 452        Line LineNo Indent HasTabs String
 453      | Span LineNo                String  -- ^ span in a line, following brackets
 454      | OpenBracket LineNo | CloseBracket LineNo
 455
 456 type Indent = Int
 457 type HasTabs = Bool
 458
 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
 464                             cs              -> cs
 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 []
 472
 473         mkspan n s ss | null s'   =             ss
 474                       | otherwise = Span n s' : ss
 475           where s' = trimTrailing (trimLeading s)
 476
 477 tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token]
 478 tokeniseLineFlat (n0, i, t, l)
 479   | null l'   = []
 480   | otherwise = [Line n0 i t l']
 481   where
 482     l' = trimTrailing (trimLeading l)
 483
 484 trimLeading, trimTrailing :: String -> String
 485 trimLeading  = dropWhile isSpace
 486 trimTrailing = dropWhileEndLE isSpace
 487
 488
 489 type SyntaxTree = Tree (LineNo, HasTabs, String)
 490
 491 -- | Parse the stream of tokens into a tree of them, based on indent \/ layout
 492 mkTree :: [Token] -> ParseResult [SyntaxTree]
 493 mkTree toks =
 494   layout 0 [] toks >>= \(trees, trailing) -> case trailing of
 495     []               -> return trees
 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
 501
 502
 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'
 516
 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'
 520
 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
 524     case lookahead of
 525         ([], _)   -> layout i (Node (n,t,l) [] :a) ss
 526         (ts, ss') -> layout i (Node (n,t,l) ts :a) ss'
 527
 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: "
 531                                                   ++ show l
 532
 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'
 543
 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'
 547
 548 braces m a (Line n i t l:ss) = do
 549     lookahead <- layout (i+1) [] ss
 550     case lookahead of
 551         ([], _)   -> braces m (Node (n,t,l) [] :a) ss
 552         (ts, ss') -> braces m (Node (n,t,l) ts :a) ss'
 553
 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 '{'"
 559
 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 ])
 569                       if tabs && d >= 1
 570                         then tabsError n
 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
 581           stripDot "." = ""
 582           stripDot s   = s
 583
 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
 595                             fs' <- ifelse fs
 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
 601                             fs' <- ifelse fs
 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'
 606                                    fs''' <- ifelse fs
 607                                    return (Section n s a fs'' : fs''')
 608 ifelse (f:fs) = do fs' <- ifelse fs
 609                    return (f : fs')
 610
 611 ------------------------------------------------------------------------------
 612
 613 -- |parse a module name
 614 parseModuleNameQ :: ReadP r ModuleName
 615 parseModuleNameQ = parseMaybeQuoted parse
 616
 617 parseFilePathQ :: ReadP r FilePath
 618 parseFilePathQ = parseTokenQ
 619   -- removed until normalise is no longer broken, was:
 620   --   liftM normalise parseTokenQ
 621
 622 betweenSpaces :: ReadP r a -> ReadP r a
 623 betweenSpaces act = do skipSpaces
 624                        res <- act
 625                        skipSpaces
 626                        return res
 627
 628 parsePackageNameQ :: ReadP r PackageName
 629 parsePackageNameQ = parseMaybeQuoted parse
 630
 631 parseOptVersion :: ReadP r Version
 632 parseOptVersion = parseMaybeQuoted ver
 633   where ver :: ReadP r Version
 634         ver = parse <++ return nullVersion
 635
 636 parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)
 637 parseTestedWithQ = parseMaybeQuoted tw
 638   where
 639     tw :: ReadP r (CompilerFlavor,VersionRange)
 640     tw = do compiler <- parseCompilerFlavorCompat
 641             version <- betweenSpaces $ parse <++ return anyVersion
 642             return (compiler,version)
 643
 644 parseLicenseQ :: ReadP r License
 645 parseLicenseQ = parseMaybeQuoted parse
 646
 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.
 651
 652 parseLanguageQ :: ReadP r Language
 653 parseLanguageQ = parseMaybeQuoted parse
 654
 655 parseExtensionQ :: ReadP r Extension
 656 parseExtensionQ = parseMaybeQuoted parse
 657
 658 parseHaskellString :: ReadP r String
 659 parseHaskellString = readS_to_P reads
 660
 661 parseTokenQ :: ReadP r String
 662 parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')
 663
 664 parseTokenQ' :: ReadP r String
 665 parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace)
 666
 667 parseSepList :: ReadP r b
 668              -> ReadP r a -- ^The parser for the stuff between commas
 669              -> ReadP r [a]
 670 parseSepList sepr p = sepBy p separator
 671     where separator = betweenSpaces sepr
 672
 673 parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
 674                -> ReadP r [a]
 675 parseSpaceList p = sepBy p skipSpaces
 676
 677 parseCommaList :: ReadP r a -- ^The parser for the stuff between commas
 678                -> ReadP r [a]
 679 parseCommaList = parseSepList (ReadP.char ',')
 680
 681 parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas
 682                   -> ReadP r [a]
 683 parseOptCommaList = parseSepList (optional (ReadP.char ','))
 684
 685 parseQuoted :: ReadP r a -> ReadP r a
 686 parseQuoted = between (ReadP.char '"') (ReadP.char '"')
 687
 688 parseMaybeQuoted :: (forall r. ReadP r a) -> ReadP r' a
 689 parseMaybeQuoted p = parseQuoted p <++ p
 690
 691 parseFreeText :: ReadP.ReadP s String
 692 parseFreeText = ReadP.munch (const True)