Add parsing of program-options and -locations

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) "<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/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,39 +142,66 @@ 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
 
 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
+type FieldSuffix = String
+
+-- | Extract the program name of a <progname> 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' "<parseProgramName>" 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 ()