ParseUtils.hs 22.2 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)
67
import System.FilePath (normalise)
Simon Marlow's avatar
Simon Marlow committed
68
69
70
import Language.Haskell.Extension (Extension)

import Text.PrettyPrint.HughesPJ
ijones's avatar
ijones committed
71
import Control.Monad (liftM)
simonmar's avatar
simonmar committed
72
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
73
import Data.Maybe	( fromMaybe)
simonmar's avatar
simonmar committed
74
75
76
77
78
79
80

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

type LineNo = Int

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

85
86
87
type PWarning = String

data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
88
89
90
        deriving Show

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

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

parseFail :: PError -> ParseResult a
parseFail = ParseFailed

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

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

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

126
127
128
tabsError :: LineNo -> ParseResult a
tabsError ln = ParseFailed $ TabsError ln

129
130
131
warning :: String -> ParseResult ()
warning s = ParseOk [s] ()

nominolo@gmail.com's avatar
nominolo@gmail.com committed
132
133
-- | Field descriptor.  The parameter @a@ parameterizes over where the field's
--   value is stored in.
Simon Marlow's avatar
Simon Marlow committed
134
135
data FieldDescr a 
  = FieldDescr 
simonmar's avatar
simonmar committed
136
137
      { fieldName     :: String
      , fieldGet      :: a -> Doc
138
      , fieldSet      :: LineNo -> String -> a -> ParseResult a
nominolo@gmail.com's avatar
nominolo@gmail.com committed
139
140
141
        -- ^ @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
142
143
      }

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

nominolo@gmail.com's avatar
nominolo@gmail.com committed
148
149
-- Lift a field descriptor storing into an 'a' to a field descriptor storing
-- into a 'b'.
Simon Marlow's avatar
Simon Marlow committed
150
151
152
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
153
154
	(\line str b -> do
	    a <- parseF line str (get b)
Simon Marlow's avatar
Simon Marlow committed
155
156
	    return (set a b))

nominolo@gmail.com's avatar
nominolo@gmail.com committed
157
-- Parser combinator for simple fields.  Takes a field name, a pretty printer,
nominolo@gmail.com's avatar
nominolo@gmail.com committed
158
159
-- a parser function, an accessor, and a setter, returns a FieldDescr over the
-- compoid structure.
Simon Marlow's avatar
Simon Marlow committed
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
186
187
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
188

189
190
------------------------------------------------------------------------------

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

194
195
196
197

dropSpaces :: String -> String
dropSpaces = dropWhile isSpace

nominolo@gmail.com's avatar
nominolo@gmail.com committed
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
-- 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
220
      -- @
nominolo@gmail.com's avatar
nominolo@gmail.com committed
221
222
      deriving (Show
               ,Eq)   -- for testing
223
224
225
226
227
228

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

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

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

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

Simon Marlow's avatar
Simon Marlow committed
250
mkStanza :: [(Int,String)] -> ParseResult [Field]
nominolo@gmail.com's avatar
nominolo@gmail.com committed
251
mkStanza lines0 = parseLines lines0 []
252
253
254
255
256
257
258
259
260
261
262
263
264
265
  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
266
267
268
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
269
  where (dir,val) = break isSpace xs
nominolo@gmail.com's avatar
nominolo@gmail.com committed
270
getField ((lineno,line0):lines0) =
271
272
    let (spaces,line) = span (==' ') line0
        indent = length spaces in
273
    case break (`elem` " :{") line of
274
      ('\t':_,_) -> tabsError lineno
275
      (fld0, ':':val0) -> do  -- regular field
276
277
278
279
          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
280
281
282
        | map toLower blkName == "if"             -> getIf (lineno,rest) lines0
        | map toLower blkName `elem` sectionNames -> 
            getSection (map toLower blkName) (lineno,rest) lines0
283
284
285
286
        | 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
287
288
            getSection (map toLower blkName) (lineno,'{':rest) lines0
      ("","") -> return (Nothing,lines0)
289
290
291
292
293
294
295
296
297
298
      (_,_) -> 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
299
getIf (n,rest) ls = do
300
301
302
    (cond, ifBlock, lines') <- 
        case break (=='{') (dropSpaces rest) of
          (cond, '{':cs) -> 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
303
304
305
            do (b,ls') <- getBlock (n,'{':cs) ls
               return (cond, b, ls')
          (_, _) -> -- condition spans more than one line
306
307
            syntaxError n "Multi-line conditions currently not supported."
    (elseBlock, lines'') <- tryElseBlock lines'
308
    return (Just $ IfBlock n cond ifBlock elseBlock, lines'') 
309
310
  where 
    tryElseBlock [] = return ([], [])
nominolo@gmail.com's avatar
nominolo@gmail.com committed
311
312
    tryElseBlock ((m,l):ls') = 
        if all isSpace l then return ([],ls') 
313
        else case (splitAt 4 . dropSpaces) l of
nominolo@gmail.com's avatar
nominolo@gmail.com committed
314
          (kw, rst) -> 
315
              if kw == "else" then 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
316
317
                  getBlock (m,dropSpaces rst) ls'
              else syntaxError m "Only 'else' may appear after an if-Block"
318
319
320
321
322
323
324
325
          
-- 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
326
327
getBlock (lnum,rest) lines0 = do
    lines' <- checkBlockStart (lnum,dropSpaces rest) lines0
328
329
330
331
332
333
334
335
336
337
    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
338
    munchTillEndOfBlock lines1@((n,l):ls) fs =
339
        case break (=='}') l of
nominolo@gmail.com's avatar
nominolo@gmail.com committed
340
          (spaces, '}':rst) ->   
341
342
              if all isSpace spaces
              then return ( reverse fs
nominolo@gmail.com's avatar
nominolo@gmail.com committed
343
                          , (n, rst):ls) 
344
              else syntaxError n "'}' must be first character on the line"
nominolo@gmail.com's avatar
nominolo@gmail.com committed
345
          _ -> do (f,ls') <- getField lines1
346
347
348
349
350
351
352
353
                  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
354
getSection sectName (n,l) lines0 = 
355
356
    case break (=='{') (dropSpaces l) of
      (sectLabel, '{':rest) -> 
nominolo@gmail.com's avatar
nominolo@gmail.com committed
357
          do (b,lines') <- getBlock (n,'{':rest) lines0 
358
             return (Just $ Section n sectName (trimTrailingSpaces sectLabel) b, lines')
nominolo@gmail.com's avatar
nominolo@gmail.com committed
359
      (_,_) -> error "getSection got a line without a '{'.  Consider this a bug."
360

361
362
363
364
365
366
367
368
-- 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')
369
370
  where
    val' = dropWhile isSpace val
371
372
373
374
375
    rest valrest =
        -- don't include initial newline if it would be the first
        -- character
        (if val' == "" then safeTail else id) $
           concatMap (getContinuation) valrest
376
377
    safeTail (_:xs) = xs
    safeTail [] = []
378

379
380
    -- the continuation of a field value is everything that is indented
    -- relative to the field's label
381
382
383
384
385
386
387
388
389
390
    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')

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

------------------------------------------------------------------------------
simonmar's avatar
simonmar committed
396
397

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

405
parseFilePathQ :: ReadP r FilePath
406
parseFilePathQ = 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