diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 4c6e31e5aaa..83f63649125 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/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) "" . 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) "" + . fieldLineStreamFromString + -- | Parse a 'String' with 'lexemeParsec'. eitherParsec :: Parsec a => String -> Either String a eitherParsec = explicitEitherParsec parsec diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index c176e6ce890..f7d49e8bfe3 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 2d882285bd8..c06b60ef9ba 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/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 -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