Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE Rank2Types #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6
   7 -----------------------------------------------------------------------------
   8
   9 -- |
  10 -- Module      :  Distribution.PackageDescription.Parsec
  11 -- Copyright   :  Isaac Jones 2003-2005
  12 -- License     :  BSD3
  13 --
  14 -- Maintainer  :  cabal-devel@haskell.org
  15 -- Portability :  portable
  16 --
  17 -- This defined parsers and partial pretty printers for the @.cabal@ format.
  18 module Distribution.PackageDescription.Parsec
  19   ( -- * Package descriptions
  20     parseGenericPackageDescription
  21   , parseGenericPackageDescriptionMaybe
  22
  23     -- ** Parsing
  24   , ParseResult
  25   , runParseResult
  26
  27     -- * New-style spec-version
  28   , scanSpecVersion
  29
  30     -- ** Supplementary build information
  31   , parseHookedBuildInfo
  32   ) where
  33
  34 import Distribution.Compat.Prelude
  35 import Prelude ()
  36
  37 import Control.Monad.State.Strict (StateT, execStateT)
  38 import Control.Monad.Trans.Class (lift)
  39 import Distribution.CabalSpecVersion
  40 import Distribution.Compat.Lens
  41 import Distribution.FieldGrammar
  42 import Distribution.FieldGrammar.Parsec (NamelessField (..))
  43 import Distribution.Fields.ConfVar (parseConditionConfVar)
  44 import Distribution.Fields.Field (FieldName, getName)
  45 import Distribution.Fields.LexerMonad (LexWarning, toPWarnings)
  46 import Distribution.Fields.ParseResult
  47 import Distribution.Fields.Parser
  48 import Distribution.PackageDescription
  49 import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos)
  50 import Distribution.PackageDescription.FieldGrammar
  51 import Distribution.PackageDescription.Quirks (patchQuirks)
  52 import Distribution.Parsec (parsec, simpleParsecBS)
  53 import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
  54 import Distribution.Parsec.Position (Position (..), zeroPos)
  55 import Distribution.Parsec.Warning (PWarnType (..))
  56 import Distribution.Pretty (prettyShow)
  57 import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8)
  58 import Distribution.Version (Version, mkVersion, versionNumbers)
  59
  60 import qualified Data.ByteString as BS
  61 import qualified Data.ByteString.Char8 as BS8
  62 import qualified Data.Map.Strict as Map
  63 import qualified Data.Set as Set
  64 import qualified Distribution.Compat.Newtype as Newtype
  65 import qualified Distribution.Compat.NonEmptySet as NES
  66 import qualified Distribution.Types.BuildInfo.Lens as L
  67 import qualified Distribution.Types.Executable.Lens as L
  68 import qualified Distribution.Types.ForeignLib.Lens as L
  69 import qualified Distribution.Types.GenericPackageDescription.Lens as L
  70 import qualified Distribution.Types.PackageDescription.Lens as L
  71 import qualified Distribution.Types.SetupBuildInfo.Lens as L
  72 import qualified Text.Parsec as P
  73
  74 ------------------------------------------------------------------------------
  75
  76 -- | Parses the given file into a 'GenericPackageDescription'.
  77 --
  78 -- In Cabal 1.2 the syntax for package descriptions was changed to a format
  79 -- with sections and possibly indented property descriptions.
  80 parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription
  81 parseGenericPackageDescription bs = do
  82   -- set scanned version
  83   setCabalSpecVersion ver
  84
  85   csv <- case ver of
  86     -- if we get too new version, fail right away
  87     Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of
  88       Just csv -> return (Just csv)
  89       Nothing ->
  90         parseFatalFailure zeroPos $
  91           "Unsupported cabal format version in cabal-version field: "
  92             ++ prettyShow v
  93             ++ ".\n"
  94             ++ cabalFormatVersionsDesc
  95     _ -> pure Nothing
  96
  97   case readFields' bs'' of
  98     Right (fs, lexWarnings) -> do
  99       when patched $
 100         parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"
 101       -- UTF8 is validated in a prepass step, afterwards parsing is lenient.
 102       parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs
 103     -- TODO: better marshalling of errors
 104     Left perr -> parseFatalFailure pos (show perr)
 105       where
 106         ppos = P.errorPos perr
 107         pos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
 108   where
 109     (patched, bs') = patchQuirks bs
 110     ver = scanSpecVersion bs'
 111
 112     invalidUtf8 = validateUTF8 bs'
 113
 114     -- if there are invalid utf8 characters, we make the bytestring valid.
 115     bs'' = case invalidUtf8 of
 116       Nothing -> bs'
 117       Just _ -> toUTF8BS (fromUTF8BS bs')
 118
 119 -- | 'Maybe' variant of 'parseGenericPackageDescription'
 120 parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription
 121 parseGenericPackageDescriptionMaybe =
 122   either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription
 123
 124 fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
 125 fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
 126
 127 -- Monad in which sections are parsed
 128 type SectionParser = StateT SectionS ParseResult
 129
 130 -- | State of section parser
 131 data SectionS = SectionS
 132   { _stateGpd :: !GenericPackageDescription
 133   , _stateCommonStanzas :: !(Map String CondTreeBuildInfo)
 134   }
 135
 136 stateGpd :: Lens' SectionS GenericPackageDescription
 137 stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd
 138 {-# INLINE stateGpd #-}
 139
 140 stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo)
 141 stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs
 142 {-# INLINE stateCommonStanzas #-}
 143
 144 -- Note [Accumulating parser]
 145 --
 146 -- This parser has two "states":
 147
 148 -- * first we parse fields of PackageDescription
 149
 150 -- * then we parse sections (libraries, executables, etc)
 151 parseGenericPackageDescription'
 152   :: Maybe CabalSpecVersion
 153   -> [LexWarning]
 154   -> Maybe Int
 155   -> [Field Position]
 156   -> ParseResult GenericPackageDescription
 157 parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do
 158   parseWarnings (toPWarnings lexWarnings)
 159   for_ utf8WarnPos $ \pos ->
 160     parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos
 161   let (syntax, fs') = sectionizeFields fs
 162   let (fields, sectionFields) = takeFields fs'
 163
 164   -- cabal-version
 165   specVer <- case scannedVer of
 166     Just v -> return v
 167     Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of
 168       Nothing -> return CabalSpecV1_0
 169       Just (MkNamelessField pos fls) -> do
 170         -- version will be parsed twice, therefore we parse without warnings.
 171         v <-
 172           withoutWarnings $
 173             Newtype.unpack' SpecVersion
 174               <$>
 175               -- Use version with || and && but before addition of ^>= and removal of -any
 176               runFieldParser pos parsec CabalSpecV1_24 fls
 177
 178         -- if it were at the beginning, scanner would found it
 179         when (v >= CabalSpecV2_2) $
 180           parseFailure pos $
 181             "cabal-version should be at the beginning of the file starting with spec version 2.2.\n"
 182               ++ cabalFormatVersionsDesc
 183
 184         return v
 185
 186   -- reset cabal version, it might not be set
 187   let specVer' = mkVersion (cabalSpecToVersionDigits specVer)
 188   setCabalSpecVersion (Just specVer')
 189
 190   -- Package description
 191   pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar
 192
 193   -- Check that scanned and parsed versions match.
 194   unless (specVer == specVersion pd) $
 195     parseFailure zeroPos $
 196       "Scanned and parsed cabal-versions don't match "
 197         ++ prettyShow (SpecVersion specVer)
 198         ++ " /= "
 199         ++ prettyShow (SpecVersion (specVersion pd))
 200
 201   maybeWarnCabalVersion syntax pd
 202
 203   -- Sections
 204   let gpd =
 205         emptyGenericPackageDescription
 206           & L.packageDescription .~ pd
 207   gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)
 208
 209   let gpd2 = postProcessInternalDeps specVer gpd1
 210   checkForUndefinedFlags gpd2
 211   checkForUndefinedCustomSetup gpd2
 212   -- See nothunks test, without this deepseq we get (at least):
 213   -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]}
 214   --
 215   -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks)
 216   -- TODO: remove the need for deepseq if `deepseq` in fact matters
 217   -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure
 218   gpd2 `deepseq` return gpd2
 219   where
 220     safeLast :: [a] -> Maybe a
 221     safeLast = listToMaybe . reverse
 222
 223     newSyntaxVersion :: CabalSpecVersion
 224     newSyntaxVersion = CabalSpecV1_2
 225
 226     maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()
 227     maybeWarnCabalVersion syntax pkg
 228       | syntax == NewSyntax && specVersion pkg < newSyntaxVersion =
 229           parseWarning zeroPos PWTNewSyntax $
 230             "A package using section syntax must specify at least\n"
 231               ++ "'cabal-version: >= 1.2'."
 232     maybeWarnCabalVersion syntax pkg
 233       | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion =
 234           parseWarning zeroPos PWTOldSyntax $
 235             "A package using 'cabal-version: "
 236               ++ prettyShow (SpecVersion (specVersion pkg))
 237               ++ "' must use section syntax. See the Cabal user guide for details."
 238     maybeWarnCabalVersion _ _ = return ()
 239
 240 -- See #4899
 241 cabalFormatVersionsDesc :: String
 242 cabalFormatVersionsDesc = "Current cabal-version values are listed at https://cabal.readthedocs.io/en/stable/file-format-changelog.html."
 243
 244 goSections :: CabalSpecVersion -> [Field Position] -> SectionParser ()
 245 goSections specVer = traverse_ process
 246   where
 247     process (Field (Name pos name) _) =
 248       lift $
 249         parseWarning pos PWTTrailingFields $
 250           "Ignoring trailing fields after sections: " ++ show name
 251     process (Section name args secFields) =
 252       parseSection name args secFields
 253
 254     snoc x xs = xs ++ [x]
 255
 256     hasCommonStanzas = specHasCommonStanzas specVer
 257
 258     -- we need signature, because this is polymorphic, but not-closed
 259     parseCondTree'
 260       :: L.HasBuildInfo a
 261       => ParsecFieldGrammar' a
 262       -- \^ grammar
 263       -> (BuildInfo -> a)
 264       -> Map String CondTreeBuildInfo
 265       -- \^ common stanzas
 266       -> [Field Position]
 267       -> ParseResult (CondTree ConfVar [Dependency] a)
 268     parseCondTree' = parseCondTreeWithCommonStanzas specVer
 269
 270     parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()
 271     parseSection (Name pos name) args fields
 272       | hasCommonStanzas == NoCommonStanzas
 273       , name == "common" = lift $ do
 274           parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas."
 275       | name == "common" = do
 276           commonStanzas <- use stateCommonStanzas
 277           name' <- lift $ parseCommonName pos args
 278           biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields
 279
 280           case Map.lookup name' commonStanzas of
 281             Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas
 282             Just _ ->
 283               lift $
 284                 parseFailure pos $
 285                   "Duplicate common stanza: " ++ name'
 286       | name == "library" && null args = do
 287           prev <- use $ stateGpd . L.condLibrary
 288           when (isJust prev) $
 289             lift $
 290               parseFailure pos $
 291                 "Multiple main libraries; have you forgotten to specify a name for an internal library?"
 292
 293           commonStanzas <- use stateCommonStanzas
 294           let name'' = LMainLibName
 295           lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
 296           --
 297           -- TODO check that not set
 298           stateGpd . L.condLibrary ?= lib
 299
 300       -- Sublibraries
 301       -- TODO: check cabal-version
 302       | name == "library" = do
 303           commonStanzas <- use stateCommonStanzas
 304           name' <- parseUnqualComponentName pos args
 305           let name'' = LSubLibName name'
 306           lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
 307           -- TODO check duplicate name here?
 308           stateGpd . L.condSubLibraries %= snoc (name', lib)
 309
 310       -- TODO: check cabal-version
 311       | name == "foreign-library" = do
 312           commonStanzas <- use stateCommonStanzas
 313           name' <- parseUnqualComponentName pos args
 314           flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
 315
 316           let hasType ts = foreignLibType ts /= foreignLibType mempty
 317           unless (onAllBranches hasType flib) $
 318             lift $
 319               parseFailure pos $
 320                 concat
 321                   [ "Foreign library " ++ show (prettyShow name')
 322                   , " is missing required field \"type\" or the field "
 323                   , "is not present in all conditional branches. The "
 324                   , "available test types are: "
 325                   , intercalate ", " (map prettyShow knownForeignLibTypes)
 326                   ]
 327
 328           -- TODO check duplicate name here?
 329           stateGpd . L.condForeignLibs %= snoc (name', flib)
 330       | name == "executable" = do
 331           commonStanzas <- use stateCommonStanzas
 332           name' <- parseUnqualComponentName pos args
 333           exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
 334           -- TODO check duplicate name here?
 335           stateGpd . L.condExecutables %= snoc (name', exe)
 336       | name == "test-suite" = do
 337           commonStanzas <- use stateCommonStanzas
 338           name' <- parseUnqualComponentName pos args
 339           testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields
 340           testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza
 341
 342           let hasType ts = testInterface ts /= testInterface mempty
 343           unless (onAllBranches hasType testSuite) $
 344             lift $
 345               parseFailure pos $
 346                 concat
 347                   [ "Test suite " ++ show (prettyShow name')
 348                   , concat $ case specVer of
 349                       v
 350                         | v >= CabalSpecV3_8 ->
 351                             [ " is missing required field \"main-is\" or the field "
 352                             , "is not present in all conditional branches."
 353                             ]
 354                       _ ->
 355                         [ " is missing required field \"type\" or the field "
 356                         , "is not present in all conditional branches. The "
 357                         , "available test types are: "
 358                         , intercalate ", " (map prettyShow knownTestTypes)
 359                         ]
 360                   ]
 361
 362           -- TODO check duplicate name here?
 363           stateGpd . L.condTestSuites %= snoc (name', testSuite)
 364       | name == "benchmark" = do
 365           commonStanzas <- use stateCommonStanzas
 366           name' <- parseUnqualComponentName pos args
 367           benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields
 368           bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza
 369
 370           let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty
 371           unless (onAllBranches hasType bench) $
 372             lift $
 373               parseFailure pos $
 374                 concat
 375                   [ "Benchmark " ++ show (prettyShow name')
 376                   , concat $ case specVer of
 377                       v
 378                         | v >= CabalSpecV3_8 ->
 379                             [ " is missing required field \"main-is\" or the field "
 380                             , "is not present in all conditional branches."
 381                             ]
 382                       _ ->
 383                         [ " is missing required field \"type\" or the field "
 384                         , "is not present in all conditional branches. The "
 385                         , "available benchmark types are: "
 386                         , intercalate ", " (map prettyShow knownBenchmarkTypes)
 387                         ]
 388                   ]
 389
 390           -- TODO check duplicate name here?
 391           stateGpd . L.condBenchmarks %= snoc (name', bench)
 392       | name == "flag" = do
 393           name' <- parseNameBS pos args
 394           name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""
 395           flag <- lift $ parseFields specVer fields (flagFieldGrammar name'')
 396           -- Check default flag
 397           stateGpd . L.genPackageFlags %= snoc flag
 398       | name == "custom-setup" && null args = do
 399           sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False)
 400           stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi
 401       | name == "source-repository" = do
 402           kind <- lift $ case args of
 403             [SecArgName spos secName] ->
 404               runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead
 405             [] -> do
 406               parseFailure pos "'source-repository' requires exactly one argument"
 407               pure RepoHead
 408             _ -> do
 409               parseFailure pos $ "Invalid source-repository kind " ++ show args
 410               pure RepoHead
 411
 412           sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind)
 413           stateGpd . L.packageDescription . L.sourceRepos %= snoc sr
 414       | otherwise =
 415           lift $
 416             parseWarning pos PWTUnknownSection $
 417               "Ignoring section: " ++ show name
 418
 419 parseName :: Position -> [SectionArg Position] -> SectionParser String
 420 parseName pos args = fromUTF8BS <$> parseNameBS pos args
 421
 422 parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString
 423 -- TODO: use strict parser
 424 parseNameBS pos args = case args of
 425   [SecArgName _pos secName] ->
 426     pure secName
 427   [SecArgStr _pos secName] ->
 428     pure secName
 429   [] -> do
 430     lift $ parseFailure pos "name required"
 431     pure ""
 432   _ -> do
 433     -- TODO: pretty print args
 434     lift $ parseFailure pos $ "Invalid name " ++ show args
 435     pure ""
 436
 437 parseCommonName :: Position -> [SectionArg Position] -> ParseResult String
 438 parseCommonName pos args = case args of
 439   [SecArgName _pos secName] ->
 440     pure $ fromUTF8BS secName
 441   [SecArgStr _pos secName] ->
 442     pure $ fromUTF8BS secName
 443   [] -> do
 444     parseFailure pos $ "name required"
 445     pure ""
 446   _ -> do
 447     -- TODO: pretty print args
 448     parseFailure pos $ "Invalid name " ++ show args
 449     pure ""
 450
 451 -- TODO: avoid conversion to 'String'.
 452 parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName
 453 parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
 454
 455 -- | Parse a non-recursive list of fields.
 456 parseFields
 457   :: CabalSpecVersion
 458   -> [Field Position]
 459   -- ^ fields to be parsed
 460   -> ParsecFieldGrammar' a
 461   -> ParseResult a
 462 parseFields v fields grammar = do
 463   let (fs0, ss) = partitionFields fields
 464   traverse_ (traverse_ warnInvalidSubsection) ss
 465   parseFieldGrammar v fs0 grammar
 466
 467 warnInvalidSubsection :: Section Position -> ParseResult ()
 468 warnInvalidSubsection (MkSection (Name pos name) _ _) =
 469   void $ parseFailure pos $ "invalid subsection " ++ show name
 470
 471 parseCondTree
 472   :: forall a
 473    . L.HasBuildInfo a
 474   => CabalSpecVersion
 475   -> HasElif
 476   -- ^ accept @elif@
 477   -> ParsecFieldGrammar' a
 478   -- ^ grammar
 479   -> Map String CondTreeBuildInfo
 480   -- ^ common stanzas
 481   -> (BuildInfo -> a)
 482   -- ^ constructor from buildInfo
 483   -> (a -> [Dependency])
 484   -- ^ condition extractor
 485   -> [Field Position]
 486   -> ParseResult (CondTree ConfVar [Dependency] a)
 487 parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
 488   where
 489     go fields0 = do
 490       (fields, endo) <-
 491         if v >= CabalSpecV3_0
 492           then processImports v fromBuildInfo commonStanzas fields0
 493           else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id)
 494
 495       let (fs, ss) = partitionFields fields
 496       x <- parseFieldGrammar v fs grammar
 497       branches <- concat <$> traverse parseIfs ss
 498       return $ endo $ CondNode x (cond x) branches
 499
 500     parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a]
 501     parseIfs [] = return []
 502     parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do
 503       test' <- parseConditionConfVar test
 504       fields' <- go fields
 505       (elseFields, sections') <- parseElseIfs sections
 506       return (CondBranch test' fields' elseFields : sections')
 507     parseIfs (MkSection (Name pos name) _ _ : sections) = do
 508       parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
 509       parseIfs sections
 510
 511     parseElseIfs
 512       :: [Section Position]
 513       -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])
 514     parseElseIfs [] = return (Nothing, [])
 515     parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do
 516       unless (null args) $
 517         parseFailure pos $
 518           "`else` section has section arguments " ++ show args
 519       elseFields <- go fields
 520       sections' <- parseIfs sections
 521       return (Just elseFields, sections')
 522     parseElseIfs (MkSection (Name _ name) test fields : sections)
 523       | hasElif == HasElif
 524       , name == "elif" = do
 525           test' <- parseConditionConfVar test
 526           fields' <- go fields
 527           (elseFields, sections') <- parseElseIfs sections
 528           -- we parse an empty 'Fields', to get empty value for a node
 529           a <- parseFieldGrammar v mempty grammar
 530           return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
 531     parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do
 532       parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."
 533       (,) Nothing <$> parseIfs sections
 534     parseElseIfs sections = (,) Nothing <$> parseIfs sections
 535
 536 {- Note [Accumulating parser]
 537
 538 Note: Outdated a bit
 539
 540 In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a ->
 541 FieldParser a)@.  The weird value is used because we accumulate structure of
 542 @a@ by folding over the fields.  There are various reasons for that:
 543
 544 \* Almost all fields are optional
 545
 546 \* This is simple approach so declarative bi-directional format (parsing and
 547 printing) of structure could be specified (list of @'FieldDescr' a@)
 548
 549 \* There are surface syntax fields corresponding to single field in the file:
 550   @license-file@ and @license-files@
 551
 552 \* This is quite safe approach.
 553
 554 When/if we re-implement the parser to support formatting preservging roundtrip
 555 with new AST, this all need to be rewritten.
 556 -}
 557
 558 -------------------------------------------------------------------------------
 559 -- Common stanzas
 560 -------------------------------------------------------------------------------
 561
 562 -- $commonStanzas
 563 --
 564 -- [Note: Common stanzas]
 565 --
 566 -- In Cabal 2.2 we support simple common stanzas:
 567 --
 568 -- * Commons stanzas define 'BuildInfo'
 569 --
 570 -- * import "fields" can only occur at top of other stanzas (think: imports)
 571 --
 572 -- In particular __there aren't__
 573 --
 574 -- * implicit stanzas
 575 --
 576 -- * More specific common stanzas (executable, test-suite).
 577 --
 578 --
 579 -- The approach uses the fact that 'BuildInfo' is a 'Monoid':
 580 --
 581 -- @
 582 -- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp
 583 -- mergeCommonStanza' bi = over L.BuildInfo (bi <>)
 584 -- @
 585 --
 586 -- Real 'mergeCommonStanza' is more complicated as we have to deal with
 587 -- conditional trees.
 588 --
 589 -- The approach is simple, and have good properties:
 590 --
 591 -- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.
 592 type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
 593
 594 -- | Create @a@ from 'BuildInfo'.
 595 -- This class is used to implement common stanza parsing.
 596 --
 597 -- Law: @view buildInfo . fromBuildInfo = id@
 598 --
 599 -- This takes name, as 'FieldGrammar's take names too.
 600 class L.HasBuildInfo a => FromBuildInfo a where
 601   fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a
 602
 603 libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library
 604 libraryFromBuildInfo n bi =
 605   emptyLibrary
 606     { libName = n
 607     , libVisibility = case n of
 608         LMainLibName -> LibraryVisibilityPublic
 609         LSubLibName _ -> LibraryVisibilityPrivate
 610     , libBuildInfo = bi
 611     }
 612
 613 instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id
 614 instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib
 615 instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable
 616
 617 instance FromBuildInfo TestSuiteStanza where
 618   fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi []
 619
 620 instance FromBuildInfo BenchmarkStanza where
 621   fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi
 622
 623 parseCondTreeWithCommonStanzas
 624   :: forall a
 625    . L.HasBuildInfo a
 626   => CabalSpecVersion
 627   -> ParsecFieldGrammar' a
 628   -- ^ grammar
 629   -> (BuildInfo -> a)
 630   -- ^ construct fromBuildInfo
 631   -> Map String CondTreeBuildInfo
 632   -- ^ common stanzas
 633   -> [Field Position]
 634   -> ParseResult (CondTree ConfVar [Dependency] a)
 635 parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do
 636   (fields', endo) <- processImports v fromBuildInfo commonStanzas fields
 637   x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields'
 638   return (endo x)
 639   where
 640     hasElif = specHasElif v
 641
 642 processImports
 643   :: forall a
 644    . L.HasBuildInfo a
 645   => CabalSpecVersion
 646   -> (BuildInfo -> a)
 647   -- ^ construct fromBuildInfo
 648   -> Map String CondTreeBuildInfo
 649   -- ^ common stanzas
 650   -> [Field Position]
 651   -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a)
 652 processImports v fromBuildInfo commonStanzas = go []
 653   where
 654     hasCommonStanzas = specHasCommonStanzas v
 655
 656     getList' :: List CommaFSep Token String -> [String]
 657     getList' = Newtype.unpack
 658
 659     go acc (Field (Name pos name) _ : fields)
 660       | name == "import"
 661       , hasCommonStanzas == NoCommonStanzas = do
 662           parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
 663           go acc fields
 664     -- supported:
 665     go acc (Field (Name pos name) fls : fields) | name == "import" = do
 666       names <- getList' <$> runFieldParser pos parsec v fls
 667       names' <- for names $ \commonName ->
 668         case Map.lookup commonName commonStanzas of
 669           Nothing -> do
 670             parseFailure pos $ "Undefined common stanza imported: " ++ commonName
 671             pure Nothing
 672           Just commonTree ->
 673             pure (Just commonTree)
 674
 675       go (acc ++ catMaybes names') fields
 676
 677     -- parse actual CondTree
 678     go acc fields = do
 679       fields' <- catMaybes <$> traverse (warnImport v) fields
 680       pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc)
 681
 682 -- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered
 683 warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position))
 684 warnImport v (Field (Name pos name) _) | name == "import" = do
 685   if specHasCommonStanzas v == NoCommonStanzas
 686     then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
 687     else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section"
 688   return Nothing
 689 warnImport _ f = pure (Just f)
 690
 691 mergeCommonStanza
 692   :: L.HasBuildInfo a
 693   => (BuildInfo -> a)
 694   -> CondTree ConfVar [Dependency] BuildInfo
 695   -> CondTree ConfVar [Dependency] a
 696   -> CondTree ConfVar [Dependency] a
 697 mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =
 698   CondNode x' (x' ^. L.targetBuildDepends) cs'
 699   where
 700     -- new value is old value with buildInfo field _prepended_.
 701     x' = x & L.buildInfo %~ (bi <>)
 702
 703     -- tree components are appended together.
 704     cs' = map (fmap fromBuildInfo) bis ++ cs
 705
 706 -------------------------------------------------------------------------------
 707 -- Branches
 708 -------------------------------------------------------------------------------
 709
 710 -- Check that a property holds on all branches of a condition tree
 711 onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool
 712 onAllBranches p = go mempty
 713   where
 714     -- If the current level of the tree satisfies the property, then we are
 715     -- done. If not, then one of the conditional branches below the current node
 716     -- must satisfy it. Each node may have multiple immediate children; we only
 717     -- one need one to satisfy the property because the configure step uses
 718     -- 'mappend' to join together the results of flag resolution.
 719     go :: a -> CondTree v c a -> Bool
 720     go acc ct =
 721       let acc' = acc `mappend` condTreeData ct
 722        in p acc' || any (goBranch acc') (condTreeComponents ct)
 723
 724     -- Both the 'true' and the 'false' block must satisfy the property.
 725     goBranch :: a -> CondBranch v c a -> Bool
 726     goBranch _ (CondBranch _ _ Nothing) = False
 727     goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e
 728
 729 -------------------------------------------------------------------------------
 730 -- Post parsing checks
 731 -------------------------------------------------------------------------------
 732
 733 -- | Check that we
 734 --
 735 -- * don't use undefined flags (very bad)
 736 -- * define flags which are unused (just bad)
 737 checkForUndefinedFlags :: GenericPackageDescription -> ParseResult ()
 738 checkForUndefinedFlags gpd = do
 739   let definedFlags, usedFlags :: Set.Set FlagName
 740       definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd
 741       usedFlags = getConst $ L.allCondTrees f gpd
 742
 743   -- Note: we can check for defined, but unused flags here too.
 744   unless (usedFlags `Set.isSubsetOf` definedFlags) $
 745     parseFailure zeroPos $
 746       "These flags are used without having been defined: "
 747         ++ intercalate ", " [unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags]
 748   where
 749     f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a)
 750     f ct = Const (Set.fromList (freeVars ct))
 751
 752 -- | Since @cabal-version: 1.24@ one can specify @custom-setup@.
 753 -- Let us require it.
 754 checkForUndefinedCustomSetup :: GenericPackageDescription -> ParseResult ()
 755 checkForUndefinedCustomSetup gpd = do
 756   let pd = packageDescription gpd
 757   let csv = specVersion pd
 758
 759   when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $
 760     when (csv >= CabalSpecV1_24) $
 761       parseFailure zeroPos $
 762         "Since cabal-version: 1.24 specifying custom-setup section is mandatory"
 763
 764 -------------------------------------------------------------------------------
 765 -- Post processing of internal dependencies
 766 -------------------------------------------------------------------------------
 767
 768 -- Note [Dependencies on sublibraries]
 769 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 770 --
 771 -- This is solution to https://github.com/haskell/cabal/issues/6083
 772 --
 773 -- Before 'cabal-version: 3.0' we didn't have a syntax specially
 774 -- for referring to internal libraries. Internal library names
 775 -- shadowed the outside ones.
 776 --
 777 -- Since 'cabal-version: 3.0' we have ability to write
 778 --
 779 --     build-depends: some-package:its-sub-lib >=1.2.3
 780 --
 781 -- This allows us to refer also to local packages by `this-package:sublib`.
 782 -- So since 'cabal-version: 3.4' to refer to *any*
 783 -- sublibrary we must use the two part syntax. Here's small table:
 784 --
 785 --                   | pre-3.4             |      3.4 and after            |
 786 -- ------------------|---------------------|-------------------------------|
 787 -- pkg-name          | may refer to sublib | always refers to external pkg |
 788 -- pkg-name:sublib   | refers to sublib    | refers to sublib              |
 789 -- pkg-name:pkg-name | may refer to sublib | always refers to external pkg |
 790 --
 791 -- In pre-3.4 case, if a package 'this-pkg' has a sublibrary 'pkg-name',
 792 -- all dependency definitions will refer to that sublirary.
 793 --
 794 -- In 3.4 and after case, 'pkg-name' will always refer to external package,
 795 -- and to use internal library you have to say 'this-pkg:pkg-name'.
 796 --
 797 -- In summary, In 3.4 and after, the internal names don't shadow,
 798 -- as there is an explicit syntax to refer to them,
 799 -- i.e. what you write is what you get;
 800 -- For pre-3.4 we post-process the file.
 801 --
 802 -- Similarly, we process mixins.
 803 -- See https://github.com/haskell/cabal/issues/6281
 804 --
 805
 806 postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription
 807 postProcessInternalDeps specVer gpd
 808   | specVer >= CabalSpecV3_4 = gpd
 809   | otherwise = transformAllBuildInfos transformBI transformSBI gpd
 810   where
 811     transformBI :: BuildInfo -> BuildInfo
 812     transformBI =
 813       over L.targetBuildDepends (concatMap transformD)
 814         . over L.mixins (map transformM)
 815
 816     transformSBI :: SetupBuildInfo -> SetupBuildInfo
 817     transformSBI = over L.setupDepends (concatMap transformD)
 818
 819     transformD :: Dependency -> [Dependency]
 820     transformD (Dependency pn vr ln)
 821       | uqn `Set.member` internalLibs
 822       , LMainLibName `NES.member` ln =
 823           case NES.delete LMainLibName ln of
 824             Nothing -> [dep]
 825             Just ln' -> [dep, Dependency pn vr ln']
 826       where
 827         uqn = packageNameToUnqualComponentName pn
 828         dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn))
 829     transformD d = [d]
 830
 831     transformM :: Mixin -> Mixin
 832     transformM (Mixin pn LMainLibName incl)
 833       | uqn `Set.member` internalLibs =
 834           mkMixin thisPn (LSubLibName uqn) incl
 835       where
 836         uqn = packageNameToUnqualComponentName pn
 837     transformM m = m
 838
 839     thisPn :: PackageName
 840     thisPn = pkgName (package (packageDescription gpd))
 841
 842     internalLibs :: Set UnqualComponentName
 843     internalLibs =
 844       Set.fromList
 845         [ n
 846         | (n, _) <- condSubLibraries gpd
 847         ]
 848
 849 -------------------------------------------------------------------------------
 850 -- Old syntax
 851 -------------------------------------------------------------------------------
 852
 853 -- TODO: move to own module
 854
 855 -- | "Sectionize" an old-style Cabal file.  A sectionized file has:
 856 --
 857 --  * all global fields at the beginning, followed by
 858 --
 859 --  * all flag declarations, followed by
 860 --
 861 --  * an optional library section, and an arbitrary number of executable
 862 --    sections (in any order).
 863 --
 864 -- The current implementation just gathers all library-specific fields
 865 -- in a library section and wraps all executable stanzas in an executable
 866 -- section.
 867 sectionizeFields :: [Field ann] -> (Syntax, [Field ann])
 868 sectionizeFields fs = case classifyFields fs of
 869   Just fields -> (OldSyntax, convert fields)
 870   Nothing -> (NewSyntax, fs)
 871   where
 872     -- return 'Just' if all fields are simple fields
 873     classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])]
 874     classifyFields = traverse f
 875       where
 876         f (Field name fieldlines) = Just (name, fieldlines)
 877         f _ = Nothing
 878
 879     trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse
 880     isSpace' = (== 32)
 881
 882     convert :: [(Name ann, [FieldLine ann])] -> [Field ann]
 883     convert fields =
 884       let
 885         toField (name, ls) = Field name ls
 886         -- "build-depends" is a local field now.  To be backwards
 887         -- compatible, we still allow it as a global field in old-style
 888         -- package description files and translate it to a local field by
 889         -- adding it to every non-empty section
 890         (hdr0, exes0) = break ((== "executable") . getName . fst) fields
 891         (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0
 892
 893         (deps, libfs) =
 894           partition
 895             ((== "build-depends") . getName . fst)
 896             libfs0
 897
 898         exes = unfoldr toExe exes0
 899         toExe [] = Nothing
 900         toExe ((Name pos n, ls) : r)
 901           | n == "executable" =
 902               let (efs, r') = break ((== "executable") . getName . fst) r
 903                in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')
 904         toExe _ = error "unexpected input to 'toExe'"
 905
 906         lib = case libfs of
 907           [] -> []
 908           ((Name pos _, _) : _) ->
 909             [Section (Name pos "library") [] (map toField $ deps ++ libfs)]
 910        in
 911         map toField hdr ++ lib ++ exes
 912
 913 -- | See 'sectionizeFields'.
 914 data Syntax = OldSyntax | NewSyntax
 915   deriving (Eq, Show)
 916
 917 -- TODO:
 918 libFieldNames :: [FieldName]
 919 libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName)
 920
 921 -------------------------------------------------------------------------------
 922 -- Supplementary build information
 923 -------------------------------------------------------------------------------
 924
 925 parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo
 926 parseHookedBuildInfo bs = case readFields' bs of
 927   Right (fs, lexWarnings) -> do
 928     parseHookedBuildInfo' lexWarnings fs
 929   -- TODO: better marshalling of errors
 930   Left perr -> parseFatalFailure zeroPos (show perr)
 931
 932 parseHookedBuildInfo'
 933   :: [LexWarning]
 934   -> [Field Position]
 935   -> ParseResult HookedBuildInfo
 936 parseHookedBuildInfo' lexWarnings fs = do
 937   parseWarnings (toPWarnings lexWarnings)
 938   (mLibFields, exes) <- stanzas fs
 939   mLib <- parseLib mLibFields
 940   biExes <- traverse parseExe exes
 941   return (mLib, biExes)
 942   where
 943     parseLib :: Fields Position -> ParseResult (Maybe BuildInfo)
 944     parseLib fields
 945       | Map.null fields = pure Nothing
 946       | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
 947
 948     parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo)
 949     parseExe (n, fields) = do
 950       bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
 951       pure (n, bi)
 952
 953     stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)])
 954     stanzas fields = do
 955       let (hdr0, exes0) = breakMaybe isExecutableField fields
 956       hdr <- toFields hdr0
 957       exes <- unfoldrM (traverse toExe) exes0
 958       pure (hdr, exes)
 959
 960     toFields :: [Field Position] -> ParseResult (Fields Position)
 961     toFields fields = do
 962       let (fields', ss) = partitionFields fields
 963       traverse_ (traverse_ warnInvalidSubsection) ss
 964       pure fields'
 965
 966     toExe
 967       :: ([FieldLine Position], [Field Position])
 968       -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position]))
 969     toExe (fss, fields) = do
 970       name <- runFieldParser zeroPos parsec cabalSpecLatest fss
 971       let (hdr0, rest) = breakMaybe isExecutableField fields
 972       hdr <- toFields hdr0
 973       pure ((name, hdr), rest)
 974
 975     isExecutableField (Field (Name _ name) fss)
 976       | name == "executable" = Just fss
 977       | otherwise = Nothing
 978     isExecutableField _ = Nothing
 979
 980 -------------------------------------------------------------------------------
 981 -- Scan of spec version
 982 -------------------------------------------------------------------------------
 983
 984 -- | Quickly scan new-style spec-version
 985 --
 986 -- A new-style spec-version declaration begins the .cabal file and
 987 -- follow the following case-insensitive grammar (expressed in
 988 -- RFC5234 ABNF):
 989 --
 990 -- @
 991 -- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS
 992 --
 993 -- spec-version               = NUM "." NUM [ "." NUM ]
 994 --
 995 -- NUM    = DIGIT0 / DIGITP 1*DIGIT0
 996 -- DIGIT0 = %x30-39
 997 -- DIGITP = %x31-39
 998 -- WS = %20
 999 -- @
1000 scanSpecVersion :: BS.ByteString -> Maybe Version
1001 scanSpecVersion bs = do
1002   fstline' : _ <- pure (BS8.lines bs)
1003
1004   -- parse <newstyle-spec-version-decl>
1005   -- normalise: remove all whitespace, convert to lower-case
1006   let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline'
1007   ["cabal-version", vers] <- pure (BS8.split ':' fstline)
1008
1009   -- parse <spec-version>
1010   --
1011   -- This is currently more tolerant regarding leading 0 digits.
1012   --
1013   ver <- simpleParsecBS vers
1014   guard $ case versionNumbers ver of
1015     [_, _] -> True
1016     [_, _, _] -> True
1017     _ -> False
1018
1019   pure ver
1020   where
1021     -- \| Translate ['A'..'Z'] to ['a'..'z']
1022     toLowerW8 :: Word8 -> Word8
1023     toLowerW8 w
1024       | 0x40 < w && w < 0x5b = w + 0x20
1025       | otherwise = w