Revert "Not so pretty Thing to make tests pass"

This reverts commit 71e521a.
haskell · Mar 5, 2024 · b3b1ff3 · b3b1ff3
1 parent 71e521a
commit b3b1ff3
Show file tree

Hide file tree

Showing 4 changed files with 53 additions and 69 deletions.
diff --git 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
+-- >>> 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
@@ -9,7 +9,6 @@ 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
@@ -47,11 +47,8 @@ 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 ()
@@ -87,7 +84,6 @@ 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
@@ -827,7 +823,7 @@ exResolve
   -> OnlyConstrained
   -> EnableBackjumping
   -> SolveExecutables
-  -> Maybe [ExampleVar]
+  -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
   -> [ExConstraint]
   -> [ExPreference]
   -> C.Verbosity
@@ -872,28 +868,13 @@ exResolve
           }
       enableTests
         | asBool enableAllTests =
-            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)
+            fmap
+              ( \p ->
+                  PackageConstraint
+                    (scopeToplevel (C.mkPackageName p))
+                    (PackagePropertyStanzas [TestStanzas])
+              )
+              (exDbPkgs db)
         | otherwise = []
       targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets
       params =
@@ -911,7 +892,7 @@ exResolve
                               setOnlyConstrained onlyConstrained $
                                 setEnableBackjumping enableBj $
                                   setSolveExecutables solveExes $
-                                    setGoalOrder (sortedGoalsToSortOrder <$> goalOrder) $
+                                    setGoalOrder goalOrder $
                                       setSolverVerbosity verbosity $
                                         standardInstallPolicy instIdx avaiIdx targets'
       toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
@@ -951,41 +932,3 @@ 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
@@ -33,19 +33,25 @@ 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
 
@@ -257,7 +263,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
             testOnlyConstrained
             testEnableBackjumping
             testSolveExecutables
-            testGoalOrder
+            (sortGoals <$> testGoalOrder)
             testConstraints
             testSoftConstraints
             testVerbosity
@@ -283,3 +289,39 @@ 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