diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 83f63649125..4c6e31e5aaa 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -14,7 +14,6 @@ module Distribution.Parsec , simpleParsecBS , simpleParsec' , simpleParsecW' - , explicitSimpleParsec , lexemeParsec , eitherParsec , explicitEitherParsec @@ -213,13 +212,6 @@ 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/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index c06b60ef9ba..b20b4b26402 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -19,6 +19,7 @@ import Distribution.Compat.Lens import Distribution.Compat.Prelude import Distribution.FieldGrammar import Distribution.FieldGrammar.Parsec (NamelessField (..), namelessFieldAnn) +import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) -- TODO #6101 .Legacy -> ProjectConfigSkeleton should probably be moved here @@ -34,10 +35,10 @@ import Distribution.Fields.ParseResult import Distribution.Fields (Field, FieldLine, FieldName, Name (..), readFields') import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec (CabalParsing, ParsecParser, explicitSimpleParsec, parsec, parsecToken, simpleParsecBS) +import Distribution.Parsec (CabalParsing, ParsecParser, explicitEitherParsec, parsec, parsecFilePath, parsecToken, runParsecParser, simpleParsecBS) import Distribution.Parsec.Position (Position (..), zeroPos) import Distribution.Parsec.Warning (PWarnType (..)) -import Distribution.Simple.Program.Db (ProgramDb, knownPrograms, lookupKnownProgram) +import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram) import Distribution.Simple.Program.Types (programName) import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) import Distribution.Types.ConfVar (ConfVar (..)) @@ -65,7 +66,9 @@ parseProjectSkeleton source bs = do bs' = case invalidUtf8 of Nothing -> bs Just _ -> toUTF8BS (fromUTF8BS bs) - programDb = undefined + -- TODO the legacy parser uses 'defaultProgramDb' in programLocationsFieldDescrs programOptionsFieldDescrs to parse the + -- progname-options/-locations fields, so I used this too instead of parameterizing it. Is this okay? + programDb = defaultProgramDb -- List of conditional blocks newtype Conditional ann = Conditional [Section ann] @@ -113,18 +116,23 @@ 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 cabalSpec fields sourceRepositoryPackageGrammar stateConfig . L.projectPackagesRepo %= (++ [srp]) - unless (null secs) (warnInvalidSubsection pos name) + unless (null sections) (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) + unless (null sections) (warnInvalidSubsection pos name) + | name == "program-locations" = do + -- TODO implement syntaxError lineno "the section 'program-locations' takes no arguments" + opts <- lift $ parseProgramPaths programDb fields + stateConfig . L.projectConfigLocalPackages %= (\lp -> lp{packageConfigProgramPaths = opts}) + unless (null sections) (warnInvalidSubsection pos name) | otherwise = do warnInvalidSubsection pos name + where + (fields, sections) = partitionFields secFields warnInvalidSubsection pos name = lift $ parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name @@ -134,21 +142,45 @@ 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) +parseProgramArgs programDb fields = foldM parseField mempty (Map.toList fields) where - foldField accum (fieldName, fieldValues) = do - case readProgramName programDb fieldName of + parseField accum (fieldName, fieldValues) = do + case readProgramName "-options" programDb fieldName of Nothing -> warnUnknownFields fieldName fieldValues >> return accum Just program -> do - args <- parseProgramArgsField fieldName fieldValues + args <- parseProgramArgsField fieldValues return $ accum <> (MapMappend $ Map.singleton program args) +-- | Parse fields of a program-locations stanza. +parseProgramPaths :: ProgramDb -> Fields Position -> ParseResult (MapLast String FilePath) +parseProgramPaths programDb fields = foldM parseField mempty (Map.toList fields) + where + parseField accum (fieldName, fieldValues) = do + case readProgramName "-location" programDb fieldName of + Nothing -> warnUnknownFields fieldName fieldValues >> return accum + Just program -> do + fp <- parseProgramPathsField fieldValues + return $ accum <> (MapLast $ Map.singleton program fp) + -- | 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 = +parseProgramArgsField :: [NamelessField Position] -> ParseResult ([String]) +parseProgramArgsField fieldValues = concat <$> mapM (\(MkNamelessField pos lines') -> parseProgramArgsFieldLines pos lines') fieldValues +parseProgramPathsField :: [NamelessField Position] -> ParseResult (FilePath) +parseProgramPathsField fieldValues = case fieldValues of + (MkNamelessField pos lines') : _ -> runFieldParser pos parsecFilePath cabalSpec lines' + [] -> error "TODO investigate whether this is even possible" -- TODO create a test for field without value "ghc-location: " + -- example output for cabal-version without a value: + -- Errors encountered when parsing cabal file ./tmp.cabal: + -- tmp.cabal:1:1: error: + -- unexpected end of input + -- expecting white space, version digit (integral without leading zeroes), opening paren or operator + -- 1 | cabal-version: + -- | ^ + -- [] -> undefined + -- | 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 @@ -156,17 +188,20 @@ parseProgramArgsFieldLines pos = runFieldParser pos programArgsFieldParser cabal 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 +type FieldSuffix = String + +-- | Extract the program name of a field, allow it to have a suffix such as '-options' and check whether the 'ProgramDB' contains it. +readProgramName :: FieldSuffix -> ProgramDb -> FieldName -> Maybe String +readProgramName suffix programDb fieldName = + parseProgramName suffix fieldName >>= ((flip lookupKnownProgram) programDb) >>= pure . programName -parseProgramName :: FieldName -> Maybe String -parseProgramName fieldName = (explicitSimpleParsec parser name) +parseProgramName :: FieldSuffix -> FieldName -> Maybe String +parseProgramName suffix fieldName = case runParsecParser parser' "" fieldNameStream of + Left err -> trace (show err) Nothing -- TODO should parseWarning Unknown Field fieldName + Right str -> Just str where - name = show fieldName - parser :: ParsecParser String - parser = P.manyTill P.anyChar (P.string "-options") + parser' = P.manyTill P.anyChar (P.try ((P.string suffix)) <* P.eof) + fieldNameStream = fieldLineStreamFromBS fieldName -- | Issue a 'PWTUnknownField' warning at all occurrences of a field. warnUnknownFields :: FieldName -> [NamelessField Position] -> ParseResult ()