Parsec.hs 20.3 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 21
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
-----------------------------------------------------------------------------
-- |
-- 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,
22
    parseGenericPackageDescriptionMaybe,
Oleg Grenrus's avatar
Oleg Grenrus committed
23 24 25

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

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

Oleg Grenrus's avatar
Oleg Grenrus committed
33 34 35
import Distribution.Compat.Prelude
import Prelude ()

36 37
import           Control.Monad.State.Strict                   (StateT, execStateT)
import           Control.Monad.Trans.Class                    (lift)
Oleg Grenrus's avatar
Oleg Grenrus committed
38 39 40 41
import qualified Data.ByteString                              as BS
import           Data.List                                    (partition)
import qualified Distribution.Compat.Map.Strict               as Map
import           Distribution.FieldGrammar
Oleg Grenrus's avatar
Oleg Grenrus committed
42
import           Distribution.PackageDescription
Oleg Grenrus's avatar
Oleg Grenrus committed
43 44 45 46 47 48 49
import           Distribution.PackageDescription.FieldGrammar
import           Distribution.PackageDescription.Quirks       (patchQuirks)
import           Distribution.Parsec.Class                    (parsec)
import           Distribution.Parsec.Common
import           Distribution.Parsec.ConfVar                  (parseConditionConfVar)
import           Distribution.Parsec.Field                    (FieldName, getName)
import           Distribution.Parsec.LexerMonad               (LexWarning, toPWarning)
Oleg Grenrus's avatar
Oleg Grenrus committed
50
import           Distribution.Parsec.Parser
Oleg Grenrus's avatar
Oleg Grenrus committed
51 52 53
import           Distribution.Parsec.ParseResult
import           Distribution.Simple.Utils                    (die', fromUTF8BS, warn)
import           Distribution.Text                            (display)
54
import           Distribution.Types.CondTree
Oleg Grenrus's avatar
Oleg Grenrus committed
55
import           Distribution.Types.ForeignLib
56 57
import           Distribution.Types.UnqualComponentName
                 (UnqualComponentName, mkUnqualComponentName)
Oleg Grenrus's avatar
Oleg Grenrus committed
58 59
import           Distribution.Utils.Generic                   (breakMaybe, unfoldrM)
import           Distribution.Verbosity                       (Verbosity)
60
import           Distribution.Version
Oleg Grenrus's avatar
Oleg Grenrus committed
61 62
                 (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion)
import           System.Directory                             (doesFileExist)
Oleg Grenrus's avatar
Oleg Grenrus committed
63

Oleg Grenrus's avatar
Oleg Grenrus committed
64 65 66 67
import           Distribution.Compat.Lens
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens        as L

Oleg Grenrus's avatar
Oleg Grenrus committed
68 69 70 71 72 73 74 75 76 77
-- ---------------------------------------------------------------
-- Parsing

-- | Helper combinator to do parsing plumbing for files.
--
-- Given a parser and a filename, return the parse of the file,
-- after checking if the file exists.
--
-- Argument order is chosen to encourage partial application.
readAndParseFile
78 79 80
    :: (BS.ByteString -> ParseResult a)  -- ^ File contents to final value parser
    -> Verbosity                         -- ^ Verbosity level
    -> FilePath                          -- ^ File to read
Oleg Grenrus's avatar
Oleg Grenrus committed
81 82 83
    -> IO a
readAndParseFile parser verbosity fpath = do
    exists <- doesFileExist fpath
84 85 86
    unless exists $
      die' verbosity $
        "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
Oleg Grenrus's avatar
Oleg Grenrus committed
87 88 89 90 91
    bs <- BS.readFile fpath
    let (warnings, errors, result) = runParseResult (parser bs)
    traverse_ (warn verbosity . showPWarning fpath) warnings
    traverse_ (warn verbosity . showPError fpath) errors
    case result of
92
        Nothing -> die' verbosity $ "Failing parsing \"" ++ fpath ++ "\"."
Oleg Grenrus's avatar
Oleg Grenrus committed
93 94 95 96 97 98 99 100 101 102 103 104 105
        Just x  -> return x

-- | 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
Oleg Grenrus's avatar
Oleg Grenrus committed
106 107 108
parseGenericPackageDescription bs = case readFields' bs' of
    Right (fs, lexWarnings) -> do
        when patched $
109
            parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"
Oleg Grenrus's avatar
Oleg Grenrus committed
110
        parseGenericPackageDescription' lexWarnings fs
111
    -- TODO: better marshalling of errors
Oleg Grenrus's avatar
Oleg Grenrus committed
112 113
    Left perr -> parseFatalFailure zeroPos (show perr)
  where
114
    (patched, bs') = patchQuirks bs
Oleg Grenrus's avatar
Oleg Grenrus committed
115

116 117 118 119 120 121 122
-- | 'Maybe' variant of 'parseGenericPackageDescription'
parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe =
    trdOf3 . runParseResult . parseGenericPackageDescription
  where
    trdOf3 (_, _, x) = x

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

126 127 128 129 130 131
-- Monad in which sections are parsed
type M = StateT GenericPackageDescription ParseResult

inM :: ParseResult a -> M a
inM = lift

Oleg Grenrus's avatar
Oleg Grenrus committed
132
-- Note [Accumulating parser]
133 134 135 136
--
-- 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
137
parseGenericPackageDescription'
138 139
    :: [LexWarning]
    -> [Field Position]
Oleg Grenrus's avatar
Oleg Grenrus committed
140
    -> ParseResult GenericPackageDescription
141
parseGenericPackageDescription' lexWarnings fs = do
Oleg Grenrus's avatar
Oleg Grenrus committed
142
    parseWarnings (fmap toPWarning lexWarnings)
143
    let (syntax, fs') = sectionizeFields fs
Oleg Grenrus's avatar
Oleg Grenrus committed
144 145 146 147 148

    -- PackageDescription
    let (fields, sectionFields) = takeFields fs'
    pd <- parseFieldGrammar fields packageDescriptionFieldGrammar
    maybeWarnCabalVersion syntax pd
Oleg Grenrus's avatar
Oleg Grenrus committed
149

Oleg Grenrus's avatar
Oleg Grenrus committed
150 151
    -- Sections
    let gpd = emptyGpd & L.packageDescription .~ pd
152 153 154 155

    -- elif conditional is accepted if spec version is >= 2.1
    let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif
    execStateT (goSections hasElif sectionFields) gpd
Oleg Grenrus's avatar
Oleg Grenrus committed
156
  where
157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
    emptyGpd :: GenericPackageDescription
    emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []

    newSyntaxVersion :: Version
    newSyntaxVersion = mkVersion [1, 2]

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

    maybeWarnCabalVersion syntax pkg
      | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion
      = parseWarning (Position 0 0) PWTOldSyntax $
             "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 ()

185
    -- Sections
186 187 188 189 190 191 192
goSections :: HasElif -> [Field Position] -> M ()
goSections hasElif = traverse_ process
  where
    process (Field (Name pos name) _) =
        inM $ parseWarning pos PWTTrailingFields $
            "Ignoring trailing fields after sections: " ++ show name
    process (Section name args secFields) =
193
        parseSection name args secFields
Oleg Grenrus's avatar
Oleg Grenrus committed
194

195
    snoc x xs = xs ++ [x]
Oleg Grenrus's avatar
Oleg Grenrus committed
196

197 198
    parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> M ()
    parseSection (Name pos name) args fields
Oleg Grenrus's avatar
Oleg Grenrus committed
199
        | name == "library" && null args = do
200
            lib <- inM $ parseCondTree hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields
Oleg Grenrus's avatar
Oleg Grenrus committed
201
            -- TODO: check that library is defined once
202
            L.condLibrary ?= lib
Oleg Grenrus's avatar
Oleg Grenrus committed
203

204 205
        -- Sublibraries
        | name == "library" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
206
            -- TODO: check cabal-version
207
            name' <- parseUnqualComponentName pos args
208
            lib   <- inM $ parseCondTree hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields
209
            -- TODO check duplicate name here?
210
            L.condSubLibraries %= snoc (name', lib)
211

212
        | name == "foreign-library" = do
213
            name' <- parseUnqualComponentName pos args
214
            flib  <- inM $ parseCondTree hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields
215
            -- TODO check duplicate name here?
216
            L.condForeignLibs %= snoc (name', flib)
217

Oleg Grenrus's avatar
Oleg Grenrus committed
218
        | name == "executable" = do
219
            name' <- parseUnqualComponentName pos args
220
            exe   <- inM $ parseCondTree hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields
Oleg Grenrus's avatar
Oleg Grenrus committed
221
            -- TODO check duplicate name here?
222
            L.condExecutables %= snoc (name', exe)
Oleg Grenrus's avatar
Oleg Grenrus committed
223 224

        | name == "test-suite" = do
225
            name'      <- parseUnqualComponentName pos args
226
            testStanza <- inM $ parseCondTree hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields
227
            testSuite  <- inM $ traverse (validateTestSuite pos) testStanza
Oleg Grenrus's avatar
Oleg Grenrus committed
228
            -- TODO check duplicate name here?
229
            L.condTestSuites %= snoc (name', testSuite)
Oleg Grenrus's avatar
Oleg Grenrus committed
230 231

        | name == "benchmark" = do
232
            name'       <- parseUnqualComponentName pos args
233
            benchStanza <- inM $ parseCondTree hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields
234
            bench       <- inM $ traverse (validateBenchmark pos) benchStanza
Oleg Grenrus's avatar
Oleg Grenrus committed
235
            -- TODO check duplicate name here?
236
            L.condBenchmarks %= snoc (name', bench)
Oleg Grenrus's avatar
Oleg Grenrus committed
237 238

        | name == "flag" = do
239 240 241
            name'  <- parseName pos args
            name'' <- inM $ runFieldParser' pos parsec name' `recoverWith` mkFlagName ""
            flag   <- inM $ parseFields fields (flagFieldGrammar name'')
Oleg Grenrus's avatar
Oleg Grenrus committed
242
            -- Check default flag
243
            L.genPackageFlags %= snoc flag
Oleg Grenrus's avatar
Oleg Grenrus committed
244 245

        | name == "custom-setup" && null args = do
246 247
            sbi <- inM $ parseFields fields  (setupBInfoFieldGrammar False)
            L.packageDescription . L.setupBuildInfo ?= sbi
Oleg Grenrus's avatar
Oleg Grenrus committed
248 249

        | name == "source-repository" = do
250
            kind <- inM $ case args of
Oleg Grenrus's avatar
Oleg Grenrus committed
251 252 253
                [SecArgName spos secName] ->
                    runFieldParser' spos parsec (fromUTF8BS secName) `recoverWith` RepoHead
                [] -> do
Oleg Grenrus's avatar
Oleg Grenrus committed
254
                    parseFailure pos "'source-repository' requires exactly one argument"
Oleg Grenrus's avatar
Oleg Grenrus committed
255 256 257 258
                    pure RepoHead
                _ -> do
                    parseFailure pos $ "Invalid source-repository kind " ++ show args
                    pure RepoHead
Oleg Grenrus's avatar
Oleg Grenrus committed
259

260 261
            sr <- inM $ parseFields fields (sourceRepoFieldGrammar kind)
            L.packageDescription . L.sourceRepos %= snoc sr
Oleg Grenrus's avatar
Oleg Grenrus committed
262

263
        | otherwise = inM $
Oleg Grenrus's avatar
Oleg Grenrus committed
264 265
            parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name

266
parseName :: Position -> [SectionArg Position] -> M String
Oleg Grenrus's avatar
Oleg Grenrus committed
267 268 269 270
parseName pos args = case args of
    [SecArgName _pos secName] ->
         pure $ fromUTF8BS secName
    [SecArgStr _pos secName] ->
Oleg Grenrus's avatar
Oleg Grenrus committed
271
         pure $ fromUTF8BS secName
Oleg Grenrus's avatar
Oleg Grenrus committed
272
    [] -> do
273
         inM $ parseFailure pos $ "name required"
Oleg Grenrus's avatar
Oleg Grenrus committed
274 275 276
         pure ""
    _ -> do
         -- TODO: pretty print args
277
         inM $ parseFailure pos $ "Invalid name " ++ show args
Oleg Grenrus's avatar
Oleg Grenrus committed
278 279
         pure ""

280
parseUnqualComponentName :: Position -> [SectionArg Position] -> M UnqualComponentName
281 282
parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args

Oleg Grenrus's avatar
Oleg Grenrus committed
283
-- | Parse a non-recursive list of fields.
Oleg Grenrus's avatar
Oleg Grenrus committed
284
parseFields
Oleg Grenrus's avatar
Oleg Grenrus committed
285 286
    :: [Field Position] -- ^ fields to be parsed
    -> ParsecFieldGrammar' a
Oleg Grenrus's avatar
Oleg Grenrus committed
287
    -> ParseResult a
Oleg Grenrus's avatar
Oleg Grenrus committed
288 289 290 291 292 293 294 295
parseFields fields grammar = do
    let (fs0, ss) = partitionFields fields
    traverse_ (traverse_ warnInvalidSubsection) ss
    parseFieldGrammar fs0 grammar

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

297 298 299 300

data HasElif = HasElif | NoElif
  deriving (Eq, Show)

Oleg Grenrus's avatar
Oleg Grenrus committed
301
parseCondTree
302 303 304 305
    :: forall a c.
       HasElif                -- ^ accept @elif@
    -> ParsecFieldGrammar' a  -- ^ grammar
    -> (a -> c)               -- ^ condition extractor
Oleg Grenrus's avatar
Oleg Grenrus committed
306
    -> [Field Position]
Oleg Grenrus's avatar
Oleg Grenrus committed
307
    -> ParseResult (CondTree ConfVar c a)
308
parseCondTree hasElif grammar cond = go
Oleg Grenrus's avatar
Oleg Grenrus committed
309
  where
Oleg Grenrus's avatar
Oleg Grenrus committed
310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
    go fields = do
        let (fs, ss) = partitionFields fields
        x <- parseFieldGrammar fs grammar
        branches <- concat <$> traverse parseIfs ss
        return (CondNode x (cond x) branches) -- TODO: branches

    parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar c a]
    parseIfs [] = return []
    parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do
        test' <- parseConditionConfVar test
        fields' <- go fields
        -- TODO: else
        (elseFields, sections') <- parseElseIfs sections
        return (CondBranch test' fields' elseFields : sections')
    parseIfs (MkSection (Name pos name) _ _ : sections) = do
Oleg Grenrus's avatar
Oleg Grenrus committed
325
        parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
Oleg Grenrus's avatar
Oleg Grenrus committed
326 327 328 329 330 331 332 333 334 335 336 337
        parseIfs sections

    parseElseIfs
        :: [Section Position]
        -> ParseResult (Maybe (CondTree ConfVar c a), [CondBranch ConfVar c a])
    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')
338 339

    parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do
Oleg Grenrus's avatar
Oleg Grenrus committed
340 341 342 343 344 345 346
        -- TODO: check cabal-version
        test' <- parseConditionConfVar test
        fields' <- go fields
        (elseFields, sections') <- parseElseIfs sections
        -- we parse an empty 'Fields', to get empty value for a node
        a <- parseFieldGrammar mempty grammar
        return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
347

Oleg Grenrus's avatar
Oleg Grenrus committed
348
    parseElseIfs sections = (,) Nothing <$> parseIfs sections
Oleg Grenrus's avatar
Oleg Grenrus committed
349 350 351

{- Note [Accumulating parser]

Oleg Grenrus's avatar
Oleg Grenrus committed
352 353
Note: Outdated a bit

Oleg Grenrus's avatar
Oleg Grenrus committed
354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375
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.
-}

-------------------------------------------------------------------------------
-- Old syntax
-------------------------------------------------------------------------------

Oleg Grenrus's avatar
Oleg Grenrus committed
376 377
-- TODO: move to own module

Oleg Grenrus's avatar
Oleg Grenrus committed
378 379 380 381 382 383 384 385 386 387 388 389
-- | "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.
390
sectionizeFields :: [Field ann] -> (Syntax, [Field ann])
Oleg Grenrus's avatar
Oleg Grenrus committed
391
sectionizeFields fs = case classifyFields fs of
392 393
    Just fields -> (OldSyntax, convert fields)
    Nothing     -> (NewSyntax, fs)
Oleg Grenrus's avatar
Oleg Grenrus committed
394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
  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

434 435 436 437
-- | See 'sectionizeFields'.
data Syntax = OldSyntax | NewSyntax
    deriving (Eq, Show)

Oleg Grenrus's avatar
Oleg Grenrus committed
438
libFieldNames :: [FieldName]
Oleg Grenrus's avatar
Oleg Grenrus committed
439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar Nothing)

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

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

parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo
parseHookedBuildInfo bs = case readFields' bs' of
    Right (fs, lexWarnings) -> do
        when patched $
            parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"
        parseHookedBuildInfo' lexWarnings fs
    -- TODO: better marshalling of errors
    Left perr -> parseFatalFailure zeroPos (show perr)
  where
    (patched, bs') = patchQuirks bs

parseHookedBuildInfo'
    :: [LexWarning]
    -> [Field Position]
    -> ParseResult HookedBuildInfo
parseHookedBuildInfo' lexWarnings fs = do
    parseWarnings (fmap toPWarning lexWarnings)
    (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
        | otherwise       = Just <$> parseFieldGrammar fields buildInfoFieldGrammar

    parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo)
    parseExe (n, fields) = do
        bi <- parseFieldGrammar fields buildInfoFieldGrammar
        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
        name <- runFieldParser zeroPos parsec fss
        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