1{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}
2{-# OPTIONS_GHC -fno-warn-orphans
3                -fno-warn-incomplete-patterns
4                -fno-warn-deprecations
5                -fno-warn-unused-binds #-} --FIXME
6module UnitTests.Distribution.Version (versionTests) where
7
8import Distribution.Compat.Prelude.Internal
9import Prelude ()
10
11import Distribution.Version
12import Distribution.Types.VersionRange.Internal
13import Distribution.Parsec (simpleParsec)
14import Distribution.Pretty
15
16import Data.Typeable (typeOf)
17import Math.NumberTheory.Logarithms (intLog2)
18import Text.PrettyPrint as Disp (text, render, parens, hcat
19                                ,punctuate, int, char, (<+>))
20import Test.Tasty
21import Test.Tasty.QuickCheck
22import qualified Test.Laws as Laws
23
24import Test.QuickCheck.Utils
25
26import Data.Maybe (fromJust)
27import Data.Function (on)
28
29versionTests :: [TestTree]
30versionTests =
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 "normaliseVersionRange involutive"                    prop_normalise_inv
43    , tp "parsec . prettyShow involutive"                      prop_parsec_disp_inv
44
45    , tp "simpleParsec . prettyShow = Just" prop_parse_disp
46    ]
47
48    ++
49    zipWith
50    (\n (rep, p) -> testProperty ("Range Property " ++ show n ++ " (" ++ show rep ++ ")") p)
51    [1::Int ..]
52      -- properties to validate the test framework
53    [ typProperty prop_nonNull
54    , typProperty prop_gen_intervals1
55    , typProperty prop_gen_intervals2
56  --, typProperty prop_equivalentVersionRange --FIXME: runs out of test cases
57    , typProperty prop_intermediateVersion
58
59    , typProperty prop_anyVersion
60    , typProperty prop_noVersion
61    , typProperty prop_thisVersion
62    , typProperty prop_notThisVersion
63    , typProperty prop_laterVersion
64    , typProperty prop_orLaterVersion
65    , typProperty prop_earlierVersion
66    , typProperty prop_orEarlierVersion
67    , typProperty prop_unionVersionRanges
68    , typProperty prop_intersectVersionRanges
69    , typProperty prop_differenceVersionRanges
70    , typProperty prop_invertVersionRange
71    , typProperty prop_withinVersion
72    , typProperty prop_foldVersionRange
73
74      -- the semantic query functions
75  --, typProperty prop_isAnyVersion1       --FIXME: runs out of test cases
76  --, typProperty prop_isAnyVersion2       --FIXME: runs out of test cases
77  --, typProperty prop_isNoVersion         --FIXME: runs out of test cases
78  --, typProperty prop_isSpecificVersion1  --FIXME: runs out of test cases
79  --, typProperty prop_isSpecificVersion2  --FIXME: runs out of test cases
80    , typProperty prop_simplifyVersionRange1
81    , typProperty prop_simplifyVersionRange1'
82  --, typProperty prop_simplifyVersionRange2   --FIXME: runs out of test cases
83  --, typProperty prop_simplifyVersionRange2'  --FIXME: runs out of test cases
84  --, typProperty prop_simplifyVersionRange2'' --FIXME: actually wrong
85
86      -- converting between version ranges and version intervals
87    , typProperty prop_to_intervals
88  --, typProperty prop_to_intervals_canonical  --FIXME: runs out of test cases
89  --, typProperty prop_to_intervals_canonical' --FIXME: runs out of test cases
90    , typProperty prop_from_intervals
91    , typProperty prop_to_from_intervals
92    , typProperty prop_from_to_intervals
93    , typProperty prop_from_to_intervals'
94
95      -- union and intersection of version intervals
96    , typProperty prop_unionVersionIntervals
97    , typProperty prop_unionVersionIntervals_idempotent
98    , typProperty prop_unionVersionIntervals_commutative
99    , typProperty prop_unionVersionIntervals_associative
100    , typProperty prop_intersectVersionIntervals
101    , typProperty prop_intersectVersionIntervals_idempotent
102    , typProperty prop_intersectVersionIntervals_commutative
103    , typProperty prop_intersectVersionIntervals_associative
104    , typProperty prop_union_intersect_distributive
105    , typProperty prop_intersect_union_distributive
106
107      -- inversion of version intervals
108    , typProperty prop_invertVersionIntervals
109    , typProperty prop_invertVersionIntervalsTwice
110    ]
111  where
112    tp :: Testable p => String -> p -> TestTree
113    tp = testProperty
114
115    typProperty p = (typeOf p, property p)
116
117
118-- parseTests :: [TestTree]
119-- parseTests =
120--   zipWith (\n p -> testProperty ("Parse Property " ++ show n) p) [1::Int ..]
121--    -- parsing and pretty printing
122--   [ -- property prop_parse_disp1  --FIXME: actually wrong
123
124--     --  These are also wrong, see
125--     --  https://github.com/haskell/cabal/issues/3037#issuecomment-177671011
126
127--     --   property prop_parse_disp2
128--     -- , property prop_parse_disp3
129--     -- , property prop_parse_disp4
130--     -- , property prop_parse_disp5
131--   ]
132
133instance Arbitrary Version where
134  arbitrary = do
135      branch <- smallListOf1 $
136                  frequency [(3, return 0)
137                            ,(3, return 1)
138                            ,(2, return 2)
139                            ,(2, return 3)
140                            ,(1, return 0xfffd)
141                            ,(1, return 0xfffe) -- max fitting into packed W64
142                            ,(1, return 0xffff)
143                            ,(1, return 0x10000)]
144      return (mkVersion branch)
145    where
146      smallListOf1 = adjustSize (\n -> min 6 (n `div` 3)) . listOf1
147
148  shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver)
149                              , not (null ns) ]
150
151newtype VersionArb = VersionArb [Int]
152                   deriving (Eq,Ord,Show)
153
154-- | 'Version' instance as used by QC 2.9
155instance Arbitrary VersionArb where
156  arbitrary = sized $ \n ->
157    do k <- choose (0, log2 n)
158       xs <- vectorOf (k+1) arbitrarySizedNatural
159       return (VersionArb xs)
160    where
161      log2 :: Int -> Int
162      log2 n | n <= 1 = 0
163             | otherwise = 1 + log2 (n `div` 2)
164
165  shrink (VersionArb xs) =
166    [ VersionArb xs'
167    | xs' <- shrink xs
168    , length xs' > 0
169    , all (>=0) xs'
170    ]
171
172instance Arbitrary VersionRange where
173  arbitrary = sized verRangeExp
174    where
175      verRangeExp n = frequency $
176        [ (2, return anyVersion)
177        , (1, liftM thisVersion arbitrary)
178        , (1, liftM laterVersion arbitrary)
179        , (1, liftM orLaterVersion arbitrary)
180        , (1, liftM orLaterVersion' arbitrary)
181        , (1, liftM earlierVersion arbitrary)
182        , (1, liftM orEarlierVersion arbitrary)
183        , (1, liftM orEarlierVersion' arbitrary)
184        , (1, liftM withinVersion arbitrary)
185        , (1, liftM majorBoundVersion arbitrary)
186        , (2, liftM VersionRangeParens arbitrary)
187        ] ++ if n == 0 then [] else
188        [ (2, liftM2 unionVersionRanges     verRangeExp2 verRangeExp2)
189        , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
190        ]
191        where
192          verRangeExp2 = verRangeExp (n `div` 2)
193
194      orLaterVersion'   v =
195        unionVersionRanges (LaterVersion v)   (ThisVersion v)
196      orEarlierVersion' v =
197        unionVersionRanges (EarlierVersion v) (ThisVersion v)
198
199  shrink AnyVersion                   = []
200  shrink (ThisVersion v)              = map ThisVersion (shrink v)
201  shrink (LaterVersion v)             = map LaterVersion (shrink v)
202  shrink (EarlierVersion v)           = map EarlierVersion (shrink v)
203  shrink (OrLaterVersion v)           = LaterVersion v : map OrLaterVersion (shrink v)
204  shrink (OrEarlierVersion v)         = EarlierVersion v : map OrEarlierVersion (shrink v)
205  shrink (WildcardVersion v)          = map WildcardVersion ( shrink v)
206  shrink (MajorBoundVersion v)        = map MajorBoundVersion (shrink v)
207  shrink (VersionRangeParens vr)      = vr : map VersionRangeParens (shrink vr)
208  shrink (UnionVersionRanges a b)     = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
209  shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))
210
211---------------------
212-- Version properties
213--
214
215prop_VersionId :: [NonNegative Int] -> Bool
216prop_VersionId lst0 =
217    (versionNumbers . mkVersion) lst == lst
218  where
219    lst = map getNonNegative lst0
220
221prop_VersionId2 :: VersionArb -> Bool
222prop_VersionId2 (VersionArb lst) =
223    (versionNumbers . mkVersion) lst == lst
224
225prop_VersionEq :: Version -> Version -> Bool
226prop_VersionEq v1 v2 = (==) v1 v2 == ((==) `on` versionNumbers) v1 v2
227
228prop_VersionEq2 :: VersionArb -> VersionArb -> Bool
229prop_VersionEq2 (VersionArb v1) (VersionArb v2) =
230    (==) v1 v2 == ((==) `on` mkVersion) v1 v2
231
232prop_VersionOrd :: Version -> Version -> Bool
233prop_VersionOrd v1 v2 =
234    compare v1 v2 == (compare `on` versionNumbers) v1 v2
235
236prop_VersionOrd2 :: VersionArb -> VersionArb -> Bool
237prop_VersionOrd2 (VersionArb v1) (VersionArb v2) =
238    (==) v1 v2 == ((==) `on` mkVersion) v1 v2
239
240prop_ShowRead :: Version -> Property
241prop_ShowRead v = Just v === readMaybe (show v)
242
243prop_ShowRead_example :: Bool
244prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]"
245
246---------------------------
247-- VersionRange properties
248--
249
250prop_normalise_inv :: VersionRange -> Property
251prop_normalise_inv vr =
252    normaliseVersionRange vr === normaliseVersionRange (normaliseVersionRange vr)
253
254prop_nonNull :: Version -> Bool
255prop_nonNull = (/= nullVersion)
256
257prop_anyVersion :: Version -> Bool
258prop_anyVersion v' =
259  withinRange v' anyVersion
260
261prop_noVersion :: Version -> Bool
262prop_noVersion v' =
263  withinRange v' noVersion == False
264
265prop_thisVersion :: Version -> Version -> Bool
266prop_thisVersion v v' =
267     withinRange v' (thisVersion v)
268  == (v' == v)
269
270prop_notThisVersion :: Version -> Version -> Bool
271prop_notThisVersion v v' =
272     withinRange v' (notThisVersion v)
273  == (v' /= v)
274
275prop_laterVersion :: Version -> Version -> Bool
276prop_laterVersion v v' =
277     withinRange v' (laterVersion v)
278  == (v' > v)
279
280prop_orLaterVersion :: Version -> Version -> Bool
281prop_orLaterVersion v v' =
282     withinRange v' (orLaterVersion v)
283  == (v' >= v)
284
285prop_earlierVersion :: Version -> Version -> Bool
286prop_earlierVersion v v' =
287     withinRange v' (earlierVersion v)
288  == (v' < v)
289
290prop_orEarlierVersion :: Version -> Version -> Bool
291prop_orEarlierVersion v v' =
292     withinRange v' (orEarlierVersion v)
293  == (v' <= v)
294
295prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
296prop_unionVersionRanges vr1 vr2 v' =
297     withinRange v' (unionVersionRanges vr1 vr2)
298  == (withinRange v' vr1 || withinRange v' vr2)
299
300prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
301prop_intersectVersionRanges vr1 vr2 v' =
302     withinRange v' (intersectVersionRanges vr1 vr2)
303  == (withinRange v' vr1 && withinRange v' vr2)
304
305prop_differenceVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
306prop_differenceVersionRanges vr1 vr2 v' =
307     withinRange v' (differenceVersionRanges vr1 vr2)
308  == (withinRange v' vr1 && not (withinRange v' vr2))
309
310prop_invertVersionRange :: VersionRange -> Version -> Bool
311prop_invertVersionRange vr v' =
312     withinRange v' (invertVersionRange vr)
313  == not (withinRange v' vr)
314
315prop_withinVersion :: Version -> Version -> Bool
316prop_withinVersion v v' =
317     withinRange v' (withinVersion v)
318  == (v' >= v && v' < upper v)
319  where
320    upper = alterVersion $ \numbers -> init numbers ++ [last numbers + 1]
321
322prop_foldVersionRange :: VersionRange -> Property
323prop_foldVersionRange range =
324     expandVR range
325  === foldVersionRange anyVersion thisVersion
326                      laterVersion earlierVersion
327                      unionVersionRanges intersectVersionRanges
328                      range
329  where
330    expandVR (WildcardVersion v) =
331        intersectVersionRanges (expandVR (orLaterVersion v)) (earlierVersion (wildcardUpperBound v))
332    expandVR (MajorBoundVersion v) =
333        intersectVersionRanges (expandVR (orLaterVersion v)) (earlierVersion (majorUpperBound v))
334    expandVR (OrEarlierVersion v) =
335        unionVersionRanges (thisVersion v) (earlierVersion v)
336    expandVR (OrLaterVersion v) =
337        unionVersionRanges (thisVersion v) (laterVersion v)
338    expandVR (UnionVersionRanges     v1 v2) =
339      UnionVersionRanges (expandVR v1) (expandVR v2)
340    expandVR (IntersectVersionRanges v1 v2) =
341      IntersectVersionRanges (expandVR v1) (expandVR v2)
342    expandVR (VersionRangeParens v) = expandVR v
343    expandVR v = v
344
345    upper = alterVersion $ \numbers -> init numbers ++ [last numbers + 1]
346
347prop_isAnyVersion1 :: VersionRange -> Version -> Property
348prop_isAnyVersion1 range version =
349  isAnyVersion range ==> withinRange version range
350
351prop_isAnyVersion2 :: VersionRange -> Property
352prop_isAnyVersion2 range =
353  isAnyVersion range ==>
354    foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False)
355                          (\_ _ -> False) (\_ _ -> False)
356      (simplifyVersionRange range)
357
358prop_isNoVersion :: VersionRange -> Version -> Property
359prop_isNoVersion range version =
360  isNoVersion range ==> not (withinRange version range)
361
362prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property
363prop_isSpecificVersion1 range (NonEmpty versions) =
364  isJust version && not (null versions') ==>
365    allEqual (fromJust version : versions')
366  where
367    version     = isSpecificVersion range
368    versions'   = filter (`withinRange` range) versions
369    allEqual xs = and (zipWith (==) xs (tail xs))
370
371prop_isSpecificVersion2 :: VersionRange -> Property
372prop_isSpecificVersion2 range =
373  isJust version ==>
374    foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing)
375                     (\_ _ -> Nothing) (\_ _ -> Nothing)
376      (simplifyVersionRange range)
377    == version
378
379  where
380    version = isSpecificVersion range
381
382-- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'.
383--
384prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool
385prop_simplifyVersionRange1 range version =
386  withinRange version range == withinRange version (simplifyVersionRange range)
387
388prop_simplifyVersionRange1' :: VersionRange -> Bool
389prop_simplifyVersionRange1' range =
390  range `equivalentVersionRange` (simplifyVersionRange range)
391
392-- | 'simplifyVersionRange' produces a canonical form for ranges with
393-- equivalent semantics.
394--
395prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property
396prop_simplifyVersionRange2 r r' v =
397  r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
398    withinRange v r == withinRange v r'
399
400prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property
401prop_simplifyVersionRange2' r r' =
402  r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
403    r `equivalentVersionRange` r'
404
405--FIXME: see equivalentVersionRange for details
406prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property
407prop_simplifyVersionRange2'' r r' =
408  r /= r' && r `equivalentVersionRange` r' ==>
409       simplifyVersionRange r == simplifyVersionRange r'
410    || isNoVersion r
411    || isNoVersion r'
412
413--------------------
414-- VersionIntervals
415--
416
417-- | Generating VersionIntervals
418--
419-- This is a tad tricky as VersionIntervals is an abstract type, so we first
420-- make a local type for generating the internal representation. Then we check
421-- that this lets us construct valid 'VersionIntervals'.
422--
423
424instance Arbitrary VersionIntervals where
425  arbitrary = fmap mkVersionIntervals' arbitrary
426    where
427      mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals
428      mkVersionIntervals' = mkVersionIntervals . go version0
429        where
430          go :: Version -> [(Version, Bound)] -> [VersionInterval]
431          go _ [] = []
432          go v [(lv, lb)] =
433              [(LowerBound (addVersion lv v) lb, NoUpperBound)]
434          go v ((lv, lb) : (uv, ub) : rest) =
435              (LowerBound lv' lb, UpperBound uv' ub) : go uv' rest
436            where
437              lv' = addVersion v lv
438              uv' = addVersion lv' uv
439
440          addVersion :: Version -> Version -> Version
441          addVersion xs ys = mkVersion $  z (versionNumbers xs) (versionNumbers ys)
442            where
443              z [] ys' = ys'
444              z xs' [] = xs'
445              z (x : xs') (y : ys') = x + y : z xs' ys'
446
447instance Arbitrary Bound where
448  arbitrary = elements [ExclusiveBound, InclusiveBound]
449
450-- | Check that our VersionIntervals' arbitrary instance generates intervals
451-- that satisfies the invariant.
452--
453prop_gen_intervals1 :: VersionIntervals -> Property
454prop_gen_intervals1 i
455    = label ("length i ≈ 2 ^ " ++ show metric ++ " - 1")
456    $ xs === ys
457  where
458    metric = intLog2 (length xs + 1)
459
460    xs = versionIntervals i
461    ys = versionIntervals (mkVersionIntervals xs)
462-- | Check that constructing our intervals type and converting it to a
463-- 'VersionRange' and then into the true intervals type gives us back
464-- the exact same sequence of intervals. This tells us that our arbitrary
465-- instance for 'VersionIntervals'' is ok.
466--
467prop_gen_intervals2 :: VersionIntervals -> Property
468prop_gen_intervals2 intervals =
469    toVersionIntervals (fromVersionIntervals intervals) === intervals
470
471-- | Check that 'VersionIntervals' models 'VersionRange' via
472-- 'toVersionIntervals'.
473--
474prop_to_intervals :: VersionRange -> Version -> Bool
475prop_to_intervals range version =
476  withinRange version range == withinIntervals version intervals
477  where
478    intervals = toVersionIntervals range
479
480-- | Check that semantic equality on 'VersionRange's is the same as converting
481-- to 'VersionIntervals' and doing syntactic equality.
482--
483prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property
484prop_to_intervals_canonical r r' =
485  r /= r' && r `equivalentVersionRange` r' ==>
486    toVersionIntervals r == toVersionIntervals r'
487
488prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property
489prop_to_intervals_canonical' r r' =
490  r /= r' && toVersionIntervals r == toVersionIntervals r' ==>
491    r `equivalentVersionRange` r'
492
493-- | Check that 'VersionIntervals' models 'VersionRange' via
494-- 'fromVersionIntervals'.
495--
496prop_from_intervals :: VersionIntervals -> Version -> Bool
497prop_from_intervals intervals version =
498  withinRange version range == withinIntervals version intervals
499  where
500    range = fromVersionIntervals intervals
501
502-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on
503-- 'VersionIntervals'.
504--
505prop_to_from_intervals :: VersionIntervals -> Bool
506prop_to_from_intervals intervals =
507  toVersionIntervals (fromVersionIntervals intervals) == intervals
508
509-- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on
510-- 'VersionRange', though not necessarily a syntactic identity.
511--
512prop_from_to_intervals :: VersionRange -> Bool
513prop_from_to_intervals range =
514  range' `equivalentVersionRange` range
515  where
516    range' = fromVersionIntervals (toVersionIntervals range)
517
518-- | Equivalent of 'prop_from_to_intervals'
519--
520prop_from_to_intervals' :: VersionRange -> Version -> Bool
521prop_from_to_intervals' range version =
522  withinRange version range' == withinRange version range
523  where
524    range' = fromVersionIntervals (toVersionIntervals range)
525
526-- | The semantics of 'unionVersionIntervals' is (||).
527--
528prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals
529                           -> Version -> Bool
530prop_unionVersionIntervals is1 is2 v =
531     withinIntervals v (unionVersionIntervals is1 is2)
532  == (withinIntervals v is1 || withinIntervals v is2)
533
534-- | 'unionVersionIntervals' is idempotent
535--
536prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool
537prop_unionVersionIntervals_idempotent =
538  Laws.idempotent_binary unionVersionIntervals
539
540-- | 'unionVersionIntervals' is commutative
541--
542prop_unionVersionIntervals_commutative :: VersionIntervals
543                                       -> VersionIntervals -> Bool
544prop_unionVersionIntervals_commutative =
545  Laws.commutative unionVersionIntervals
546
547-- | 'unionVersionIntervals' is associative
548--
549prop_unionVersionIntervals_associative :: VersionIntervals
550                                       -> VersionIntervals
551                                       -> VersionIntervals -> Bool
552prop_unionVersionIntervals_associative =
553  Laws.associative unionVersionIntervals
554
555-- | The semantics of 'intersectVersionIntervals' is (&&).
556--
557prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals
558                               -> Version -> Bool
559prop_intersectVersionIntervals is1 is2 v =
560     withinIntervals v (intersectVersionIntervals is1 is2)
561  == (withinIntervals v is1 && withinIntervals v is2)
562
563-- | 'intersectVersionIntervals' is idempotent
564--
565prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool
566prop_intersectVersionIntervals_idempotent =
567  Laws.idempotent_binary intersectVersionIntervals
568
569-- | 'intersectVersionIntervals' is commutative
570--
571prop_intersectVersionIntervals_commutative :: VersionIntervals
572                                           -> VersionIntervals -> Bool
573prop_intersectVersionIntervals_commutative =
574  Laws.commutative intersectVersionIntervals
575
576-- | 'intersectVersionIntervals' is associative
577--
578prop_intersectVersionIntervals_associative :: VersionIntervals
579                                           -> VersionIntervals
580                                           -> VersionIntervals -> Bool
581prop_intersectVersionIntervals_associative =
582  Laws.associative intersectVersionIntervals
583
584-- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals'
585--
586prop_union_intersect_distributive :: Property
587prop_union_intersect_distributive =
588      Laws.distributive_left  unionVersionIntervals intersectVersionIntervals
589  .&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals
590
591-- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals'
592--
593prop_intersect_union_distributive :: Property
594prop_intersect_union_distributive =
595      Laws.distributive_left  intersectVersionIntervals unionVersionIntervals
596  .&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals
597
598-- | The semantics of 'invertVersionIntervals' is 'not'.
599--
600prop_invertVersionIntervals :: VersionIntervals
601                               -> Version -> Bool
602prop_invertVersionIntervals vi v =
603     withinIntervals v (invertVersionIntervals vi)
604  == not (withinIntervals v vi)
605
606-- | Double application of 'invertVersionIntervals' is the identity function
607prop_invertVersionIntervalsTwice :: VersionIntervals -> Bool
608prop_invertVersionIntervalsTwice vi =
609    invertVersionIntervals (invertVersionIntervals vi) == vi
610
611
612
613--------------------------------
614-- equivalentVersionRange helper
615
616prop_equivalentVersionRange :: VersionRange  -> VersionRange
617                            -> Version -> Property
618prop_equivalentVersionRange range range' version =
619  equivalentVersionRange range range' && range /= range' ==>
620    withinRange version range == withinRange version range'
621
622--FIXME: this is wrong. consider version ranges "<=1" and "<1.0"
623--       this algorithm cannot distinguish them because there is no version
624--       that is included by one that is excluded by the other.
625--       Alternatively we must reconsider the semantics of '<' and '<='
626--       in version ranges / version intervals. Perhaps the canonical
627--       representation should use just < v and interpret "<= v" as "< v.0".
628equivalentVersionRange :: VersionRange -> VersionRange -> Bool
629equivalentVersionRange vr1 vr2 =
630  let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2))
631      minPoint = mkVersion [0]
632      maxPoint | null allVersionsUsed = minPoint
633               | otherwise = alterVersion (++[1]) (maximum allVersionsUsed)
634      probeVersions = minPoint : maxPoint
635                    : intermediateVersions allVersionsUsed
636
637  in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions
638
639  where
640    versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++)
641    intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2
642                                         : intermediateVersions (v2:vs)
643    intermediateVersions vs = vs
644
645intermediateVersion :: Version -> Version -> Version
646intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2"
647intermediateVersion v1 v2 =
648  mkVersion (intermediateList (versionNumbers v1) (versionNumbers v2))
649  where
650    intermediateList :: [Int] -> [Int] -> [Int]
651    intermediateList []     (_:_) = [0]
652    intermediateList (x:xs) (y:ys)
653        | x <  y    = x : xs ++ [0]
654        | otherwise = x : intermediateList xs ys
655
656prop_intermediateVersion :: Version -> Version -> Property
657prop_intermediateVersion v1 v2 =
658  (v1 /= v2) && not (adjacentVersions v1 v2) ==>
659  if v1 < v2
660    then let v = intermediateVersion v1 v2
661          in (v1 < v && v < v2)
662    else let v = intermediateVersion v2 v1
663          in v1 > v && v > v2
664
665adjacentVersions :: Version -> Version -> Bool
666adjacentVersions ver1 ver2 = v1 ++ [0] == v2 || v2 ++ [0] == v1
667  where
668    v1 = versionNumbers ver1
669    v2 = versionNumbers ver2
670
671--------------------------------
672-- Parsing and pretty printing
673--
674prop_parsec_disp_inv :: VersionRange -> Property
675prop_parsec_disp_inv vr =
676    parseDisp vr === (parseDisp vr >>= parseDisp)
677  where
678    parseDisp = simpleParsec . prettyShow
679
680prop_parse_disp :: VersionRange -> Property
681prop_parse_disp vr = counterexample (show (prettyShow vr')) $
682    fmap s (simpleParsec (prettyShow vr')) === Just vr'
683  where
684    -- we have to strip parens, because arbitrary 'VersionRange' may have
685    -- too little parens constructors.
686    s = stripParensVersionRange
687    vr' = s vr
688
689prop_parse_disp1 :: VersionRange -> Bool
690prop_parse_disp1 vr =
691    fmap stripParens (simpleParsec (prettyShow vr)) == Just (normaliseVersionRange vr)
692  where
693    stripParens :: VersionRange -> VersionRange
694    stripParens (VersionRangeParens v) = stripParens v
695    stripParens (UnionVersionRanges v1 v2) =
696      UnionVersionRanges (stripParens v1) (stripParens v2)
697    stripParens (IntersectVersionRanges v1 v2) =
698      IntersectVersionRanges (stripParens v1) (stripParens v2)
699    stripParens v = v
700
701prop_parse_disp2 :: VersionRange -> Property
702prop_parse_disp2 vr =
703  let b = fmap (prettyShow :: VersionRange -> String) (simpleParsec (prettyShow vr))
704      a = Just (prettyShow vr)
705  in
706   counterexample ("Expected: " ++ show a) $
707   counterexample ("But got: " ++ show b) $
708   b == a
709
710prop_parse_disp3 :: VersionRange -> Property
711prop_parse_disp3 vr =
712  let a = Just (prettyShow vr)
713      b = fmap displayRaw (simpleParsec (prettyShow vr))
714  in
715   counterexample ("Expected: " ++ show a) $
716   counterexample ("But got: " ++ show b) $
717   b == a
718
719prop_parse_disp4 :: VersionRange -> Property
720prop_parse_disp4 vr =
721  let a = Just vr
722      b = (simpleParsec (prettyShow vr))
723  in
724   counterexample ("Expected: " ++ show a) $
725   counterexample ("But got: " ++ show b) $
726   b == a
727
728prop_parse_disp5 :: VersionRange -> Property
729prop_parse_disp5 vr =
730  let a = Just vr
731      b = simpleParsec (displayRaw vr)
732  in
733   counterexample ("Expected: " ++ show a) $
734   counterexample ("But got: " ++ show b) $
735   b == a
736
737displayRaw :: VersionRange -> String
738displayRaw =
739   Disp.render
740 . cataVersionRange alg . normaliseVersionRange
741  where
742
743    -- precedence:
744    -- All the same as the usual pretty printer, except for the parens
745    alg AnyVersionF                     = Disp.text "-any"
746    alg (ThisVersionF v)                = Disp.text "==" <<>> pretty v
747    alg (LaterVersionF v)               = Disp.char '>'  <<>> pretty v
748    alg (EarlierVersionF v)             = Disp.char '<'  <<>> pretty v
749    alg (OrLaterVersionF v)             = Disp.text ">=" <<>> pretty v
750    alg (OrEarlierVersionF v)           = Disp.text "<=" <<>> pretty v
751    alg (WildcardVersionF v)            = Disp.text "==" <<>> dispWild v
752    alg (MajorBoundVersionF v)          = Disp.text "^>=" <<>> pretty v
753    alg (UnionVersionRangesF r1 r2)     = r1 <+> Disp.text "||" <+> r2
754    alg (IntersectVersionRangesF r1 r2) = r1 <+> Disp.text "&&" <+> r2
755    alg (VersionRangeParensF r)         = Disp.parens r -- parens
756
757
758    dispWild v =
759           Disp.hcat (Disp.punctuate (Disp.char '.')
760                                     (map Disp.int (versionNumbers v)))
761        <<>> Disp.text ".*"
762