From 82785686d93a18e78eb2411b7ee25309246c0b4e Mon Sep 17 00:00:00 2001
From: Kristen Kozak <grayjay@wordroute.com>
Date: Sat, 11 Nov 2017 17:38:04 -0800
Subject: [PATCH] Add Exe goal qualifier to solver DSL.
---
.../Distribution/Solver/Modular/DSL.hs | 12 +-
.../Solver/Modular/DSL/TestCaseUtils.hs | 16 +--
.../Solver/Modular/MemoryUsage.hs | 4 +-
.../Distribution/Solver/Modular/Solver.hs | 118 +++++++++---------
4 files changed, 78 insertions(+), 72 deletions(-)
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
index 376f835c85..ef4d956986 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
@@ -210,13 +210,17 @@ data ExampleVar =
| S ExampleQualifier ExamplePkgName OptionalStanza
data ExampleQualifier =
- None
- | Indep ExamplePkgName
- | Setup ExamplePkgName
+ QualNone
+ | QualIndep ExamplePkgName
+ | QualSetup ExamplePkgName
-- The two package names are the build target and the package containing the
-- setup script.
- | IndepSetup ExamplePkgName ExamplePkgName
+ | QualIndepSetup ExamplePkgName ExamplePkgName
+
+ -- The two package names are the package depending on the exe and the
+ -- package containing the exe.
+ | QualExe ExamplePkgName ExamplePkgName
-- | Whether to enable tests in all packages in a test case.
newtype EnableAllTests = EnableAllTests Bool
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
index 33fdbce40d..bc9fa32705 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
@@ -229,10 +229,12 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
toQPN q pn = P.Q pp (C.mkPackageName pn)
where
pp = case q of
- None -> P.PackagePath P.DefaultNamespace P.QualToplevel
- Indep p -> P.PackagePath (P.Independent $ C.mkPackageName p)
- P.QualToplevel
- Setup s -> P.PackagePath P.DefaultNamespace
- (P.QualSetup (C.mkPackageName s))
- IndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p)
- (P.QualSetup (C.mkPackageName s))
+ QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel
+ QualIndep p -> P.PackagePath (P.Independent $ C.mkPackageName p)
+ P.QualToplevel
+ QualSetup s -> P.PackagePath P.DefaultNamespace
+ (P.QualSetup (C.mkPackageName s))
+ QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p)
+ (P.QualSetup (C.mkPackageName s))
+ QualExe p1 p2 -> P.PackagePath P.DefaultNamespace
+ (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs
index df41cfe7c6..e953cb68eb 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs
@@ -59,7 +59,7 @@ flagsTest name =
flagName x = "flag-" ++ show x
orderedFlags :: [ExampleVar]
- orderedFlags = [F None "pkg" (flagName i) | i <- [1..n]]
+ orderedFlags = [F QualNone "pkg" (flagName i) | i <- [1..n]]
-- | Test for a space leak caused by sharing of search trees under packages with
-- link choices (issue #2899).
@@ -94,4 +94,4 @@ issue2899 name =
pkgName x = "pkg-" ++ show x
goals :: [ExampleVar]
- goals = [P None "setup-dep", P (Setup "target") "setup-dep"]
+ goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"]
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
index e9dd57e721..d19599997f 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
@@ -21,7 +21,7 @@ import Language.Haskell.Extension ( Extension(..)
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
-import Distribution.Solver.Types.PackagePath
+import qualified Distribution.Solver.Types.PackagePath as P
import UnitTests.Distribution.Solver.Modular.DSL
import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
@@ -71,34 +71,34 @@ tests = [
]
, testGroup "Qualified manual flag constraints" [
let name = "Top-level flag constraint does not constrain setup dep's flag"
- cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False]
+ cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $
solverSuccess [ ("A", 1), ("B", 1), ("B", 2)
, ("b-1-false-dep", 1), ("b-2-true-dep", 1) ]
, let name = "Solver can toggle setup dep's flag to match top-level constraint"
- cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False
+ cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False
, ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ]
in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $
solverSuccess [ ("A", 1), ("B", 1), ("B", 2)
, ("b-1-false-dep", 1), ("b-2-false-dep", 1) ]
, let name = "User can constrain flags separately with qualified constraints"
- cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" True
- , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ]
+ cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
+ , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]
in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $
solverSuccess [ ("A", 1), ("B", 1), ("B", 2)
, ("b-1-true-dep", 1), ("b-2-false-dep", 1) ]
-- Regression test for #4299
, let name = "Solver can link deps when only one has constrained manual flag"
- cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False]
+ cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $
solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ]
, let name = "Solver cannot link deps that have conflicting manual flag constraints"
- cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" True
- , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ]
+ cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
+ , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]
failureReason = "(constraint from unknown source requires opposite flag selection)"
checkFullLog lns =
all (\msg -> any (msg `isInfixOf`) lns)
@@ -180,8 +180,8 @@ tests = [
mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $
solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)]
- , let cs = [ ExVersionConstraint (ScopeQualified QualToplevel "D") $ mkVersionRange 1 4
- , ExVersionConstraint (ScopeQualified (QualSetup "B") "D") $ mkVersionRange 4 7
+ , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4
+ , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7
]
in runTest $ constraints cs $
mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $
@@ -482,10 +482,10 @@ testTestSuiteWithFlag name =
goals :: [ExampleVar]
goals = [
- P None "B"
- , P None "A"
- , F None "A" "flag"
- , S None "A" TestStanzas
+ P QualNone "B"
+ , P QualNone "A"
+ , F QualNone "A" "flag"
+ , S QualNone "A" TestStanzas
]
-- Packages with setup dependencies
@@ -673,9 +673,9 @@ testStanzaPreference name =
[ExAny "unknown-pkg2"]
[]]
goals = [
- P None "A"
- , F None "A" "flag"
- , S None "A" TestStanzas
+ P QualNone "A"
+ , F QualNone "A" "flag"
+ , S QualNone "A" TestStanzas
]
in runTest $ goalOrder goals $
preferences [ ExStanzaPref "A" [TestStanzas]] $
@@ -750,7 +750,7 @@ testCyclicDependencyErrorMessages name =
-- Solve for pkg-D and pkg-E last.
goals :: [ExampleVar]
- goals = [P None ("pkg-" ++ [c]) | c <- ['A'..'E']]
+ goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']]
-- | Check that the solver can backtrack after encountering the SIR (issue #2843)
--
@@ -810,14 +810,14 @@ testIndepGoals2 name =
goals :: [ExampleVar]
goals = [
- P (Indep "A") "A"
- , P (Indep "A") "C"
- , P (Indep "A") "D"
- , P (Indep "B") "B"
- , P (Indep "B") "C"
- , P (Indep "B") "D"
- , S (Indep "B") "B" TestStanzas
- , S (Indep "A") "A" TestStanzas
+ P (QualIndep "A") "A"
+ , P (QualIndep "A") "C"
+ , P (QualIndep "A") "D"
+ , P (QualIndep "B") "B"
+ , P (QualIndep "B") "C"
+ , P (QualIndep "B") "D"
+ , S (QualIndep "B") "B" TestStanzas
+ , S (QualIndep "A") "A" TestStanzas
]
-- | Issue #2834
@@ -894,16 +894,16 @@ testIndepGoals3 name =
goals :: [ExampleVar]
goals = [
- P (Indep "D") "D"
- , P (Indep "D") "C"
- , P (Indep "D") "A"
- , P (Indep "E") "E"
- , P (Indep "E") "C"
- , P (Indep "E") "B"
- , P (Indep "F") "F"
- , P (Indep "F") "B"
- , P (Indep "F") "C"
- , P (Indep "F") "A"
+ P (QualIndep "D") "D"
+ , P (QualIndep "D") "C"
+ , P (QualIndep "D") "A"
+ , P (QualIndep "E") "E"
+ , P (QualIndep "E") "C"
+ , P (QualIndep "E") "B"
+ , P (QualIndep "F") "F"
+ , P (QualIndep "F") "B"
+ , P (QualIndep "F") "C"
+ , P (QualIndep "F") "A"
]
-- | This test checks that the solver correctly backjumps when dependencies
@@ -936,15 +936,15 @@ testIndepGoals4 name =
goals :: [ExampleVar]
goals = [
- P (Indep "A") "A"
- , P (Indep "A") "E"
- , P (Indep "B") "B"
- , P (Indep "B") "D"
- , P (Indep "B") "E"
- , P (Indep "C") "C"
- , P (Indep "C") "D"
- , P (Indep "C") "E"
- , S (Indep "C") "C" TestStanzas
+ P (QualIndep "A") "A"
+ , P (QualIndep "A") "E"
+ , P (QualIndep "B") "B"
+ , P (QualIndep "B") "D"
+ , P (QualIndep "B") "E"
+ , P (QualIndep "C") "C"
+ , P (QualIndep "C") "D"
+ , P (QualIndep "C") "E"
+ , S (QualIndep "C") "C" TestStanzas
]
-- | Test the trace messages that we get when a package refers to an unknown pkg
@@ -1013,14 +1013,14 @@ testIndepGoals5 name fixGoalOrder =
goals :: [ExampleVar]
goals = [
- P (Indep "X") "X"
- , P (Indep "X") "A"
- , P (Indep "X") "B"
- , P (Indep "X") "C"
- , P (Indep "Y") "Y"
- , P (Indep "Y") "A"
- , P (Indep "Y") "B"
- , P (Indep "Y") "C"
+ P (QualIndep "X") "X"
+ , P (QualIndep "X") "A"
+ , P (QualIndep "X") "B"
+ , P (QualIndep "X") "C"
+ , P (QualIndep "Y") "Y"
+ , P (QualIndep "Y") "A"
+ , P (QualIndep "Y") "B"
+ , P (QualIndep "Y") "C"
]
-- | A simplified version of 'testIndepGoals5'.
@@ -1047,12 +1047,12 @@ testIndepGoals6 name fixGoalOrder =
goals :: [ExampleVar]
goals = [
- P (Indep "X") "X"
- , P (Indep "X") "A"
- , P (Indep "X") "B"
- , P (Indep "Y") "Y"
- , P (Indep "Y") "A"
- , P (Indep "Y") "B"
+ P (QualIndep "X") "X"
+ , P (QualIndep "X") "A"
+ , P (QualIndep "X") "B"
+ , P (QualIndep "Y") "Y"
+ , P (QualIndep "Y") "A"
+ , P (QualIndep "Y") "B"
]
dbExts1 :: ExampleDb
--
GitLab