diff --git a/Cabal-syntax/src/Distribution/Compat/Lens.hs b/Cabal-syntax/src/Distribution/Compat/Lens.hs index d31c9198889..92a1156ad29 100644 --- 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 index 9eaea4c1d0a..5ccae31e3da 100644 --- 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 index e6299a72f2b..1d60474b7ad 100644 --- 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,6 +252,11 @@ parseSection programDb (MkSection (Name pos name) args secFields) | name == "program-options" = do verifyNullSubsections verifyNullSectionArgs + 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 @@ -355,9 +361,49 @@ 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 <$> (sequenceA $ programArgsFields programs) + +programArgsFields :: [String] -> [ParsecFieldGrammar (MapMappend String [String]) [String]] +programArgsFields programs = addField <$> programs + +addField :: String -> ParsecFieldGrammar (MapMappend String [String]) [String] +addField key = monoidalFieldAla (toUTF8BS (key ++ "-options")) (alaList' NoCommaFSep Token') (keyLens key) + + -- programFieldNames = (<> "-options") <$> programs + +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 index a6b7e752725..6c80878728e 100644 --- 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)