Add monoidField[Parsec] helpers

haskell · Feb 25, 2025 · 4a16b1b · 4a16b1b
1 parent facd40f
commit 4a16b1b
Show file tree

Hide file tree

Showing 2 changed files with 31 additions and 2 deletions.
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -1563,12 +1563,12 @@ legacyPackageConfigFieldDescrs =
             parseTokenQ
             configConfigureArgs
             (\v conf -> conf{configConfigureArgs = v})
-        , simpleFieldParsec
+        , monoidFieldParsec
             "flags"
             dispFlagAssignment
             parsecFlagAssignment
             configConfigurationsFlags
-            (\v conf -> conf{configConfigurationsFlags = configConfigurationsFlags conf <> v})
+            (\v conf -> conf{configConfigurationsFlags = v})
         , overrideDumpBuildInfo
         ]
       . filterFields

diff --git a/cabal-install/src/Distribution/Deprecated/ParseUtils.hs b/cabal-install/src/Distribution/Deprecated/ParseUtils.hs
@@ -44,6 +44,7 @@ module Distribution.Deprecated.ParseUtils
   , showFreeText
   , field
   , simpleField
+  , monoidField
   , listField
   , listFieldWithSep
   , spaceListField
@@ -52,6 +53,7 @@ module Distribution.Deprecated.ParseUtils
   , readPToMaybe
   , fieldParsec
   , simpleFieldParsec
+  , monoidFieldParsec
   , listFieldParsec
   , commaListFieldParsec
   , commaNewLineListFieldParsec
@@ -254,6 +256,33 @@ simpleFieldParsec
 simpleFieldParsec name showF readF get set =
   liftField get set $ fieldParsec name showF readF
 
+monoidField
+  :: Semigroup a
+  => String
+  -> (a -> Doc)
+  -> ReadP a a
+  -> (b -> a)
+  -> (a -> b -> b)
+  -> FieldDescr b
+monoidField name showF readF get set =
+  liftField get set' $ field name showF readF
+  where
+    set' xs b = set (get b <> xs) b
+
+monoidFieldParsec
+  :: Semigroup a
+  => String
+  -> (a -> Doc)
+  -> ParsecParser a
+  -> (b -> a)
+  -> (a -> b -> b)
+  -> FieldDescr b
+monoidFieldParsec name showF readF get set =
+  liftField get set' $ fieldParsec name showF readF
+  where
+    set' xs b = set (get b <> xs) b
+
+
 commaListFieldWithSepParsec
   :: Separator
   -> String