1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
module Futhark.Pkg.SolveTests (tests) where
import Data.Map qualified as M
import Data.Monoid
import Data.Text qualified as T
import Futhark.Pkg.Solve
import Futhark.Pkg.Types
import Test.Tasty
import Test.Tasty.HUnit
import Prelude
semverE :: T.Text -> SemVer
semverE s = case parseVersion s of
Left err ->
error $
T.unpack s
<> " is not a valid version number: "
<> errorBundlePretty err
Right x -> x
-- | A world of packages and interdependencies for testing the solver
-- without touching the outside world.
testEnv :: PkgRevDepInfo
testEnv =
M.fromList $
concatMap
frob
[ ( "athas",
[ ( "foo",
[ ("0.1.0", []),
("0.2.0", [("athas/bar", "1.0.0")]),
("0.3.0", [])
]
),
("foo@v2", [("2.0.0", [("athas/quux", "0.1.0")])]),
("bar", [("1.0.0", [])]),
("baz", [("0.1.0", [("athas/foo", "0.3.0")])]),
( "quux",
[ ( "0.1.0",
[ ("athas/foo", "0.2.0"),
("athas/baz", "0.1.0")
]
)
]
),
( "quux_perm",
[ ( "0.1.0",
[ ("athas/baz", "0.1.0"),
("athas/foo", "0.2.0")
]
)
]
),
("x_bar", [("1.0.0", [("athas/bar", "1.0.0")])]),
("x_foo", [("1.0.0", [("athas/foo", "0.3.0")])]),
( "tricky",
[ ( "1.0.0",
[ ("athas/foo", "0.2.0"),
("athas/x_foo", "1.0.0")
]
)
]
)
]
),
-- Some mutually recursive packages.
( "nasty",
[ ("foo", [("1.0.0", [("nasty/bar", "1.0.0")])]),
("bar", [("1.0.0", [("nasty/foo", "1.0.0")])])
]
)
]
where
frob (user, repos) = do
(repo, repo_revs) <- repos
(rev, deps) <- repo_revs
let rev' = semverE rev
onDep (dp, dv) = (dp, (semverE dv, Nothing))
deps' = PkgRevDeps $ M.fromList $ map onDep deps
pure ((user <> "/" <> repo, rev'), deps')
newtype SolverRes = SolverRes BuildList
deriving (Eq)
instance Show SolverRes where
show (SolverRes bl) = T.unpack $ prettyBuildList bl
solverTest :: PkgPath -> T.Text -> Either T.Text [(PkgPath, T.Text)] -> TestTree
solverTest p v expected =
testCase (T.unpack $ p <> "-" <> prettySemVer v') $
fmap SolverRes (solveDepsPure testEnv target)
@?= expected'
where
target = PkgRevDeps $ M.singleton p (v', Nothing)
v' = semverE v
expected' = SolverRes . BuildList . M.fromList . map onRes <$> expected
onRes (dp, dv) = (dp, semverE dv)
tests :: TestTree
tests =
testGroup
"SolveTests"
[ solverTest "athas/foo" "0.1.0" $
Right [("athas/foo", "0.1.0")],
solverTest "athas/foo" "0.2.0" $
Right
[ ("athas/foo", "0.2.0"),
("athas/bar", "1.0.0")
],
solverTest "athas/quux" "0.1.0" $
Right
[ ("athas/quux", "0.1.0"),
("athas/foo", "0.3.0"),
("athas/baz", "0.1.0")
],
solverTest "athas/quux_perm" "0.1.0" $
Right
[ ("athas/quux_perm", "0.1.0"),
("athas/foo", "0.3.0"),
("athas/baz", "0.1.0")
],
solverTest "athas/foo@v2" "2.0.0" $
Right
[ ("athas/foo@v2", "2.0.0"),
("athas/quux", "0.1.0"),
("athas/foo", "0.3.0"),
("athas/baz", "0.1.0")
],
solverTest "athas/foo@v3" "3.0.0" $
Left "Unknown package/version: athas/foo@v3-3.0.0",
solverTest "nasty/foo" "1.0.0" $
Right
[ ("nasty/foo", "1.0.0"),
("nasty/bar", "1.0.0")
],
solverTest "athas/tricky" "1.0.0" $
Right
[ ("athas/tricky", "1.0.0"),
("athas/foo", "0.3.0"),
("athas/x_foo", "1.0.0")
]
]
|
