Add parsing of program-options stanza

Cabal-syntax/src/Distribution/Parsec.hs

@@ -14,6 +14,7 @@ module Distribution.Parsec
   , simpleParsecBS
   , simpleParsec'
   , simpleParsecW'
+  , explicitSimpleParsec
   , lexemeParsec
   , eitherParsec
   , explicitEitherParsec
@@ -212,6 +213,13 @@ simpleParsecW' spec =
     . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "<simpleParsec>"
     . fieldLineStreamFromString
 
+-- | Parse a 'String' with given 'ParsecParser'. Like 'explicitEitherParsec' but for 'Maybe'. Trailing whitespace is accepted.
+explicitSimpleParsec :: ParsecParser a -> String -> Maybe a
+explicitSimpleParsec parser =
+  either (const Nothing) Just
+    . runParsecParser (parser <* P.spaces) "<simpleParsec>"
+    . fieldLineStreamFromString
+
 -- | Parse a 'String' with 'lexemeParsec'.
 eitherParsec :: Parsec a => String -> Either String a
 eitherParsec = explicitEitherParsec parsec

cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs

@@ -32,8 +32,7 @@ projectConfigFieldGrammar source =
     <*> pure provenance
     <*> pure mempty
     -- \^ PackageConfig to be applied to all packages, specified inside 'package *' stanza
-    -- <*> blurFieldGrammar L.projectConfigLocalPackages packageConfigFieldGrammar
-    <*> pure mempty
+    <*> blurFieldGrammar L.projectConfigLocalPackages packageConfigFieldGrammar
     -- \^ PackageConfig to be applied to locally built packages, specified not inside a stanza
     <*> pure mempty
   where

cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs

@@ -13,34 +13,39 @@ module Distribution.Client.ProjectConfig.Parsec
   ) where
 
 import Control.Monad.State.Strict (StateT, execStateT, lift, modify)
+import qualified Data.Map.Strict as Map
 import Distribution.CabalSpecVersion
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Distribution.FieldGrammar
+import Distribution.FieldGrammar.Parsec (NamelessField (..), namelessFieldAnn)
 import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))
 
 -- TODO #6101 .Legacy -> ProjectConfigSkeleton should probably be moved here
 import Distribution.Client.ProjectConfig.FieldGrammar (projectConfigFieldGrammar)
 import Distribution.Client.ProjectConfig.Legacy (ProjectConfigImport, ProjectConfigSkeleton)
 import qualified Distribution.Client.ProjectConfig.Lens as L
-import Distribution.Client.ProjectConfig.Types (ProjectConfig (..))
+import Distribution.Client.ProjectConfig.Types (MapLast (..), MapMappend (..), PackageConfig (..), ProjectConfig (..))
 import Distribution.Client.Types.SourceRepo (SourceRepoList, sourceRepositoryPackageGrammar)
 import Distribution.Fields.ConfVar (parseConditionConfVar)
 import Distribution.Fields.ParseResult
 
 -- AST type
-import Distribution.Fields (Field, Name (..), readFields')
+import Distribution.Fields (Field, FieldLine, FieldName, Name (..), readFields')
 import Distribution.Fields.LexerMonad (LexWarning, toPWarnings)
 import Distribution.PackageDescription.Quirks (patchQuirks)
-import Distribution.Parsec (parsec, simpleParsecBS)
+import Distribution.Parsec (CabalParsing, ParsecParser, explicitSimpleParsec, parsec, parsecToken, simpleParsecBS)
 import Distribution.Parsec.Position (Position (..), zeroPos)
 import Distribution.Parsec.Warning (PWarnType (..))
+import Distribution.Simple.Program.Db (ProgramDb, knownPrograms, lookupKnownProgram)
+import Distribution.Simple.Program.Types (programName)
 import Distribution.Types.CondTree (CondBranch (..), CondTree (..))
 import Distribution.Types.ConfVar (ConfVar (..))
 import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8)
 
 import qualified Data.ByteString as BS
-import qualified Text.Parsec as P
+import qualified Distribution.Compat.CharParsing as P
+import qualified Text.Parsec
 
 -- | Preprocess file and start parsing
 parseProjectSkeleton :: FilePath -> BS.ByteString -> ParseResult ProjectConfigSkeleton
@@ -50,16 +55,17 @@ parseProjectSkeleton source bs = do
       parseWarnings (toPWarnings lexWarnings)
       for_ invalidUtf8 $ \pos ->
         parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos
-      parseCondTree source fs
+      parseCondTree programDb source fs
     Left perr -> parseFatalFailure pos (show perr)
       where
-        ppos = P.errorPos perr
-        pos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
+        ppos = Text.Parsec.errorPos perr
+        pos = Position (Text.Parsec.sourceLine ppos) (Text.Parsec.sourceColumn ppos)
   where
     invalidUtf8 = validateUTF8 bs
     bs' = case invalidUtf8 of
       Nothing -> bs
       Just _ -> toUTF8BS (fromUTF8BS bs)
+    programDb = undefined
 
 -- List of conditional blocks
 newtype Conditional ann = Conditional [Section ann]
@@ -72,17 +78,18 @@ partitionConditionals :: [[Section ann]] -> ([Section ann], [Conditional ann])
 partitionConditionals sections = (concat sections, [])
 
 parseCondTree
-  :: FilePath
+  :: ProgramDb
+  -> FilePath
   -> [Field Position]
   -> ParseResult ProjectConfigSkeleton
-parseCondTree source fields0 = do
-  -- sections are groups of sections between fields
+parseCondTree programDb source fields0 = do
+  -- sectionGroups are groups of sections between fields
   let (fs, sectionGroups) = partitionFields fields0
       (sections, conditionals) = partitionConditionals sectionGroups
       msg = show sectionGroups
   imports <- parseImports fs
-  config <- parseFieldGrammar cabalSpecLatest fs (projectConfigFieldGrammar source)
-  config' <- view stateConfig <$> execStateT (goSections sections) (SectionS config)
+  config <- parseFieldGrammar cabalSpec fs (projectConfigFieldGrammar source)
+  config' <- view stateConfig <$> execStateT (goSections programDb sections) (SectionS config)
   let configSkeleton = CondNode config' imports []
   -- TODO parse conditionals
   return configSkeleton
@@ -99,16 +106,23 @@ stateConfig :: Lens' SectionS ProjectConfig
 stateConfig f (SectionS cfg) = SectionS <$> f cfg
 {-# INLINEABLE stateConfig #-}
 
-goSections :: [Section Position] -> SectionParser ()
-goSections = traverse_ parseSection
+goSections :: ProgramDb -> [Section Position] -> SectionParser ()
+goSections programDb = traverse_ (parseSection programDb)
 
-parseSection :: Section Position -> SectionParser ()
-parseSection (MkSection (Name pos name) args secFields)
+parseSection :: ProgramDb -> Section Position -> SectionParser ()
+parseSection programDb (MkSection (Name pos name) args secFields)
   | name == "source-repository-package" = do
+      -- TODO implement syntaxError lineno "the section 'source-repository-package' takes no arguments"
       let (fields, secs) = partitionFields secFields
-      srp <- lift $ parseFieldGrammar cabalSpecLatest fields sourceRepositoryPackageGrammar
+      srp <- lift $ parseFieldGrammar cabalSpec fields sourceRepositoryPackageGrammar
       stateConfig . L.projectPackagesRepo %= (++ [srp])
       unless (null secs) (warnInvalidSubsection pos name)
+  | name == "program-options" = do
+      -- TODO implement syntaxError lineno "the section 'program-options' takes no arguments"
+      let (fields, secs) = partitionFields secFields
+      opts <- lift $ parseProgramArgs programDb fields
+      stateConfig . L.projectConfigLocalPackages %= (\lp -> lp{packageConfigProgramArgs = opts})
+      unless (null secs) (warnInvalidSubsection pos name)
   | otherwise = do
       warnInvalidSubsection pos name
 
@@ -117,3 +131,49 @@ warnInvalidSubsection pos name = lift $ parseWarning pos PWTInvalidSubsection $
 -- TODO implement, caution: check for cyclical imports
 parseImports :: Fields Position -> ParseResult [ProjectConfigImport]
 parseImports fs = return mempty
+
+-- | Parse fields of a program-options stanza.
+parseProgramArgs :: ProgramDb -> Fields Position -> ParseResult (MapMappend String [String])
+parseProgramArgs programDb fields = foldM foldField mempty (Map.toList fields)
+  where
+    foldField accum (fieldName, fieldValues) = do
+      case readProgramName programDb fieldName of
+        Nothing -> warnUnknownFields fieldName fieldValues >> return accum
+        Just program -> do
+          args <- parseProgramArgsField fieldName fieldValues
+          return $ accum <> (MapMappend $ Map.singleton program args)
+
+-- | Parse all arguments to a single program in program-options stanza.
+-- By processing '[NamelessField Position]', we support multiple occurrences of the field, concatenating the arguments.
+parseProgramArgsField :: FieldName -> [NamelessField Position] -> ParseResult ([String])
+parseProgramArgsField fieldName fieldValues =
+  concat <$> mapM (\(MkNamelessField pos lines') -> parseProgramArgsFieldLines pos lines') fieldValues
+
+-- | Parse all fieldLines of a single field occurrence in a program-options stanza.
+parseProgramArgsFieldLines :: Position -> [FieldLine Position] -> ParseResult [String]
+parseProgramArgsFieldLines pos = runFieldParser pos programArgsFieldParser cabalSpec
+
+programArgsFieldParser :: CabalParsing m => m [String]
+programArgsFieldParser = parseSep (Proxy :: Proxy FSep) parsecToken
+
+-- | Extract the program name of a <progname>-options field and check whether it is known in the 'ProgramDb'.
+readProgramName :: ProgramDb -> FieldName -> Maybe String
+readProgramName programDb fieldName =
+  parseProgramName fieldName >>= ((flip lookupKnownProgram) programDb) >>= pure . programName
+
+parseProgramName :: FieldName -> Maybe String
+parseProgramName fieldName = (explicitSimpleParsec parser name)
+  where
+    name = show fieldName
+    parser :: ParsecParser String
+    parser = P.manyTill P.anyChar (P.string "-options")
+
+-- | Issue a 'PWTUnknownField' warning at all occurrences of a field.
+warnUnknownFields :: FieldName -> [NamelessField Position] -> ParseResult ()
+warnUnknownFields fieldName fieldLines = for_ fieldLines (\field -> parseWarning (pos field) PWTUnknownField message)
+  where
+    message = "Unknown field: " ++ show fieldName
+    pos = namelessFieldAnn
+
+cabalSpec :: CabalSpecVersion
+cabalSpec = cabalSpecLatest