From ee93371deb1b663f42d45bf598e81ae2cdfb30f2 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 24 Feb 2020 21:06:46 +0200 Subject: [PATCH] Split QuickCheck instances into separate directory ... which may become a package we upload --- Cabal/Cabal-quickcheck/Cabal-quickcheck.cabal | 18 +++ .../src/Test/QuickCheck/Instances/Cabal.hs | 147 ++++++++++++++++++ Cabal/Cabal.cabal | 6 + Cabal/tests/UnitTests/Distribution/SPDX.hs | 47 +----- Cabal/tests/UnitTests/Distribution/Version.hs | 99 +----------- cabal.project | 2 + 6 files changed, 178 insertions(+), 141 deletions(-) create mode 100644 Cabal/Cabal-quickcheck/Cabal-quickcheck.cabal create mode 100644 Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs diff --git a/Cabal/Cabal-quickcheck/Cabal-quickcheck.cabal b/Cabal/Cabal-quickcheck/Cabal-quickcheck.cabal new file mode 100644 index 00000000000..ca30e085afd --- /dev/null +++ b/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 diff --git a/Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs new file mode 100644 index 00000000000..cb2c1ad402f --- /dev/null +++ b/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 _ = [] + diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 3122f2168c1..a992a58672c 100644 --- a/Cabal/Cabal.cabal +++ b/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, diff --git a/Cabal/tests/UnitTests/Distribution/SPDX.hs b/Cabal/tests/UnitTests/Distribution/SPDX.hs index c1cf95df56e..1e605a40340 100644 --- a/Cabal/tests/UnitTests/Distribution/SPDX.hs +++ b/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 _ = [] - diff --git a/Cabal/tests/UnitTests/Distribution/Version.hs b/Cabal/tests/UnitTests/Distribution/Version.hs index 4551145e84b..c308b749ea3 100644 --- a/Cabal/tests/UnitTests/Distribution/Version.hs +++ b/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. -- diff --git a/cabal.project b/cabal.project index e041cc34b9c..353d0fcb6e5 100644 --- a/cabal.project +++ b/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: */