Parse.hs 50.8 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.PackageDescription.Parse
-- Copyright   :  Isaac Jones 2003-2005
5
-- License     :  BSD3
6
--
Duncan Coutts's avatar
Duncan Coutts committed
7
-- Maintainer  :  cabal-devel@haskell.org
8
9
-- Portability :  portable
--
Duncan Coutts's avatar
Duncan Coutts committed
10
11
12
13
-- This defined parsers and partial pretty printers for the @.cabal@ format.
-- Some of the complexity in this module is due to the fact that we have to be
-- backwards compatible with old @.cabal@ files, so there's code to translate
-- into the newer structure.
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

module Distribution.PackageDescription.Parse (
        -- * Package descriptions
        readPackageDescription,
        writePackageDescription,
        parsePackageDescription,
        showPackageDescription,

        -- ** Parsing
        ParseResult(..),
        FieldDescr(..),
        LineNo,

        -- ** Supplementary build information
        readHookedBuildInfo,
        parseHookedBuildInfo,
30
31
        writeHookedBuildInfo,
        showHookedBuildInfo,
jutaro's avatar
jutaro committed
32
33
34
35
36
37
38
39

        pkgDescrFieldDescrs,
        libFieldDescrs,
        executableFieldDescrs,
        binfoFieldDescrs,
        sourceRepoFieldDescrs,
        testSuiteFieldDescrs,
        flagFieldDescrs
40
41
  ) where

42
import Data.Char  (isSpace)
43
import Data.Maybe (listToMaybe, isJust)
44
import Data.Monoid ( Monoid(..) )
45
import Data.List  (nub, unfoldr, partition, (\\))
46
47
import Control.Monad (liftM, foldM, when, unless, ap)
import Control.Applicative (Applicative(..))
48
import Control.Arrow (first)
49
import System.Directory (doesFileExist)
50
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
51

52
import Distribution.Text
53
         ( Text(disp, parse), display, simpleParse )
54
import Distribution.Compat.ReadP
55
         ((+++), option)
dterei's avatar
dterei committed
56
import Text.PrettyPrint
57

58
import Distribution.ParseUtils hiding (parseFields)
59
import Distribution.PackageDescription
60
61
import Distribution.PackageDescription.Utils
         ( cabalBug, userBug )
62
import Distribution.Package
63
         ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )
64
import Distribution.ModuleName ( ModuleName )
65
import Distribution.Version
66
67
        ( Version(Version), orLaterVersion
        , LowerBound(..), asVersionIntervals )
68
69
import Distribution.Verbosity (Verbosity)
import Distribution.Compiler  (CompilerFlavor(..))
70
import Distribution.PackageDescription.Configuration (parseCondition, freeVars)
71
import Distribution.Simple.Utils
72
         ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion
73
74
         , withFileContents, withUTF8FileContents
         , writeFileAtomic, writeUTF8File )
75
76
77
78
79
80
81


-- -----------------------------------------------------------------------------
-- The PackageDescription type

pkgDescrFieldDescrs :: [FieldDescr PackageDescription]
pkgDescrFieldDescrs =
82
    [ simpleField "name"
Duncan Coutts's avatar
Duncan Coutts committed
83
           disp                   parse
84
           packageName            (\name pkg -> pkg{package=(package pkg){pkgName=name}})
85
 , simpleField "version"
86
           disp                   parse
87
           packageVersion         (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})
88
 , simpleField "cabal-version"
89
90
           (either disp disp)     (liftM Left parse +++ liftM Right parse)
           specVersionRaw         (\v pkg -> pkg{specVersionRaw=v})
91
 , simpleField "build-type"
92
           (maybe empty disp)     (fmap Just parse)
93
94
           buildType              (\t pkg -> pkg{buildType=t})
 , simpleField "license"
Duncan Coutts's avatar
Duncan Coutts committed
95
           disp                   parseLicenseQ
96
           license                (\l pkg -> pkg{license=l})
Duncan Coutts's avatar
Duncan Coutts committed
97
98
99
100
101
102
   -- We have both 'license-file' and 'license-files' fields.
   -- Rather than declaring license-file to be deprecated, we will continue
   -- to allow both. The 'license-file' will continue to only allow single
   -- tokens, while 'license-files' allows multiple. On pretty-printing, we
   -- will use 'license-file' if there's just one, and use 'license-files'
   -- otherwise.
103
104
 , simpleField "license-file"
           showFilePath           parseFilePathQ
Duncan Coutts's avatar
Duncan Coutts committed
105
106
107
108
           (\pkg -> case licenseFiles pkg of
                      [x] -> x
                      _   -> "")
           (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})
109
 , spaceListField "license-files"
Duncan Coutts's avatar
Duncan Coutts committed
110
111
112
113
114
           showFilePath           parseFilePathQ
           (\pkg -> case licenseFiles pkg of
                      [_] -> []
                      xs  -> xs)
           (\ls pkg -> pkg{licenseFiles=ls})
115
 , simpleField "copyright"
116
           showFreeText           parseFreeText
117
           copyright              (\val pkg -> pkg{copyright=val})
118
 , simpleField "maintainer"
119
           showFreeText           parseFreeText
120
121
           maintainer             (\val pkg -> pkg{maintainer=val})
 , commaListField  "build-depends"
122
           disp                   parse
123
124
           buildDepends           (\xs    pkg -> pkg{buildDepends=xs})
 , simpleField "stability"
125
           showFreeText           parseFreeText
126
127
           stability              (\val pkg -> pkg{stability=val})
 , simpleField "homepage"
128
           showFreeText           parseFreeText
129
130
           homepage               (\val pkg -> pkg{homepage=val})
 , simpleField "package-url"
131
           showFreeText           parseFreeText
132
           pkgUrl                 (\val pkg -> pkg{pkgUrl=val})
Duncan Coutts's avatar
Duncan Coutts committed
133
134
135
 , simpleField "bug-reports"
           showFreeText           parseFreeText
           bugReports             (\val pkg -> pkg{bugReports=val})
136
 , simpleField "synopsis"
137
           showFreeText           parseFreeText
138
           synopsis               (\val pkg -> pkg{synopsis=val})
139
 , simpleNestedField "description"
140
           showFreeText           parseFreeText
141
142
           description            (\val pkg -> pkg{description=val})
 , simpleField "category"
143
           showFreeText           parseFreeText
144
145
           category               (\val pkg -> pkg{category=val})
 , simpleField "author"
146
           showFreeText           parseFreeText
147
           author                 (\val pkg -> pkg{author=val})
148
 , spaceListField "tested-with"
149
150
           showTestedWith         parseTestedWithQ
           testedWith             (\val pkg -> pkg{testedWith=val})
151
 , listField "data-files"
152
153
           showFilePath           parseFilePathQ
           dataFiles              (\val pkg -> pkg{dataFiles=val})
154
155
156
 , simpleField "data-dir"
           showFilePath           parseFilePathQ
           dataDir                (\val pkg -> pkg{dataDir=val})
157
 , listField "extra-source-files"
158
159
           showFilePath    parseFilePathQ
           extraSrcFiles          (\val pkg -> pkg{extraSrcFiles=val})
160
 , listField "extra-tmp-files"
161
162
           showFilePath       parseFilePathQ
           extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})
163
 , listField "extra-doc-files"
164
           showFilePath    parseFilePathQ
165
           extraDocFiles          (\val pkg -> pkg{extraDocFiles=val})
166
167
 ]

168
169
170
-- | Store any fields beginning with "x-" in the customFields field of
--   a PackageDescription.  All other fields will generate a warning.
storeXFieldsPD :: UnrecFieldParser PackageDescription
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
171
172
173
storeXFieldsPD (f@('x':'-':_),val) pkg =
  Just pkg{ customFieldsPD =
               customFieldsPD pkg ++ [(f,val)]}
174
175
storeXFieldsPD _ _ = Nothing

176
177
178
179
-- ---------------------------------------------------------------------------
-- The Library type

libFieldDescrs :: [FieldDescr Library]
180
181
182
183
184
185
186
libFieldDescrs =
  [ listField "exposed-modules" disp parseModuleNameQ
      exposedModules (\mods lib -> lib{exposedModules=mods})

  , boolField "exposed"
      libExposed     (\val lib -> lib{libExposed=val})
  ] ++ map biToLib binfoFieldDescrs
187
188
  where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})

189
storeXFieldsLib :: UnrecFieldParser Library
190
storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
191
192
    Just $ l {libBuildInfo =
                 bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}}
193
194
storeXFieldsLib _ _ = Nothing

195
196
197
198
199
-- ---------------------------------------------------------------------------
-- The Executable type


executableFieldDescrs :: [FieldDescr Executable]
200
executableFieldDescrs =
201
202
203
204
205
206
207
208
209
210
211
212
  [ -- note ordering: configuration must come first, for
    -- showPackageDescription.
    simpleField "executable"
                           showToken          parseTokenQ
                           exeName            (\xs    exe -> exe{exeName=xs})
  , simpleField "main-is"
                           showFilePath       parseFilePathQ
                           modulePath         (\xs    exe -> exe{modulePath=xs})
  ]
  ++ map biToExe binfoFieldDescrs
  where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})

213
214
storeXFieldsExe :: UnrecFieldParser Executable
storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =
EyalLotem's avatar
EyalLotem committed
215
    Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}}
216
storeXFieldsExe _ _ = Nothing
217

ttuegel's avatar
ttuegel committed
218
-- ---------------------------------------------------------------------------
219
-- The TestSuite type
ttuegel's avatar
ttuegel committed
220

221
222
223
224
225
226
227
228
-- | An intermediate type just used for parsing the test-suite stanza.
-- After validation it is converted into the proper 'TestSuite' type.
data TestSuiteStanza = TestSuiteStanza {
       testStanzaTestType   :: Maybe TestType,
       testStanzaMainIs     :: Maybe FilePath,
       testStanzaTestModule :: Maybe ModuleName,
       testStanzaBuildInfo  :: BuildInfo
     }
229

230
231
emptyTestStanza :: TestSuiteStanza
emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty
232

233
testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]
234
testSuiteFieldDescrs =
235
    [ simpleField "type"
236
237
        (maybe empty disp)    (fmap Just parse)
        testStanzaTestType    (\x suite -> suite { testStanzaTestType = x })
238
    , simpleField "main-is"
239
240
        (maybe empty showFilePath)  (fmap Just parseFilePathQ)
        testStanzaMainIs      (\x suite -> suite { testStanzaMainIs = x })
241
    , simpleField "test-module"
242
243
        (maybe empty disp)    (fmap Just parseModuleNameQ)
        testStanzaTestModule  (\x suite -> suite { testStanzaTestModule = x })
ttuegel's avatar
ttuegel committed
244
245
    ]
    ++ map biToTest binfoFieldDescrs
246
247
248
249
250
251
  where
    biToTest = liftField testStanzaBuildInfo
                         (\bi suite -> suite { testStanzaBuildInfo = bi })

storeXFieldsTest :: UnrecFieldParser TestSuiteStanza
storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =
EyalLotem's avatar
EyalLotem committed
252
    Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}}
253
254
255
256
257
storeXFieldsTest _ _ = Nothing

validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite
validateTestSuite line stanza =
    case testStanzaTestType stanza of
258
259
      Nothing -> return $
        emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }
260
261
262
263
264
265
266
267
268
269
270
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

      Just tt@(TestTypeUnknown _ _) ->
        return emptyTestSuite {
          testInterface = TestSuiteUnsupported tt,
          testBuildInfo = testStanzaBuildInfo stanza
        }

      Just tt | tt `notElem` knownTestTypes ->
        return emptyTestSuite {
          testInterface = TestSuiteUnsupported tt,
          testBuildInfo = testStanzaBuildInfo stanza
        }

      Just tt@(TestTypeExe ver) ->
        case testStanzaMainIs stanza of
          Nothing   -> syntaxError line (missingField "main-is" tt)
          Just file -> do
            when (isJust (testStanzaTestModule stanza)) $
              warning (extraField "test-module" tt)
            return emptyTestSuite {
              testInterface = TestSuiteExeV10 ver file,
              testBuildInfo = testStanzaBuildInfo stanza
            }

      Just tt@(TestTypeLib ver) ->
        case testStanzaTestModule stanza of
          Nothing      -> syntaxError line (missingField "test-module" tt)
          Just module_ -> do
            when (isJust (testStanzaMainIs stanza)) $
              warning (extraField "main-is" tt)
            return emptyTestSuite {
              testInterface = TestSuiteLibV09 ver module_,
              testBuildInfo = testStanzaBuildInfo stanza
            }

  where
    missingField name tt = "The '" ++ name ++ "' field is required for the "
                        ++ display tt ++ " test suite type."

    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"
                        ++ display tt ++ "' test suite type."

ttuegel's avatar
ttuegel committed
302

303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
-- ---------------------------------------------------------------------------
-- The Benchmark type

-- | An intermediate type just used for parsing the benchmark stanza.
-- After validation it is converted into the proper 'Benchmark' type.
data BenchmarkStanza = BenchmarkStanza {
       benchmarkStanzaBenchmarkType   :: Maybe BenchmarkType,
       benchmarkStanzaMainIs          :: Maybe FilePath,
       benchmarkStanzaBenchmarkModule :: Maybe ModuleName,
       benchmarkStanzaBuildInfo       :: BuildInfo
     }

emptyBenchmarkStanza :: BenchmarkStanza
emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty

benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]
benchmarkFieldDescrs =
    [ simpleField "type"
        (maybe empty disp)    (fmap Just parse)
        benchmarkStanzaBenchmarkType
        (\x suite -> suite { benchmarkStanzaBenchmarkType = x })
    , simpleField "main-is"
        (maybe empty showFilePath)  (fmap Just parseFilePathQ)
        benchmarkStanzaMainIs
        (\x suite -> suite { benchmarkStanzaMainIs = x })
    ]
    ++ map biToBenchmark binfoFieldDescrs
  where
    biToBenchmark = liftField benchmarkStanzaBuildInfo
                    (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })

storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza
storeXFieldsBenchmark (f@('x':'-':_), val)
    t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =
        Just $ t {benchmarkStanzaBuildInfo =
EyalLotem's avatar
EyalLotem committed
338
                       bi{ customFieldsBI = (f,val):customFieldsBI bi}}
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
storeXFieldsBenchmark _ _ = Nothing

validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark
validateBenchmark line stanza =
    case benchmarkStanzaBenchmarkType stanza of
      Nothing -> return $
        emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }

      Just tt@(BenchmarkTypeUnknown _ _) ->
        return emptyBenchmark {
          benchmarkInterface = BenchmarkUnsupported tt,
          benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
        }

      Just tt | tt `notElem` knownBenchmarkTypes ->
        return emptyBenchmark {
          benchmarkInterface = BenchmarkUnsupported tt,
          benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
        }

      Just tt@(BenchmarkTypeExe ver) ->
        case benchmarkStanzaMainIs stanza of
          Nothing   -> syntaxError line (missingField "main-is" tt)
          Just file -> do
            when (isJust (benchmarkStanzaBenchmarkModule stanza)) $
              warning (extraField "benchmark-module" tt)
            return emptyBenchmark {
              benchmarkInterface = BenchmarkExeV10 ver file,
              benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
            }

  where
    missingField name tt = "The '" ++ name ++ "' field is required for the "
                        ++ display tt ++ " benchmark type."

    extraField   name tt = "The '" ++ name ++ "' field is not used for the '"
                        ++ display tt ++ "' benchmark type."

377
378
379
380
381
382
-- ---------------------------------------------------------------------------
-- The BuildInfo type


binfoFieldDescrs :: [FieldDescr BuildInfo]
binfoFieldDescrs =
383
 [ boolField "buildable"
384
385
           buildable          (\val binfo -> binfo{buildable=val})
 , commaListField  "build-tools"
386
           disp               parseBuildTool
387
           buildTools         (\xs  binfo -> binfo{buildTools=xs})
388
 , spaceListField "cpp-options"
389
           showToken          parseTokenQ'
390
           cppOptions          (\val binfo -> binfo{cppOptions=val})
391
 , spaceListField "cc-options"
392
           showToken          parseTokenQ'
393
           ccOptions          (\val binfo -> binfo{ccOptions=val})
394
 , spaceListField "ld-options"
395
           showToken          parseTokenQ'
396
397
           ldOptions          (\val binfo -> binfo{ldOptions=val})
 , commaListField  "pkgconfig-depends"
398
           disp               parsePkgconfigDependency
399
           pkgconfigDepends   (\xs  binfo -> binfo{pkgconfigDepends=xs})
400
 , spaceListField "frameworks"
401
402
403
404
405
           showToken          parseTokenQ
           frameworks         (\val binfo -> binfo{frameworks=val})
 , listField   "c-sources"
           showFilePath       parseFilePathQ
           cSources           (\paths binfo -> binfo{cSources=paths})
406
407

 , simpleField "default-language"
408
           (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
409
           defaultLanguage    (\lang  binfo -> binfo{defaultLanguage=lang})
410
 , spaceListField "other-languages"
411
412
           disp               parseLanguageQ
           otherLanguages     (\langs binfo -> binfo{otherLanguages=langs})
413
 , spaceListField "default-extensions"
414
415
           disp               parseExtensionQ
           defaultExtensions  (\exts  binfo -> binfo{defaultExtensions=exts})
416
 , spaceListField "other-extensions"
417
418
           disp               parseExtensionQ
           otherExtensions    (\exts  binfo -> binfo{otherExtensions=exts})
419
 , spaceListField "extensions"
420
           disp               parseExtensionQ
421
422
           oldExtensions      (\exts  binfo -> binfo{oldExtensions=exts})

423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
 , listField   "extra-libraries"
           showToken          parseTokenQ
           extraLibs          (\xs    binfo -> binfo{extraLibs=xs})
 , listField   "extra-lib-dirs"
           showFilePath       parseFilePathQ
           extraLibDirs       (\xs    binfo -> binfo{extraLibDirs=xs})
 , listField   "includes"
           showFilePath       parseFilePathQ
           includes           (\paths binfo -> binfo{includes=paths})
 , listField   "install-includes"
           showFilePath       parseFilePathQ
           installIncludes    (\paths binfo -> binfo{installIncludes=paths})
 , listField   "include-dirs"
           showFilePath       parseFilePathQ
           includeDirs        (\paths binfo -> binfo{includeDirs=paths})
438
 , spaceListField "hs-source-dirs"
439
440
           showFilePath       parseFilePathQ
           hsSourceDirs       (\paths binfo -> binfo{hsSourceDirs=paths})
441
 , listField   "other-modules"
442
           disp               parseModuleNameQ
443
           otherModules       (\val binfo -> binfo{otherModules=val})
444
 , spaceListField "ghc-prof-options"
445
446
           text               parseTokenQ
           ghcProfOptions        (\val binfo -> binfo{ghcProfOptions=val})
447
 , spaceListField "ghc-shared-options"
448
           text               parseTokenQ
449
           ghcSharedOptions      (\val binfo -> binfo{ghcSharedOptions=val})
450
451
452
453
454
455
456
457
458
459
 , optsField   "ghc-options"  GHC
           options            (\path  binfo -> binfo{options=path})
 , optsField   "hugs-options" Hugs
           options            (\path  binfo -> binfo{options=path})
 , optsField   "nhc98-options"  NHC
           options            (\path  binfo -> binfo{options=path})
 , optsField   "jhc-options"  JHC
           options            (\path  binfo -> binfo{options=path})
 ]

460
storeXFieldsBI :: UnrecFieldParser BuildInfo
EyalLotem's avatar
EyalLotem committed
461
storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi }
462
463
storeXFieldsBI _ _ = Nothing

464
465
466
467
468
------------------------------------------------------------------------------

flagFieldDescrs :: [FieldDescr Flag]
flagFieldDescrs =
    [ simpleField "description"
469
        showFreeText     parseFreeText
470
        flagDescription  (\val fl -> fl{ flagDescription = val })
471
    , boolField "default"
472
        flagDefault      (\val fl -> fl{ flagDefault = val })
473
474
    , boolField "manual"
        flagManual       (\val fl -> fl{ flagManual = val })
475
476
    ]

477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
------------------------------------------------------------------------------

sourceRepoFieldDescrs :: [FieldDescr SourceRepo]
sourceRepoFieldDescrs =
    [ simpleField "type"
        (maybe empty disp)         (fmap Just parse)
        repoType                   (\val repo -> repo { repoType = val })
    , simpleField "location"
        (maybe empty showFreeText) (fmap Just parseFreeText)
        repoLocation               (\val repo -> repo { repoLocation = val })
    , simpleField "module"
        (maybe empty showToken)    (fmap Just parseTokenQ)
        repoModule                 (\val repo -> repo { repoModule = val })
    , simpleField "branch"
        (maybe empty showToken)    (fmap Just parseTokenQ)
        repoBranch                 (\val repo -> repo { repoBranch = val })
    , simpleField "tag"
        (maybe empty showToken)    (fmap Just parseTokenQ)
        repoTag                    (\val repo -> repo { repoTag = val })
    , simpleField "subdir"
        (maybe empty showFilePath) (fmap Just parseFilePathQ)
        repoSubdir                 (\val repo -> repo { repoSubdir = val })
    ]

501
502
503
504
505
-- ---------------------------------------------------------------
-- Parsing

-- | Given a parser and a filename, return the parse of the file,
-- after checking if the file exists.
506
readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)
507
508
509
                 -> (String -> ParseResult a)
                 -> Verbosity
                 -> FilePath -> IO a
510
readAndParseFile withFileContents' parser verbosity fpath = do
511
  exists <- doesFileExist fpath
EyalLotem's avatar
EyalLotem committed
512
513
  unless exists
    (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
514
  withFileContents' fpath $ \str -> case parser str of
515
516
517
    ParseFailed e -> do
        let (line, message) = locatedErrorMsg e
        dieWithLocation fpath line message
518
    ParseOk warnings x -> do
519
        mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings
520
521
522
        return x

readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
523
readHookedBuildInfo =
524
    readAndParseFile withFileContents parseHookedBuildInfo
525
526
527

-- |Parse the given package file.
readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
528
readPackageDescription =
529
    readAndParseFile withUTF8FileContents parsePackageDescription
530
531
532
533

stanzas :: [Field] -> [[Field]]
stanzas [] = []
stanzas (f:fields) = (f:this) : stanzas rest
534
  where
535
536
537
538
539
540
541
542
543
    (this, rest) = break isStanzaHeader fields

isStanzaHeader :: Field -> Bool
isStanzaHeader (F _ f _) = f == "executable"
isStanzaHeader _ = False

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


544
mapSimpleFields :: (Field -> ParseResult Field) -> [Field]
545
                -> ParseResult [Field]
EyalLotem's avatar
EyalLotem committed
546
mapSimpleFields f = mapM walk
547
  where
EyalLotem's avatar
EyalLotem committed
548
    walk fld@F{} = f fld
549
550
    walk (IfBlock l c fs1 fs2) = do
      fs1' <- mapM walk fs1
551
552
553
554
555
556
557
      fs2' <- mapM walk fs2
      return (IfBlock l c fs1' fs2')
    walk (Section ln n l fs1) = do
      fs1' <-  mapM walk fs1
      return (Section ln n l fs1')

-- prop_isMapM fs = mapSimpleFields return fs == return fs
558

559
560
561
562
563
564
565
566
567
568

-- names of fields that represents dependencies, thus consrca
constraintFieldNames :: [String]
constraintFieldNames = ["build-depends"]

-- Possible refactoring would be to have modifiers be explicit about what
-- they add and define an accessor that specifies what the dependencies
-- are.  This way we would completely reuse the parsing knowledge from the
-- field descriptor.
parseConstraint :: Field -> ParseResult [Dependency]
569
parseConstraint (F l n v)
570
    | n == "build-depends" = runP l n (parseCommaList parse) v
571
parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"
572
573
574

{-
headerFieldNames :: [String]
575
headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))
576
577
578
579
                 . map fieldName $ pkgDescrFieldDescrs
-}

libFieldNames :: [String]
580
libFieldNames = map fieldName libFieldDescrs
581
582
583
                ++ buildInfoNames ++ constraintFieldNames

-- exeFieldNames :: [String]
584
-- exeFieldNames = map fieldName executableFieldDescrs
585
586
587
588
589
590
591
592
593
594
--                 ++ buildInfoNames

buildInfoNames :: [String]
buildInfoNames = map fieldName binfoFieldDescrs
                ++ map fst deprecatedFieldsBuildInfo

-- A minimal implementation of the StateT monad transformer to avoid depending
-- on the 'mtl' package.
newtype StT s m a = StT { runStT :: s -> m (a,s) }

595
instance Functor f => Functor (StT s f) where
596
    fmap g (StT f) = StT $ fmap (first g)  . f
597
598
599
600
601

instance (Monad m, Functor m) => Applicative (StT s m) where
    pure = return
    (<*>) = ap

602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
instance Monad m => Monad (StT s m) where
    return a = StT (\s -> return (a,s))
    StT f >>= g = StT $ \s -> do
                        (a,s') <- f s
                        runStT (g a) s'

get :: Monad m => StT s m s
get = StT $ \s -> return (s, s)

modify :: Monad m => (s -> s) -> StT s m ()
modify f = StT $ \s -> return ((),f s)

lift :: Monad m => m a -> StT s m a
lift m = StT $ \s -> m >>= \a -> return (a,s)

evalStT :: Monad m => StT s m a -> s -> m a
EyalLotem's avatar
EyalLotem committed
618
evalStT st s = liftM fst $ runStT st s
619
620
621
622
623
624
625
626
627

-- Our monad for parsing a list/tree of fields.
--
-- The state represents the remaining fields to be processed.
type PM a = StT [Field] ParseResult a



-- return look-ahead field or nothing if we're at the end of the file
628
peekField :: PM (Maybe Field)
EyalLotem's avatar
EyalLotem committed
629
peekField = liftM listToMaybe get
630
631
632
633
634
635

-- Unconditionally discard the first field in our state.  Will error when it
-- reaches end of file.  (Yes, that's evil.)
skipField :: PM ()
skipField = modify tail

636
637
638
--FIXME: this should take a ByteString, not a String. We have to be able to
-- decode UTF8 and handle the BOM.

639
640
641
-- | Parses the given file into a 'GenericPackageDescription'.
--
-- In Cabal 1.2 the syntax for package descriptions was changed to a format
642
-- with sections and possibly indented property descriptions.
643
644
parsePackageDescription :: String -> ParseResult GenericPackageDescription
parsePackageDescription file = do
645
646
647
648
649
650
651

    -- This function is quite complex because it needs to be able to parse
    -- both pre-Cabal-1.2 and post-Cabal-1.2 files.  Additionally, it contains
    -- a lot of parser-related noise since we do not want to depend on Parsec.
    --
    -- If we detect an pre-1.2 file we implicitly convert it to post-1.2
    -- style.  See 'sectionizeFields' below for details about the conversion.
652
653

    fields0 <- readFields file `catchParseError` \err ->
654
                 let tabs = findIndentTabs file in
655
656
657
658
659
660
661
662
663
                 case err of
                   -- In case of a TabsError report them all at once.
                   TabsError tabLineNo -> reportTabsError
                   -- but only report the ones including and following
                   -- the one that caused the actual error
                                            [ t | t@(lineNo',_) <- tabs
                                                , lineNo' >= tabLineNo ]
                   _ -> parseFail err

664
    let cabalVersionNeeded =
665
          head $ [ minVersionBound versionRange
666
667
                 | Just versionRange <- [ simpleParse v
                                        | F _ "cabal-version" v <- fields0 ] ]
668
669
670
671
672
              ++ [Version [0] []]
        minVersionBound versionRange =
          case asVersionIntervals versionRange of
            []                            -> Version [0] []
            ((LowerBound version _, _):_) -> version
673

674
675
    handleFutureVersionParseFailure cabalVersionNeeded $ do

676
677
678
679
      let sf = sectionizeFields fields0  -- ensure 1.2 format

        -- figure out and warn about deprecated stuff (warnings are collected
        -- inside our parsing monad)
680
681
      fields <- mapSimpleFields deprecField sf

682
683
684
685
686
687
688
        -- Our parsing monad takes the not-yet-parsed fields as its state.
        -- After each successful parse we remove the field from the state
        -- ('skipField') and move on to the next one.
        --
        -- Things are complicated a bit, because fields take a tree-like
        -- structure -- they can be sections or "if"/"else" conditionals.

689
      flip evalStT fields $ do
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705

          -- The header consists of all simple fields up to the first section
          -- (flag, library, executable).
        header_fields <- getHeader []

          -- Parses just the header fields and stores them in a
          -- 'PackageDescription'.  Note that our final result is a
          -- 'GenericPackageDescription'; for pragmatic reasons we just store
          -- the partially filled-out 'PackageDescription' inside the
          -- 'GenericPackageDescription'.
        pkg <- lift $ parseFields pkgDescrFieldDescrs
                                  storeXFieldsPD
                                  emptyPackageDescription
                                  header_fields

          -- 'getBody' assumes that the remaining fields only consist of
706
          -- flags, lib and exe sections.
707
        (repos, flags, mlib, exes, tests, bms) <- getBody
708
        warnIfRest  -- warn if getBody did not parse up to the last field.
709
710
          -- warn about using old/new syntax with wrong cabal-version:
        maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
ttuegel's avatar
ttuegel committed
711
        checkForUndefinedFlags flags mlib exes tests
712
713
        return $ GenericPackageDescription
                   pkg { sourceRepos = repos }
714
                   flags mlib exes tests bms
715
716

  where
EyalLotem's avatar
EyalLotem committed
717
    oldSyntax = all isSimpleField
718
719
720
721
    reportTabsError tabs =
        syntaxError (fst (head tabs)) $
          "Do not use tabs for indentation (use spaces instead)\n"
          ++ "  Tabs were used at (line,column): " ++ show tabs
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743

    maybeWarnCabalVersion newsyntax pkg
      | newsyntax && specVersion pkg < Version [1,2] []
      = lift $ warning $
             "A package using section syntax must specify at least\n"
          ++ "'cabal-version: >= 1.2'."

    maybeWarnCabalVersion newsyntax pkg
      | not newsyntax && specVersion pkg >= Version [1,2] []
      = lift $ warning $
             "A package using 'cabal-version: "
          ++ displaySpecVersion (specVersionRaw pkg)
          ++ "' must use section syntax. See the Cabal user guide for details."
      where
        displaySpecVersion (Left version)       = display version
        displaySpecVersion (Right versionRange) =
          case asVersionIntervals versionRange of
            [] {- impossible -}           -> display versionRange
            ((LowerBound version _, _):_) -> display (orLaterVersion version)

    maybeWarnCabalVersion _ _ = return ()

744

745
746
747
748
749
750
    handleFutureVersionParseFailure cabalVersionNeeded parseBody =
      (unless versionOk (warning message) >> parseBody)
        `catchParseError` \parseError -> case parseError of
        TabsError _   -> parseFail parseError
        _ | versionOk -> parseFail parseError
          | otherwise -> fail message
751
752
      where versionOk = cabalVersionNeeded <= cabalVersion
            message   = "This package requires at least Cabal version "
753
754
                     ++ display cabalVersionNeeded

755
756
757
    -- "Sectionize" an old-style Cabal file.  A sectionized file has:
    --
    --  * all global fields at the beginning, followed by
758
    --
759
    --  * all flag declarations, followed by
760
761
762
    --
    --  * an optional library section, and an arbitrary number of executable
    --    sections (in any order).
763
764
765
766
    --
    -- The current implementatition just gathers all library-specific fields
    -- in a library section and wraps all executable stanzas in an executable
    -- section.
767
    sectionizeFields :: [Field] -> [Field]
768
769
    sectionizeFields fs
      | oldSyntax fs =
770
          let
771
772
773
774
775
776
777
778
779
780
781
782
            -- "build-depends" is a local field now.  To be backwards
            -- compatible, we still allow it as a global field in old-style
            -- package description files and translate it to a local field by
            -- adding it to every non-empty section
            (hdr0, exes0) = break ((=="executable") . fName) fs
            (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0

            (deps, libfs) = partition ((== "build-depends") . fName)
                                       libfs0

            exes = unfoldr toExe exes0
            toExe [] = Nothing
783
784
            toExe (F l e n : r)
              | e == "executable" =
785
786
                  let (efs, r') = break ((=="executable") . fName) r
                  in Just (Section l "executable" n (deps ++ efs), r')
787
            toExe _ = cabalBug "unexpected input to 'toExe'"
788
789
790
          in
            hdr ++
           (if null libfs then []
791
792
793
794
            else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)])
            ++ exes
      | otherwise = fs

EyalLotem's avatar
EyalLotem committed
795
    isSimpleField F{} = True
796
797
798
799
    isSimpleField _ = False

    -- warn if there's something at the end of the file
    warnIfRest :: PM ()
800
    warnIfRest = do
801
      s <- get
802
      case s of
803
804
805
806
807
808
809
        [] -> return ()
        _ -> lift $ warning "Ignoring trailing declarations."  -- add line no.

    -- all simple fields at the beginning of the file are (considered) header
    -- fields
    getHeader :: [Field] -> PM [Field]
    getHeader acc = peekField >>= \mf -> case mf of
EyalLotem's avatar
EyalLotem committed
810
        Just f@F{} -> skipField >> getHeader (f:acc)
811
        _ -> return (reverse acc)
812

813
    --
ttuegel's avatar
ttuegel committed
814
    -- body ::= { repo | flag | library | executable | test }+   -- at most one lib
815
    --
816
817
    -- The body consists of an optional sequence of declarations of flags and
    -- an arbitrary number of executables and at most one library.
818
    getBody :: PM ([SourceRepo], [Flag]
819
                  ,Maybe (CondTree ConfVar [Dependency] Library)
ttuegel's avatar
ttuegel committed
820
                  ,[(String, CondTree ConfVar [Dependency] Executable)]
821
822
                  ,[(String, CondTree ConfVar [Dependency] TestSuite)]
                  ,[(String, CondTree ConfVar [Dependency] Benchmark)])
823
824
825
826
827
828
829
830
    getBody = peekField >>= \mf -> case mf of
      Just (Section line_no sec_type sec_label sec_fields)
        | sec_type == "executable" -> do
            when (null sec_label) $ lift $ syntaxError line_no
              "'executable' needs one argument (the executable's name)"
            exename <- lift $ runP line_no "executable" parseTokenQ sec_label
            flds <- collectFields parseExeFields sec_fields
            skipField
831
832
            (repos, flags, lib, exes, tests, bms) <- getBody
            return (repos, flags, lib, (exename, flds): exes, tests, bms)
ttuegel's avatar
ttuegel committed
833

834
        | sec_type == "test-suite" -> do
ttuegel's avatar
ttuegel committed
835
            when (null sec_label) $ lift $ syntaxError line_no
836
                "'test-suite' needs one argument (the test suite's name)"
ttuegel's avatar
ttuegel committed
837
            testname <- lift $ runP line_no "test" parseTokenQ sec_label
838
            flds <- collectFields (parseTestFields line_no) sec_fields
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868

            -- Check that a valid test suite type has been chosen. A type
            -- field may be given inside a conditional block, so we must
            -- check for that before complaining that a type field has not
            -- been given. The test suite must always have a valid type, so
            -- we need to check both the 'then' and 'else' blocks, though
            -- the blocks need not have the same type.
            let checkTestType ts ct =
                    let ts' = mappend ts $ condTreeData ct
                        -- If a conditional has only a 'then' block and no
                        -- 'else' block, then it cannot have a valid type
                        -- in every branch, unless the type is specified at
                        -- a higher level in the tree.
                        checkComponent (_, _, Nothing) = False
                        -- If a conditional has a 'then' block and an 'else'
                        -- block, both must specify a test type, unless the
                        -- type is specified higher in the tree.
                        checkComponent (_, t, Just e) =
                            checkTestType ts' t && checkTestType ts' e
                        -- Does the current node specify a test type?
                        hasTestType = testInterface ts'
                            /= testInterface emptyTestSuite
                        components = condTreeComponents ct
                    -- If the current level of the tree specifies a type,
                    -- then we are done. If not, then one of the conditional
                    -- branches below the current node must specify a type.
                    -- Each node may have multiple immediate children; we
                    -- only one need one to specify a type because the
                    -- configure step uses 'mappend' to join together the
                    -- results of flag resolution.
EyalLotem's avatar
EyalLotem committed
869
                    in hasTestType || any checkComponent components
870
871
872
            if checkTestType emptyTestSuite flds
                then do
                    skipField
873
874
                    (repos, flags, lib, exes, tests, bms) <- getBody
                    return (repos, flags, lib, exes, (testname, flds) : tests, bms)
875
876
877
878
879
880
                else lift $ syntaxError line_no $
                         "Test suite \"" ++ testname
                      ++ "\" is missing required field \"type\" or the field "
                      ++ "is not present in all conditional branches. The "
                      ++ "available test types are: "
                      ++ intercalate ", " (map display knownTestTypes)
881

882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
        | sec_type == "benchmark" -> do
            when (null sec_label) $ lift $ syntaxError line_no
                "'benchmark' needs one argument (the benchmark's name)"
            benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label
            flds <- collectFields (parseBenchmarkFields line_no) sec_fields

            -- Check that a valid benchmark type has been chosen. A type
            -- field may be given inside a conditional block, so we must
            -- check for that before complaining that a type field has not
            -- been given. The benchmark must always have a valid type, so
            -- we need to check both the 'then' and 'else' blocks, though
            -- the blocks need not have the same type.
            let checkBenchmarkType ts ct =
                    let ts' = mappend ts $ condTreeData ct
                        -- If a conditional has only a 'then' block and no
                        -- 'else' block, then it cannot have a valid type
                        -- in every branch, unless the type is specified at
                        -- a higher level in the tree.
                        checkComponent (_, _, Nothing) = False
                        -- If a conditional has a 'then' block and an 'else'
                        -- block, both must specify a benchmark type, unless the
                        -- type is specified higher in the tree.
                        checkComponent (_, t, Just e) =
                            checkBenchmarkType ts' t && checkBenchmarkType ts' e
                        -- Does the current node specify a benchmark type?
                        hasBenchmarkType = benchmarkInterface ts'
                            /= benchmarkInterface emptyBenchmark
                        components = condTreeComponents ct
                    -- If the current level of the tree specifies a type,
                    -- then we are done. If not, then one of the conditional
                    -- branches below the current node must specify a type.
                    -- Each node may have multiple immediate children; we
                    -- only one need one to specify a type because the
                    -- configure step uses 'mappend' to join together the
                    -- results of flag resolution.
EyalLotem's avatar
EyalLotem committed
917
                    in hasBenchmarkType || any checkComponent components
918
919
920
921
922
923
924
925
926
927
928
929
            if checkBenchmarkType emptyBenchmark flds
                then do
                    skipField
                    (repos, flags, lib, exes, tests, bms) <- getBody
                    return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
                else lift $ syntaxError line_no $
                         "Benchmark \"" ++ benchname
                      ++ "\" is missing required field \"type\" or the field "
                      ++ "is not present in all conditional branches. The "
                      ++ "available benchmark types are: "
                      ++ intercalate ", " (map display knownBenchmarkTypes)

930
        | sec_type == "library" -> do
EyalLotem's avatar
EyalLotem committed
931
            unless (null sec_label) $ lift $
932
933
934
              syntaxError line_no "'library' expects no argument"
            flds <- collectFields parseLibFields sec_fields
            skipField
935
            (repos, flags, lib, exes, tests, bms) <- getBody
936
937
            when (isJust lib) $ lift $ syntaxError line_no
              "There can only be one library section in a package description."
938
            return (repos, flags, Just flds, exes, tests, bms)
939
940
941
942
943
944
945
946
947
948

        | sec_type == "flag" -> do
            when (null sec_label) $ lift $
              syntaxError line_no "'flag' needs one argument (the flag's name)"
            flag <- lift $ parseFields
                    flagFieldDescrs
                    warnUnrec
                    (MkFlag (FlagName (lowercase sec_label)) "" True False)
                    sec_fields
            skipField
949
950
            (repos, flags, lib, exes, tests, bms) <- getBody
            return (repos, flag:flags, lib, exes, tests, bms)
951
952
953
954
955
956
957
958
959
960
961
962

        | sec_type == "source-repository" -> do
            when (null sec_label) $ lift $ syntaxError line_no $
                 "'source-repository' needs one argument, "
              ++ "the repo kind which is usually 'head' or 'this'"
            kind <- case simpleParse sec_label of
              Just kind -> return kind
              Nothing   -> lift $ syntaxError line_no $
                             "could not parse repo kind: " ++ sec_label
            repo <- lift $ parseFields
                    sourceRepoFieldDescrs
                    warnUnrec
EyalLotem's avatar
EyalLotem committed
963
                    SourceRepo {
964
965
966
967
968
969
970
                      repoKind     = kind,
                      repoType     = Nothing,
                      repoLocation = Nothing,
                      repoModule   = Nothing,
                      repoBranch   = Nothing,
                      repoTag      = Nothing,
                      repoSubdir   = Nothing
EyalLotem's avatar
EyalLotem committed
971
                    }
972
973
                    sec_fields
            skipField
974
975
            (repos, flags, lib, exes, tests, bms) <- getBody
            return (repo:repos, flags, lib, exes, tests, bms)
976
977
978
979
980

        | otherwise -> do
            lift $ warning $ "Ignoring unknown section type: " ++ sec_type
            skipField
            getBody
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
981
      Just f@(F {}) -> do
982
            _ <- lift $ syntaxError (lineNo f) $
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
983
984
985
              "Plain fields are not allowed in between stanzas: " ++ show f
            skipField
            getBody
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
986
      Just f@(IfBlock {}) -> do
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
987
988
            _ <- lift $ syntaxError (lineNo f) $
              "If-blocks are not allowed in between stanzas: " ++ show f
989
990
            skipField
            getBody
991
      Nothing -> return ([], [], Nothing, [], [], [])
992

993
994
995
996
    -- Extracts all fields in a block and returns a 'CondTree'.
    --
    -- We have to recurse down into conditionals and we treat fields that
    -- describe dependencies specially.
997
    collectFields :: ([Field] -> PM a) -> [Field]
998
999
                  -> PM (CondTree ConfVar [Dependency] a)
    collectFields parser allflds = do
1000
1001

        let simplFlds = [ F l n v | F l n v <- allflds ]
EyalLotem's avatar
EyalLotem committed
1002
            condFlds = [ f | f@IfBlock{} <- allflds ]
1003
            sections = [ s | s@Section{} <- allflds ]
1004
1005

        let (depFlds, dataFlds) = partition isConstraint simplFlds
1006
1007
1008
1009
1010
        
        mapM_
            (\(Section l n _ _) -> lift . warning $
                "Unexpected section '" ++ n ++ "' on line " ++ show l)
            sections
1011

1012
1013
        a <- parser dataFlds
        deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds
1014

1015
        ifs <- mapM processIfs condFlds
1016

1017
1018
1019
1020
        return (CondNode a deps ifs)
      where
        isConstraint (F _ n _) = n `elem` constraintFieldNames
        isConstraint _ = False
1021

1022
1023
1024
1025
1026
1027
1028
1029
        processIfs (IfBlock l c t e) = do
            cnd <- lift $ runP l "if" parseCondition c
            t' <- collectFields parser t
            e' <- case e of
                   [] -> return Nothing
                   es -> do fs <- collectFields parser es
                            return (Just fs)
            return (cnd, t', e')
1030
        processIfs _ = cabalBug "processIfs called with wrong field type"
1031

1032
    parseLibFields :: [Field] -> PM Library
1033
    parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary
1034

1035
    -- Note: we don't parse the "executable" field here, hence the tail hack.
1036
    parseExeFields :: [Field] -> PM Executable
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1037
1038
    parseExeFields = lift . parseFields (tail executableFieldDescrs)
                                        storeXFieldsExe emptyExecutable
1039

1040
1041
    parseTestFields :: LineNo -> [Field] -> PM TestSuite
    parseTestFields line fields = do
1042
        x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest
1043
1044
                                emptyTestStanza fields
        lift $ validateTestSuite line x
ttuegel's avatar
ttuegel committed
1045

1046
1047
1048
1049
1050
1051
    parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark
    parseBenchmarkFields line fields = do
        x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark
                                emptyBenchmarkStanza fields
        lift $ validateBenchmark line x

1052
1053
1054
1055
    checkForUndefinedFlags ::
        [Flag] ->
        Maybe (CondTree ConfVar [Dependency] Library) ->
        [(String, CondTree ConfVar [Dependency] Executable)] ->
1056
        [(String, CondTree ConfVar [Dependency] TestSuite)] ->
1057
        PM ()
ttuegel's avatar
ttuegel committed
1058
    checkForUndefinedFlags flags mlib exes tests = do
1059
1060
1061
        let definedFlags = map flagName flags
        maybe (return ()) (checkCondTreeFlags definedFlags) mlib
        mapM_ (checkCondTreeFlags definedFlags . snd) exes
ttuegel's avatar
ttuegel committed
1062
        mapM_ (checkCondTreeFlags definedFlags . snd) tests
1063

1064
    checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
1065
1066
    checkCondTreeFlags definedFlags ct = do
        let fv = nub $ freeVars ct
EyalLotem's avatar
EyalLotem committed
1067
        unless (all (`elem` definedFlags) fv) $
1068
1069
            fail $ "These flags are used without having been defined: "
                ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]
1070
1071


1072
1073
1074
-- | Parse a list of fields, given a list of field descriptions,
--   a structure to accumulate the parsed fields, and a function
--   that can decide what to do with fields which don't match any
1075
--   of the field descriptions.
1076
1077
parseFields :: [FieldDescr a]      -- ^ descriptions of fields we know how to
                                   --   parse
1078
1079
1080
1081
1082
            -> UnrecFieldParser a  -- ^ possibly do something with
                                   --   unrecognized fields
            -> a                   -- ^ accumulator
            -> [Field]             -- ^ fields to be parsed
            -> ParseResult a
1083
parseFields descrs unrec ini fields =
1084
    do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields
EyalLotem's avatar
EyalLotem committed
1085
1086
1087
1088
1089
1090
1091
       unless (null unknowns) $ warning $ render $
         text "Unknown fields:" <+>
              commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")
                            (reverse unknowns))
         $+$
         text "Fields allowed in this section:" $$
           nest 4 (commaSep $ map fieldName descrs)
1092
1093
1094
1095
       return a
  where
    commaSep = fsep . punctuate comma . map text

1096
1097
1098
1099
1100
1101
parseField :: [FieldDescr a]     -- ^ list of parseable fields
           -> UnrecFieldParser a -- ^ possibly do something with
                                 --   unrecognized fields
           -> (a,[(Int,String)]) -- ^ accumulated result and warnings
           -> Field              -- ^ the field to be parsed
           -> ParseResult (a, [(Int,String)])
EyalLotem's avatar
EyalLotem committed
1102
parseField (FieldDescr name _ parser : fields) unrec (a, us) (F line f val)
Duncan Coutts's avatar