Skip to content

Commit 9964e05

Browse files
phadejphadej
committed
Split QuickCheck instances into separate directory
... which may become a package we upload
1 parent 24e3b9b commit 9964e05

File tree

6 files changed

+183
-141
lines changed

6 files changed

+183
-141
lines changed

‎Cabal/Cabal-quickcheck/Cabal-quickcheck.cabal

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
cabal-version: 2.2
2+
name: Cabal-quickcheck
3+
version: 3.3.0.0
4+
synopsis: QuickCheck instances for types in Cabal
5+
category: Testing
6+
description:
7+
Provides QuickCheck Arbitrary instances for some types in Cabal
8+
9+
library
10+
default-language: Haskell2010
11+
hs-source-dirs: src
12+
ghc-options: -Wall
13+
build-depends:
14+
, base
15+
, Cabal ^>=3.3.0.0
16+
, QuickCheck ^>=2.13.2
17+
18+
exposed-modules: Test.QuickCheck.Instances.Cabal

‎Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs

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

‎Cabal/Cabal.cabal

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -628,6 +628,12 @@ test-suite unit-tests
628628
UnitTests.Distribution.Version
629629
UnitTests.Distribution.PkgconfigVersion
630630
UnitTests.Orphans
631+
632+
-- Cabal-quickcheck
633+
hs-source-dirs: Cabal-quickcheck/src
634+
other-modules:
635+
Test.QuickCheck.Instances.Cabal
636+
631637
main-is: UnitTests.hs
632638
build-depends:
633639
array,

‎Cabal/tests/UnitTests/Distribution/SPDX.hs

Lines changed: 3 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
{-# LANGUAGE CPP #-}
2-
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
2+
{-# OPTIONS_GHC -fno-warn-deprecations #-}
33
module UnitTests.Distribution.SPDX (spdxTests) where
44

55
import Distribution.Compat.Prelude.Internal
@@ -20,6 +20,8 @@ import qualified Data.ByteString.Lazy as LBS
2020
import GHC.Generics (to, from)
2121
#endif
2222

23+
import Test.QuickCheck.Instances.Cabal ()
24+
2325
spdxTests :: [TestTree]
2426
spdxTests =
2527
[ testProperty "LicenseId roundtrip" licenseIdRoundtrip
@@ -176,46 +178,3 @@ shouldAcceptProp = conjoin $
176178
shouldRejectProp :: Property
177179
shouldRejectProp = conjoin $
178180
map (\l -> counterexample (prettyShow l) (not $ isAcceptableLicense l)) shouldReject
179-
180-
-------------------------------------------------------------------------------
181-
-- Instances
182-
-------------------------------------------------------------------------------
183-
184-
instance Arbitrary LicenseId where
185-
arbitrary = elements $ licenseIdList LicenseListVersion_3_6
186-
187-
instance Arbitrary LicenseExceptionId where
188-
arbitrary = elements $ licenseExceptionIdList LicenseListVersion_3_6
189-
190-
instance Arbitrary LicenseRef where
191-
arbitrary = mkLicenseRef' <$> ids' <*> ids
192-
where
193-
ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-"
194-
ids' = oneof [ pure Nothing, Just <$> ids ]
195-
196-
instance Arbitrary SimpleLicenseExpression where
197-
arbitrary = oneof
198-
[ ELicenseId <$> arbitrary
199-
, ELicenseIdPlus <$> arbitrary
200-
, ELicenseRef <$> arbitrary
201-
]
202-
203-
instance Arbitrary LicenseExpression where
204-
arbitrary = sized arb
205-
where
206-
arb n
207-
| n <= 0 = ELicense <$> arbitrary <*> pure Nothing
208-
| otherwise = oneof
209-
[ ELicense <$> arbitrary <*> arbitrary
210-
, EAnd <$> arbA <*> arbB
211-
, EOr <$> arbA <*> arbB
212-
]
213-
where
214-
m = n `div` 2
215-
arbA = arb m
216-
arbB = arb (n - m)
217-
218-
shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b))
219-
shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b))
220-
shrink _ = []
221-

‎Cabal/tests/UnitTests/Distribution/Version.hs

Lines changed: 2 additions & 97 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,5 @@
11
{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}
2-
{-# OPTIONS_GHC -fno-warn-orphans
3-
-fno-warn-incomplete-patterns
2+
{-# OPTIONS_GHC -fno-warn-incomplete-patterns
43
-fno-warn-deprecations
54
-fno-warn-unused-binds #-} --FIXME
65
module UnitTests.Distribution.Version (versionTests) where
@@ -22,7 +21,7 @@ import Test.Tasty
2221
import Test.Tasty.QuickCheck
2322
import qualified Test.Laws as Laws
2423

25-
import Test.QuickCheck.Utils
24+
import Test.QuickCheck.Instances.Cabal ()
2625

2726
import Data.Maybe (fromJust)
2827
import Data.Function (on)
@@ -131,24 +130,6 @@ versionTests =
131130
-- -- , property prop_parse_disp5
132131
-- ]
133132

134-
instance Arbitrary Version where
135-
arbitrary = do
136-
branch <- smallListOf1 $
137-
frequency [(3, return 0)
138-
,(3, return 1)
139-
,(2, return 2)
140-
,(2, return 3)
141-
,(1, return 0xfffd)
142-
,(1, return 0xfffe) -- max fitting into packed W64
143-
,(1, return 0xffff)
144-
,(1, return 0x10000)]
145-
return (mkVersion branch)
146-
where
147-
smallListOf1 = adjustSize (\n -> min 6 (n `div` 3)) . listOf1
148-
149-
shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver)
150-
, not (null ns) ]
151-
152133
newtype VersionArb = VersionArb [Int]
153134
deriving (Eq,Ord,Show)
154135

@@ -170,45 +151,6 @@ instance Arbitrary VersionArb where
170151
, all (>=0) xs'
171152
]
172153

173-
instance Arbitrary VersionRange where
174-
arbitrary = sized verRangeExp
175-
where
176-
verRangeExp n = frequency $
177-
[ (2, return anyVersion)
178-
, (1, liftM thisVersion arbitrary)
179-
, (1, liftM laterVersion arbitrary)
180-
, (1, liftM orLaterVersion arbitrary)
181-
, (1, liftM orLaterVersion' arbitrary)
182-
, (1, liftM earlierVersion arbitrary)
183-
, (1, liftM orEarlierVersion arbitrary)
184-
, (1, liftM orEarlierVersion' arbitrary)
185-
, (1, liftM withinVersion arbitrary)
186-
, (1, liftM majorBoundVersion arbitrary)
187-
, (2, liftM VersionRangeParens arbitrary)
188-
] ++ if n == 0 then [] else
189-
[ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2)
190-
, (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
191-
]
192-
where
193-
verRangeExp2 = verRangeExp (n `div` 2)
194-
195-
orLaterVersion' v =
196-
unionVersionRanges (LaterVersion v) (ThisVersion v)
197-
orEarlierVersion' v =
198-
unionVersionRanges (EarlierVersion v) (ThisVersion v)
199-
200-
shrink AnyVersion = []
201-
shrink (ThisVersion v) = map ThisVersion (shrink v)
202-
shrink (LaterVersion v) = map LaterVersion (shrink v)
203-
shrink (EarlierVersion v) = map EarlierVersion (shrink v)
204-
shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v)
205-
shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v)
206-
shrink (WildcardVersion v) = map WildcardVersion ( shrink v)
207-
shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v)
208-
shrink (VersionRangeParens vr) = vr : map VersionRangeParens (shrink vr)
209-
shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
210-
shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))
211-
212154
---------------------
213155
-- Version properties
214156
--
@@ -415,43 +357,6 @@ prop_simplifyVersionRange2'' r r' =
415357
|| isNoVersion r
416358
|| isNoVersion r'
417359

418-
--------------------
419-
-- VersionIntervals
420-
--
421-
422-
-- | Generating VersionIntervals
423-
--
424-
-- This is a tad tricky as VersionIntervals is an abstract type, so we first
425-
-- make a local type for generating the internal representation. Then we check
426-
-- that this lets us construct valid 'VersionIntervals'.
427-
--
428-
429-
instance Arbitrary VersionIntervals where
430-
arbitrary = fmap mkVersionIntervals' arbitrary
431-
where
432-
mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals
433-
mkVersionIntervals' = mkVersionIntervals . go version0
434-
where
435-
go :: Version -> [(Version, Bound)] -> [VersionInterval]
436-
go _ [] = []
437-
go v [(lv, lb)] =
438-
[(LowerBound (addVersion lv v) lb, NoUpperBound)]
439-
go v ((lv, lb) : (uv, ub) : rest) =
440-
(LowerBound lv' lb, UpperBound uv' ub) : go uv' rest
441-
where
442-
lv' = addVersion v lv
443-
uv' = addVersion lv' uv
444-
445-
addVersion :: Version -> Version -> Version
446-
addVersion xs ys = mkVersion $ z (versionNumbers xs) (versionNumbers ys)
447-
where
448-
z [] ys' = ys'
449-
z xs' [] = xs'
450-
z (x : xs') (y : ys') = x + y : z xs' ys'
451-
452-
instance Arbitrary Bound where
453-
arbitrary = elements [ExclusiveBound, InclusiveBound]
454-
455360
-- | Check that our VersionIntervals' arbitrary instance generates intervals
456361
-- that satisfies the invariant.
457362
--

‎cabal.project

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@ packages: Cabal/ cabal-testsuite/
22
packages: cabal-install/ solver-benchmarks/
33
tests: True
44

5+
packages: Cabal/Cabal-quickcheck/
6+
57
-- Uncomment to allow picking up extra local unpacked deps:
68
--optional-packages: */
79

0 commit comments

Comments
 (0)