Split QuickCheck instances into separate directory

... which may become a package we upload

Cabal/Cabal-quickcheck/Cabal-quickcheck.cabal

@@ -0,0 +1,18 @@
+cabal-version: 2.2
+name:          Cabal-quickcheck
+version:       3.3.0.0
+synopsis:      QuickCheck instances for types in Cabal
+category:      Testing
+description:
+  Provides QuickCheck Arbitrary instances for some types in Cabal
+
+library
+  default-language: Haskell2010
+  hs-source-dirs:   src
+  ghc-options:      -Wall
+  build-depends:
+    , base
+    , Cabal       ^>=3.3.0.0
+    , QuickCheck  ^>=2.13.2
+
+  exposed-modules:  Test.QuickCheck.Instances.Cabal

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

@@ -0,0 +1,147 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Test.QuickCheck.Instances.Cabal () where
+
+import Control.Applicative (liftA2)
+import Test.QuickCheck
+
+import Distribution.SPDX
+import Distribution.Version
+import Distribution.Types.VersionRange.Internal
+
+-------------------------------------------------------------------------------
+-- Version
+-------------------------------------------------------------------------------
+
+instance Arbitrary Version where
+  arbitrary = do
+      branch <- smallListOf1 $
+                  frequency [(3, return 0)
+                            ,(3, return 1)
+                            ,(2, return 2)
+                            ,(2, return 3)
+                            ,(1, return 0xfffd)
+                            ,(1, return 0xfffe) -- max fitting into packed W64
+                            ,(1, return 0xffff)
+                            ,(1, return 999999999)
+                            ,(1, return 0x10000)]
+      return (mkVersion branch)
+    where
+      smallListOf1 = scale (\n -> min 6 (n `div` 3)) . listOf1
+
+  shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver)
+                              , not (null ns) ]
+
+instance Arbitrary VersionRange where
+  arbitrary = sized verRangeExp
+    where
+      verRangeExp n = frequency $
+        [ (2, return anyVersion)
+        , (1, fmap thisVersion arbitrary)
+        , (1, fmap laterVersion arbitrary)
+        , (1, fmap orLaterVersion arbitrary)
+        , (1, fmap orLaterVersion' arbitrary)
+        , (1, fmap earlierVersion arbitrary)
+        , (1, fmap orEarlierVersion arbitrary)
+        , (1, fmap orEarlierVersion' arbitrary)
+        , (1, fmap withinVersion arbitrary)
+        , (1, fmap majorBoundVersion arbitrary)
+        , (2, fmap VersionRangeParens arbitrary)
+        ] ++ if n == 0 then [] else
+        [ (2, liftA2 unionVersionRanges     verRangeExp2 verRangeExp2)
+        , (2, liftA2 intersectVersionRanges verRangeExp2 verRangeExp2)
+        ]
+        where
+          verRangeExp2 = verRangeExp (n `div` 2)
+
+      orLaterVersion'   v =
+        unionVersionRanges (LaterVersion v)   (ThisVersion v)
+      orEarlierVersion' v =
+        unionVersionRanges (EarlierVersion v) (ThisVersion v)
+
+  shrink AnyVersion                   = []
+  shrink (ThisVersion v)              = map ThisVersion (shrink v)
+  shrink (LaterVersion v)             = map LaterVersion (shrink v)
+  shrink (EarlierVersion v)           = map EarlierVersion (shrink v)
+  shrink (OrLaterVersion v)           = LaterVersion v : map OrLaterVersion (shrink v)
+  shrink (OrEarlierVersion v)         = EarlierVersion v : map OrEarlierVersion (shrink v)
+  shrink (WildcardVersion v)          = map WildcardVersion ( shrink v)
+  shrink (MajorBoundVersion v)        = map MajorBoundVersion (shrink v)
+  shrink (VersionRangeParens vr)      = vr : map VersionRangeParens (shrink vr)
+  shrink (UnionVersionRanges a b)     = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
+  shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))
+
+-- | Generating VersionIntervals
+--
+-- This is a tad tricky as VersionIntervals is an abstract type, so we first
+-- make a local type for generating the internal representation. Then we check
+-- that this lets us construct valid 'VersionIntervals'.
+--
+
+instance Arbitrary VersionIntervals where
+  arbitrary = fmap mkVersionIntervals' arbitrary
+    where
+      mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals
+      mkVersionIntervals' = mkVersionIntervals . go version0
+        where
+          go :: Version -> [(Version, Bound)] -> [VersionInterval]
+          go _ [] = []
+          go v [(lv, lb)] =
+              [(LowerBound (addVersion lv v) lb, NoUpperBound)]
+          go v ((lv, lb) : (uv, ub) : rest) =
+              (LowerBound lv' lb, UpperBound uv' ub) : go uv' rest
+            where
+              lv' = addVersion v lv
+              uv' = addVersion lv' uv
+
+          addVersion :: Version -> Version -> Version
+          addVersion xs ys = mkVersion $  z (versionNumbers xs) (versionNumbers ys)
+            where
+              z [] ys' = ys'
+              z xs' [] = xs'
+              z (x : xs') (y : ys') = x + y : z xs' ys'
+
+instance Arbitrary Bound where
+  arbitrary = elements [ExclusiveBound, InclusiveBound]
+
+-------------------------------------------------------------------------------
+-- SPDX
+-------------------------------------------------------------------------------
+
+instance Arbitrary LicenseId where
+    arbitrary = elements $ licenseIdList LicenseListVersion_3_6
+
+instance Arbitrary LicenseExceptionId where
+    arbitrary = elements $ licenseExceptionIdList LicenseListVersion_3_6
+
+instance Arbitrary LicenseRef where
+    arbitrary = mkLicenseRef' <$> ids' <*> ids
+      where
+        ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-"
+        ids' = oneof [ pure Nothing, Just <$> ids ]
+
+instance Arbitrary SimpleLicenseExpression where
+    arbitrary = oneof
+        [ ELicenseId <$> arbitrary
+        , ELicenseIdPlus <$> arbitrary
+        , ELicenseRef <$> arbitrary
+        ]
+
+instance Arbitrary LicenseExpression where
+    arbitrary = sized arb
+      where
+        arb n
+            | n <= 0     = ELicense <$> arbitrary <*> pure Nothing
+            | otherwise = oneof
+                [ ELicense <$> arbitrary <*> arbitrary
+                , EAnd <$> arbA <*> arbB
+                , EOr <$> arbA <*> arbB
+                ]
+              where
+                m = n `div` 2
+                arbA = arb m
+                arbB = arb (n - m)
+
+    shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b))
+    shrink (EOr a b)  = a : b : map (uncurry EOr) (shrink (a, b))
+    shrink _          = []
+

Cabal/Cabal.cabal

@@ -628,6 +628,12 @@ test-suite unit-tests
     UnitTests.Distribution.Version
     UnitTests.Distribution.PkgconfigVersion
     UnitTests.Orphans
+
+  -- Cabal-quickcheck
+  hs-source-dirs: Cabal-quickcheck/src
+  other-modules:
+    Test.QuickCheck.Instances.Cabal
+
   main-is: UnitTests.hs
   build-depends:
     array,

Cabal/tests/UnitTests/Distribution/SPDX.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
 module UnitTests.Distribution.SPDX (spdxTests) where
 
 import Distribution.Compat.Prelude.Internal
@@ -20,6 +20,8 @@ import qualified Data.ByteString.Lazy as LBS
 import GHC.Generics (to, from)
 #endif
 
+import Test.QuickCheck.Instances.Cabal ()
+
 spdxTests :: [TestTree]
 spdxTests =
     [ testProperty "LicenseId roundtrip" licenseIdRoundtrip
@@ -176,46 +178,3 @@ shouldAcceptProp = conjoin $
 shouldRejectProp :: Property
 shouldRejectProp = conjoin $
     map (\l -> counterexample (prettyShow l) (not $ isAcceptableLicense l)) shouldReject
-
--------------------------------------------------------------------------------
--- Instances
--------------------------------------------------------------------------------
-
-instance Arbitrary LicenseId where
-    arbitrary = elements $ licenseIdList LicenseListVersion_3_6
-
-instance Arbitrary LicenseExceptionId where
-    arbitrary = elements $ licenseExceptionIdList LicenseListVersion_3_6
-
-instance Arbitrary LicenseRef where
-    arbitrary = mkLicenseRef' <$> ids' <*> ids
-      where
-        ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-"
-        ids' = oneof [ pure Nothing, Just <$> ids ]
-
-instance Arbitrary SimpleLicenseExpression where
-    arbitrary = oneof
-        [ ELicenseId <$> arbitrary
-        , ELicenseIdPlus <$> arbitrary
-        , ELicenseRef <$> arbitrary
-        ]
-
-instance Arbitrary LicenseExpression where
-    arbitrary = sized arb
-      where
-        arb n
-            | n <= 0     = ELicense <$> arbitrary <*> pure Nothing
-            | otherwise = oneof
-                [ ELicense <$> arbitrary <*> arbitrary
-                , EAnd <$> arbA <*> arbB
-                , EOr <$> arbA <*> arbB
-                ]
-              where
-                m = n `div` 2
-                arbA = arb m
-                arbB = arb (n - m)
-
-    shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b))
-    shrink (EOr a b)  = a : b : map (uncurry EOr) (shrink (a, b))
-    shrink _          = []
-

Cabal/tests/UnitTests/Distribution/Version.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}
-{-# OPTIONS_GHC -fno-warn-orphans
-                -fno-warn-incomplete-patterns
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns
                 -fno-warn-deprecations
                 -fno-warn-unused-binds #-} --FIXME
 module UnitTests.Distribution.Version (versionTests) where
@@ -22,7 +21,7 @@ import Test.Tasty
 import Test.Tasty.QuickCheck
 import qualified Test.Laws as Laws
 
-import Test.QuickCheck.Utils
+import Test.QuickCheck.Instances.Cabal ()
 
 import Data.Maybe (fromJust)
 import Data.Function (on)
@@ -131,24 +130,6 @@ versionTests =
 --     -- , property prop_parse_disp5
 --   ]
 
-instance Arbitrary Version where
-  arbitrary = do
-      branch <- smallListOf1 $
-                  frequency [(3, return 0)
-                            ,(3, return 1)
-                            ,(2, return 2)
-                            ,(2, return 3)
-                            ,(1, return 0xfffd)
-                            ,(1, return 0xfffe) -- max fitting into packed W64
-                            ,(1, return 0xffff)
-                            ,(1, return 0x10000)]
-      return (mkVersion branch)
-    where
-      smallListOf1 = adjustSize (\n -> min 6 (n `div` 3)) . listOf1
-
-  shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver)
-                              , not (null ns) ]
-
 newtype VersionArb = VersionArb [Int]
                    deriving (Eq,Ord,Show)
 
@@ -170,45 +151,6 @@ instance Arbitrary VersionArb where
     , all (>=0) xs'
     ]
 
-instance Arbitrary VersionRange where
-  arbitrary = sized verRangeExp
-    where
-      verRangeExp n = frequency $
-        [ (2, return anyVersion)
-        , (1, liftM thisVersion arbitrary)
-        , (1, liftM laterVersion arbitrary)
-        , (1, liftM orLaterVersion arbitrary)
-        , (1, liftM orLaterVersion' arbitrary)
-        , (1, liftM earlierVersion arbitrary)
-        , (1, liftM orEarlierVersion arbitrary)
-        , (1, liftM orEarlierVersion' arbitrary)
-        , (1, liftM withinVersion arbitrary)
-        , (1, liftM majorBoundVersion arbitrary)
-        , (2, liftM VersionRangeParens arbitrary)
-        ] ++ if n == 0 then [] else
-        [ (2, liftM2 unionVersionRanges     verRangeExp2 verRangeExp2)
-        , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
-        ]
-        where
-          verRangeExp2 = verRangeExp (n `div` 2)
-
-      orLaterVersion'   v =
-        unionVersionRanges (LaterVersion v)   (ThisVersion v)
-      orEarlierVersion' v =
-        unionVersionRanges (EarlierVersion v) (ThisVersion v)
-
-  shrink AnyVersion                   = []
-  shrink (ThisVersion v)              = map ThisVersion (shrink v)
-  shrink (LaterVersion v)             = map LaterVersion (shrink v)
-  shrink (EarlierVersion v)           = map EarlierVersion (shrink v)
-  shrink (OrLaterVersion v)           = LaterVersion v : map OrLaterVersion (shrink v)
-  shrink (OrEarlierVersion v)         = EarlierVersion v : map OrEarlierVersion (shrink v)
-  shrink (WildcardVersion v)          = map WildcardVersion ( shrink v)
-  shrink (MajorBoundVersion v)        = map MajorBoundVersion (shrink v)
-  shrink (VersionRangeParens vr)      = vr : map VersionRangeParens (shrink vr)
-  shrink (UnionVersionRanges a b)     = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
-  shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))
-
 ---------------------
 -- Version properties
 --
@@ -415,43 +357,6 @@ prop_simplifyVersionRange2'' r r' =
     || isNoVersion r
     || isNoVersion r'
 
---------------------
--- VersionIntervals
---
-
--- | Generating VersionIntervals
---
--- This is a tad tricky as VersionIntervals is an abstract type, so we first
--- make a local type for generating the internal representation. Then we check
--- that this lets us construct valid 'VersionIntervals'.
---
-
-instance Arbitrary VersionIntervals where
-  arbitrary = fmap mkVersionIntervals' arbitrary
-    where
-      mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals
-      mkVersionIntervals' = mkVersionIntervals . go version0
-        where
-          go :: Version -> [(Version, Bound)] -> [VersionInterval]
-          go _ [] = []
-          go v [(lv, lb)] =
-              [(LowerBound (addVersion lv v) lb, NoUpperBound)]
-          go v ((lv, lb) : (uv, ub) : rest) =
-              (LowerBound lv' lb, UpperBound uv' ub) : go uv' rest
-            where
-              lv' = addVersion v lv
-              uv' = addVersion lv' uv
-
-          addVersion :: Version -> Version -> Version
-          addVersion xs ys = mkVersion $  z (versionNumbers xs) (versionNumbers ys)
-            where
-              z [] ys' = ys'
-              z xs' [] = xs'
-              z (x : xs') (y : ys') = x + y : z xs' ys'
-
-instance Arbitrary Bound where
-  arbitrary = elements [ExclusiveBound, InclusiveBound]
-
 -- | Check that our VersionIntervals' arbitrary instance generates intervals
 -- that satisfies the invariant.
 --

cabal.project

@@ -2,6 +2,8 @@ packages: Cabal/ cabal-testsuite/
 packages: cabal-install/ solver-benchmarks/
 tests: True
 
+packages: Cabal/Cabal-quickcheck/
+
 -- Uncomment to allow picking up extra local unpacked deps:
 --optional-packages: */