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
|
module UnitTests.Distribution.Client.Targets
( tests
) where
import Distribution.Client.Targets
( UserConstraint (..)
, UserConstraintScope (..)
, UserQualifier (..)
, readUserConstraint
)
import Distribution.Package (mkPackageName)
import Distribution.PackageDescription (mkFlagAssignment, mkFlagName)
import Distribution.Version (anyVersion, mkVersion, thisVersion)
import Distribution.Parsec (explicitEitherParsec, parsec, parsecCommaList)
import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..))
import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
import Test.Tasty
import Test.Tasty.HUnit
import Data.List (intercalate)
-- Helper function: makes a test group by mapping each element
-- of a list to a test case.
makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree
makeGroup name f xs =
testGroup name $
zipWith testCase (map show [0 :: Integer ..]) (map f xs)
tests :: [TestTree]
tests =
[ makeGroup
"readUserConstraint"
(uncurry readUserConstraintTest)
exampleConstraints
, makeGroup
"parseUserConstraint"
(uncurry parseUserConstraintTest)
exampleConstraints
, makeGroup
"readUserConstraints"
(uncurry readUserConstraintsTest)
[ -- First example only.
( case exampleStrs of (e : _) -> e; _ -> error "empty examples"
, take 1 exampleUcs
)
, -- All examples separated by commas.
(intercalate ", " exampleStrs, exampleUcs)
]
]
where
(exampleStrs, exampleUcs) = unzip exampleConstraints
exampleConstraints :: [(String, UserConstraint)]
exampleConstraints =
[
( "template-haskell installed"
, UserConstraint
(UserQualified UserQualToplevel (pn "template-haskell"))
PackagePropertyInstalled
)
,
( "bytestring >= 0"
, UserConstraint
(UserQualified UserQualToplevel (pn "bytestring"))
(PackagePropertyVersion anyVersion)
)
,
( "any.directory test"
, UserConstraint
(UserAnyQualifier (pn "directory"))
(PackagePropertyStanzas [TestStanzas])
)
,
( "setup.Cabal installed"
, UserConstraint
(UserAnySetupQualifier (pn "Cabal"))
PackagePropertyInstalled
)
,
( "process:setup.bytestring ==5.2"
, UserConstraint
(UserQualified (UserQualSetup (pn "process")) (pn "bytestring"))
(PackagePropertyVersion (thisVersion (mkVersion [5, 2])))
)
, -- flag MUST be prefixed with - or +
( "network:setup.containers +foo -bar +baz"
, UserConstraint
(UserQualified (UserQualSetup (pn "network")) (pn "containers"))
( PackagePropertyFlags
( mkFlagAssignment
[ (fn "foo", True)
, (fn "bar", False)
, (fn "baz", True)
]
)
)
)
-- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.
--
-- , ("foo:happy:exe.template-haskell test",
-- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell"))
-- (PackagePropertyStanzas [TestStanzas]))
]
where
pn = mkPackageName
fn = mkFlagName
readUserConstraintTest :: String -> UserConstraint -> Assertion
readUserConstraintTest str uc =
assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual
where
expected = Right uc
actual = readUserConstraint str
parseUserConstraintTest :: String -> UserConstraint -> Assertion
parseUserConstraintTest str uc =
assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual
where
expected = Right uc
actual = explicitEitherParsec parsec str
readUserConstraintsTest :: String -> [UserConstraint] -> Assertion
readUserConstraintsTest str ucs =
assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual
where
expected = Right ucs
actual = explicitEitherParsec (parsecCommaList parsec) str
|
