Skip to content

Commit 71e521a

Browse files
alt-romesalt-romes
committed
Not so pretty Thing to make tests pass
1 parent c61fb54 commit 71e521a

File tree

4 files changed

+69
-53
lines changed

4 files changed

+69
-53
lines changed

‎cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -359,4 +359,4 @@ showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
359359
-- >>> let v0 = POption (I (mkVersion [0]) InRepo) Nothing
360360
-- >>> let v1 = POption (I (mkVersion [1]) InRepo) Nothing
361361
-- >>> let i0 = POption (I (mkVersion [0]) (Inst $ mkUnitId "foo-bar-0-inplace")) Nothing
362-
-- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing
362+
-- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing

‎cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import Distribution.Solver.Types.PackageConstraint
99
-- | 'PackageConstraint' labeled with its source.
1010
data LabeledPackageConstraint
1111
= LabeledPackageConstraint PackageConstraint ConstraintSource
12+
deriving Show
1213

1314
unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint
1415
unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc

‎cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

Lines changed: 66 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -47,8 +47,11 @@ module UnitTests.Distribution.Solver.Modular.DSL
4747
, runProgress
4848
, mkSimpleVersion
4949
, mkVersionRange
50+
, exQualToQPN
51+
, sortedGoalsToSortOrder
5052
) where
5153

54+
import Data.List (elemIndex)
5255
import Distribution.Solver.Compat.Prelude
5356
import Distribution.Utils.Generic
5457
import Prelude ()
@@ -84,6 +87,7 @@ import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan
8487
import Distribution.Client.Types
8588

8689
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
90+
import qualified Distribution.Solver.Types.ComponentDeps as C
8791
import qualified Distribution.Solver.Types.ComponentDeps as CD
8892
import Distribution.Solver.Types.ConstraintSource
8993
import Distribution.Solver.Types.Flag
@@ -823,7 +827,7 @@ exResolve
823827
-> OnlyConstrained
824828
-> EnableBackjumping
825829
-> SolveExecutables
826-
-> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
830+
-> Maybe [ExampleVar]
827831
-> [ExConstraint]
828832
-> [ExPreference]
829833
-> C.Verbosity
@@ -868,13 +872,28 @@ exResolve
868872
}
869873
enableTests
870874
| asBool enableAllTests =
871-
fmap
872-
( \p ->
873-
PackageConstraint
874-
(scopeToplevel (C.mkPackageName p))
875-
(PackagePropertyStanzas [TestStanzas])
876-
)
877-
(exDbPkgs db)
875+
nub $
876+
-- We need to traverse the explicit goals and introduce the tests for each in the corresponding scope,
877+
-- because some may be qualified and simply introducing them at the top-level would not be correct
878+
map
879+
( \var ->
880+
PackageConstraint
881+
( case case var of
882+
P qual pkgname -> exQualToQPN qual pkgname
883+
F qual pkgname _ -> exQualToQPN qual pkgname
884+
S qual pkgname _ -> exQualToQPN qual pkgname of
885+
P.Q (P.PackagePath ns ql) pkgname -> ScopeQualified ns ql pkgname
886+
)
887+
(PackagePropertyStanzas [TestStanzas])
888+
)
889+
(fromMaybe [] goalOrder)
890+
<> fmap
891+
( \p ->
892+
PackageConstraint
893+
(scopeToplevel (C.mkPackageName p))
894+
(PackagePropertyStanzas [TestStanzas])
895+
)
896+
(exDbPkgs db)
878897
| otherwise = []
879898
targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets
880899
params =
@@ -892,7 +911,7 @@ exResolve
892911
setOnlyConstrained onlyConstrained $
893912
setEnableBackjumping enableBj $
894913
setSolveExecutables solveExes $
895-
setGoalOrder goalOrder $
914+
setGoalOrder (sortedGoalsToSortOrder <$> goalOrder) $
896915
setSolverVerbosity verbosity $
897916
standardInstallPolicy instIdx avaiIdx targets'
898917
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
@@ -932,3 +951,41 @@ runProgress = go
932951
go (Step s p) = let (ss, result) = go p in (s : ss, result)
933952
go (Fail e) = ([], Left e)
934953
go (Done a) = ([], Right a)
954+
955+
exQualToQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
956+
exQualToQPN q pn = P.Q pp (C.mkPackageName pn)
957+
where
958+
pp = case q of
959+
QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel
960+
QualIndep p ->
961+
P.PackagePath
962+
(P.Independent $ C.mkPackageName p)
963+
P.QualToplevel
964+
QualSetup s ->
965+
P.PackagePath
966+
(P.IndependentComponent (C.mkPackageName s) C.ComponentSetup)
967+
(P.QualToplevel)
968+
QualExe p1 p2 ->
969+
P.PackagePath
970+
(P.IndependentBuildTool (C.mkPackageName p1) (C.mkPackageName p2))
971+
P.QualToplevel
972+
973+
sortedGoalsToSortOrder :: [ExampleVar] -> Variable P.QPN -> Variable P.QPN -> Ordering
974+
sortedGoalsToSortOrder = sortGoals where
975+
sortGoals
976+
:: [ExampleVar]
977+
-> Variable P.QPN
978+
-> Variable P.QPN
979+
-> Ordering
980+
sortGoals = orderFromList . map toVariable
981+
982+
-- Sort elements in the list ahead of elements not in the list. Otherwise,
983+
-- follow the order in the list.
984+
orderFromList :: Eq a => [a] -> a -> a -> Ordering
985+
orderFromList xs =
986+
comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)
987+
988+
toVariable :: ExampleVar -> Variable P.QPN
989+
toVariable (P q pn) = PackageVar (exQualToQPN q pn)
990+
toVariable (F q pn fn) = FlagVar (exQualToQPN q pn) (C.mkFlagName fn)
991+
toVariable (S q pn stanza) = StanzaVar (exQualToQPN q pn) stanza

‎cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs

Lines changed: 1 addition & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -33,25 +33,19 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
3333
import Distribution.Solver.Compat.Prelude
3434
import Prelude ()
3535

36-
import Data.List (elemIndex)
37-
3836
-- test-framework
3937
import Test.Tasty as TF
4038
import Test.Tasty.HUnit (assertBool, assertEqual, testCase)
4139

4240
-- Cabal
43-
import qualified Distribution.PackageDescription as C
4441
import Distribution.Verbosity
4542
import Language.Haskell.Extension (Extension (..), Language (..))
4643

4744
-- cabal-install
4845

4946
import Distribution.Client.Dependency (foldProgress)
50-
import qualified Distribution.Solver.Types.ComponentDeps as C
51-
import qualified Distribution.Solver.Types.PackagePath as P
5247
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList)
5348
import Distribution.Solver.Types.Settings
54-
import Distribution.Solver.Types.Variable
5549
import UnitTests.Distribution.Solver.Modular.DSL
5650
import UnitTests.Options
5751

@@ -263,7 +257,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
263257
testOnlyConstrained
264258
testEnableBackjumping
265259
testSolveExecutables
266-
(sortGoals <$> testGoalOrder)
260+
testGoalOrder
267261
testConstraints
268262
testSoftConstraints
269263
testVerbosity
@@ -289,39 +283,3 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
289283
case resultErrorMsgPredicateOrPlan result of
290284
Left f -> f msg
291285
Right _ -> False
292-
293-
sortGoals
294-
:: [ExampleVar]
295-
-> Variable P.QPN
296-
-> Variable P.QPN
297-
-> Ordering
298-
sortGoals = orderFromList . map toVariable
299-
300-
-- Sort elements in the list ahead of elements not in the list. Otherwise,
301-
-- follow the order in the list.
302-
orderFromList :: Eq a => [a] -> a -> a -> Ordering
303-
orderFromList xs =
304-
comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)
305-
306-
toVariable :: ExampleVar -> Variable P.QPN
307-
toVariable (P q pn) = PackageVar (toQPN q pn)
308-
toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn)
309-
toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
310-
311-
toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
312-
toQPN q pn = P.Q pp (C.mkPackageName pn)
313-
where
314-
pp = case q of
315-
QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel
316-
QualIndep p ->
317-
P.PackagePath
318-
(P.Independent $ C.mkPackageName p)
319-
P.QualToplevel
320-
QualSetup s ->
321-
P.PackagePath
322-
(P.IndependentComponent (C.mkPackageName s) C.ComponentSetup)
323-
(P.QualToplevel)
324-
QualExe p1 p2 ->
325-
P.PackagePath
326-
(P.IndependentBuildTool (C.mkPackageName p1) (C.mkPackageName p2))
327-
P.QualToplevel

0 commit comments

Comments
 (0)