Add monoidal parsing of AllowNewer and AllowOlder

jgotoh · Aug 22, 2024 · 0bcb7d4 · 0bcb7d4
1 parent 98a7a72
commit 0bcb7d4
Show file tree

Hide file tree

Showing 4 changed files with 70 additions and 14 deletions.
diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs
@@ -87,6 +87,7 @@ parserTests =
     , testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat
     , testCase "test program-locations concatenation" testProgramLocationsConcat
     , testCase "test program-options concatenation" testProgramOptionsConcat
+    , testCase "test allow-newer and allow-older concatenation" testRelaxDepsConcat
     ]
 
 testPackages :: Assertion
@@ -470,6 +471,31 @@ testProgramOptionsConcat = do
         { packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-threaded", "-Wall", "-fno-state-hack"]), ("gcc", ["-baz", "-foo", "-bar"])]
         }
 
+testRelaxDepsConcat :: Assertion
+testRelaxDepsConcat = do
+  (config, legacy) <- readConfigDefault "relax-deps-concat"
+  assertConfigEquals expectedAllowNewer config legacy (projectConfigAllowNewer . projectConfigShared . condTreeData)
+  assertConfigEquals expectedAllowOlder config legacy (projectConfigAllowOlder . projectConfigShared . condTreeData)
+  where
+    expectedAllowNewer :: Maybe AllowNewer
+    expectedAllowNewer =
+      pure $
+        AllowNewer $
+          RelaxDepsSome
+            [ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "cassava") (mkVersion [0, 5, 2, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))
+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))
+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "template-haskell"))
+            ]
+    expectedAllowOlder :: Maybe AllowOlder
+    expectedAllowOlder =
+      pure $
+        AllowOlder $
+          RelaxDepsSome
+            [ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "mtl") (mkVersion [2, 3, 1]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))
+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "aeson") (mkVersion [2, 2, 3, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "bytestring"))
+            , RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "containers") (mkVersion [0, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "array"))
+            ]
+
 -------------------------------------------------------------------------------
 -- Test Utilities
 -------------------------------------------------------------------------------

diff --git a/cabal-install/parser-tests/Tests/files/relax-deps-concat/cabal.project b/cabal-install/parser-tests/Tests/files/relax-deps-concat/cabal.project
@@ -0,0 +1,7 @@
+-- allow-newer: parallel-3.2.2.0:base
+allow-newer: cassava-0.5.2.0:base
+allow-newer: vector-th-unbox-0.2.1.7:base
+allow-newer: vector-th-unbox-0.2.1.7:template-haskell
+
+allow-older: mtl-2.3.1:base, aeson-2.2.3.0:bytestring
+allow-older: containers-0.7:array
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs
@@ -90,8 +90,8 @@ projectConfigSharedFieldGrammar source =
     <*> monoidalFieldAla "preferences" formatPackageVersionConstraints L.projectConfigPreferences
     <*> optionalFieldDef "cabal-lib-version" L.projectConfigCabalVersion mempty
     <*> optionalFieldDef "solver" L.projectConfigSolver mempty
-    <*> optionalField "allow-older" L.projectConfigAllowOlder
-    <*> optionalField "allow-newer" L.projectConfigAllowNewer
+    <*> monoidalFieldAla "allow-older" AllowOlderNT L.projectConfigAllowOlder
+    <*> monoidalFieldAla "allow-newer" AllowNewerNT L.projectConfigAllowNewer
     <*> optionalFieldDef "write-ghc-environment-files" L.projectConfigWriteGhcEnvironmentFilesPolicy mempty
     <*> optionalFieldDefAla "max-backjumps" (alaFlag MaxBackjumps) L.projectConfigMaxBackjumps mempty
     <*> optionalFieldDef "reorder-goals" L.projectConfigReorderGoals mempty

diff --git a/cabal-install/src/Distribution/Client/Utils/Newtypes.hs b/cabal-install/src/Distribution/Client/Utils/Newtypes.hs
@@ -6,6 +6,8 @@
 module Distribution.Client.Utils.Newtypes
   ( NumJobs (..)
   , PackageDBNT (..)
+  , AllowNewerNT (..)
+  , AllowOlderNT (..)
   , ProjectConstraints (..)
   , MaxBackjumps (..)
   , URI_NT (..)
@@ -15,6 +17,7 @@ where
 
 import Distribution.Client.Compat.Prelude
 import Distribution.Client.Targets (UserConstraint)
+import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..))
 import Distribution.Compat.CharParsing
 import Distribution.Compat.Newtype
 import Distribution.Parsec
@@ -39,6 +42,18 @@ instance Newtype (Maybe Int) NumJobs
 instance Parsec NumJobs where
   parsec = parsecNumJobs
 
+parsecNumJobs :: CabalParsing m => m NumJobs
+parsecNumJobs = ncpus <|> numJobs
+  where
+    ncpus = string "$ncpus" >> return (NumJobs Nothing)
+    numJobs = do
+      num <- integral
+      if num < (1 :: Int)
+        then do
+          parsecWarning PWTOther "The number of jobs should be 1 or more."
+          return (NumJobs Nothing)
+        else return (NumJobs $ Just num)
+
 newtype URI_NT = URI_NT {getURI_NT :: URI}
 
 instance Newtype (URI) URI_NT
@@ -60,18 +75,6 @@ instance Newtype Int KeyThreshold
 instance Parsec KeyThreshold where
   parsec = KeyThreshold <$> integral
 
-parsecNumJobs :: CabalParsing m => m NumJobs
-parsecNumJobs = ncpus <|> numJobs
-  where
-    ncpus = string "$ncpus" >> return (NumJobs Nothing)
-    numJobs = do
-      num <- integral
-      if num < (1 :: Int)
-        then do
-          parsecWarning PWTOther "The number of jobs should be 1 or more."
-          return (NumJobs Nothing)
-        else return (NumJobs $ Just num)
-
 newtype ProjectConstraints = ProjectConstraints {getProjectConstraints :: (UserConstraint, ConstraintSource)}
 
 instance Newtype (UserConstraint, ConstraintSource) ProjectConstraints
@@ -95,3 +98,23 @@ instance Parsec MaxBackjumps where
 
 parseMaxBackjumps :: CabalParsing m => m MaxBackjumps
 parseMaxBackjumps = MaxBackjumps <$> integral
+
+newtype AllowNewerNT = AllowNewerNT {getAllowNewerNT :: Maybe AllowNewer}
+
+instance Newtype (Maybe AllowNewer) AllowNewerNT
+
+instance Parsec AllowNewerNT where
+  parsec = parsecAllowNewer
+
+parsecAllowNewer :: CabalParsing m => m AllowNewerNT
+parsecAllowNewer = AllowNewerNT . Just <$> parsec
+
+newtype AllowOlderNT = AllowOlderNT {getAllowOlderNT :: Maybe AllowOlder}
+
+instance Newtype (Maybe AllowOlder) AllowOlderNT
+
+instance Parsec AllowOlderNT where
+  parsec = parsecAllowOlder
+
+parsecAllowOlder :: CabalParsing m => m AllowOlderNT
+parsecAllowOlder = AllowOlderNT . Just <$> parsec