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