From c4ef63f74f3c894f50e404aa6c05de0543004d06 Mon Sep 17 00:00:00 2001
From: jgotoh <18658140+jgotoh@users.noreply.github.com>
Date: Thu, 25 Jan 2024 14:00:23 +0100
Subject: [PATCH] Parsing PackageConfig for AllPackages and Specific

---
 .../Client/ProjectConfig/FieldGrammar.hs      |  1 +
 .../Client/ProjectConfig/Parsec.hs            | 39 ++++++++++++++++---
 2 files changed, 35 insertions(+), 5 deletions(-)

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs
index 249f09a2f32..e884a916b8b 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs
@@ -3,6 +3,7 @@
 -- | 'ProjectConfig' Field descriptions
 module Distribution.Client.ProjectConfig.FieldGrammar
   ( projectConfigFieldGrammar
+  , packageConfigFieldGrammar
   ) where
 
 import qualified Data.Set as Set
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
index 7815712ce02..bc6e6402043 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
@@ -23,7 +23,7 @@ import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
 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.FieldGrammar (packageConfigFieldGrammar, projectConfigFieldGrammar)
 import Distribution.Client.ProjectConfig.Legacy (ProjectConfigImport, ProjectConfigSkeleton)
 import qualified Distribution.Client.ProjectConfig.Lens as L
 import Distribution.Client.ProjectConfig.Types (MapLast (..), MapMappend (..), PackageConfig (..), ProjectConfig (..))
@@ -32,16 +32,17 @@ import Distribution.Fields.ConfVar (parseConditionConfVar)
 import Distribution.Fields.ParseResult
 
 -- AST type
-import Distribution.Fields (Field, FieldLine, FieldName, Name (..), readFields')
+import Distribution.Fields (Field, FieldLine, FieldName, Name (..), SectionArg (..), readFields')
 import Distribution.Fields.LexerMonad (LexWarning, toPWarnings)
 import Distribution.PackageDescription.Quirks (patchQuirks)
-import Distribution.Parsec (CabalParsing, ParsecParser, explicitEitherParsec, parsec, parsecFilePath, parsecToken, runParsecParser, simpleParsecBS)
+import Distribution.Parsec (CabalParsing, ParsecParser, explicitEitherParsec, parsec, parsecFilePath, parsecToken, runParsecParser, simpleParsec, simpleParsecBS)
 import Distribution.Parsec.Position (Position (..), zeroPos)
 import Distribution.Parsec.Warning (PWarnType (..))
 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 (..))
+import Distribution.Types.PackageName (PackageName)
 import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8)
 
 import qualified Data.ByteString as BS
@@ -129,11 +130,39 @@ parseSection programDb (MkSection (Name pos name) args secFields)
       opts <- lift $ parseProgramPaths programDb fields
       stateConfig . L.projectConfigLocalPackages %= (\lp -> lp{packageConfigProgramPaths = opts})
       unless (null sections) (warnInvalidSubsection pos name)
+  | name == "package" = do
+      package <- lift $ parsePackageName pos args
+      case package of
+        Just AllPackages -> do
+          pkgCfg <- lift $ parseFieldGrammar cabalSpec fields packageConfigFieldGrammar
+          stateConfig . L.projectConfigAllPackages .= pkgCfg
+        Just (SpecificPackage packageName) -> do
+          pkgCfg <- lift $ parseFieldGrammar cabalSpec fields packageConfigFieldGrammar
+          stateConfig . L.projectConfigSpecificPackage %= (\spcs -> spcs <> (MapMappend $ Map.singleton packageName pkgCfg))
+        Nothing -> return ()
+      unless (null sections) (warnInvalidSubsection pos name)
   | otherwise = do
       warnInvalidSubsection pos name
   where
     (fields, sections) = partitionFields secFields
 
+data PackageConfigTarget = AllPackages | SpecificPackage PackageName
+
+-- TODO what happens when package * is used more than once? maybe emit "warning, not more than once?" what happens atm?
+parsePackageName :: Position -> [SectionArg Position] -> ParseResult (Maybe PackageConfigTarget)
+parsePackageName pos args = case args of
+  [SecArgName _ secName] -> parseName secName
+  [SecArgStr _ secName] -> parseName secName
+  _ -> do
+    parseWarning pos PWTUnknownSection "target package name or * required"
+    return Nothing
+  where
+    parseName secName = case runParsecParser parser "<parsePackageName>" (fieldLineStreamFromBS secName) of
+      Left _ -> return Nothing
+      Right cfgTarget -> return $ pure cfgTarget
+    parser :: ParsecParser PackageConfigTarget
+    parser = P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec] -- parse * or parsec :: m PackageName
+
 warnInvalidSubsection pos name = lift $ parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
 
 -- TODO implement, caution: check for cyclical imports
@@ -196,11 +225,11 @@ readProgramName suffix programDb fieldName =
   parseProgramName suffix fieldName >>= ((flip lookupKnownProgram) programDb) >>= pure . programName
 
 parseProgramName :: FieldSuffix -> FieldName -> Maybe String
-parseProgramName suffix fieldName = case runParsecParser parser' "<parseProgramName>" fieldNameStream of
+parseProgramName suffix fieldName = case runParsecParser parser "<parseProgramName>" fieldNameStream of
   Left _ -> Nothing
   Right str -> Just str
   where
-    parser' = P.manyTill P.anyChar (P.try ((P.string suffix)) <* P.eof)
+    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.