From 71e521aeaaa4cd19b70356bc583228972ad06d0b Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Mon, 4 Mar 2024 17:38:24 +0000 Subject: [PATCH] Not so pretty Thing to make tests pass --- .../Distribution/Solver/Modular/Message.hs | 2 +- .../Solver/Types/LabeledPackageConstraint.hs | 1 + .../Distribution/Solver/Modular/DSL.hs | 75 ++++++++++++++++--- .../Solver/Modular/DSL/TestCaseUtils.hs | 44 +---------- 4 files changed, 69 insertions(+), 53 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index ec188b14cde..b76f36011b3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -359,4 +359,4 @@ showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = -- >>> let v0 = POption (I (mkVersion [0]) InRepo) Nothing -- >>> let v1 = POption (I (mkVersion [1]) InRepo) Nothing -- >>> let i0 = POption (I (mkVersion [0]) (Inst $ mkUnitId "foo-bar-0-inplace")) Nothing --- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing \ No newline at end of file +-- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing diff --git a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs index 8715e46fd22..aa756ea9185 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs @@ -9,6 +9,7 @@ import Distribution.Solver.Types.PackageConstraint -- | 'PackageConstraint' labeled with its source. data LabeledPackageConstraint = LabeledPackageConstraint PackageConstraint ConstraintSource + deriving Show unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 812d7e81800..5014fdad161 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -47,8 +47,11 @@ module UnitTests.Distribution.Solver.Modular.DSL , runProgress , mkSimpleVersion , mkVersionRange + , exQualToQPN + , sortedGoalsToSortOrder ) where +import Data.List (elemIndex) import Distribution.Solver.Compat.Prelude import Distribution.Utils.Generic import Prelude () @@ -84,6 +87,7 @@ import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan import Distribution.Client.Types import Distribution.Solver.Types.ComponentDeps (ComponentDeps) +import qualified Distribution.Solver.Types.ComponentDeps as C import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag @@ -823,7 +827,7 @@ exResolve -> OnlyConstrained -> EnableBackjumping -> SolveExecutables - -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) + -> Maybe [ExampleVar] -> [ExConstraint] -> [ExPreference] -> C.Verbosity @@ -868,13 +872,28 @@ exResolve } enableTests | asBool enableAllTests = - fmap - ( \p -> - PackageConstraint - (scopeToplevel (C.mkPackageName p)) - (PackagePropertyStanzas [TestStanzas]) - ) - (exDbPkgs db) + nub $ + -- We need to traverse the explicit goals and introduce the tests for each in the corresponding scope, + -- because some may be qualified and simply introducing them at the top-level would not be correct + map + ( \var -> + PackageConstraint + ( case case var of + P qual pkgname -> exQualToQPN qual pkgname + F qual pkgname _ -> exQualToQPN qual pkgname + S qual pkgname _ -> exQualToQPN qual pkgname of + P.Q (P.PackagePath ns ql) pkgname -> ScopeQualified ns ql pkgname + ) + (PackagePropertyStanzas [TestStanzas]) + ) + (fromMaybe [] goalOrder) + <> fmap + ( \p -> + PackageConstraint + (scopeToplevel (C.mkPackageName p)) + (PackagePropertyStanzas [TestStanzas]) + ) + (exDbPkgs db) | otherwise = [] targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets params = @@ -892,7 +911,7 @@ exResolve setOnlyConstrained onlyConstrained $ setEnableBackjumping enableBj $ setSolveExecutables solveExes $ - setGoalOrder goalOrder $ + setGoalOrder (sortedGoalsToSortOrder <$> goalOrder) $ setSolverVerbosity verbosity $ standardInstallPolicy instIdx avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown @@ -932,3 +951,41 @@ runProgress = go go (Step s p) = let (ss, result) = go p in (s : ss, result) go (Fail e) = ([], Left e) go (Done a) = ([], Right a) + +exQualToQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN +exQualToQPN q pn = P.Q pp (C.mkPackageName pn) + where + pp = case q of + QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel + QualIndep p -> + P.PackagePath + (P.Independent $ C.mkPackageName p) + P.QualToplevel + QualSetup s -> + P.PackagePath + (P.IndependentComponent (C.mkPackageName s) C.ComponentSetup) + (P.QualToplevel) + QualExe p1 p2 -> + P.PackagePath + (P.IndependentBuildTool (C.mkPackageName p1) (C.mkPackageName p2)) + P.QualToplevel + +sortedGoalsToSortOrder :: [ExampleVar] -> Variable P.QPN -> Variable P.QPN -> Ordering +sortedGoalsToSortOrder = sortGoals where + sortGoals + :: [ExampleVar] + -> Variable P.QPN + -> Variable P.QPN + -> Ordering + sortGoals = orderFromList . map toVariable + + -- Sort elements in the list ahead of elements not in the list. Otherwise, + -- follow the order in the list. + orderFromList :: Eq a => [a] -> a -> a -> Ordering + orderFromList xs = + comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) + + toVariable :: ExampleVar -> Variable P.QPN + toVariable (P q pn) = PackageVar (exQualToQPN q pn) + toVariable (F q pn fn) = FlagVar (exQualToQPN q pn) (C.mkFlagName fn) + toVariable (S q pn stanza) = StanzaVar (exQualToQPN q pn) stanza 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 6bec16ea5e1..398143dbfe6 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -33,25 +33,19 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils import Distribution.Solver.Compat.Prelude import Prelude () -import Data.List (elemIndex) - -- test-framework import Test.Tasty as TF import Test.Tasty.HUnit (assertBool, assertEqual, testCase) -- Cabal -import qualified Distribution.PackageDescription as C import Distribution.Verbosity import Language.Haskell.Extension (Extension (..), Language (..)) -- cabal-install import Distribution.Client.Dependency (foldProgress) -import qualified Distribution.Solver.Types.ComponentDeps as C -import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList) import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.Variable import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Options @@ -263,7 +257,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> testOnlyConstrained testEnableBackjumping testSolveExecutables - (sortGoals <$> testGoalOrder) + testGoalOrder testConstraints testSoftConstraints testVerbosity @@ -289,39 +283,3 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> case resultErrorMsgPredicateOrPlan result of Left f -> f msg Right _ -> False - - sortGoals - :: [ExampleVar] - -> Variable P.QPN - -> Variable P.QPN - -> Ordering - sortGoals = orderFromList . map toVariable - - -- Sort elements in the list ahead of elements not in the list. Otherwise, - -- follow the order in the list. - orderFromList :: Eq a => [a] -> a -> a -> Ordering - orderFromList xs = - comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) - - toVariable :: ExampleVar -> Variable P.QPN - toVariable (P q pn) = PackageVar (toQPN q pn) - toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) - toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza - - toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN - toQPN q pn = P.Q pp (C.mkPackageName pn) - where - pp = case q of - QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel - QualIndep p -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - P.QualToplevel - QualSetup s -> - P.PackagePath - (P.IndependentComponent (C.mkPackageName s) C.ComponentSetup) - (P.QualToplevel) - QualExe p1 p2 -> - P.PackagePath - (P.IndependentBuildTool (C.mkPackageName p1) (C.mkPackageName p2)) - P.QualToplevel