?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
update jinja2 per CVE-2024-34064
[cabal.git] / Cabal-tests / tests / UnitTests / Distribution / Version.hs
blob27d9f440af899a7b5419e38078ed942d062418f3
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE StandaloneDeriving #-}
3 {-# OPTIONS_GHC -fno-warn-incomplete-patterns
4 -fno-warn-deprecations
5 -fno-warn-unused-binds #-} --FIXME
6 module UnitTests.Distribution.Version (versionTests) where
7
8 import Distribution.Compat.Prelude.Internal
9 import Prelude ()
10
11 import Distribution.Parsec (simpleParsec)
12 import Distribution.Pretty
13 import Distribution.Types.VersionRange.Internal
14 import Distribution.Utils.Generic
15 import Distribution.Version
16
17
18 import Data.Maybe (fromJust)
19 import Data.Typeable (typeOf)
20 import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), NonNegative (..), Property, Testable, counterexample, property, (===), (==>), vectorOf, sized, choose, arbitrarySizedNatural)
21 import Test.QuickCheck.Instances.Cabal ()
22 import Test.Tasty (TestTree)
23 import Test.Tasty.QuickCheck (testProperty)
24
25 import qualified Distribution.Types.VersionInterval as New
26 import qualified Distribution.Types.VersionInterval.Legacy as Old
27 import qualified Text.PrettyPrint as Disp
28
29 versionTests :: [TestTree]
30 versionTests =
31 -- test 'Version' type
32 [ tp "versionNumbers . mkVersion = id @[NonNegative Int]" prop_VersionId
33 , tp "versionNumbers . mkVersion = id @Base.Version" prop_VersionId2
34 , tp "(==) = (==) `on` versionNumbers" prop_VersionEq
35 , tp "(==) = (==) `on` mkVersion" prop_VersionEq2
36 , tp "compare = compare `on` versionNumbers" prop_VersionOrd
37 , tp "compare = compare `on` mkVersion" prop_VersionOrd2
38
39 , tp "readMaybe . show = Just" prop_ShowRead
40 , tp "read example" prop_ShowRead_example
41
42 , tp "parsec . prettyShow involutive" prop_parsec_disp_inv
43
44 , tp "normaliseVersionRange involutive" prop_normalise_inv
45 , tp "normaliseVersionRange equivalent" prop_normalise_equiv
46 , tp "normaliseVersionRange caretequiv" prop_normalise_caret_equiv
47 , tp "normaliseVersionRange model" prop_normalise_model
48
49 , tp "simplifyVersionRange involutive" prop_simplify_inv
50 , tp "simplifyVersionRange equivalent" prop_simplify_equiv
51 -- , tp "simplifyVersionRange caretequiv" prop_simplify_caret_equiv
52
53 , tp "simpleParsec . prettyShow = Just" prop_parse_disp
54 ]
55
56 ++
57 zipWith
58 (\n (rep, p) -> testProperty ("Range Property " ++ show n ++ " (" ++ show rep ++ ")") p)
59 [1::Int ..]
60 -- properties to validate the test framework
61 [ typProperty prop_nonNull
62 , typProperty prop_gen_intervals1
63 , typProperty prop_gen_intervals2
64
65 , typProperty prop_anyVersion
66 , typProperty prop_noVersion
67 , typProperty prop_thisVersion
68 , typProperty prop_notThisVersion
69 , typProperty prop_laterVersion
70 , typProperty prop_orLaterVersion
71 , typProperty prop_earlierVersion
72 , typProperty prop_orEarlierVersion
73 , typProperty prop_unionVersionRanges
74 , typProperty prop_intersectVersionRanges
75 , typProperty prop_withinVersion
76 , typProperty prop_foldVersionRange
77
78 -- converting between version ranges and version intervals
79 , typProperty prop_to_from_intervals
80 ]
81 where
82 tp :: Testable p => String -> p -> TestTree
83 tp = testProperty
84
85 typProperty p = (typeOf p, property p)
86
87 -------------------------------------------------------------------------------
88 -- Arbitrary for inputs of mkVersion
89 -------------------------------------------------------------------------------
90
91 newtype VersionArb = VersionArb [Int]
92 deriving (Eq,Ord,Show)
93
94 -- | 'Version' instance as used by QC 2.9
95 instance Arbitrary VersionArb where
96 arbitrary = sized $ \n ->
97 do k <- choose (0, log2 n)
98 xs <- vectorOf (k+1) arbitrarySizedNatural
99 return (VersionArb xs)
100 where
101 log2 :: Int -> Int
102 log2 n | n <= 1 = 0
103 | otherwise = 1 + log2 (n `div` 2)
104
105 shrink (VersionArb xs) =
106 [ VersionArb xs'
107 | xs' <- shrink xs
108 , length xs' > 0
109 , all (>=0) xs'
110 ]
111
112 ---------------------
113 -- Version properties
114 --
115
116 prop_VersionId :: [NonNegative Int] -> Bool
117 prop_VersionId lst0 =
118 (versionNumbers . mkVersion) lst == lst
119 where
120 lst = map getNonNegative lst0
121
122 prop_VersionId2 :: VersionArb -> Bool
123 prop_VersionId2 (VersionArb lst) =
124 (versionNumbers . mkVersion) lst == lst
125
126 prop_VersionEq :: Version -> Version -> Bool
127 prop_VersionEq v1 v2 = (==) v1 v2 == ((==) `on` versionNumbers) v1 v2
128
129 prop_VersionEq2 :: VersionArb -> VersionArb -> Bool
130 prop_VersionEq2 (VersionArb v1) (VersionArb v2) =
131 (==) v1 v2 == ((==) `on` mkVersion) v1 v2
132
133 prop_VersionOrd :: Version -> Version -> Bool
134 prop_VersionOrd v1 v2 =
135 compare v1 v2 == (compare `on` versionNumbers) v1 v2
136
137 prop_VersionOrd2 :: VersionArb -> VersionArb -> Bool
138 prop_VersionOrd2 (VersionArb v1) (VersionArb v2) =
139 (==) v1 v2 == ((==) `on` mkVersion) v1 v2
140
141 prop_ShowRead :: Version -> Property
142 prop_ShowRead v = Just v === readMaybe (show v)
143
144 prop_ShowRead_example :: Bool
145 prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]"
146
147 ---------------------------
148 -- VersionRange properties
149 --
150
151 prop_normalise_inv :: VersionRange -> Property
152 prop_normalise_inv vr = normaliseVersionRange vr === normaliseVersionRange (normaliseVersionRange vr)
153
154 prop_normalise_equiv :: VersionRange -> Version -> Property
155 prop_normalise_equiv vr =
156 prop_equivalentVersionRange vr (normaliseVersionRange vr)
157
158 prop_normalise_caret_equiv :: VersionRange -> Version -> Property
159 prop_normalise_caret_equiv vr = prop_equivalentVersionRange
160 (transformCaretUpper vr)
161 (transformCaretUpper (normaliseVersionRange vr))
162
163 prop_normalise_model :: VersionRange -> Property
164 prop_normalise_model vr =
165 oldNormaliseVersionRange vr' === newNormaliseVersionRange vr'
166 where
167 vr' = transformCaret vr
168
169 oldNormaliseVersionRange :: VersionRange -> VersionRange
170 oldNormaliseVersionRange = Old.fromVersionIntervals . Old.toVersionIntervals
171
172 newNormaliseVersionRange :: VersionRange -> VersionRange
173 newNormaliseVersionRange = New.normaliseVersionRange2
174
175 prop_simplify_inv :: VersionRange -> Property
176 prop_simplify_inv vr =
177 simplifyVersionRange vr === simplifyVersionRange (simplifyVersionRange vr)
178
179 prop_simplify_equiv :: VersionRange -> Version -> Property
180 prop_simplify_equiv vr v =
181 counterexample (show vr') $ prop_equivalentVersionRange vr vr' v
182 where
183 vr' = simplifyVersionRange vr
184
185 -- TODO: Doesn't hold yet
186 -- prop_simplify_caret_equiv :: VersionRange -> Version -> Property
187 -- prop_simplify_caret_equiv vr = prop_equivalentVersionRange
188 -- (transformCaretUpper vr)
189 -- (transformCaretUpper (simplifyVersionRange vr))
190
191 prop_nonNull :: Version -> Bool
192 prop_nonNull = (/= nullVersion)
193
194 prop_anyVersion :: Version -> Bool
195 prop_anyVersion v' =
196 withinRange v' anyVersion
197
198 prop_noVersion :: Version -> Bool
199 prop_noVersion v' =
200 withinRange v' noVersion == False
201
202 prop_thisVersion :: Version -> Version -> Bool
203 prop_thisVersion v v' =
204 withinRange v' (thisVersion v)
205 == (v' == v)
206
207 prop_notThisVersion :: Version -> Version -> Bool
208 prop_notThisVersion v v' =
209 withinRange v' (notThisVersion v)
210 == (v' /= v)
211
212 prop_laterVersion :: Version -> Version -> Bool
213 prop_laterVersion v v' =
214 withinRange v' (laterVersion v)
215 == (v' > v)
216
217 prop_orLaterVersion :: Version -> Version -> Bool
218 prop_orLaterVersion v v' =
219 withinRange v' (orLaterVersion v)
220 == (v' >= v)
221
222 prop_earlierVersion :: Version -> Version -> Bool
223 prop_earlierVersion v v' =
224 withinRange v' (earlierVersion v)
225 == (v' < v)
226
227 prop_orEarlierVersion :: Version -> Version -> Bool
228 prop_orEarlierVersion v v' =
229 withinRange v' (orEarlierVersion v)
230 == (v' <= v)
231
232 prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
233 prop_unionVersionRanges vr1 vr2 v' =
234 withinRange v' (unionVersionRanges vr1 vr2)
235 == (withinRange v' vr1 || withinRange v' vr2)
236
237 prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
238 prop_intersectVersionRanges vr1 vr2 v' =
239 withinRange v' (intersectVersionRanges vr1 vr2)
240 == (withinRange v' vr1 && withinRange v' vr2)
241
242 prop_withinVersion :: Version -> Version -> Property
243 prop_withinVersion v v' =
244 withinRange v' (withinVersion v)
245 ===
246 (v' >= v && v' < upper v)
247 where
248 upper = alterVersion $ \numbers -> case unsnoc numbers of
249 Nothing -> []
250 Just (xs, x) -> xs ++ [x + 1]
251
252 prop_foldVersionRange :: VersionRange -> Property
253 prop_foldVersionRange range =
254 expandVR range
255 === foldVersionRange anyVersion thisVersion
256 laterVersion earlierVersion
257 unionVersionRanges intersectVersionRanges
258 range
259 where
260 expandVR (MajorBoundVersion v) =
261 intersectVersionRanges (expandVR (orLaterVersion v)) (earlierVersion (majorUpperBound v))
262 expandVR (OrEarlierVersion v) =
263 unionVersionRanges (thisVersion v) (earlierVersion v)
264 expandVR (OrLaterVersion v) =
265 unionVersionRanges (thisVersion v) (laterVersion v)
266 expandVR (UnionVersionRanges v1 v2) =
267 UnionVersionRanges (expandVR v1) (expandVR v2)
268 expandVR (IntersectVersionRanges v1 v2) =
269 IntersectVersionRanges (expandVR v1) (expandVR v2)
270 expandVR v = v
271
272 upper = alterVersion $ \numbers -> case unsnoc numbers of
273 Nothing -> []
274 Just (xs, x) -> xs ++ [x + 1]
275
276 prop_isAnyVersion1 :: VersionRange -> Version -> Property
277 prop_isAnyVersion1 range version =
278 isAnyVersion range ==> withinRange version range
279
280 prop_isAnyVersion2 :: VersionRange -> Property
281 prop_isAnyVersion2 range =
282 isAnyVersion range ==>
283 foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False)
284 (\_ _ -> False) (\_ _ -> False)
285 (simplifyVersionRange range)
286
287 prop_isNoVersion :: VersionRange -> Version -> Property
288 prop_isNoVersion range version =
289 isNoVersion range ==> not (withinRange version range)
290
291 prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property
292 prop_isSpecificVersion1 range (NonEmpty versions) =
293 isJust version && not (null versions') ==>
294 allEqual (fromJust version) versions'
295 where
296 version = isSpecificVersion range
297 versions' = filter (`withinRange` range) versions
298 allEqual x xs = and (zipWith (==) (x:xs) xs)
299
300 prop_isSpecificVersion2 :: VersionRange -> Property
301 prop_isSpecificVersion2 range =
302 isJust version ==>
303 foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing)
304 (\_ _ -> Nothing) (\_ _ -> Nothing)
305 (simplifyVersionRange range)
306 == version
307
308 where
309 version = isSpecificVersion range
310
311 -- | Check that our VersionIntervals' arbitrary instance generates intervals
312 -- that satisfies the invariant.
313 --
314 prop_gen_intervals1 :: VersionIntervals -> Property
315 prop_gen_intervals1 = property . New.invariantVersionIntervals
316
317 -- | Check that constructing our intervals type and converting it to a
318 -- 'VersionRange' and then into the true intervals type gives us back
319 -- the exact same sequence of intervals. This tells us that our arbitrary
320 -- instance for 'VersionIntervals'' is ok.
321 --
322 prop_gen_intervals2 :: VersionIntervals -> Property
323 prop_gen_intervals2 intervals =
324 toVersionIntervals (fromVersionIntervals intervals) === intervals
325 --
326 -- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on
327 -- 'VersionIntervals'.
328 --
329 prop_to_from_intervals :: VersionIntervals -> Bool
330 prop_to_from_intervals intervals =
331 toVersionIntervals (fromVersionIntervals intervals) == intervals
332
333 --------------------------------
334 -- equivalentVersionRange helper
335
336 prop_equivalentVersionRange
337 :: VersionRange -> VersionRange -> Version -> Property
338 prop_equivalentVersionRange range range' version =
339 withinRange version range === withinRange version range'
340
341 --------------------------------
342 -- Parsing and pretty printing
343 --
344 prop_parsec_disp_inv :: VersionRange -> Property
345 prop_parsec_disp_inv vr =
346 parseDisp vr === (parseDisp vr >>= parseDisp)
347 where
348 parseDisp = simpleParsec . prettyShow
349
350 prop_parse_disp :: VersionRange -> Property
351 prop_parse_disp vr = counterexample (show (prettyShow vr')) $
352 fmap s (simpleParsec (prettyShow vr')) === Just vr'
353 where
354 -- we have to strip parens, because arbitrary 'VersionRange' may have
355 -- too little parens constructors.
356 s = stripParensVersionRange
357 vr' = s vr
358
359 prop_parse_disp1 :: VersionRange -> Bool
360 prop_parse_disp1 vr =
361 simpleParsec (prettyShow vr) == Just (normaliseVersionRange vr)
362
363 prop_parse_disp2 :: VersionRange -> Property
364 prop_parse_disp2 vr =
365 let b = fmap (prettyShow :: VersionRange -> String) (simpleParsec (prettyShow vr))
366 a = Just (prettyShow vr)
367 in
368 counterexample ("Expected: " ++ show a) $
369 counterexample ("But got: " ++ show b) $
370 b == a
371
372 prop_parse_disp3 :: VersionRange -> Property
373 prop_parse_disp3 vr =
374 let a = Just (prettyShow vr)
375 b = fmap displayRaw (simpleParsec (prettyShow vr))
376 in
377 counterexample ("Expected: " ++ show a) $
378 counterexample ("But got: " ++ show b) $
379 b == a
380
381 prop_parse_disp4 :: VersionRange -> Property
382 prop_parse_disp4 vr =
383 let a = Just vr
384 b = (simpleParsec (prettyShow vr))
385 in
386 counterexample ("Expected: " ++ show a) $
387 counterexample ("But got: " ++ show b) $
388 b == a
389
390 prop_parse_disp5 :: VersionRange -> Property
391 prop_parse_disp5 vr =
392 let a = Just vr
393 b = simpleParsec (displayRaw vr)
394 in
395 counterexample ("Expected: " ++ show a) $
396 counterexample ("But got: " ++ show b) $
397 b == a
398
399 displayRaw :: VersionRange -> String
400 displayRaw =
401 Disp.render
402 . cataVersionRange alg . normaliseVersionRange
403 where
404
405 -- precedence:
406 -- All the same as the usual pretty printer, except for the parens
407 alg (ThisVersionF v) = Disp.text "==" <<>> pretty v
408 alg (LaterVersionF v) = Disp.char '>' <<>> pretty v
409 alg (EarlierVersionF v) = Disp.char '<' <<>> pretty v
410 alg (OrLaterVersionF v) = Disp.text ">=" <<>> pretty v
411 alg (OrEarlierVersionF v) = Disp.text "<=" <<>> pretty v
412 alg (MajorBoundVersionF v) = Disp.text "^>=" <<>> pretty v
413 alg (UnionVersionRangesF r1 r2) = r1 <+> Disp.text "||" <+> r2
414 alg (IntersectVersionRangesF r1 r2) = r1 <+> Disp.text "&&" <+> r2
415
416 dispWild v =
417 Disp.hcat (Disp.punctuate (Disp.char '.')
418 (map Disp.int (versionNumbers v)))
419 <<>> Disp.text ".*"
Common Architecture for Building Applications and Libraries