ParseUtils.hs 20.8 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(..),
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
81
82
83

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

type LineNo = Int

data PError = AmbigousParse String LineNo
            | NoParse String LineNo
            | FromString String (Maybe LineNo)
        deriving Show

84
85
86
type PWarning = String

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

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

97
runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
Simon Marlow's avatar
Simon Marlow committed
98
runP lineNo fieldname p s =
simonmar's avatar
simonmar committed
99
  case [ x | (x,"") <- results ] of
100
    [a] -> ParseOk [] a
simonmar's avatar
simonmar committed
101
    []  -> case [ x | (x,ys) <- results, all isSpace ys ] of
102
             [a] -> ParseOk [] a
Simon Marlow's avatar
Simon Marlow committed
103
104
105
             []  -> ParseFailed (NoParse fieldname lineNo)
             _   -> ParseFailed (AmbigousParse fieldname lineNo)
    _   -> ParseFailed (AmbigousParse fieldname lineNo)
simonmar's avatar
simonmar committed
106
107
  where results = readP_to_S p s

ijones's avatar
ijones committed
108
locatedErrorMsg :: PError -> (Maybe LineNo, String)
nominolo@gmail.com's avatar
nominolo@gmail.com committed
109
locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'")
110
locatedErrorMsg (NoParse f n)       = (Just n, "Parse of field '"++f++"' failed: ")
ijones's avatar
ijones committed
111
112
113
114
locatedErrorMsg (FromString s n)    = (n, s)

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

116
117
118
warning :: String -> ParseResult ()
warning s = ParseOk [s] ()

nominolo@gmail.com's avatar
nominolo@gmail.com committed
119
120
-- | Field descriptor.  The parameter @a@ parameterizes over where the field's
--   value is stored in.
Simon Marlow's avatar
Simon Marlow committed
121
122
data FieldDescr a 
  = FieldDescr 
simonmar's avatar
simonmar committed
123
124
      { fieldName     :: String
      , fieldGet      :: a -> Doc
125
      , fieldSet      :: LineNo -> String -> a -> ParseResult a
nominolo@gmail.com's avatar
nominolo@gmail.com committed
126
127
128
        -- ^ @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
129
130
      }

Simon Marlow's avatar
Simon Marlow committed
131
132
133
134
field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a
field name showF readF = 
  FieldDescr name showF (\lineNo val _st -> runP lineNo name readF val)

nominolo@gmail.com's avatar
nominolo@gmail.com committed
135
136
-- Lift a field descriptor storing into an 'a' to a field descriptor storing
-- into a 'b'.
Simon Marlow's avatar
Simon Marlow committed
137
138
139
140
141
142
143
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
liftField get set (FieldDescr name showF parseF)
 = FieldDescr name (\b -> showF (get b))
	(\lineNo str b -> do
	    a <- parseF lineNo str (get b)
	    return (set a b))

nominolo@gmail.com's avatar
nominolo@gmail.com committed
144
145
146
-- Parser combinator for simple fields.  Takes a field name, a pretty printer,
-- a parser function, an accessor, and a modifier, returns a package
-- FieldDescr over the compoid structure.
Simon Marlow's avatar
Simon Marlow committed
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
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
175

176
177
------------------------------------------------------------------------------

178
179
trimTrailingSpaces :: String -> String
trimTrailingSpaces = reverse . dropWhile isSpace . reverse
simonmar's avatar
simonmar committed
180

181
182
183
184

dropSpaces :: String -> String
dropSpaces = dropWhile isSpace

185
186
187
188
189
190
191
192
193
194
195
196
data Field = F LineNo String String
           | Section LineNo String String [Field]
           | IfBlock LineNo String [Field] [Field]
             deriving (Show
                      ,Eq)   -- for testing

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

fName (F _ n _) = n
197
198
199

--   sectionname ::= "library" | "executable"
sectionNames :: [String]
nominolo@gmail.com's avatar
nominolo@gmail.com committed
200
sectionNames = ["library", "executable", "flag"]
Simon Marlow's avatar
Simon Marlow committed
201
202
203

-- |Split a file into "Field: value" groups
readFields :: String -> ParseResult [Field]
204
205
206
207
208
209
readFields = mkStanza 
           -- . merge 
           . filter validLine 
           . zip [1..] 
           . map trimTrailingSpaces . lines
  where validLine (_,s) = case dropSpaces s of
ijones's avatar
ijones committed
210
211
212
                            '-':'-':_ -> False      -- Comment
                            []        -> False      -- blank line
                            _         -> True
simonmar's avatar
simonmar committed
213

Simon Marlow's avatar
Simon Marlow committed
214
mkStanza :: [(Int,String)] -> ParseResult [Field]
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
mkStanza lines = parseLines lines []
  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, [])
getField ((n,[]):lines) = return (Nothing,lines)
getField ((n,'#':xs):lines) | not (isSpace (head xs)) = do
  return (Just $ F n ('#':dir) (dropSpaces val), lines)
Simon Marlow's avatar
Simon Marlow committed
233
  where (dir,val) = break isSpace xs
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
getField ((lineno,line0):lines) =
    let (spaces,line) = span isSpace line0
        indent = length spaces in 
    case break (`elem` " :{") line of
      (fld0, ':':val0) -> do  -- regular field
        let fld = map toLower fld0
            (val, lines') = getFieldValue indent (dropWhile isSpace val0) lines
        return (Just $ F lineno fld val, lines')
      (blkName, ' ':rest) 
        | map toLower blkName == "if"             -> getIf (lineno,rest) lines 
        | map toLower blkName `elem` sectionNames -> getSection blkName (lineno,rest) lines
        | otherwise -> syntaxError lineno $
            "Missing colon after field label or invalid section name"
      (blkName, '{':rest) 
        | map toLower blkName `elem` sectionNames -> 
            getSection blkName (lineno,'{':rest) lines
      ("","") -> return (Nothing,lines)
      (_,_) -> syntaxError lineno $
        "Unrecognized field format: '" ++ line ++ "'"
          


-- parses:
--
--   cond ::= (any - '}')* block [ space* "else" block ]
--
getIf :: (Int,String) -> [(Int,String)] -> ParseResult (Maybe Field,[(Int,String)])
getIf (n,rest) lines = do
    (cond, ifBlock, lines') <- 
        case break (=='{') (dropSpaces rest) of
          (cond, '{':cs) -> 
            do (b,ls) <- getBlock (n,'{':cs) lines
               return (cond, b, ls)
          (cond, _) -> -- condition spans more than one line
            syntaxError n "Multi-line conditions currently not supported."
    (elseBlock, lines'') <- tryElseBlock lines'
270
    return (Just $ IfBlock n cond ifBlock elseBlock, lines'') 
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
  where 
    tryElseBlock [] = return ([], [])
    tryElseBlock ((n,l):ls) = 
        if all isSpace l then return ([],ls) 
        else case (splitAt 4 . dropSpaces) l of
          (kw, rest) -> 
              if kw == "else" then 
                  getBlock (n,dropSpaces rest) ls
              else syntaxError n "Only 'else' may appear after an if-Block"
          
-- parses:
-- 
--   block ::= space* '{' space* '\n'
--             field*
--             space* '}' space* '\n'
--   
getBlock :: (Int,String) -> [(Int,String)] -> ParseResult ([Field],[(Int,String)])
getBlock (n,rest) lines = do
    lines' <- checkBlockStart (n,dropSpaces rest) lines
    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"
    munchTillEndOfBlock lines@((n,l):ls) fs =
        case break (=='}') l of
          (spaces, '}':rest) ->   
              if all isSpace spaces
              then return ( reverse fs
                          , (n, rest):ls) 
              else syntaxError n "'}' must be first character on the line"
          _ -> do (f,ls') <- getField lines
                  munchTillEndOfBlock ls' $ maybe fs (:fs) f

-- parses:
--
--   section ::= space* [ blocklabel ] space* block
--   
getSection :: String -> (Int,String) -> [(Int,String)] 
           -> ParseResult (Maybe Field,[(Int,String)])
getSection sectName (n,l) lines = 
    case break (=='{') (dropSpaces l) of
      (sectLabel, '{':rest) -> 
          do (b,lines') <- getBlock (n,'{':rest) lines 
320
             return (Just $ Section n sectName (trimTrailingSpaces sectLabel) b, lines')
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344

-- Get the field value of a field at given indentation      
getFieldValue :: Int -> String -> [(Int,String)] 
              -> (String,[(Int,String)])
getFieldValue indent val lines = 
    ( val' ++ rest 
    , lines')
  where
    val' = dropWhile isSpace val
    rest = (if val' == "" then tail else id) $
             -- don't include initial newline if it would be the first
             -- character
             concatMap (getContinuation . snd) valrest
                
    (valrest,lines') = span (isContinuation indent . snd) lines
    -- the continuation of a field value is everything that is indented
    -- relative to the field's label
    isContinuation indent line = 
        length (takeWhile isSpace line) > indent && not (all isSpace line)
    getContinuation line = '\n':stripDot (dropWhile isSpace line)
    stripDot "." = ""
    stripDot s   = s

------------------------------------------------------------------------------
simonmar's avatar
simonmar committed
345
346

-- |parse a module name
347
parseModuleNameQ :: ReadP r String
ijones's avatar
ijones committed
348
349
parseModuleNameQ = parseQuoted modu <++ modu
 where modu = do 
350
351
352
	  c <- satisfy isUpper
	  cs <- munch (\x -> isAlphaNum x || x `elem` "_'.")
	  return (c:cs)
simonmar's avatar
simonmar committed
353

354
parseFilePathQ :: ReadP r FilePath
355
parseFilePathQ = liftM normalise parseTokenQ
simonmar's avatar
simonmar committed
356
357
358
359
360

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

parseDependency :: ReadP r Dependency
361
parseDependency = do name <- parsePackageNameQ
simonmar's avatar
simonmar committed
362
                     skipSpaces
363
                     ver <- parseVersionRangeQ <++ return AnyVersion
simonmar's avatar
simonmar committed
364
365
366
                     skipSpaces
                     return $ Dependency name ver

ijones's avatar
ijones committed
367
parsePackageNameQ :: ReadP r String
368
parsePackageNameQ = parseQuoted parsePackageName <++ parsePackageName 
ijones's avatar
ijones committed
369
370

parseVersionRangeQ :: ReadP r VersionRange
371
372
parseVersionRangeQ = parseQuoted parseVersionRange <++ parseVersionRange

simonmar's avatar
simonmar committed
373
parseOptVersion :: ReadP r Version
374
375
376
377
378
379
380
381
382
383
384
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
385

386
387
parseLicenseQ :: ReadP r License
parseLicenseQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
388

389
390
391
392
-- 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
393

394
395
parseExtensionQ :: ReadP r Extension
parseExtensionQ = parseQuoted parseReadS <++ parseReadS
simonmar's avatar
simonmar committed
396

397
398
399
400
-- | Parse something optionally wrapped in quotes.
parseReadSQ :: Read a => ReadP r a
parseReadSQ = parseQuoted parseReadS <++ parseReadS

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

Simon Marlow's avatar
Simon Marlow committed
404
405
406
407
408
409
410
411
412
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
413
414
parseCommaList :: ReadP r a -- ^The parser for the stuff between commas
               -> ReadP r [a]
Simon Marlow's avatar
Simon Marlow committed
415
parseCommaList = parseSepList (ReadP.char ',')
simonmar's avatar
simonmar committed
416

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

421
422
423
parseQuoted :: ReadP r a -> ReadP r a
parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p

simonmar's avatar
simonmar committed
424
425
426
427
-- --------------------------------------------
-- ** Pretty printing

showFilePath :: FilePath -> Doc
ijones's avatar
ijones committed
428
429
430
431
showFilePath = showToken

showToken :: String -> Doc
showToken str
432
433
 | not (any dodgy str) &&
   not (null str)       = text str
ijones's avatar
ijones committed
434
435
 | otherwise            = text (show str)
  where dodgy c = isSpace c || c == ','
simonmar's avatar
simonmar committed
436
437
438
439
440
441

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

showDependency :: Dependency -> Doc
showDependency (Dependency name ver) = text name <+> text (showVersionRange ver)
442
443
444
445
446

-- | 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]
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486

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

#ifdef DEBUG
test_readFields = case readFields testFile of
                    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."
487
          , IfBlock 5 "os(windows) " 
488
489
490
491
              [ F 6 "license" 
                      "You may not use this software\n\nIf you do use this software you will be seeked and destroyed."
              ]
              []
492
          , IfBlock 10 "os(linux) " 
493
494
              [ F 11 "main-is" "foo1" ] 
              [ ]
495
496
          , IfBlock 14 "os(vista) " 
              [ Section 15 "executable" "RootKit " 
497
498
                [ F 16 "main-is" "DRMManager.hs"]
              ] 
499
              [ Section 19 "executable" "VistaRemoteAccess "
500
501
                 [F 20 "main-is" "VCtrl"]
              ]
502
          , Section 23 "executable" "Foo-bar " 
503
504
505
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
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
              [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
-}
#endif