ParseUtils.hs 22.3 KB
Newer Older
1
{-# OPTIONS -cpp #-}
simonmar's avatar
simonmar committed
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.ParseUtils
-- Copyright   :  (c) The University of Glasgow 2004
-- 
-- Maintainer  :  libraries@haskell.org
-- Stability   :  alpha
-- Portability :  portable
--
-- Utilities for parsing PackageDescription and InstalledPackageInfo.


{- All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of the University nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

-- This module is meant to be local-only to Distribution...

-- #hide
module Distribution.ParseUtils (
Simon Marlow's avatar
Simon Marlow committed
48
        LineNo, PError(..), PWarning, locatedErrorMsg, syntaxError, warning,
49
	runP, ParseResult(..), catchParseError, parseFail,
50
	Field(..), fName, lineNo,
Simon Marlow's avatar
Simon Marlow committed
51
	FieldDescr(..), readFields,
ijones's avatar
ijones committed
52
	parseFilePathQ, parseTokenQ,
53
54
	parseModuleNameQ, parseDependency, parseOptVersion,
	parsePackageNameQ, parseVersionRangeQ,
Simon Marlow's avatar
Simon Marlow committed
55
56
	parseTestedWithQ, parseLicenseQ, parseExtensionQ, 
	parseSepList, parseCommaList, parseOptCommaList,
ijones's avatar
ijones committed
57
	showFilePath, showToken, showTestedWith, showDependency, showFreeText,
Simon Marlow's avatar
Simon Marlow committed
58
	field, simpleField, listField, commaListField, optsField, liftField,
59
	parseReadS, parseReadSQ, parseQuoted,
simonmar's avatar
simonmar committed
60
61
  ) where

ijones's avatar
ijones committed
62
import Distribution.Compiler (CompilerFlavor)
simonmar's avatar
simonmar committed
63
64
65
66
import Distribution.License
import Distribution.Version
import Distribution.Package	( parsePackageName )
import Distribution.Compat.ReadP as ReadP hiding (get)
Simon Marlow's avatar
Simon Marlow committed
67
68
69
import Language.Haskell.Extension (Extension)

import Text.PrettyPrint.HughesPJ
Duncan Coutts's avatar
Duncan Coutts committed
70
import Data.Char        (isSpace, isUpper, toLower, isAlphaNum)
Simon Marlow's avatar
Simon Marlow committed
71
import Data.Maybe	( fromMaybe)
simonmar's avatar
simonmar committed
72
73
74
75
76
77
78

-- -----------------------------------------------------------------------------

type LineNo = Int

data PError = AmbigousParse String LineNo
            | NoParse String LineNo
79
            | TabsError LineNo
simonmar's avatar
simonmar committed
80
81
82
            | FromString String (Maybe LineNo)
        deriving Show

83
84
85
type PWarning = String

data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
86
87
88
        deriving Show

instance Monad ParseResult where
89
	return x = ParseOk [] x
90
	ParseFailed err >>= _ = ParseFailed err
91
92
93
	ParseOk ws x >>= f = case f x of
	                       ParseFailed err -> ParseFailed err
			       ParseOk ws' x' -> ParseOk (ws'++ws) x'
94
	fail s = ParseFailed (FromString s Nothing)
simonmar's avatar
simonmar committed
95

96
97
98
99
100
101
102
103
catchParseError :: ParseResult a -> (PError -> ParseResult a)
                -> ParseResult a
p@(ParseOk _ _) `catchParseError` _ = p
ParseFailed e `catchParseError` k   = k e

parseFail :: PError -> ParseResult a
parseFail = ParseFailed

104
runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
nominolo@gmail.com's avatar
nominolo@gmail.com committed
105
runP line fieldname p s =
simonmar's avatar
simonmar committed
106
  case [ x | (x,"") <- results ] of
107
    [a] -> ParseOk [] a
simonmar's avatar
simonmar committed
108
    []  -> case [ x | (x,ys) <- results, all isSpace ys ] of
109
             [a] -> ParseOk [] a
nominolo@gmail.com's avatar
nominolo@gmail.com committed
110
111
112
             []  -> ParseFailed (NoParse fieldname line)
             _   -> ParseFailed (AmbigousParse fieldname line)
    _   -> ParseFailed (AmbigousParse fieldname line)
simonmar's avatar
simonmar committed
113
114
  where results = readP_to_S p s

ijones's avatar
ijones committed
115
locatedErrorMsg :: PError -> (Maybe LineNo, String)
nominolo@gmail.com's avatar
nominolo@gmail.com committed
116
locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'")
117
locatedErrorMsg (NoParse f n)       = (Just n, "Parse of field '"++f++"' failed: ")
118
locatedErrorMsg (TabsError n)       = (Just n, "Tab used as indentation.")
ijones's avatar
ijones committed
119
120
121
122
locatedErrorMsg (FromString s n)    = (n, s)

syntaxError :: LineNo -> String -> ParseResult a
syntaxError n s = ParseFailed $ FromString s (Just n)
simonmar's avatar
simonmar committed
123

124
125
126
tabsError :: LineNo -> ParseResult a
tabsError ln = ParseFailed $ TabsError ln

127
128
129
warning :: String -> ParseResult ()
warning s = ParseOk [s] ()

nominolo@gmail.com's avatar
nominolo@gmail.com committed
130
131
-- | Field descriptor.  The parameter @a@ parameterizes over where the field's
--   value is stored in.
Simon Marlow's avatar
Simon Marlow committed
132
133
data FieldDescr a 
  = FieldDescr 
simonmar's avatar
simonmar committed
134
135
      { fieldName     :: String
      , fieldGet      :: a -> Doc
136
      , fieldSet      :: LineNo -> String -> a -> ParseResult a
nominolo@gmail.com's avatar
nominolo@gmail.com committed
137
138
139
        -- ^ @fieldSet n str x@ Parses the field value from the given input
        -- string @str@ and stores the result in @x@ if the parse was
        -- successful.  Otherwise, reports an error on line number @n@.
simonmar's avatar
simonmar committed
140
141
      }

Simon Marlow's avatar
Simon Marlow committed
142
143
field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a
field name showF readF = 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
144
  FieldDescr name showF (\line val _st -> runP line name readF val)
Simon Marlow's avatar
Simon Marlow committed
145

nominolo@gmail.com's avatar
nominolo@gmail.com committed
146
147
-- Lift a field descriptor storing into an 'a' to a field descriptor storing
-- into a 'b'.
Simon Marlow's avatar
Simon Marlow committed
148
149
150
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField get set (FieldDescr name showF parseF)
 = FieldDescr name (\b -> showF (get b))
nominolo@gmail.com's avatar
nominolo@gmail.com committed
151
152
	(\line str b -> do
	    a <- parseF line str (get b)
Simon Marlow's avatar
Simon Marlow committed
153
154
	    return (set a b))

nominolo@gmail.com's avatar
nominolo@gmail.com committed
155
-- Parser combinator for simple fields.  Takes a field name, a pretty printer,
nominolo@gmail.com's avatar
nominolo@gmail.com committed
156
157
-- a parser function, an accessor, and a setter, returns a FieldDescr over the
-- compoid structure.
Simon Marlow's avatar
Simon Marlow committed
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
simpleField :: String -> (a -> Doc) -> (ReadP a a)
            -> (b -> a) -> (a -> b -> b) -> FieldDescr b
simpleField name showF readF get set
  = liftField get set $ field name showF readF

commaListField :: String -> (a -> Doc) -> (ReadP [a] a)
		 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
commaListField name showF readF get set = 
  liftField get set $ 
    field name (fsep . punctuate comma . map showF) (parseCommaList readF)

listField :: String -> (a -> Doc) -> (ReadP [a] a)
		 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
listField name showF readF get set = 
  liftField get set $ 
    field name (fsep . map showF) (parseOptCommaList readF)

optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
optsField name flavor get set = 
   liftField (fromMaybe [] . lookup flavor . get) 
	     (\opts b -> set (update flavor opts (get b)) b) $
	field name (hsep . map text)
		   (sepBy parseTokenQ' (munch1 isSpace))
  where
        update f opts [] = [(f,opts)]
	update f opts ((f',opts'):rest)
           | f == f'   = (f, opts ++ opts') : rest
           | otherwise = (f',opts') : update f opts rest
simonmar's avatar
simonmar committed
186

187
188
------------------------------------------------------------------------------

189
190
trimTrailingSpaces :: String -> String
trimTrailingSpaces = reverse . dropWhile isSpace . reverse
simonmar's avatar
simonmar committed
191

192
193
194
195

dropSpaces :: String -> String
dropSpaces = dropWhile isSpace

nominolo@gmail.com's avatar
nominolo@gmail.com committed
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
-- The data type for our three syntactic categories 
data Field 
    = F LineNo String String
      -- ^ A regular @<property>: <value>@ field
    | Section LineNo String String [Field]
      -- ^ A section with a name and possible parameter.  The syntactic
      -- structure is:
      -- 
      -- @
      --   <sectionname> <arg> {
      --     <field>*
      --   }
      -- @
    | IfBlock LineNo String [Field] [Field]
      -- ^ A conditional block with an optional else branch:
      --
      -- @
      --  if <condition> {
      --    <field>*
      --  } else {
      --    <field>*
      --  }
Ian Lynagh's avatar
Ian Lynagh committed
218
      -- @
nominolo@gmail.com's avatar
nominolo@gmail.com committed
219
220
      deriving (Show
               ,Eq)   -- for testing
221
222
223
224
225
226

lineNo :: Field -> LineNo
lineNo (F n _ _) = n
lineNo (Section n _ _ _) = n
lineNo (IfBlock n _ _ _) = n

nominolo@gmail.com's avatar
nominolo@gmail.com committed
227
fName :: Field -> String
228
fName (F _ n _) = n
nominolo@gmail.com's avatar
nominolo@gmail.com committed
229
230
fName (Section _ n _ _) = n
fName _ = undefined
231
232
233

--   sectionname ::= "library" | "executable"
sectionNames :: [String]
nominolo@gmail.com's avatar
nominolo@gmail.com committed
234
sectionNames = ["library", "executable", "flag"]
Simon Marlow's avatar
Simon Marlow committed
235
236
237

-- |Split a file into "Field: value" groups
readFields :: String -> ParseResult [Field]
238
239
240
241
242
243
readFields = mkStanza 
           -- . merge 
           . filter validLine 
           . zip [1..] 
           . map trimTrailingSpaces . lines
  where validLine (_,s) = case dropSpaces s of
ijones's avatar
ijones committed
244
245
246
                            '-':'-':_ -> False      -- Comment
                            []        -> False      -- blank line
                            _         -> True
simonmar's avatar
simonmar committed
247

Simon Marlow's avatar
Simon Marlow committed
248
mkStanza :: [(Int,String)] -> ParseResult [Field]
nominolo@gmail.com's avatar
nominolo@gmail.com committed
249
mkStanza lines0 = parseLines lines0 []
250
251
252
253
254
255
256
257
258
259
260
261
262
263
  where 
    parseLines [] fs = return (reverse fs)
    parseLines ls fs = do (f, ls') <- getField ls
                          parseLines ls' $ maybe fs (:fs) f

-- parses:
--
--   field ::= '#' directive value '\n'
--           | [<indent>] fieldname ':' space* fieldvalue
--           | "if" space cond
--           | sectionname section
--
getField :: [(Int,String)] -> ParseResult (Maybe Field,[(Int,String)])
getField [] = return (Nothing, [])
nominolo@gmail.com's avatar
nominolo@gmail.com committed
264
265
266
getField ((_,[]):ls) = return (Nothing,ls)
getField ((n,'#':xs):ls) | not (isSpace (head xs)) = do
  return (Just $ F n ('#':dir) (dropSpaces val), ls)
Simon Marlow's avatar
Simon Marlow committed
267
  where (dir,val) = break isSpace xs
nominolo@gmail.com's avatar
nominolo@gmail.com committed
268
getField ((lineno,line0):lines0) =
269
270
    let (spaces,line) = span (==' ') line0
        indent = length spaces in
271
    case break (`elem` " :{") line of
272
      ('\t':_,_) -> tabsError lineno
273
      (fld0, ':':val0) -> do  -- regular field
274
275
276
277
          let fld = map toLower fld0
          (val, lines') <- getFieldValue indent (dropWhile isSpace val0) lines0
          return (Just $ F lineno fld val, lines')
      (blkName, ' ':rest)
nominolo@gmail.com's avatar
nominolo@gmail.com committed
278
279
280
        | map toLower blkName == "if"             -> getIf (lineno,rest) lines0
        | map toLower blkName `elem` sectionNames -> 
            getSection (map toLower blkName) (lineno,rest) lines0
281
282
283
284
        | otherwise -> syntaxError lineno $
            "Missing colon after field label or invalid section name"
      (blkName, '{':rest) 
        | map toLower blkName `elem` sectionNames -> 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
285
286
            getSection (map toLower blkName) (lineno,'{':rest) lines0
      ("","") -> return (Nothing,lines0)
287
288
289
290
291
292
293
294
295
296
      (_,_) -> syntaxError lineno $
        "Unrecognized field format: '" ++ line ++ "'"
          


-- parses:
--
--   cond ::= (any - '}')* block [ space* "else" block ]
--
getIf :: (Int,String) -> [(Int,String)] -> ParseResult (Maybe Field,[(Int,String)])
nominolo@gmail.com's avatar
nominolo@gmail.com committed
297
getIf (n,rest) ls = do
298
299
300
    (cond, ifBlock, lines') <- 
        case break (=='{') (dropSpaces rest) of
          (cond, '{':cs) -> 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
301
302
303
            do (b,ls') <- getBlock (n,'{':cs) ls
               return (cond, b, ls')
          (_, _) -> -- condition spans more than one line
304
305
            syntaxError n "Multi-line conditions currently not supported."
    (elseBlock, lines'') <- tryElseBlock lines'
306
    return (Just $ IfBlock n cond ifBlock elseBlock, lines'') 
307
308
  where 
    tryElseBlock [] = return ([], [])
nominolo@gmail.com's avatar
nominolo@gmail.com committed
309
310
    tryElseBlock ((m,l):ls') = 
        if all isSpace l then return ([],ls') 
311
        else case (splitAt 4 . dropSpaces) l of
nominolo@gmail.com's avatar
nominolo@gmail.com committed
312
          (kw, rst) -> 
313
              if kw == "else" then 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
314
315
                  getBlock (m,dropSpaces rst) ls'
              else syntaxError m "Only 'else' may appear after an if-Block"
316
317
318
319
320
321
322
323
          
-- parses:
-- 
--   block ::= space* '{' space* '\n'
--             field*
--             space* '}' space* '\n'
--   
getBlock :: (Int,String) -> [(Int,String)] -> ParseResult ([Field],[(Int,String)])
nominolo@gmail.com's avatar
nominolo@gmail.com committed
324
325
getBlock (lnum,rest) lines0 = do
    lines' <- checkBlockStart (lnum,dropSpaces rest) lines0
326
327
328
329
330
331
332
333
334
335
    munchTillEndOfBlock lines' []
  where
    checkBlockStart (n,'{':cs) ls = 
        if all isSpace cs then return ls
        else syntaxError n "Invalid characters after '{'"
    checkBlockStart (_,[]) ((n,l):ls) = 
        checkBlockStart (n,dropSpaces l) ls
    checkBlockStart (n,_) _ = syntaxError n "'{' expected"
                         
    munchTillEndOfBlock [] _ = syntaxError (-1) "missing '}' at end of file"
nominolo@gmail.com's avatar
nominolo@gmail.com committed
336
    munchTillEndOfBlock lines1@((n,l):ls) fs =
337
        case break (=='}') l of
nominolo@gmail.com's avatar
nominolo@gmail.com committed
338
          (spaces, '}':rst) ->   
339
340
              if all isSpace spaces
              then return ( reverse fs
nominolo@gmail.com's avatar
nominolo@gmail.com committed
341
                          , (n, rst):ls) 
342
              else syntaxError n "'}' must be first character on the line"
nominolo@gmail.com's avatar
nominolo@gmail.com committed
343
          _ -> do (f,ls') <- getField lines1
344
345
346
347
348
349
350
351
                  munchTillEndOfBlock ls' $ maybe fs (:fs) f

-- parses:
--
--   section ::= space* [ blocklabel ] space* block
--   
getSection :: String -> (Int,String) -> [(Int,String)] 
           -> ParseResult (Maybe Field,[(Int,String)])
nominolo@gmail.com's avatar
nominolo@gmail.com committed
352
getSection sectName (n,l) lines0 = 
353
354
    case break (=='{') (dropSpaces l) of
      (sectLabel, '{':rest) -> 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
355
          do (b,lines') <- getBlock (n,'{':rest) lines0 
356
             return (Just $ Section n sectName (trimTrailingSpaces sectLabel) b, lines')
nominolo@gmail.com's avatar
nominolo@gmail.com committed
357
      (_,_) -> error "getSection got a line without a '{'.  Consider this a bug."
358

359
360
361
362
363
364
365
366
-- Get the field value of a field at given indentation
getFieldValue :: Int -> String -> [(Int,String)]
              -> ParseResult (String,[(Int,String)])
getFieldValue indent val lines0 = do
    (valrest, lines') <- getValRest lines0
    let v = val' ++ rest valrest
    return ( v
           , lines')
367
368
  where
    val' = dropWhile isSpace val
369
370
371
372
373
    rest valrest =
        -- don't include initial newline if it would be the first
        -- character
        (if val' == "" then safeTail else id) $
           concatMap (getContinuation) valrest
374
375
    safeTail (_:xs) = xs
    safeTail [] = []
376

377
378
    -- the continuation of a field value is everything that is indented
    -- relative to the field's label
379
380
381
382
383
384
385
386
387
388
    getValRest [] = return ([],[])
    getValRest lls@((n,l):ls) =
        let (ind, v') = span isSpace l in
        case () of
         _ | indent > 0 && '\t' `elem` ind   -> tabsError n
           | length ind <= indent || null v' -> return ([], lls)
           | otherwise ->
               do (valrest, lines') <- getValRest ls
                  return (v':valrest, lines')

389
390
391
392
393
    getContinuation line = '\n':stripDot (dropWhile isSpace line)
    stripDot "." = ""
    stripDot s   = s

------------------------------------------------------------------------------
simonmar's avatar
simonmar committed
394
395

-- |parse a module name
396
parseModuleNameQ :: ReadP r String
ijones's avatar
ijones committed
397
398
parseModuleNameQ = parseQuoted modu <++ modu
 where modu = do 
399
400
401
	  c <- satisfy isUpper
	  cs <- munch (\x -> isAlphaNum x || x `elem` "_'.")
	  return (c:cs)
simonmar's avatar
simonmar committed
402

403
parseFilePathQ :: ReadP r FilePath
404
405
406
parseFilePathQ = parseTokenQ 
  -- removed until normalise is no longer broken, was:
  --   liftM normalise parseTokenQ
simonmar's avatar
simonmar committed
407
408
409
410
411

parseReadS :: Read a => ReadP r a
parseReadS = readS_to_P reads

parseDependency :: ReadP r Dependency
412
parseDependency = do name <- parsePackageNameQ
simonmar's avatar
simonmar committed
413
                     skipSpaces
414
                     ver <- parseVersionRangeQ <++ return AnyVersion
simonmar's avatar
simonmar committed
415
416
417
                     skipSpaces
                     return $ Dependency name ver

ijones's avatar
ijones committed
418
parsePackageNameQ :: ReadP r String
419
parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName 
ijones's avatar
ijones committed
420
421

parseVersionRangeQ :: ReadP r VersionRange
422
423
parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange

simonmar's avatar
simonmar committed
424
parseOptVersion :: ReadP r Version
425
426
427
428
429
430
431
432
433
434
435
parseOptVersion = parseQuoted ver <++ ver
  where ver = parseVersion <++ return noVersion
	noVersion = Version{ versionBranch=[], versionTags=[] }

parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)
parseTestedWithQ = parseQuoted tw <++ tw
  where tw = do compiler <- parseReadS
		skipSpaces
		version <- parseVersionRange <++ return AnyVersion
		skipSpaces
		return (compiler,version)
simonmar's avatar
simonmar committed
436

437
438
parseLicenseQ :: ReadP r License
parseLicenseQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
439

440
441
442
443
-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a
-- because the "compat" version of ReadP isn't quite powerful enough.  In
-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a
-- Hence the trick above to make 'lic' polymorphic.
simonmar's avatar
simonmar committed
444

445
446
parseExtensionQ :: ReadP r Extension
parseExtensionQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
447

448
449
450
451
-- | Parse something optionally wrapped in quotes.
parseReadSQ :: Read a => ReadP r a
parseReadSQ = parseQuoted parseReadS <++ parseReadS

ijones's avatar
ijones committed
452
453
parseTokenQ :: ReadP r String
parseTokenQ = parseReadS <++ munch1 (\x -> not (isSpace x) && x /= ',')
simonmar's avatar
simonmar committed
454

Simon Marlow's avatar
Simon Marlow committed
455
456
457
458
459
460
461
462
463
parseTokenQ' :: ReadP r String
parseTokenQ' = parseReadS <++ munch1 (\x -> not (isSpace x))

parseSepList :: ReadP r b
	     -> ReadP r a -- ^The parser for the stuff between commas
             -> ReadP r [a]
parseSepList sepr p = sepBy p separator
    where separator = skipSpaces >> sepr >> skipSpaces

simonmar's avatar
simonmar committed
464
465
parseCommaList :: ReadP r a -- ^The parser for the stuff between commas
               -> ReadP r [a]
Simon Marlow's avatar
Simon Marlow committed
466
parseCommaList = parseSepList (ReadP.char ',')
simonmar's avatar
simonmar committed
467

ijones's avatar
ijones committed
468
parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas
Simon Marlow's avatar
Simon Marlow committed
469
470
                  -> ReadP r [a]
parseOptCommaList = parseSepList (optional (ReadP.char ','))
ijones's avatar
ijones committed
471

472
473
474
parseQuoted :: ReadP r a -> ReadP r a
parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p

simonmar's avatar
simonmar committed
475
476
477
478
-- --------------------------------------------
-- ** Pretty printing

showFilePath :: FilePath -> Doc
ijones's avatar
ijones committed
479
480
481
482
showFilePath = showToken

showToken :: String -> Doc
showToken str
483
484
 | not (any dodgy str) &&
   not (null str)       = text str
ijones's avatar
ijones committed
485
486
 | otherwise            = text (show str)
  where dodgy c = isSpace c || c == ','
simonmar's avatar
simonmar committed
487
488
489
490
491
492

showTestedWith :: (CompilerFlavor,VersionRange) -> Doc
showTestedWith (compiler,version) = text (show compiler ++ " " ++ showVersionRange version)

showDependency :: Dependency -> Doc
showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)
493
494
495
496
497

-- | Pretty-print free-format text, ensuring that it is vertically aligned,
-- and with blank lines replaced by dots for correct re-parsing.
showFreeText :: String -> Doc
showFreeText s = vcat [text (if null l then "." else l) | l <- lines s]
498
499
500
501
502

------------------------------------------------------------------------------
-- TESTING

#ifdef DEBUG
nominolo@gmail.com's avatar
nominolo@gmail.com committed
503
504
505
test_readFields = case 
                    readFields testFile 
                  of
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
                    ParseOk _ x -> x == expectedResult
                    _ -> False
  where 
    testFile = unlines $
          [ "Cabal-version: 3"
          , ""
          , "Description: This is a test file   "
          , "  with a description longer than two lines.  "
          , "if os(windows) {"
          , "  License:  You may not use this software"
          , "    ."
          , "    If you do use this software you will be seeked and destroyed."
          , "}"
          , "if os(linux) {"
          , "  Main-is:  foo1  "
          , "}"
          , ""
          , "if os(vista) {"
          , "  executable RootKit {"
          , "    Main-is: DRMManager.hs"
          , "  }"
          , "} else {"
          , "  executable VistaRemoteAccess {"
          , "    Main-is: VCtrl"
          , "}}"
          , ""
          , "executable Foo-bar {"
          , "  Main-is: Foo.hs"
          , "}"
          ]
    expectedResult = 
          [ F 1 "cabal-version" "3"
          , F 3 "description" 
                  "This is a test file\nwith a description longer than two lines."
540
          , IfBlock 5 "os(windows) " 
541
542
543
544
              [ F 6 "license" 
                      "You may not use this software\n\nIf you do use this software you will be seeked and destroyed."
              ]
              []
545
          , IfBlock 10 "os(linux) " 
546
547
              [ F 11 "main-is" "foo1" ] 
              [ ]
548
549
          , IfBlock 14 "os(vista) " 
              [ Section 15 "executable" "RootKit " 
550
551
                [ F 16 "main-is" "DRMManager.hs"]
              ] 
552
              [ Section 19 "executable" "VistaRemoteAccess "
553
554
                 [F 20 "main-is" "VCtrl"]
              ]
555
          , Section 23 "executable" "Foo-bar " 
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
              [F 24 "main-is" "Foo.hs"]
          ]

test_readFieldsCompat' = case test_readFieldsCompat of
                           ParseOk _ fs -> mapM_ (putStrLn . show) fs
                           x -> putStrLn $ "Failed: " ++ show x
test_readFieldsCompat = readFields testPkgDesc
  where 
    testPkgDesc = unlines [
        "-- Required",
        "Name: Cabal",
        "Version: 0.1.1.1.1-rain",
        "License: LGPL",
        "License-File: foo",
        "Copyright: Free Text String",
        "Cabal-version: >1.1.1",
        "-- Optional - may be in source?",
        "Author: Happy Haskell Hacker",
        "Homepage: http://www.haskell.org/foo",
        "Package-url: http://www.haskell.org/foo",
        "Synopsis: a nice package!",
        "Description: a really nice package!",
        "Category: tools",
        "buildable: True",
        "CC-OPTIONS: -g -o",
        "LD-OPTIONS: -BStatic -dn",
        "Frameworks: foo",
        "Tested-with: GHC",
        "Stability: Free Text String",
        "Build-Depends: haskell-src, HUnit>=1.0.0-rain",
        "Other-Modules: Distribution.Package, Distribution.Version,",
        "                Distribution.Simple.GHCPackageConfig",
        "Other-files: file1, file2",
        "Extra-Tmp-Files:    file1, file2",
        "C-Sources: not/even/rain.c, such/small/hands",
        "HS-Source-Dirs: src, src2",
        "Exposed-Modules: Distribution.Void, Foo.Bar",
        "Extensions: OverlappingInstances, TypeSynonymInstances",
        "Extra-Libraries: libfoo, bar, bang",
        "Extra-Lib-Dirs: \"/usr/local/libs\"",
        "Include-Dirs: your/slightest, look/will",
        "Includes: /easily/unclose, /me, \"funky, path\\\\name\"",
        "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"",
        "GHC-Options: -fTH -fglasgow-exts",
        "Hugs-Options: +TH",
        "Nhc-Options: ",
        "Jhc-Options: ",
        "",
        "-- Next is an executable",
        "Executable: somescript",
        "Main-is: SomeFile.hs",
        "Other-Modules: Foo1, Util, Main",
        "HS-Source-Dir: scripts",
        "Extensions: OverlappingInstances",
        "GHC-Options: ",
        "Hugs-Options: ",
        "Nhc-Options: ",
        "Jhc-Options: "
        ]
{-
test' = do h <- openFile "../Cabal.cabal" ReadMode
           s <- hGetContents h
           let r = readFields s
           case r of
             ParseOk _ fs -> mapM_ (putStrLn . show) fs
             x -> putStrLn $ "Failed: " ++ show x
           putStrLn "==================="
           mapM_ (putStrLn . show) $
                 merge . zip [1..] . lines $ s
           hClose h
-}
nominolo@gmail.com's avatar
nominolo@gmail.com committed
627
628
-- 
#endif