Parsec.hs 36.2 KB
Newer Older
Oleg Grenrus's avatar
Oleg Grenrus committed
1
{-# LANGUAGE CPP                 #-}
Oleg Grenrus's avatar
Oleg Grenrus committed
2
{-# LANGUAGE FlexibleContexts    #-}
Oleg Grenrus's avatar
Oleg Grenrus committed
3
{-# LANGUAGE OverloadedStrings   #-}
4
{-# LANGUAGE Rank2Types          #-}
Oleg Grenrus's avatar
Oleg Grenrus committed
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.PackageDescription.Parsec
-- Copyright   :  Isaac Jones 2003-2005
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This defined parsers and partial pretty printers for the @.cabal@ format.

module Distribution.PackageDescription.Parsec (
    -- * Package descriptions
    readGenericPackageDescription,
    parseGenericPackageDescription,
21
    parseGenericPackageDescriptionMaybe,
Oleg Grenrus's avatar
Oleg Grenrus committed
22
23
24

    -- ** Parsing
    ParseResult,
25
    runParseResult,
Oleg Grenrus's avatar
Oleg Grenrus committed
26

27
28
29
    -- * New-style spec-version
    scanSpecVersion,

Oleg Grenrus's avatar
Oleg Grenrus committed
30
    -- ** Supplementary build information
Oleg Grenrus's avatar
Oleg Grenrus committed
31
32
    readHookedBuildInfo,
    parseHookedBuildInfo,
Oleg Grenrus's avatar
Oleg Grenrus committed
33
34
    ) where

Oleg Grenrus's avatar
Oleg Grenrus committed
35
36
37
import Distribution.Compat.Prelude
import Prelude ()

38
import Control.Applicative                           (Const (..))
39
import Control.DeepSeq                               (deepseq)
40
41
42
43
import Control.Monad                                 (guard)
import Control.Monad.State.Strict                    (StateT, execStateT)
import Control.Monad.Trans.Class                     (lift)
import Data.List                                     (partition)
44
45
46
import Distribution.CabalSpecVersion
import Distribution.Compat.Lens
import Distribution.FieldGrammar
47
48
49
50
import Distribution.FieldGrammar.Parsec              (NamelessField (..))
import Distribution.Fields.ConfVar                   (parseConditionConfVar)
import Distribution.Fields.Field                     (FieldName, getName)
import Distribution.Fields.LexerMonad                (LexWarning, toPWarnings)
51
52
import Distribution.Fields.Parser
import Distribution.Fields.ParseResult
53
import Distribution.PackageDescription
54
import Distribution.PackageDescription.Configuration (freeVars)
55
import Distribution.PackageDescription.FieldGrammar
56
57
58
59
60
61
62
import Distribution.PackageDescription.Quirks        (patchQuirks)
import Distribution.Parsec                           (parsec, simpleParsec)
import Distribution.Parsec.FieldLineStream           (fieldLineStreamFromBS)
import Distribution.Parsec.Newtypes                  (CommaFSep, List, SpecVersion (..), Token)
import Distribution.Parsec.Position                  (Position (..), zeroPos)
import Distribution.Parsec.Warning                   (PWarnType (..))
import Distribution.Pretty                           (prettyShow)
63
import Distribution.Simple.Utils                     (fromUTF8BS, toUTF8BS)
64
import Distribution.Types.CondTree
65
import Distribution.Types.Dependency                 (Dependency)
66
import Distribution.Types.ForeignLib
67
68
69
70
71
72
73
import Distribution.Types.ForeignLibType             (knownForeignLibTypes)
import Distribution.Types.GenericPackageDescription  (emptyGenericPackageDescription)
import Distribution.Types.LibraryVisibility          (LibraryVisibility (..))
import Distribution.Types.PackageDescription         (specVersion')
import Distribution.Types.UnqualComponentName        (UnqualComponentName, mkUnqualComponentName)
import Distribution.Utils.Generic                    (breakMaybe, unfoldrM, validateUTF8)
import Distribution.Verbosity                        (Verbosity)
74
import Distribution.Version                          (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion, version0, versionNumbers)
75
76

import qualified Data.ByteString                                   as BS
77
import qualified Data.ByteString.Char8                             as BS8
78
import qualified Data.Map.Strict                                   as Map
79
import qualified Data.Set                                          as Set
80
import qualified Distribution.Compat.Newtype                       as Newtype
Oleg Grenrus's avatar
Oleg Grenrus committed
81
import qualified Distribution.Types.BuildInfo.Lens                 as L
Oleg Grenrus's avatar
Oleg Grenrus committed
82
83
import qualified Distribution.Types.Executable.Lens                as L
import qualified Distribution.Types.ForeignLib.Lens                as L
Oleg Grenrus's avatar
Oleg Grenrus committed
84
85
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens        as L
86
import qualified Text.Parsec                                       as P
Oleg Grenrus's avatar
Oleg Grenrus committed
87

Oleg Grenrus's avatar
Oleg Grenrus committed
88
89
-- ---------------------------------------------------------------
-- Parsing
Alexis Williams's avatar
Alexis Williams committed
90
-- ---------------------------------------------------------------
Oleg Grenrus's avatar
Oleg Grenrus committed
91
92
93
94
95
96
97
98
99
100
101
102

-- | Parse the given package file.
readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription = readAndParseFile parseGenericPackageDescription

------------------------------------------------------------------------------
-- | Parses the given file into a 'GenericPackageDescription'.
--
-- In Cabal 1.2 the syntax for package descriptions was changed to a format
-- with sections and possibly indented property descriptions.
--
parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription
103
parseGenericPackageDescription bs = do
104
    -- set scanned version
105
    setCabalSpecVersion ver
106
107
    -- if we get too new version, fail right away
    case ver of
108
        Just v | v > mkVersion [3,0] -> parseFailure zeroPos
109
110
111
            "Unsupported cabal-version. See https://github.com/haskell/cabal/issues/4899."
        _ -> pure ()

112
    case readFields' bs'' of
113
114
115
        Right (fs, lexWarnings) -> do
            when patched $
                parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"
116
            -- UTF8 is validated in a prepass step, afterwards parsing is lenient.
117
            parseGenericPackageDescription' ver lexWarnings invalidUtf8 fs
118
        -- TODO: better marshalling of errors
119
120
121
        Left perr -> parseFatalFailure pos (show perr) where
            ppos = P.errorPos perr
            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)
Oleg Grenrus's avatar
Oleg Grenrus committed
122
  where
123
    (patched, bs') = patchQuirks bs
124
    ver = scanSpecVersion bs'
Oleg Grenrus's avatar
Oleg Grenrus committed
125

126
127
128
129
130
131
132
133
    invalidUtf8 = validateUTF8 bs'

    -- if there are invalid utf8 characters, we make the bytestring valid.
    bs'' = case invalidUtf8 of
        Nothing -> bs'
        Just _  -> toUTF8BS (fromUTF8BS bs')


134
135
136
-- | 'Maybe' variant of 'parseGenericPackageDescription'
parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe =
137
    either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription
138

Oleg Grenrus's avatar
Oleg Grenrus committed
139
140
141
fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)

142
-- Monad in which sections are parsed
Oleg Grenrus's avatar
Oleg Grenrus committed
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
type SectionParser = StateT SectionS ParseResult

-- | State of section parser
data SectionS = SectionS
    { _stateGpd           :: !GenericPackageDescription
    , _stateCommonStanzas :: !(Map String CondTreeBuildInfo)
    }

stateGpd :: Lens' SectionS GenericPackageDescription
stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd
{-# INLINE stateGpd #-}

stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo)
stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs
{-# INLINE stateCommonStanzas #-}
158

Oleg Grenrus's avatar
Oleg Grenrus committed
159
-- Note [Accumulating parser]
160
161
162
163
--
-- This parser has two "states":
-- * first we parse fields of PackageDescription
-- * then we parse sections (libraries, executables, etc)
Oleg Grenrus's avatar
Oleg Grenrus committed
164
parseGenericPackageDescription'
165
166
    :: Maybe Version
    -> [LexWarning]
167
    -> Maybe Int
168
    -> [Field Position]
Oleg Grenrus's avatar
Oleg Grenrus committed
169
    -> ParseResult GenericPackageDescription
170
parseGenericPackageDescription' cabalVerM lexWarnings utf8WarnPos fs = do
Oleg Grenrus's avatar
Oleg Grenrus committed
171
    parseWarnings (toPWarnings lexWarnings)
172
173
    for_ utf8WarnPos $ \pos ->
        parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos
174
    let (syntax, fs') = sectionizeFields fs
Oleg Grenrus's avatar
Oleg Grenrus committed
175
    let (fields, sectionFields) = takeFields fs'
176
177

    -- cabal-version
178
179
180
181
    cabalVer <- case cabalVerM of
        Just v  -> return v
        Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of
            Nothing                        -> return version0
182
183
184
185
186
187
188
            Just (MkNamelessField pos fls) -> do
                v <- specVersion' . Newtype.unpack' SpecVersion <$> runFieldParser pos parsec cabalSpecLatest fls
                when (v >= mkVersion [2,1]) $ parseFailure pos $
                    "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++
                    "See https://github.com/haskell/cabal/issues/4899"

                return v
189

Oleg Grenrus's avatar
Oleg Grenrus committed
190
    let specVer = cabalSpecFromVersionDigits (versionNumbers cabalVer)
191

192
193
194
    -- reset cabal version
    setCabalSpecVersion (Just cabalVer)

195
196
197
    -- Package description
    pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar

198
199
200
201
202
    -- Check that scanned and parsed versions match.
    unless (cabalVer == specVersion pd) $ parseFailure zeroPos $
        "Scanned and parsed cabal-versions don't match " ++
        prettyShow cabalVer ++ " /= " ++ prettyShow (specVersion pd)

Oleg Grenrus's avatar
Oleg Grenrus committed
203
    maybeWarnCabalVersion syntax pd
Oleg Grenrus's avatar
Oleg Grenrus committed
204

Oleg Grenrus's avatar
Oleg Grenrus committed
205
    -- Sections
206
    let gpd = emptyGenericPackageDescription & L.packageDescription .~ pd
207
    gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)
208

209
    checkForUndefinedFlags gpd1
210
    gpd1 `deepseq` return gpd1
Oleg Grenrus's avatar
Oleg Grenrus committed
211
  where
212
213
214
    safeLast :: [a] -> Maybe a
    safeLast = listToMaybe . reverse

215
216
217
218
219
220
    newSyntaxVersion :: Version
    newSyntaxVersion = mkVersion [1, 2]

    maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()
    maybeWarnCabalVersion syntax pkg
      | syntax == NewSyntax && specVersion pkg < newSyntaxVersion
221
      = parseWarning zeroPos PWTNewSyntax $
222
223
224
225
226
             "A package using section syntax must specify at least\n"
          ++ "'cabal-version: >= 1.2'."

    maybeWarnCabalVersion syntax pkg
      | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion
227
      = parseWarning zeroPos PWTOldSyntax $
228
229
230
231
             "A package using 'cabal-version: "
          ++ displaySpecVersion (specVersionRaw pkg)
          ++ "' must use section syntax. See the Cabal user guide for details."
      where
232
        displaySpecVersion (Left version)       = prettyShow version
233
234
        displaySpecVersion (Right versionRange) =
          case asVersionIntervals versionRange of
235
236
            [] {- impossible -}           -> prettyShow versionRange
            ((LowerBound version _, _):_) -> prettyShow (orLaterVersion version)
237
238
239

    maybeWarnCabalVersion _ _ = return ()

240
goSections :: CabalSpecVersion -> [Field Position] -> SectionParser ()
241
goSections specVer = traverse_ process
242
243
  where
    process (Field (Name pos name) _) =
Oleg Grenrus's avatar
Oleg Grenrus committed
244
        lift $ parseWarning pos PWTTrailingFields $
245
246
            "Ignoring trailing fields after sections: " ++ show name
    process (Section name args secFields) =
247
        parseSection name args secFields
Oleg Grenrus's avatar
Oleg Grenrus committed
248

249
    snoc x xs = xs ++ [x]
Oleg Grenrus's avatar
Oleg Grenrus committed
250

251
252
    hasCommonStanzas = specHasCommonStanzas specVer

253
    -- we need signature, because this is polymorphic, but not-closed
254
    parseCondTree'
Oleg Grenrus's avatar
Oleg Grenrus committed
255
        :: L.HasBuildInfo a
256
        => ParsecFieldGrammar' a       -- ^ grammar
Oleg Grenrus's avatar
Oleg Grenrus committed
257
        -> (BuildInfo -> a)
258
259
260
261
262
        -> Map String CondTreeBuildInfo  -- ^ common stanzas
        -> [Field Position]
        -> ParseResult (CondTree ConfVar [Dependency] a)
    parseCondTree' = parseCondTreeWithCommonStanzas specVer

Oleg Grenrus's avatar
Oleg Grenrus committed
263
    parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()
264
    parseSection (Name pos name) args fields
265
        | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do
266
          parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas."
Oleg Grenrus's avatar
Oleg Grenrus committed
267
268
269
270

        | name == "common" = do
            commonStanzas <- use stateCommonStanzas
            name' <- lift $ parseCommonName pos args
Oleg Grenrus's avatar
Oleg Grenrus committed
271
            biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields
Oleg Grenrus's avatar
Oleg Grenrus committed
272
273
274
275
276
277

            case Map.lookup name' commonStanzas of
                Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas
                Just _  -> lift $ parseFailure pos $
                    "Duplicate common stanza: " ++ name'

Oleg Grenrus's avatar
Oleg Grenrus committed
278
        | name == "library" && null args = do
Oleg Grenrus's avatar
Oleg Grenrus committed
279
280
281
282
            prev <- use $ stateGpd . L.condLibrary
            when (isJust prev) $ lift $ parseFailure pos $
                "Multiple main libraries; have you forgotten to specify a name for an internal library?"

Oleg Grenrus's avatar
Oleg Grenrus committed
283
            commonStanzas <- use stateCommonStanzas
284
285
286
287
            let name'' = LMainLibName
            lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
            --
            -- TODO check that not set
Oleg Grenrus's avatar
Oleg Grenrus committed
288
            stateGpd . L.condLibrary ?= lib
Oleg Grenrus's avatar
Oleg Grenrus committed
289

290
        -- Sublibraries
Oleg Grenrus's avatar
Oleg Grenrus committed
291
        -- TODO: check cabal-version
292
        | name == "library" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
293
            commonStanzas <- use stateCommonStanzas
294
            name' <- parseUnqualComponentName pos args
295
            let name'' = LSubLibName name'
Oleg Grenrus's avatar
Oleg Grenrus committed
296
            lib   <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
297
            -- TODO check duplicate name here?
Oleg Grenrus's avatar
Oleg Grenrus committed
298
            stateGpd . L.condSubLibraries %= snoc (name', lib)
299

Oleg Grenrus's avatar
Oleg Grenrus committed
300
        -- TODO: check cabal-version
301
        | name == "foreign-library" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
302
            commonStanzas <- use stateCommonStanzas
303
            name' <- parseUnqualComponentName pos args
Oleg Grenrus's avatar
Oleg Grenrus committed
304
            flib  <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
305
306
307

            let hasType ts = foreignLibType ts /= foreignLibType mempty
            unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat
308
                [ "Foreign library " ++ show (prettyShow name')
309
310
311
                , " is missing required field \"type\" or the field "
                , "is not present in all conditional branches. The "
                , "available test types are: "
312
                , intercalate ", " (map prettyShow knownForeignLibTypes)
313
314
                ]

315
            -- TODO check duplicate name here?
Oleg Grenrus's avatar
Oleg Grenrus committed
316
            stateGpd . L.condForeignLibs %= snoc (name', flib)
317

Oleg Grenrus's avatar
Oleg Grenrus committed
318
        | name == "executable" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
319
            commonStanzas <- use stateCommonStanzas
320
            name' <- parseUnqualComponentName pos args
Oleg Grenrus's avatar
Oleg Grenrus committed
321
            exe   <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
Oleg Grenrus's avatar
Oleg Grenrus committed
322
            -- TODO check duplicate name here?
Oleg Grenrus's avatar
Oleg Grenrus committed
323
            stateGpd . L.condExecutables %= snoc (name', exe)
Oleg Grenrus's avatar
Oleg Grenrus committed
324
325

        | name == "test-suite" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
326
            commonStanzas <- use stateCommonStanzas
327
            name'      <- parseUnqualComponentName pos args
Oleg Grenrus's avatar
Oleg Grenrus committed
328
            testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields
Oleg Grenrus's avatar
Oleg Grenrus committed
329
            testSuite  <- lift $ traverse (validateTestSuite pos) testStanza
330
331
332

            let hasType ts = testInterface ts /= testInterface mempty
            unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat
333
                [ "Test suite " ++ show (prettyShow name')
334
335
336
                , " is missing required field \"type\" or the field "
                , "is not present in all conditional branches. The "
                , "available test types are: "
337
                , intercalate ", " (map prettyShow knownTestTypes)
338
339
                ]

Oleg Grenrus's avatar
Oleg Grenrus committed
340
            -- TODO check duplicate name here?
Oleg Grenrus's avatar
Oleg Grenrus committed
341
            stateGpd . L.condTestSuites %= snoc (name', testSuite)
Oleg Grenrus's avatar
Oleg Grenrus committed
342
343

        | name == "benchmark" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
344
            commonStanzas <- use stateCommonStanzas
345
            name'       <- parseUnqualComponentName pos args
Oleg Grenrus's avatar
Oleg Grenrus committed
346
            benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields
Oleg Grenrus's avatar
Oleg Grenrus committed
347
            bench       <- lift $ traverse (validateBenchmark pos) benchStanza
348
349
350

            let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty
            unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat
351
                [ "Benchmark " ++ show (prettyShow name')
352
353
354
                , " is missing required field \"type\" or the field "
                , "is not present in all conditional branches. The "
                , "available benchmark types are: "
355
                , intercalate ", " (map prettyShow knownBenchmarkTypes)
356
357
                ]

Oleg Grenrus's avatar
Oleg Grenrus committed
358
            -- TODO check duplicate name here?
Oleg Grenrus's avatar
Oleg Grenrus committed
359
            stateGpd . L.condBenchmarks %= snoc (name', bench)
Oleg Grenrus's avatar
Oleg Grenrus committed
360
361

        | name == "flag" = do
362
            name'  <- parseNameBS pos args
363
            name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""
364
            flag   <- lift $ parseFields specVer fields (flagFieldGrammar name'')
Oleg Grenrus's avatar
Oleg Grenrus committed
365
            -- Check default flag
Oleg Grenrus's avatar
Oleg Grenrus committed
366
            stateGpd . L.genPackageFlags %= snoc flag
Oleg Grenrus's avatar
Oleg Grenrus committed
367
368

        | name == "custom-setup" && null args = do
369
            sbi <- lift $ parseFields specVer fields  (setupBInfoFieldGrammar False)
Oleg Grenrus's avatar
Oleg Grenrus committed
370
            stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi
Oleg Grenrus's avatar
Oleg Grenrus committed
371
372

        | name == "source-repository" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
373
            kind <- lift $ case args of
Oleg Grenrus's avatar
Oleg Grenrus committed
374
                [SecArgName spos secName] ->
375
                    runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead
Oleg Grenrus's avatar
Oleg Grenrus committed
376
                [] -> do
Oleg Grenrus's avatar
Oleg Grenrus committed
377
                    parseFailure pos "'source-repository' requires exactly one argument"
Oleg Grenrus's avatar
Oleg Grenrus committed
378
379
380
381
                    pure RepoHead
                _ -> do
                    parseFailure pos $ "Invalid source-repository kind " ++ show args
                    pure RepoHead
Oleg Grenrus's avatar
Oleg Grenrus committed
382

383
            sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind)
Oleg Grenrus's avatar
Oleg Grenrus committed
384
            stateGpd . L.packageDescription . L.sourceRepos %= snoc sr
Oleg Grenrus's avatar
Oleg Grenrus committed
385

Oleg Grenrus's avatar
Oleg Grenrus committed
386
        | otherwise = lift $
Oleg Grenrus's avatar
Oleg Grenrus committed
387
388
            parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name

Oleg Grenrus's avatar
Oleg Grenrus committed
389
parseName :: Position -> [SectionArg Position] -> SectionParser String
390
391
392
parseName pos args = fromUTF8BS <$> parseNameBS pos args

parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString
Oleg Grenrus's avatar
Oleg Grenrus committed
393
-- TODO: use strict parser
394
parseNameBS pos args = case args of
Oleg Grenrus's avatar
Oleg Grenrus committed
395
    [SecArgName _pos secName] ->
396
         pure secName
Oleg Grenrus's avatar
Oleg Grenrus committed
397
    [SecArgStr _pos secName] ->
398
         pure secName
Oleg Grenrus's avatar
Oleg Grenrus committed
399
    [] -> do
400
         lift $ parseFailure pos "name required"
Oleg Grenrus's avatar
Oleg Grenrus committed
401
402
403
         pure ""
    _ -> do
         -- TODO: pretty print args
Oleg Grenrus's avatar
Oleg Grenrus committed
404
         lift $ parseFailure pos $ "Invalid name " ++ show args
Oleg Grenrus's avatar
Oleg Grenrus committed
405
406
         pure ""

Oleg Grenrus's avatar
Oleg Grenrus committed
407
408
409
410
411
412
413
414
415
416
417
418
419
420
parseCommonName :: Position -> [SectionArg Position] -> ParseResult String
parseCommonName pos args = case args of
    [SecArgName _pos secName] ->
         pure $ fromUTF8BS secName
    [SecArgStr _pos secName] ->
         pure $ fromUTF8BS secName
    [] -> do
         parseFailure pos $ "name required"
         pure ""
    _ -> do
         -- TODO: pretty print args
         parseFailure pos $ "Invalid name " ++ show args
         pure ""

421
-- TODO: avoid conversion to 'String'.
Oleg Grenrus's avatar
Oleg Grenrus committed
422
parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName
423
424
parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args

Oleg Grenrus's avatar
Oleg Grenrus committed
425
-- | Parse a non-recursive list of fields.
Oleg Grenrus's avatar
Oleg Grenrus committed
426
parseFields
427
    :: CabalSpecVersion
428
    -> [Field Position] -- ^ fields to be parsed
429
    -> ParsecFieldGrammar' a
Oleg Grenrus's avatar
Oleg Grenrus committed
430
    -> ParseResult a
431
parseFields v fields grammar = do
Oleg Grenrus's avatar
Oleg Grenrus committed
432
433
    let (fs0, ss) = partitionFields fields
    traverse_ (traverse_ warnInvalidSubsection) ss
434
    parseFieldGrammar v fs0 grammar
Oleg Grenrus's avatar
Oleg Grenrus committed
435
436
437

warnInvalidSubsection :: Section Position -> ParseResult ()
warnInvalidSubsection (MkSection (Name pos name) _ _) =
438
    void $ parseFailure pos $ "invalid subsection " ++ show name
Oleg Grenrus's avatar
Oleg Grenrus committed
439
440

parseCondTree
441
442
443
444
445
446
447
    :: forall a. L.HasBuildInfo a
    => CabalSpecVersion
    -> HasElif                        -- ^ accept @elif@
    -> ParsecFieldGrammar' a          -- ^ grammar
    -> Map String CondTreeBuildInfo   -- ^ common stanzas
    -> (BuildInfo -> a)               -- ^ constructor from buildInfo
    -> (a -> [Dependency])            -- ^ condition extractor
Oleg Grenrus's avatar
Oleg Grenrus committed
448
    -> [Field Position]
449
450
    -> ParseResult (CondTree ConfVar [Dependency] a)
parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
Oleg Grenrus's avatar
Oleg Grenrus committed
451
  where
452
453
454
455
456
457
    go fields0 = do
        (fields, endo) <-
            if v >= CabalSpecV3_0
            then processImports v fromBuildInfo commonStanzas fields0
            else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id)

Oleg Grenrus's avatar
Oleg Grenrus committed
458
        let (fs, ss) = partitionFields fields
459
        x <- parseFieldGrammar v fs grammar
Oleg Grenrus's avatar
Oleg Grenrus committed
460
        branches <- concat <$> traverse parseIfs ss
461
        return $ endo $ CondNode x (cond x) branches
Oleg Grenrus's avatar
Oleg Grenrus committed
462

463
    parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a]
Oleg Grenrus's avatar
Oleg Grenrus committed
464
465
466
467
468
469
470
    parseIfs [] = return []
    parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do
        test' <- parseConditionConfVar test
        fields' <- go fields
        (elseFields, sections') <- parseElseIfs sections
        return (CondBranch test' fields' elseFields : sections')
    parseIfs (MkSection (Name pos name) _ _ : sections) = do
Oleg Grenrus's avatar
Oleg Grenrus committed
471
        parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
Oleg Grenrus's avatar
Oleg Grenrus committed
472
473
474
475
        parseIfs sections

    parseElseIfs
        :: [Section Position]
476
        -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])
Oleg Grenrus's avatar
Oleg Grenrus committed
477
478
479
480
481
482
483
    parseElseIfs [] = return (Nothing, [])
    parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do
        unless (null args) $
            parseFailure pos $ "`else` section has section arguments " ++ show args
        elseFields <- go fields
        sections' <- parseIfs sections
        return (Just elseFields, sections')
484
485

    parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
486
487
488
489
        test' <- parseConditionConfVar test
        fields' <- go fields
        (elseFields, sections') <- parseElseIfs sections
        -- we parse an empty 'Fields', to get empty value for a node
490
        a <- parseFieldGrammar v mempty grammar
Oleg Grenrus's avatar
Oleg Grenrus committed
491
        return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
492

Oleg Grenrus's avatar
Oleg Grenrus committed
493
494
495
496
    parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do
        parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."
        (,) Nothing <$> parseIfs sections

Oleg Grenrus's avatar
Oleg Grenrus committed
497
    parseElseIfs sections = (,) Nothing <$> parseIfs sections
Oleg Grenrus's avatar
Oleg Grenrus committed
498
499
500

{- Note [Accumulating parser]

Oleg Grenrus's avatar
Oleg Grenrus committed
501
502
Note: Outdated a bit

Oleg Grenrus's avatar
Oleg Grenrus committed
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a ->
FieldParser a)@.  The weird value is used because we accumulate structure of
@a@ by folding over the fields.  There are various reasons for that:

* Almost all fields are optional

* This is simple approach so declarative bi-directional format (parsing and
printing) of structure could be specified (list of @'FieldDescr' a@)

* There are surface syntax fields corresponding to single field in the file:
  @license-file@ and @license-files@

* This is quite safe approach.

When/if we re-implement the parser to support formatting preservging roundtrip
with new AST, this all need to be rewritten.
-}

Oleg Grenrus's avatar
Oleg Grenrus committed
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
-------------------------------------------------------------------------------
-- Common stanzas
-------------------------------------------------------------------------------

-- $commonStanzas
--
-- [Note: Common stanzas]
--
-- In Cabal 2.2 we support simple common stanzas:
--
-- * Commons stanzas define 'BuildInfo'
--
-- * import "fields" can only occur at top of other stanzas (think: imports)
--
-- In particular __there aren't__
--
-- * implicit stanzas
--
-- * More specific common stanzas (executable, test-suite).
--
--
-- The approach uses the fact that 'BuildInfo' is a 'Monoid':
--
-- @
-- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp
-- mergeCommonStanza' bi = over L.BuildInfo (bi <>)
-- @
--
-- Real 'mergeCommonStanza' is more complicated as we have to deal with
-- conditional trees.
--
-- The approach is simple, and have good properties:
--
-- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.
--
type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo

-- | Create @a@ from 'BuildInfo'.
Oleg Grenrus's avatar
Oleg Grenrus committed
559
-- This class is used to implement common stanza parsing.
Oleg Grenrus's avatar
Oleg Grenrus committed
560
561
--
-- Law: @view buildInfo . fromBuildInfo = id@
Oleg Grenrus's avatar
Oleg Grenrus committed
562
563
--
-- This takes name, as 'FieldGrammar's take names too.
Oleg Grenrus's avatar
Oleg Grenrus committed
564
class L.HasBuildInfo a => FromBuildInfo a where
Oleg Grenrus's avatar
Oleg Grenrus committed
565
    fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a
Oleg Grenrus's avatar
Oleg Grenrus committed
566

567
libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library
Oleg Grenrus's avatar
Oleg Grenrus committed
568
569
libraryFromBuildInfo n bi = emptyLibrary
    { libName       = n
570
571
572
    , libVisibility = case n of
        LMainLibName  -> LibraryVisibilityPublic
        LSubLibName _ -> LibraryVisibilityPrivate
Oleg Grenrus's avatar
Oleg Grenrus committed
573
574
    , libBuildInfo  = bi
    }
Oleg Grenrus's avatar
Oleg Grenrus committed
575

Oleg Grenrus's avatar
Oleg Grenrus committed
576
577
578
instance FromBuildInfo BuildInfo  where fromBuildInfo' _ = id
instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib
instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName        n $ set L.buildInfo bi emptyExecutable
Oleg Grenrus's avatar
Oleg Grenrus committed
579
580

instance FromBuildInfo TestSuiteStanza where
Oleg Grenrus's avatar
Oleg Grenrus committed
581
    fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi
Oleg Grenrus's avatar
Oleg Grenrus committed
582
583

instance FromBuildInfo BenchmarkStanza where
Oleg Grenrus's avatar
Oleg Grenrus committed
584
    fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi
Oleg Grenrus's avatar
Oleg Grenrus committed
585
586

parseCondTreeWithCommonStanzas
Oleg Grenrus's avatar
Oleg Grenrus committed
587
    :: forall a. L.HasBuildInfo a
588
589
    => CabalSpecVersion
    -> ParsecFieldGrammar' a       -- ^ grammar
Oleg Grenrus's avatar
Oleg Grenrus committed
590
    -> (BuildInfo -> a)              -- ^ construct fromBuildInfo
Oleg Grenrus's avatar
Oleg Grenrus committed
591
592
593
    -> Map String CondTreeBuildInfo  -- ^ common stanzas
    -> [Field Position]
    -> ParseResult (CondTree ConfVar [Dependency] a)
594
595
596
597
parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do
    (fields', endo) <- processImports v fromBuildInfo commonStanzas fields
    x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields'
    return (endo x)
Oleg Grenrus's avatar
Oleg Grenrus committed
598
  where
599
    hasElif = specHasElif v
600
601
602
603
604
605
606
607
608
609

processImports
    :: forall a. L.HasBuildInfo a
    => CabalSpecVersion
    -> (BuildInfo -> a)              -- ^ construct fromBuildInfo
    -> Map String CondTreeBuildInfo  -- ^ common stanzas
    -> [Field Position]
    -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a)
processImports v fromBuildInfo commonStanzas = go []
  where
610
611
612
613
614
    hasCommonStanzas = specHasCommonStanzas v

    getList' :: List CommaFSep Token String -> [String]
    getList' = Newtype.unpack

615
    go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do
Oleg Grenrus's avatar
Oleg Grenrus committed
616
        parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
617
        go acc fields
Oleg Grenrus's avatar
Oleg Grenrus committed
618
    -- supported:
619
    go acc (Field (Name pos name) fls : fields) | name == "import" = do
620
        names <- getList' <$> runFieldParser pos parsec v fls
Oleg Grenrus's avatar
Oleg Grenrus committed
621
622
623
624
625
626
627
628
        names' <- for names $ \commonName ->
            case Map.lookup commonName commonStanzas of
                Nothing -> do
                    parseFailure pos $ "Undefined common stanza imported: " ++ commonName
                    pure Nothing
                Just commonTree ->
                    pure (Just commonTree)

629
        go (acc ++ catMaybes names') fields
Oleg Grenrus's avatar
Oleg Grenrus committed
630
631

    -- parse actual CondTree
632
633
634
635
636
637
638
639
640
641
642
643
    go acc fields = do
        fields' <- catMaybes <$> traverse (warnImport v) fields
        pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc)

-- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered
warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position))
warnImport v (Field (Name pos name) _) | name ==  "import" = do
    if specHasCommonStanzas v == NoCommonStanzas
    then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
    else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section"
    return Nothing
warnImport _ f = pure (Just f)
Oleg Grenrus's avatar
Oleg Grenrus committed
644
645

mergeCommonStanza
Oleg Grenrus's avatar
Oleg Grenrus committed
646
647
648
    :: L.HasBuildInfo a
    => (BuildInfo -> a)
    -> CondTree ConfVar [Dependency] BuildInfo
Oleg Grenrus's avatar
Oleg Grenrus committed
649
650
    -> CondTree ConfVar [Dependency] a
    -> CondTree ConfVar [Dependency] a
Oleg Grenrus's avatar
Oleg Grenrus committed
651
mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =
Oleg Grenrus's avatar
Oleg Grenrus committed
652
653
654
655
656
657
658
659
    CondNode x' (x' ^. L.targetBuildDepends) cs'
  where
    -- new value is old value with buildInfo field _prepended_.
    x' = x & L.buildInfo %~ (bi <>)

    -- tree components are appended together.
    cs' = map (fmap fromBuildInfo) bis ++ cs

660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
-------------------------------------------------------------------------------
-- Branches
-------------------------------------------------------------------------------

-- Check that a property holds on all branches of a condition tree
onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool
onAllBranches p = go mempty
  where
    -- If the current level of the tree satisfies the property, then we are
    -- done. If not, then one of the conditional branches below the current node
    -- must satisfy it. Each node may have multiple immediate children; we only
    -- one need one to satisfy the property because the configure step uses
    -- 'mappend' to join together the results of flag resolution.
    go :: a -> CondTree v c a -> Bool
    go acc ct = let acc' = acc `mappend` condTreeData ct
                in p acc' || any (goBranch acc') (condTreeComponents ct)

    -- Both the 'true' and the 'false' block must satisfy the property.
    goBranch :: a -> CondBranch v c a -> Bool
    goBranch _   (CondBranch _ _ Nothing) = False
    goBranch acc (CondBranch _ t (Just e))  = go acc t && go acc e

682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
-------------------------------------------------------------------------------
-- Flag check
-------------------------------------------------------------------------------

checkForUndefinedFlags :: GenericPackageDescription -> ParseResult ()
checkForUndefinedFlags gpd = do
    let definedFlags, usedFlags :: Set.Set FlagName
        definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd
        usedFlags    = getConst $ L.allCondTrees f gpd

    -- Note: we can check for defined, but unused flags here too.
    unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $
        "These flags are used without having been defined: " ++
        intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ]
  where
    f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a)
    f ct = Const (Set.fromList (freeVars ct))

Oleg Grenrus's avatar
Oleg Grenrus committed
700
701
702
703
-------------------------------------------------------------------------------
-- Old syntax
-------------------------------------------------------------------------------

Oleg Grenrus's avatar
Oleg Grenrus committed
704
705
-- TODO: move to own module

Oleg Grenrus's avatar
Oleg Grenrus committed
706
707
708
709
710
711
712
713
714
715
716
717
-- | "Sectionize" an old-style Cabal file.  A sectionized file has:
--
--  * all global fields at the beginning, followed by
--
--  * all flag declarations, followed by
--
--  * an optional library section, and an arbitrary number of executable
--    sections (in any order).
--
-- The current implementation just gathers all library-specific fields
-- in a library section and wraps all executable stanzas in an executable
-- section.
718
sectionizeFields :: [Field ann] -> (Syntax, [Field ann])
Oleg Grenrus's avatar
Oleg Grenrus committed
719
sectionizeFields fs = case classifyFields fs of
720
721
    Just fields -> (OldSyntax, convert fields)
    Nothing     -> (NewSyntax, fs)
Oleg Grenrus's avatar
Oleg Grenrus committed
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
  where
    -- return 'Just' if all fields are simple fields
    classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])]
    classifyFields = traverse f
      where
        f (Field name fieldlines) = Just (name, fieldlines)
        f _                      = Nothing

    trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse
    isSpace' = (== 32)

    convert :: [(Name ann, [FieldLine ann])] -> [Field ann]
    convert fields =
      let
        toField (name, ls) = Field name ls
        -- "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") . getName . fst) fields
        (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0

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

        exes = unfoldr toExe exes0
        toExe [] = Nothing
        toExe ((Name pos n, ls) : r)
          | n == "executable" =
              let (efs, r') = break ((== "executable") . getName . fst) r
              in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')
        toExe _ = error "unexpected input to 'toExe'"

        lib = case libfs of
            []                         -> []
            ((Name pos _,  _) : _) ->
                [Section (Name pos "library") [] (map toField $ deps ++ libfs)]

      in map toField hdr ++ lib ++ exes

762
763
764
765
-- | See 'sectionizeFields'.
data Syntax = OldSyntax | NewSyntax
    deriving (Eq, Show)

766
-- TODO:
Oleg Grenrus's avatar
Oleg Grenrus committed
767
libFieldNames :: [FieldName]
768
libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName)
Oleg Grenrus's avatar
Oleg Grenrus committed
769
770
771
772
773
774
775
776
777

-------------------------------------------------------------------------------
-- Suplementary build information
-------------------------------------------------------------------------------

readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
readHookedBuildInfo = readAndParseFile parseHookedBuildInfo

parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo
778
parseHookedBuildInfo bs = case readFields' bs of
Oleg Grenrus's avatar
Oleg Grenrus committed
779
780
781
782
783
784
785
786
787
788
    Right (fs, lexWarnings) -> do
        parseHookedBuildInfo' lexWarnings fs
    -- TODO: better marshalling of errors
    Left perr -> parseFatalFailure zeroPos (show perr)

parseHookedBuildInfo'
    :: [LexWarning]
    -> [Field Position]
    -> ParseResult HookedBuildInfo
parseHookedBuildInfo' lexWarnings fs = do
Oleg Grenrus's avatar
Oleg Grenrus committed
789
    parseWarnings (toPWarnings lexWarnings)
Oleg Grenrus's avatar
Oleg Grenrus committed
790
791
792
793
794
795
796
797
    (mLibFields, exes) <- stanzas fs
    mLib <- parseLib mLibFields
    biExes <- traverse parseExe exes
    return (mLib, biExes)
  where
    parseLib :: Fields Position -> ParseResult (Maybe BuildInfo)
    parseLib fields
        | Map.null fields = pure Nothing
798
        | otherwise       = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
Oleg Grenrus's avatar
Oleg Grenrus committed
799
800
801

    parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo)
    parseExe (n, fields) = do
802
        bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
Oleg Grenrus's avatar
Oleg Grenrus committed
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
        pure (n, bi)

    stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)])
    stanzas fields = do
        let (hdr0, exes0) = breakMaybe isExecutableField fields
        hdr <- toFields hdr0
        exes <- unfoldrM (traverse toExe) exes0
        pure (hdr, exes)

    toFields :: [Field Position] -> ParseResult (Fields Position)
    toFields fields = do
        let (fields', ss) = partitionFields fields
        traverse_ (traverse_ warnInvalidSubsection) ss
        pure fields'

    toExe
        :: ([FieldLine Position], [Field Position])
        -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position]))
    toExe (fss, fields) = do
822
        name <- runFieldParser zeroPos parsec cabalSpecLatest fss
Oleg Grenrus's avatar
Oleg Grenrus committed
823
824
825
826
827
828
829
830
        let (hdr0, rest) = breakMaybe isExecutableField fields
        hdr <- toFields hdr0
        pure ((name, hdr), rest)

    isExecutableField (Field (Name _ name) fss)
        | name == "executable" = Just fss
        | otherwise            = Nothing
    isExecutableField _ = Nothing
831
832
833
834
835
836
837
838
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
869
870
871
872
873

-- | Quickly scan new-style spec-version
--
-- A new-style spec-version declaration begins the .cabal file and
-- follow the following case-insensitive grammar (expressed in
-- RFC5234 ABNF):
--
-- @
-- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS
--
-- spec-version               = NUM "." NUM [ "." NUM ]
--
-- NUM    = DIGIT0 / DIGITP 1*DIGIT0
-- DIGIT0 = %x30-39
-- DIGITP = %x31-39
-- WS = %20
-- @
--
scanSpecVersion :: BS.ByteString -> Maybe Version
scanSpecVersion bs = do
    fstline':_ <- pure (BS8.lines bs)

    -- parse <newstyle-spec-version-decl>
    -- normalise: remove all whitespace, convert to lower-case
    let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline'
    ["cabal-version",vers] <- pure (BS8.split ':' fstline)

    -- parse <spec-version>
    --
    -- This is currently more tolerant regarding leading 0 digits.
    --
    ver <- simpleParsec (BS8.unpack vers)
    guard $ case versionNumbers ver of
              [_,_]   -> True
              [_,_,_] -> True
              _       -> False

    pure ver
  where
    -- | Translate ['A'..'Z'] to ['a'..'z']
    toLowerW8 :: Word8 -> Word8
    toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20
                | otherwise            = w