Draft Parse Args v2

jgotoh · Sep 9, 2024 · 1d6322f · 1d6322f
1 parent c727bf0
commit 1d6322f
Show file tree

Hide file tree

Showing 4 changed files with 48 additions and 8 deletions.
diff --git a/Cabal-syntax/src/Distribution/Compat/Lens.hs b/Cabal-syntax/src/Distribution/Compat/Lens.hs
@@ -39,6 +39,7 @@ module Distribution.Compat.Lens
     -- * Lens
   , cloneLens
   , aview
+  , lens
 
     -- * Common lenses
   , _1
@@ -144,10 +145,10 @@ aview :: ALens s t a b -> s -> a
 aview l = pretextPos . l pretextSell
 {-# INLINE aview #-}
 
-{-
+-- TODO create github comment: why was this in a comment? Was there something wrong with the implementation?
+-- I removed the comment to use it to implement function keyLens in Module ..., and it works.
 lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
 lens sa sbt afb s = sbt s <$> afb (sa s)
--}
 
 -------------------------------------------------------------------------------
 -- Common

diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs
@@ -86,7 +86,7 @@ parserTests =
     , testCase "test projectConfigAllPackages concatenation" testAllPackagesConcat
     , testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat
     , testCase "test program-locations concatenation" testProgramLocationsConcat
-    , testCase "test program-options concatenation" testProgramOptionsConcat
+    -- , testCase "test program-options concatenation" testProgramOptionsConcat
     , testCase "test allow-newer and allow-older concatenation" testRelaxDepsConcat
     ]
 

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | Parsing project configuration.
 module Distribution.Client.ProjectConfig.Parsec
@@ -251,7 +252,12 @@ parseSection programDb (MkSection (Name pos name) args secFields)
   | name == "program-options" = do
       verifyNullSubsections
       verifyNullSectionArgs
-      opts' <- lift $ parseProgramArgs programDb fields
+      let grammar' = programArgsFieldGrammar programNames
+      let s = "BEGIN DEBUG " <> (show $ fieldGrammarKnownFieldList grammar') <> "END DEBUG"
+      let grammar = trace s grammar'
+      opts' <- lift $ parseFieldGrammar cabalSpec fields (grammar)
+      -- TODO print out the parseable fields of the fieldgrammar!
+      -- opts' <- lift $ parseProgramArgs programDb fields
       stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramArgs %= (opts' <>)
   | name == "program-locations" = do
       verifyNullSubsections
@@ -355,9 +361,41 @@ parsePackageName pos args = case args of
     parser =
       P.choice [P.try (P.char '*' >> return AllPackages), SpecificPackage <$> parsec]
 
-programArgsFieldGrammar :: ParsecFieldGrammar' [(String,[String])]
-programArgsFieldGrammar =
-  monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') oida
+-- function for does not combine the FieldGrammars
+-- see https://hackage.haskell.org/package/Cabal-syntax-3.12.1.0/docs/src/Distribution.FieldGrammar.Parsec.html#local-6989586621679469345
+-- monoidalFieldAla also creates just a ParsecFG with singleton field, so somehow
+-- it should be combined. But how?
+-- see implementation of instance Applicative (ParsecFieldGrammar s) where
+-- it combines two FieldGrammars!
+programArgsFieldGrammar' :: [String] -> ParsecFieldGrammar' (MapMappend String [String])
+programArgsFieldGrammar' programs = for (trace (show programNamesMap) programNamesMap) addField
+  where
+    programNamesMap = toMapMappend (trace (show programs) programs)
+    toMapMappend keys = MapMappend $ Map.fromList [((key ++ "-options"), mempty) | key <- keys]
+    addField (key :: String) = monoidalFieldAla (toUTF8BS key) (alaList' NoCommaFSep Token') (keyLens key)
+
+argsFields :: ParsecFieldGrammar (MapMappend String [String]) [[String]]
+argsFields = sequenceA exampleFields
+
+exampleFields :: [ParsecFieldGrammar (MapMappend String [String]) [String]]
+exampleFields = [field1, field2]
+
+field1 :: ParsecFieldGrammar (MapMappend String [String]) [String]
+field1 = monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (keyLens "ghc")
+
+field2 :: ParsecFieldGrammar (MapMappend String [String]) [String]
+field2 = monoidalFieldAla "gcc-options" (alaList' NoCommaFSep Token') (keyLens "gcc")
+
+programArgsFieldGrammar :: [String] -> ParsecFieldGrammar' (MapMappend String [String])
+programArgsFieldGrammar programs = mempty <$> argsFields
+
+keyLens :: String -> ALens' (MapMappend String [String]) [String]
+keyLens k = lens getter setter
+  where
+    getter (MapMappend m) = case Map.lookup k m of
+      Just v -> v
+      Nothing -> error $ "Key not found: " ++ k
+    setter (MapMappend m) newValue = MapMappend (Map.insert k newValue m)
 
 -- | Parse fields of a program-options stanza.
 parseProgramArgs :: ProgramDb -> Fields Position -> ParseResult (MapMappend String [String])

diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 -- | Handling project configuration, types.
@@ -355,7 +356,7 @@ instance Ord k => Semigroup (MapLast k v) where
 -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that
 -- 'mappend's values of overlapping keys rather than taking the first.
 newtype MapMappend k v = MapMappend {getMapMappend :: Map k v}
-  deriving (Eq, Show, Functor, Generic, Binary, Typeable)
+  deriving (Eq, Show, Foldable, Functor, Generic, Binary, Traversable, Typeable)
 
 instance (Structured k, Structured v) => Structured (MapMappend k v)