|
| 1 | +{-# OPTIONS_GHC -fno-warn-orphans #-} |
| 2 | +module Test.QuickCheck.Instances.Cabal () where |
| 3 | + |
| 4 | +import Control.Applicative (liftA2) |
| 5 | +import Test.QuickCheck |
| 6 | + |
| 7 | +import Distribution.SPDX |
| 8 | +import Distribution.Version |
| 9 | +import Distribution.Types.VersionRange.Internal |
| 10 | + |
| 11 | +------------------------------------------------------------------------------- |
| 12 | +-- Version |
| 13 | +------------------------------------------------------------------------------- |
| 14 | + |
| 15 | +instance Arbitrary Version where |
| 16 | + arbitrary = do |
| 17 | + branch <- smallListOf1 $ |
| 18 | + frequency [(3, return 0) |
| 19 | + ,(3, return 1) |
| 20 | + ,(2, return 2) |
| 21 | + ,(2, return 3) |
| 22 | + ,(1, return 0xfffd) |
| 23 | + ,(1, return 0xfffe) -- max fitting into packed W64 |
| 24 | + ,(1, return 0xffff) |
| 25 | + ,(1, return 999999999) |
| 26 | + ,(1, return 0x10000)] |
| 27 | + return (mkVersion branch) |
| 28 | + where |
| 29 | + smallListOf1 = scale (\n -> min 6 (n `div` 3)) . listOf1 |
| 30 | + |
| 31 | + shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver) |
| 32 | + , not (null ns) ] |
| 33 | + |
| 34 | +instance Arbitrary VersionRange where |
| 35 | + arbitrary = sized verRangeExp |
| 36 | + where |
| 37 | + verRangeExp n = frequency $ |
| 38 | + [ (2, return anyVersion) |
| 39 | + , (1, fmap thisVersion arbitrary) |
| 40 | + , (1, fmap laterVersion arbitrary) |
| 41 | + , (1, fmap orLaterVersion arbitrary) |
| 42 | + , (1, fmap orLaterVersion' arbitrary) |
| 43 | + , (1, fmap earlierVersion arbitrary) |
| 44 | + , (1, fmap orEarlierVersion arbitrary) |
| 45 | + , (1, fmap orEarlierVersion' arbitrary) |
| 46 | + , (1, fmap withinVersion arbitrary) |
| 47 | + , (1, fmap majorBoundVersion arbitrary) |
| 48 | + , (2, fmap VersionRangeParens arbitrary) |
| 49 | + ] ++ if n == 0 then [] else |
| 50 | + [ (2, liftA2 unionVersionRanges verRangeExp2 verRangeExp2) |
| 51 | + , (2, liftA2 intersectVersionRanges verRangeExp2 verRangeExp2) |
| 52 | + ] |
| 53 | + where |
| 54 | + verRangeExp2 = verRangeExp (n `div` 2) |
| 55 | + |
| 56 | + orLaterVersion' v = |
| 57 | + unionVersionRanges (LaterVersion v) (ThisVersion v) |
| 58 | + orEarlierVersion' v = |
| 59 | + unionVersionRanges (EarlierVersion v) (ThisVersion v) |
| 60 | + |
| 61 | + shrink AnyVersion = [] |
| 62 | + shrink (ThisVersion v) = map ThisVersion (shrink v) |
| 63 | + shrink (LaterVersion v) = map LaterVersion (shrink v) |
| 64 | + shrink (EarlierVersion v) = map EarlierVersion (shrink v) |
| 65 | + shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v) |
| 66 | + shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v) |
| 67 | + shrink (WildcardVersion v) = map WildcardVersion ( shrink v) |
| 68 | + shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v) |
| 69 | + shrink (VersionRangeParens vr) = vr : map VersionRangeParens (shrink vr) |
| 70 | + shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b)) |
| 71 | + shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b)) |
| 72 | + |
| 73 | +-- | Generating VersionIntervals |
| 74 | +-- |
| 75 | +-- This is a tad tricky as VersionIntervals is an abstract type, so we first |
| 76 | +-- make a local type for generating the internal representation. Then we check |
| 77 | +-- that this lets us construct valid 'VersionIntervals'. |
| 78 | +-- |
| 79 | + |
| 80 | +instance Arbitrary VersionIntervals where |
| 81 | + arbitrary = fmap mkVersionIntervals' arbitrary |
| 82 | + where |
| 83 | + mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals |
| 84 | + mkVersionIntervals' = mkVersionIntervals . go version0 |
| 85 | + where |
| 86 | + go :: Version -> [(Version, Bound)] -> [VersionInterval] |
| 87 | + go _ [] = [] |
| 88 | + go v [(lv, lb)] = |
| 89 | + [(LowerBound (addVersion lv v) lb, NoUpperBound)] |
| 90 | + go v ((lv, lb) : (uv, ub) : rest) = |
| 91 | + (LowerBound lv' lb, UpperBound uv' ub) : go uv' rest |
| 92 | + where |
| 93 | + lv' = addVersion v lv |
| 94 | + uv' = addVersion lv' uv |
| 95 | + |
| 96 | + addVersion :: Version -> Version -> Version |
| 97 | + addVersion xs ys = mkVersion $ z (versionNumbers xs) (versionNumbers ys) |
| 98 | + where |
| 99 | + z [] ys' = ys' |
| 100 | + z xs' [] = xs' |
| 101 | + z (x : xs') (y : ys') = x + y : z xs' ys' |
| 102 | + |
| 103 | +instance Arbitrary Bound where |
| 104 | + arbitrary = elements [ExclusiveBound, InclusiveBound] |
| 105 | + |
| 106 | +------------------------------------------------------------------------------- |
| 107 | +-- SPDX |
| 108 | +------------------------------------------------------------------------------- |
| 109 | + |
| 110 | +instance Arbitrary LicenseId where |
| 111 | + arbitrary = elements $ licenseIdList LicenseListVersion_3_6 |
| 112 | + |
| 113 | +instance Arbitrary LicenseExceptionId where |
| 114 | + arbitrary = elements $ licenseExceptionIdList LicenseListVersion_3_6 |
| 115 | + |
| 116 | +instance Arbitrary LicenseRef where |
| 117 | + arbitrary = mkLicenseRef' <$> ids' <*> ids |
| 118 | + where |
| 119 | + ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-" |
| 120 | + ids' = oneof [ pure Nothing, Just <$> ids ] |
| 121 | + |
| 122 | +instance Arbitrary SimpleLicenseExpression where |
| 123 | + arbitrary = oneof |
| 124 | + [ ELicenseId <$> arbitrary |
| 125 | + , ELicenseIdPlus <$> arbitrary |
| 126 | + , ELicenseRef <$> arbitrary |
| 127 | + ] |
| 128 | + |
| 129 | +instance Arbitrary LicenseExpression where |
| 130 | + arbitrary = sized arb |
| 131 | + where |
| 132 | + arb n |
| 133 | + | n <= 0 = ELicense <$> arbitrary <*> pure Nothing |
| 134 | + | otherwise = oneof |
| 135 | + [ ELicense <$> arbitrary <*> arbitrary |
| 136 | + , EAnd <$> arbA <*> arbB |
| 137 | + , EOr <$> arbA <*> arbB |
| 138 | + ] |
| 139 | + where |
| 140 | + m = n `div` 2 |
| 141 | + arbA = arb m |
| 142 | + arbB = arb (n - m) |
| 143 | + |
| 144 | + shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b)) |
| 145 | + shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b)) |
| 146 | + shrink _ = [] |
| 147 | + |
0 commit comments