From 0bcb7d4f86fad4ce5b12c9ebbe461f43bc605029 Mon Sep 17 00:00:00 2001 From: jgotoh <18658140+jgotoh@users.noreply.github.com> Date: Thu, 22 Aug 2024 22:24:24 +0200 Subject: [PATCH] Add monoidal parsing of AllowNewer and AllowOlder --- .../parser-tests/Tests/ParserTests.hs | 26 ++++++++++ .../files/relax-deps-concat/cabal.project | 7 +++ .../Client/ProjectConfig/FieldGrammar.hs | 4 +- .../src/Distribution/Client/Utils/Newtypes.hs | 47 ++++++++++++++----- 4 files changed, 70 insertions(+), 14 deletions(-) create mode 100644 cabal-install/parser-tests/Tests/files/relax-deps-concat/cabal.project diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index fe00940a711..06d3f8ebf45 100644 --- 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 new file mode 100644 index 00000000000..8e328432b64 --- /dev/null +++ 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 index ab30818d2cf..fd5bd2fec90 100644 --- 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 index 69db368d048..976c08c1d1b 100644 --- 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