diff --git a/QuickCheck.cabal b/QuickCheck.cabal --- a/QuickCheck.cabal +++ b/QuickCheck.cabal @@ -1,5 +1,5 @@ Name: QuickCheck -Version: 2.16.0.0 +Version: 2.17.0.0 Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 @@ -8,9 +8,7 @@ Author: Koen Claessen Maintainer: Nick Smallbone Bug-reports: https://github.com/nick8325/quickcheck/issues -Tested-with: GHC == 7.10.3 || - == 8.0.2 || - >= 8.2.2 && < 9.11 +Tested-with: GHC >= 8.10 && < 9.13, hugs Homepage: https://github.com/nick8325/quickcheck Category: Testing Synopsis: Automatic testing of Haskell programs @@ -51,6 +49,7 @@ examples/Simple.hs make-hugs test-hugs + test-mhs source-repository head type: git @@ -73,7 +72,7 @@ library Hs-source-dirs: src - Build-depends: base >=4.3 && <5, containers + Build-depends: base >=4.9 && <5, containers Default-language: Haskell2010 -- New vs old random. @@ -114,57 +113,41 @@ Test.QuickCheck.Features -- GHC-specific modules. - if impl(ghc) + if impl(ghc) || impl(mhs) Exposed-Modules: Test.QuickCheck.Function Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0 - else - cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ if impl(ghc) && flag(templateHaskell) Build-depends: template-haskell >= 2.4 - if impl(ghc >=8.0) - Other-Extensions: TemplateHaskellQuotes - else - Other-Extensions: TemplateHaskell + Other-Extensions: TemplateHaskellQuotes Exposed-Modules: Test.QuickCheck.All else cpp-options: -DNO_TEMPLATE_HASKELL - if !impl(ghc >= 8.0) - cpp-options: -DNO_CALLSTACK -DNO_SEMIGROUP - - if !impl(ghc >= 7.4) - cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS - - -- The new generics appeared in GHC 7.2... - if impl(ghc < 7.2) - cpp-options: -DNO_GENERICS - -- ...but in 7.2-7.4 it lives in the ghc-prim package. - if impl(ghc >= 7.2) && impl(ghc < 7.6) - Build-depends: ghc-prim - - -- Safe Haskell appeared in GHC 7.2, but GHC.Generics isn't safe until 7.4. - if impl (ghc < 7.4) - cpp-options: -DNO_SAFE_HASKELL + if !impl(ghc) && !impl(mhs) + cpp-options: -DNO_CALLSTACK + -DNO_SEMIGROUP + -DNO_CTYPES_CONSTRUCTORS + -DNO_FOREIGN_C_USECONDS + -DNO_POLYKINDS + -DNO_MONADFAIL + -DNO_TRANSFORMERS + -DNO_DEEPSEQ -- random is explicitly Trustworthy since 1.0.1.0 -- similar constraint for containers - if impl(ghc >= 7.2) + if impl(ghc) Build-depends: random >=1.0.1.0 - if impl(ghc >= 7.4) - Build-depends: containers >=0.4.2.1 - - if !impl(ghc >= 7.6) - cpp-options: -DNO_POLYKINDS - - if !impl(ghc >= 8.0) - cpp-options: -DNO_MONADFAIL + , containers >=0.4.2.1 if impl(ghc >= 9.8) ghc-options: -Wno-x-partial + if impl(ghc < 9.4) + Build-depends: data-array-byte + -- Switch off most optional features on non-GHC systems. - if !impl(ghc) + if !impl(ghc) && !impl(mhs) -- If your Haskell compiler can cope without some of these, please -- send a message to the QuickCheck mailing list! cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS @@ -173,17 +156,14 @@ if !impl(hugs) && !impl(uhc) cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES + if impl(mhs) + cpp-options: -DNO_GENERICS -DNO_TEMPLATE_HASKELL -DNO_CTYPES_CONSTRUCTORS + -DNO_EXISTENTIAL_FIELD_SELECTORS + -- LANGUAGE pragmas don't have any effect in Hugs. if impl(hugs) Default-Extensions: CPP - if impl(uhc) - -- Cabal under UHC needs pointing out all the dependencies of the - -- random package. - Build-depends: old-time, old-locale - -- Plus some bits of the standard library are missing. - cpp-options: -DNO_FIXED -DNO_EXCEPTIONS - Test-Suite test-quickcheck type: exitcode-stdio-1.0 Default-language: Haskell2010 @@ -200,10 +180,8 @@ hs-source-dirs: tests main-is: GCoArbitraryExample.hs build-depends: base, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.2) + if !flag(templateHaskell) buildable: False - if impl(ghc >= 7.2) && impl(ghc < 7.6) - build-depends: ghc-prim Test-Suite test-quickcheck-generators type: exitcode-stdio-1.0 @@ -220,10 +198,8 @@ hs-source-dirs: tests main-is: GShrinkExample.hs build-depends: base, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.2) + if !flag(templateHaskell) buildable: False - if impl(ghc >= 7.2) && impl(ghc < 7.6) - build-depends: ghc-prim Test-Suite test-quickcheck-terminal type: exitcode-stdio-1.0 @@ -231,7 +207,7 @@ hs-source-dirs: tests main-is: Terminal.hs build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-monadfix @@ -240,7 +216,7 @@ hs-source-dirs: tests main-is: MonadFix.hs build-depends: base, QuickCheck - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-split @@ -258,7 +234,7 @@ hs-source-dirs: tests main-is: Strictness.hs build-depends: base, QuickCheck, containers - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-misc @@ -267,7 +243,7 @@ hs-source-dirs: tests main-is: Misc.hs build-depends: base, QuickCheck, containers - if !flag(templateHaskell) || !impl(ghc >= 7.10) + if !flag(templateHaskell) buildable: False Test-Suite test-quickcheck-discard @@ -283,10 +259,6 @@ hs-source-dirs: tests main-is: Monoids.hs build-depends: base, QuickCheck - if !impl(ghc >= 8.4) - cpp-options: -DNO_SEMIGROUP_SUPERCLASS - if !impl(ghc >= 8.0) - cpp-options: -DNO_SEMIGROUP_CLASS Test-Suite test-quickcheck-withprogress type: exitcode-stdio-1.0 @@ -294,3 +266,20 @@ hs-source-dirs: tests main-is: WithProgress.hs build-depends: base, QuickCheck + +Test-Suite test-quickcheck-instances + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + hs-source-dirs: tests + other-modules: CollectDataTypes + main-is: RunCollectDataTypes.hs + build-depends: + base, + QuickCheck, + transformers, + split, + process, + template-haskell, + hint + if !flag(templateHaskell) || impl(ghc <= 8.10) + buildable: False diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +QuickCheck 2.17 + * Lower the memory use of `arbitrary` for `Double` and `Float` (thanks + ChickenProp) + * BREAKING: Remove `Gen.Class` + * BREAKING: Add `Arbitrary` instances for most of the types in `base` + * Add microHS support (thanks Lennart) + QuickCheck 2.16 * Add a `Safe` declaration to `Test.QuickCheck.Monoids` * Fix `Test.QuickCheck.Features` to not depend on the internal testing loop diff --git a/src/Test/QuickCheck/All.hs b/src/Test/QuickCheck/All.hs --- a/src/Test/QuickCheck/All.hs +++ b/src/Test/QuickCheck/All.hs @@ -20,6 +20,7 @@ verboseCheckAll, forAllProperties, allProperties, + runQuickCheckAll, -- ** Testing polymorphic properties polyQuickCheck, polyVerboseCheck, diff --git a/src/Test/QuickCheck/Arbitrary.hs b/src/Test/QuickCheck/Arbitrary.hs --- a/src/Test/QuickCheck/Arbitrary.hs +++ b/src/Test/QuickCheck/Arbitrary.hs @@ -89,10 +89,20 @@ import Control.Applicative import Data.Foldable(toList) +#if MIN_VERSION_random(1,3,0) +import System.Random(Random, uniformByteArray) +#else import System.Random(Random) +#endif import Test.QuickCheck.Gen import Test.QuickCheck.Random import Test.QuickCheck.Gen.Unsafe +#if defined(__MHS__) +-- These two are not exported by Control.Applicative. +-- Why should they be? They are just bloat. +import Data.ZipList +import Control.WrappedMonad +#endif {- import Data.Generics @@ -136,16 +146,25 @@ , nub ) + import Data.Version (Version (..)) #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) +import Numeric.Natural + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + import System.IO ( Newline(..) , NewlineMode(..) + , SeekMode(..) + , BufferMode(..) + , TextEncoding + , latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 + , IOMode(..) ) #endif -#endif import Control.Monad ( liftM @@ -175,7 +194,6 @@ #endif import qualified Data.Sequence as Sequence import qualified Data.Tree as Tree -import Data.Bits import qualified Data.Monoid as Monoid @@ -186,6 +204,30 @@ import Data.Functor.Product #endif +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,16,0) +--import Data.Type.Ord +#endif + +import qualified Data.Semigroup as Semigroup +import Data.Ord + +import System.Console.GetOpt + ( ArgDescr(..), ArgOrder(..), OptDescr(..) ) + +import Data.Functor.Contravariant + +import Data.Array.Byte +import qualified GHC.Exts as Exts + +#if MIN_VERSION_base(4,16,0) +import Data.Tuple +#endif +#endif + +import Data.Bits +import Text.Printf + -------------------------------------------------------------------------- -- ** class Arbitrary @@ -493,14 +535,16 @@ xs1 = take k xs xs2 = drop k xs -{- - -- "standard" definition for lists: - shrink [] = [] - shrink (x:xs) = [ xs ] - ++ [ x:xs' | xs' <- shrink xs ] - ++ [ x':xs | x' <- shrink x ] --} +#if defined(MIN_VERSION_base) +instance Arbitrary1 NonEmpty where + liftArbitrary arb = NonEmpty.fromList <$> listOf1 arb + liftShrink shr xs = [ NonEmpty.fromList xs' | xs' <- liftShrink shr (NonEmpty.toList xs), not (null xs') ] +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = arbitrary1 + shrink = shrink1 +#endif + instance Integral a => Arbitrary (Ratio a) where arbitrary = sized $ \ n -> do denom <- chooseInt (1, max 1 n) @@ -513,7 +557,8 @@ pure $ fromI numer % fromI denom shrink = shrinkRealFrac -#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) + +#if defined(MIN_VERSION_base) instance Arbitrary a => Arbitrary (Complex a) where #else instance (RealFloat a, Arbitrary a) => Arbitrary (Complex a) where @@ -645,6 +690,12 @@ arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral +#if defined(MIN_VERSION_base) +instance Arbitrary Natural where + arbitrary = arbitrarySizedNatural + shrink = shrinkIntegral +#endif + instance Arbitrary Int where arbitrary = arbitrarySizedIntegral shrink = shrinkIntegral @@ -722,7 +773,7 @@ ] where smallDenominators = sized $ \n -> do - i <- chooseInt (0, n) + i <- chooseInt (0, min n 256) pure (fromRational (streamNth i rationalUniverse)) uniform = sized $ \n -> do @@ -748,7 +799,7 @@ ] where smallDenominators = sized $ \n -> do - i <- chooseInt (0, n) + i <- chooseInt (0, min n 256) pure (fromRational (streamNth i rationalUniverse)) uniform = sized $ \n -> do @@ -1020,7 +1071,6 @@ shrink = map Monoid.Product . shrink . Monoid.getProduct #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) instance Arbitrary a => Arbitrary (Monoid.First a) where arbitrary = fmap Monoid.First arbitrary shrink = map Monoid.First . shrink . Monoid.getFirst @@ -1028,15 +1078,170 @@ instance Arbitrary a => Arbitrary (Monoid.Last a) where arbitrary = fmap Monoid.Last arbitrary shrink = map Monoid.Last . shrink . Monoid.getLast -#endif -#if MIN_VERSION_base(4,8,0) instance Arbitrary (f a) => Arbitrary (Monoid.Alt f a) where arbitrary = fmap Monoid.Alt arbitrary shrink = map Monoid.Alt . shrink . Monoid.getAlt + +instance Arbitrary a => Arbitrary (Semigroup.Min a) where + arbitrary = fmap Semigroup.Min arbitrary + shrink = map Semigroup.Min . shrink . Semigroup.getMin + +instance Arbitrary a => Arbitrary (Semigroup.Max a) where + arbitrary = fmap Semigroup.Max arbitrary + shrink = map Semigroup.Max . shrink . Semigroup.getMax + +instance Arbitrary a => Arbitrary (Semigroup.First a) where + arbitrary = fmap Semigroup.First arbitrary + shrink = map Semigroup.First . shrink . Semigroup.getFirst + +instance Arbitrary a => Arbitrary (Semigroup.Last a) where + arbitrary = fmap Semigroup.Last arbitrary + shrink = map Semigroup.Last . shrink . Semigroup.getLast + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Semigroup.Arg a b) where + arbitrary = Semigroup.Arg <$> arbitrary <*> arbitrary + shrink (Semigroup.Arg a b) = uncurry Semigroup.Arg <$> shrink (a, b) + +instance Arbitrary a => Arbitrary (Semigroup.WrappedMonoid a) where + arbitrary = Semigroup.WrapMonoid <$> arbitrary + shrink = map Semigroup.WrapMonoid . shrink . Semigroup.unwrapMonoid + +#if !MIN_VERSION_base(4,15,0) +instance Arbitrary a => Arbitrary (Semigroup.Option a) where + arbitrary = Semigroup.Option <$> arbitrary + shrink = map Semigroup.Option . shrink . Semigroup.getOption #endif + +#if MIN_VERSION_base(4,16,0) +instance Arbitrary a => Arbitrary (Iff a) where + arbitrary = Iff <$> arbitrary + shrink = map Iff . shrink . getIff + +instance Arbitrary a => Arbitrary (Ior a) where + arbitrary = Ior <$> arbitrary + shrink = map Ior . shrink . getIor + +instance Arbitrary a => Arbitrary (Xor a) where + arbitrary = Xor <$> arbitrary + shrink = map Xor . shrink . getXor + +instance Arbitrary a => Arbitrary (And a) where + arbitrary = And <$> arbitrary + shrink = map And . shrink . getAnd #endif +#if !defined(__MHS__) +instance Arbitrary ByteArray where +#if MIN_VERSION_random(1,3,0) + arbitrary = do + pin <- arbitrary + len <- abs <$> arbitrary + MkGen $ \ qcGen _ -> fst $ uniformByteArray pin len qcGen +#else + arbitrary = Exts.fromList <$> arbitrary +#endif + shrink = map Exts.fromList . shrink . Exts.toList +#else +-- MicroHs does not have Exts.fromList +#endif /* !defined(__MHS__) */ + +#if MIN_VERSION_base(4,16,0) + +#if !MIN_VERSION_base(4,18,0) + +getSolo :: Solo a -> a +getSolo (Solo a) = a + +mkSolo :: a -> Solo a +mkSolo = Solo + +#elif !MIN_VERSION_base(4,19,0) + +getSolo :: Solo a -> a +getSolo (MkSolo a) = a + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#else + +mkSolo :: a -> Solo a +mkSolo = MkSolo + +#endif + +instance Arbitrary a => Arbitrary (Solo a) where + arbitrary = mkSolo <$> arbitrary + shrink = map mkSolo . shrink . getSolo +#endif + +instance Arbitrary a => Arbitrary (Down a) where + arbitrary = fmap Down arbitrary + shrink = map Down . shrink . getDown +#endif + +#ifdef __GLASGOW_HASKELL__ + +instance Arbitrary a => Arbitrary (ArgDescr a) where + arbitrary = oneof [ NoArg <$> arbitrary + , ReqArg <$> arbitrary <*> arbitrary + , OptArg <$> arbitrary <*> arbitrary + ] + + shrink (NoArg i) = [ NoArg i' | i' <- shrink i ] + shrink (ReqArg a1 a2) = [ ReqArg a1' a2 | a1' <- shrink a1 ] ++ + [ ReqArg a1 a2' | a2' <- shrink a2 ] + shrink (OptArg a1 a2) = [ OptArg a1' a2 | a1' <- shrink a1 ] ++ + [ OptArg a1 a2' | a2' <- shrink a2 ] + +instance Arbitrary a => Arbitrary (ArgOrder a) where + arbitrary = oneof [ return RequireOrder + , return Permute + , ReturnInOrder <$> arbitrary + ] + + shrink RequireOrder = [] + shrink Permute = [] + shrink (ReturnInOrder a) = [ ReturnInOrder a' | a' <- shrink a ] + +instance Arbitrary a => Arbitrary (OptDescr a) where + arbitrary = Option + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + + shrink (Option a b c d) = [ Option a' b c d | a' <- shrink a ] ++ + [ Option a b' c d | b' <- shrink b ] ++ + [ Option a b c' d | c' <- shrink c ] ++ + [ Option a b c d' | d' <- shrink d ] + +-- Data.Functor.Contravariant + +-- can maybe use Arbitrary1/2 for these +instance CoArbitrary a => Arbitrary (Predicate a) where + arbitrary = Predicate <$> arbitrary + + shrink (Predicate p) = [ Predicate p' | p' <- shrink p ] + +instance (Arbitrary a, CoArbitrary b) => Arbitrary (Op a b) where + arbitrary = Op <$> arbitrary + + shrink (Op f) = [ Op f' | f' <- shrink f ] + +instance CoArbitrary a => Arbitrary (Equivalence a) where + arbitrary = Equivalence <$> arbitrary + + shrink (Equivalence e) = [ Equivalence e' | e' <- shrink e ] + +instance CoArbitrary a => Arbitrary (Comparison a) where + arbitrary = Comparison <$> arbitrary + + shrink (Comparison c) = [ Comparison c' | c' <- shrink c ] + +#endif + -- | Generates 'Version' with non-empty non-negative @versionBranch@, and empty @versionTags@ instance Arbitrary Version where arbitrary = sized $ \n -> @@ -1065,7 +1270,6 @@ shrink _ = [] #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) instance Arbitrary Newline where arbitrary = elements [LF, CRLF] @@ -1081,7 +1285,52 @@ arbitrary = NewlineMode <$> arbitrary <*> arbitrary shrink (NewlineMode inNL outNL) = [NewlineMode inNL' outNL' | (inNL', outNL') <- shrink (inNL, outNL)] -#endif + +instance Arbitrary GeneralCategory where + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum + +instance Arbitrary SeekMode where + arbitrary = elements [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + shrink x = takeWhile (x /=) [ AbsoluteSeek, RelativeSeek, SeekFromEnd ] + +instance Arbitrary TextEncoding where + arbitrary = elements [ latin1, utf8, utf8_bom, utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, char8 ] + +instance Arbitrary BufferMode where + arbitrary = oneof [ pure NoBuffering, pure LineBuffering, BlockBuffering <$> arbitrary ] + shrink NoBuffering = [] + shrink LineBuffering = [ NoBuffering ] + shrink (BlockBuffering m) = [ NoBuffering, LineBuffering ] ++ map BlockBuffering (shrink m) + +instance Arbitrary IOMode where + arbitrary = elements [ReadMode, WriteMode, AppendMode, ReadWriteMode] + shrink x = takeWhile (/=x) [ReadMode, WriteMode, AppendMode, ReadWriteMode] + +instance Arbitrary FormatSign where + arbitrary = elements [SignPlus, SignSpace] + shrink SignPlus = [] + shrink SignSpace = [SignPlus] + +instance Arbitrary FormatAdjustment where + arbitrary = elements [LeftAdjust, ZeroPad] + shrink LeftAdjust = [] + shrink ZeroPad = [LeftAdjust] + +instance Arbitrary FormatParse where + arbitrary = FormatParse <$> arbitrary <*> arbitrary <*> arbitrary + shrink (FormatParse a b c) = [ FormatParse a' b' c' | (a', b', c') <- shrink (a, b, c) ] + +instance Arbitrary FieldFormat where + arbitrary = FieldFormat <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + shrink (FieldFormat a b c d e f g) = [ FieldFormat a' b' c' d' e' f' g' | (a', b', c', d', e', f', g') <- shrink (a, b, c, d, e, f, g) ] + #endif -- ** Helper functions for implementing arbitrary @@ -1433,7 +1682,7 @@ coarbitrary = coarbitraryReal #endif -#if defined(MIN_VERSION_base) && MIN_VERSION_base(4,4,0) +#if defined(MIN_VERSION_base) instance CoArbitrary a => CoArbitrary (Complex a) where #else instance (RealFloat a, CoArbitrary a) => CoArbitrary (Complex a) where @@ -1565,25 +1814,20 @@ coarbitrary = coarbitrary . Monoid.getProduct #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(3,0,0) instance CoArbitrary a => CoArbitrary (Monoid.First a) where coarbitrary = coarbitrary . Monoid.getFirst instance CoArbitrary a => CoArbitrary (Monoid.Last a) where coarbitrary = coarbitrary . Monoid.getLast -#endif -#if MIN_VERSION_base(4,8,0) instance CoArbitrary (f a) => CoArbitrary (Monoid.Alt f a) where coarbitrary = coarbitrary . Monoid.getAlt #endif -#endif instance CoArbitrary Version where coarbitrary (Version a b) = coarbitrary (a, b) #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) instance CoArbitrary Newline where coarbitrary LF = variant 0 coarbitrary CRLF = variant 1 @@ -1591,7 +1835,6 @@ instance CoArbitrary NewlineMode where coarbitrary (NewlineMode inNL outNL) = coarbitrary inNL . coarbitrary outNL #endif -#endif -- ** Helpers for implementing coarbitrary @@ -1639,8 +1882,9 @@ streamNth n (x :< xs) | n <= 0 = x | otherwise = streamNth (n - 1) xs --- We read into this stream only with ~size argument, --- so it's ok to have it as CAF. +-- We read into this stream only with ~size argument, capped to 256, +-- so it's ok to have it as CAF. (256 chosen somewhat arbitrarily, the +-- point is just to stop this blowing up.) -- rationalUniverse :: Stream Rational rationalUniverse = 0 :< 1 :< (-1) :< go leftSideStream diff --git a/src/Test/QuickCheck/Exception.hs b/src/Test/QuickCheck/Exception.hs --- a/src/Test/QuickCheck/Exception.hs +++ b/src/Test/QuickCheck/Exception.hs @@ -10,7 +10,7 @@ #endif module Test.QuickCheck.Exception where -#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700) +#if (!defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700)) && !defined(__MHS__) #define OLD_EXCEPTIONS #endif @@ -63,7 +63,7 @@ tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) where notAsync :: AnException -> Maybe AnException -#if MIN_VERSION_base(4,7,0) +#if defined(MIN_VERSION_base) notAsync e = case E.fromException e of Just (E.SomeAsyncException _) -> Nothing Nothing -> Just e diff --git a/src/Test/QuickCheck/Function.hs b/src/Test/QuickCheck/Function.hs --- a/src/Test/QuickCheck/Function.hs +++ b/src/Test/QuickCheck/Function.hs @@ -86,13 +86,11 @@ import qualified Data.Monoid as Monoid #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) import System.IO ( Newline(..) , NewlineMode(..) ) #endif -#endif #ifndef NO_FIXED import Data.Fixed @@ -137,7 +135,14 @@ -- turning a concrete function into an abstract function (with a default result) abstract :: (a :-> c) -> c -> (a -> c) +#if defined(__MHS__) +{- This is a temporary fix for a deficiency in the MicroHs type checker. -} +abstract (Pair p) d xy = + case xy of + (x,y) -> abstract (fmap (\q -> abstract q d y) p) d x +#else abstract (Pair p) d (x,y) = abstract (fmap (\q -> abstract q d y) p) d x +#endif abstract (p :+: q) d exy = either (abstract p d) (abstract q d) exy abstract (Unit c) _ _ = c abstract Nil d _ = d @@ -383,7 +388,6 @@ function = functionIntegral #if defined(MIN_VERSION_base) -#if MIN_VERSION_base(4,2,0) instance Function Newline where function = functionMap g h where @@ -399,7 +403,6 @@ g (NewlineMode inNL outNL) = (inNL,outNL) h (inNL,outNL) = NewlineMode inNL outNL #endif -#endif -- instances for Data.Monoid newtypes @@ -424,10 +427,8 @@ instance Function a => Function (Monoid.Last a) where function = functionMap Monoid.getLast Monoid.Last -#if MIN_VERSION_base(4,8,0) instance Function (f a) => Function (Monoid.Alt f a) where function = functionMap Monoid.getAlt Monoid.Alt -#endif -- poly instances @@ -522,6 +523,7 @@ where shrXy (x,y) = [(x,y') | y' <- shr y] + table :: Eq aa => [(aa,cc)] -> (aa :-> cc) -- MicroHs needs this table [] = Nil table xys = Table xys diff --git a/src/Test/QuickCheck/Gen.hs b/src/Test/QuickCheck/Gen.hs --- a/src/Test/QuickCheck/Gen.hs +++ b/src/Test/QuickCheck/Gen.hs @@ -21,7 +21,6 @@ ( Random , random , randomR - , split ) import Control.Monad @@ -89,7 +88,7 @@ MkGen m >>= k = MkGen (\r n -> - case split r of + case splitImpl r of (r1, r2) -> let MkGen m' = k (m r1 n) in m' r2 n diff --git a/src/Test/QuickCheck/Monadic.hs b/src/Test/QuickCheck/Monadic.hs --- a/src/Test/QuickCheck/Monadic.hs +++ b/src/Test/QuickCheck/Monadic.hs @@ -1,11 +1,7 @@ {-# LANGUAGE CPP #-} #ifndef NO_SAFE_HASKELL -#if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) -{-# LANGUAGE Trustworthy #-} -#else {-# LANGUAGE Safe #-} #endif -#endif #ifndef NO_ST_MONAD {-# LANGUAGE Rank2Types #-} #endif @@ -142,9 +138,6 @@ instance Monad m => Monad (PropertyM m) where return = pure (>>=) = bind -#if !MIN_VERSION_base(4,13,0) - fail = fail_ -#endif #ifndef NO_MONADFAIL instance Monad m => Fail.MonadFail (PropertyM m) where diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs --- a/src/Test/QuickCheck/Property.hs +++ b/src/Test/QuickCheck/Property.hs @@ -25,7 +25,7 @@ #endif import Data.Maybe import Control.Applicative -#if MIN_VERSION_base(4,8,0) +#if defined(MIN_VERSION_base) import Control.Exception (displayException) #endif import Control.Monad @@ -322,7 +322,7 @@ theException = Just err } formatException :: String -> AnException -> String -#if MIN_VERSION_base(4,8,0) +#if defined(MIN_VERSION_base) formatException msg err = msg ++ ":" ++ format (displayException err) #else formatException msg err = msg ++ ":" ++ format (show err) @@ -886,7 +886,8 @@ onTimeout timeoutResult n = mapRoseResult f where f rose = ioRose $ do - let m `orError` x = fmap (fromMaybe x) m + let orError :: IO (Maybe a) -> a -> IO a + m `orError` x = fmap (fromMaybe x) m MkRose res roses <- timeout n (reduceRose rose) `orError` return timeoutResult res' <- timeout n (protectResult (return res)) `orError` diff --git a/src/Test/QuickCheck/Random.hs b/src/Test/QuickCheck/Random.hs --- a/src/Test/QuickCheck/Random.hs +++ b/src/Test/QuickCheck/Random.hs @@ -26,17 +26,25 @@ instance Read QCGen where readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] -instance RandomGen QCGen where +splitImpl :: QCGen -> (QCGen, QCGen) #ifdef NO_SPLITMIX - split (QCGen g) = +splitImpl (QCGen g) = case split g of (g1, g2) -> (QCGen g1, QCGen g2) - genRange (QCGen g) = genRange g - next = wrapQCGen next #else - split (QCGen g) = +splitImpl (QCGen g) = case splitSMGen g of (g1, g2) -> (QCGen g1, QCGen g2) +#endif + +instance RandomGen QCGen where +#ifdef OLD_RANDOM + split = splitImpl +#endif +#ifdef NO_SPLITMIX + genRange (QCGen g) = genRange g + next = wrapQCGen next +#else genRange _ = (minBound, maxBound) next = wrapQCGen nextInt @@ -47,10 +55,15 @@ genWord64 = wrapQCGen genWord64 genWord32R r = wrapQCGen (genWord32R r) genWord64R r = wrapQCGen (genWord64R r) - genShortByteString n = wrapQCGen (genShortByteString n) + genShortByteString n = wrapQCGen (uniformShortByteString n) #endif #endif +#ifndef OLD_RANDOM +instance SplitGen QCGen where + splitGen = splitImpl +#endif + {-# INLINE wrapQCGen #-} #ifdef NO_SPLITMIX wrapQCGen :: (StdGen -> (a, StdGen)) -> (QCGen -> (a, QCGen)) @@ -80,8 +93,8 @@ left, right :: a -> a instance Splittable QCGen where - left = fst . split - right = snd . split + left = fst . splitImpl + right = snd . splitImpl -- The logic behind 'variant'. Given a random number seed, and an integer, uses -- splitting to transform the seed according to the integer. We use a diff --git a/src/Test/QuickCheck/Test.hs b/src/Test/QuickCheck/Test.hs --- a/src/Test/QuickCheck/Test.hs +++ b/src/Test/QuickCheck/Test.hs @@ -21,7 +21,6 @@ import qualified Test.QuickCheck.State as S import Test.QuickCheck.Exception import Test.QuickCheck.Random -import System.Random(split) #if defined(MIN_VERSION_containers) #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as Map @@ -299,9 +298,9 @@ test :: State -> Property -> IO Result test st prop - | finishedSuccessfully st = doneTesting st prop - | finishedInsufficientCoverage st = failCoverage st prop - | tooManyDiscards st = giveUp st prop + | finishedSuccessfully st = doneTesting st + | finishedInsufficientCoverage st = failCoverage st + | tooManyDiscards st = giveUp st | otherwise = runATest st prop finishedSuccessfully :: State -> Bool @@ -352,8 +351,8 @@ | (_, _, tot, n, p) <- allCoverage st ] coverageKnownInsufficient _ = False -failCoverage :: State -> Property -> IO Result -failCoverage st prop = +failCoverage :: State -> IO Result +failCoverage st = -- The last test wasn't actually successful, as the coverage failed -- also this prevents an off-by-one error in the printing runATest st{numSuccessTests = numSuccessTests st - 1} @@ -361,8 +360,8 @@ (paragraphs [theLabels, theTables]) where (theLabels, theTables) = labelsAndTables st -doneTesting :: State -> Property -> IO Result -doneTesting st _f +doneTesting :: State -> IO Result +doneTesting st | expected st == False = do putPart (terminal st) ( bold ("*** Failed!") @@ -383,8 +382,8 @@ theOutput <- terminalOutput (terminal st) return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) -giveUp :: State -> Property -> IO Result -giveUp st _f = +giveUp :: State -> IO Result +giveUp st = do -- CALLBACK gave_up? putPart (terminal st) ( bold ("*** Gave up!") @@ -426,9 +425,10 @@ MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty prop) rnd1 size))) res <- callbackPostTest st res - let continue break st' + let continue :: (State -> IO Result) -> State -> IO Result + continue break st' | abort res = break $ updateState st' - | otherwise = test $ updateState st' + | otherwise = test (updateState st') prop updateState st0 = addNewOptions $ st0{ randomSeed = rnd2 } @@ -459,14 +459,14 @@ do continue doneTesting stC{ numSuccessTests = numSuccessTests st + 1 , numRecentlyDiscardedTests = 0 - } prop + } MkResult{ok = Nothing} -> -- discarded test do continue giveUp -- Don't add coverage info from this test st{ numDiscardedTests = numDiscardedTests st + 1 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st + 1 - } prop + } MkResult{ok = Just False} -> -- failed test do (numShrinks, totFailed, lastFailed, res) <- foundFailure (addNewOptions stC) res ts @@ -498,7 +498,7 @@ #endif } where - (rnd1,rnd2) = split (randomSeed st) + (rnd1,rnd2) = splitImpl (randomSeed st) failureSummary :: State -> P.Result -> String failureSummary st res = fst (failureSummaryAndReason st res) diff --git a/test-mhs b/test-mhs new file mode 100644 --- /dev/null +++ b/test-mhs @@ -0,0 +1,25 @@ +#!/bin/sh + +set -e + +mcabal -r install + +die() { + echo "TEST FAILED" + exit 1 +} + +dotest() { + cat >Main.hs < reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." +dotest Test.QuickCheck 'quickCheck $ \xs -> reverse xs === (xs :: [Int])' "\[0,1\]" +echo +echo 'All tests passed!' diff --git a/tests/CollectDataTypes.hs b/tests/CollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/CollectDataTypes.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE TemplateHaskell, RecordWildCards, DeriveLift, TupleSections, CPP #-} +module CollectDataTypes where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Ppr +import Language.Haskell.Interpreter hiding (lift) +import Data.Maybe +import Data.List +import System.Process +import Data.List.Split +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class +import Text.Printf +import Data.Either +import Data.Char +import Data.Function + +data DataType = + DataType { + dt_package :: String, + dt_module :: String, + dt_type :: String } + deriving (Show, Lift) + +getPackageDataTypes :: String -> IO [DataType] +getPackageDataTypes pkg = do + mods <- filter isValidModule <$> getPackageModules pkg + typess <- mapM getModuleDataTypes mods + return [DataType pkg mod typ | (mod, types) <- zip mods typess, typ <- types] + +getPackageModules :: String -> IO [String] +getPackageModules pkg = + concatMap (parseWords . words) . splitOn ", " . unwords . words <$> readProcess cmd args "" + where + cmd:args = ["ghc-pkg", "field", pkg, "exposed-modules", "--simple-output"] + parseWords [mod, "from", _] = [mod] + parseWords xs = xs + +getModuleDataTypes :: String -> IO [String] +getModuleDataTypes mod = do + putStrLn mod + Right names <- runInterpreter $ getModuleExports mod + return [x | Data x _ <- names] + +haskellName :: DataType -> String +haskellName DataType{..} = printf "%s.%s" dt_module (stripParens dt_type) + where + stripParens = reverse . dropWhile (== ')') . reverse . dropWhile (== '(') + +dataTypeType :: DataType -> Q (Maybe Type) +dataTypeType dt = do + mname <- lookupTypeName (haskellName dt) + case mname of + Nothing -> return Nothing + Just name -> Just <$> reifyType name + +typeArity :: Type -> Maybe Int +typeArity (AppT (AppT ArrowT StarT) kind) = succ <$> typeArity kind +typeArity StarT = return 0 +typeArity _ = Nothing + +createProperties :: String -> Q [Dec] +createProperties pkg = do + datatypes0 <- runIO (getPackageDataTypes pkg) + let datatypes = [ dt | dt <- datatypes0, not $ haskellName dt `elem` typeBlacklist ] + let mkImport dt = printf "import %s -- for %s" (dt_module dt) (dt_type dt) + missingModules <- fmap (map mkImport . nubBy ((==) `on` dt_module)) $ filterM (\ dt -> isNothing <$> dataTypeType dt) datatypes + unless (null missingModules) $ error ("Missing the following imports:\n" ++ unlines missingModules) + namesAndDecs <- fmap concat $ mapM createProperty datatypes + let (allNames, props) = unzip namesAndDecs + allPropsDec <- [d| allProps = + $(pure $ ListE [ TupE [Just (LitE (StringL $ nameBase name)), Just (VarE name)] + | name <- allNames ] + ) + |] + return $ allPropsDec ++ props + +createProperty :: DataType -> Q [(Name, Dec)] +createProperty dt = do + mtype <- dataTypeType dt + -- TODO: monad?! + case mtype of + Nothing -> error $ "Can't find type in scope " ++ show dt + Just typ -> case typeArity typ of + Nothing -> pure [] + Just arity -> do + Just name <- lookupTypeName (haskellName dt) + Just int <- lookupTypeName "Int" + Just gen <- lookupTypeName "Gen" + nm <- newName ("prop_" ++ filter isAlphaNum (haskellName dt)) + let propName = pure $ VarP nm + let ty = pure $ AppT (ConT gen) $ foldl AppT (ConT name) $ replicate arity (ConT int) + map (nm,) <$> [d| $propName = forAllBlind (arbitrary :: $ty) (\ x -> x `seq` True) |] + +typeBlacklist :: [String] +typeBlacklist = [ "Prelude.IO" + , "Prelude.ReadS" + , "Prelude.ShowS" + , "System.IO.IO" + , "System.IO.Error.IOError" + , "Prelude.IOError" + , "Data.Kind.Type" + , "Data.Array.Byte.MutableByteArray" + , "Data.IORef.IORef" + , "Data.Kind.Constraint" + , "Data.Unique.Unique" + , "Data.STRef.STRef" + , "Data.STRef.Lazy.STRef" + , "Data.STRef.Strict.STRef" + , "Data.Void.Void" + , "Data.Proxy.KProxy" + , "Data.Monoid.Endo" + , "Data.Semigroup.Endo" + , "Data.List.[]" -- This is buggy and annoying + , "System.IO.HandlePosn" + , "System.IO.Handle" + , "Text.Printf.FieldFormatter" -- This is a function type and it + -- requires an annoying coarbitrary instance + ] ++ + -- These are phantom types used for indexing + [ "Data.Fixed.E" ++ show i | i <- [0,1,2,3,6,9,12] ] ++ +#if MIN_VERSION_base(4,15,0) + -- Exists but is deprecated + [ "Data.Semigroup.Option" ] ++ +#endif + -- TODO: Some controversial ones? + [ "System.IO.Error.IOErrorType" ] + + +modulePrefixBlacklist :: [String] +modulePrefixBlacklist = [ "GHC" + , "Foreign" + , "Control.Exception" + -- Exports things like MVar etc + , "Control.Concurrent" + -- Exports ST and RealWorld that we can't support + , "Control.Monad.ST" + -- Existential wrapper around a Typeable thing, could + -- be supported but would be a bit artificially + -- limited to wrapping a bunch of types we can list + , "Data.Dynamic" + -- We _could_ support this, but it would result in + -- the same problem as with Dynamic + , "Data.Typeable" + , "Type.Reflection" + -- System.Mem.Weak and System.Mem.Stable export + -- pointer types we don't support + , "System.Mem" + -- Exports an exception + , "System.Timeout" + -- Exports types, but not the constructors (or ways of + -- creating them, e.g. Number). No feasible way to + -- create meaningful generator + , "Text.Read" + -- Old generics implementation that doesn't fit nicely + -- with arbitrary, as it has the same kind of problem + -- that Typeable and Dynamic face + , "Data.Data" + -- Platform specific types that one could implement but + -- would be tricky to keep consistent and correct + -- across a number of platforms, esp. since we don't + -- have good CI tests for them + , "System.Posix" + -- This exports a bunch of combinators whose only real + -- role is to build a parser of an opaque type, + -- consequently there isn't some super-interesting + -- useful work you can do with it and it should be OK + -- not to provide instances for it + , "Text.ParserCombinators.ReadP" + ] + +isValidModule :: String -> Bool +isValidModule mod = not $ any (`isPrefixOf` mod) modulePrefixBlacklist diff --git a/tests/RunCollectDataTypes.hs b/tests/RunCollectDataTypes.hs new file mode 100644 --- /dev/null +++ b/tests/RunCollectDataTypes.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +{-# OPTIONS_GHC -ddump-splices #-} +import CollectDataTypes +import Language.Haskell.TH +import Test.QuickCheck.All +import Test.QuickCheck + +import Control.Applicative +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent.QSem +import Control.Concurrent.QSemN +import Control.Exception +import Control.Exception.Base +import Control.Monad.ST +import Control.Monad.ST.Lazy +import Control.Monad.ST.Strict +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,17,0) +import Data.Array.Byte +#endif +#endif +import Data.Bits +import Data.Bool +import Data.Char +import Data.Complex +import Data.Data +import Data.Dynamic +import Data.Either +import Data.Fixed +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Contravariant +import Data.Functor.Identity +import Data.Functor.Product +import Data.Functor.Sum +import Data.IORef +import Data.Int +import Data.Kind +import Data.List.NonEmpty +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Proxy +import Data.Ratio +import Data.STRef +import Data.STRef.Lazy +import Data.STRef.Strict +import Data.Semigroup +import Data.String +import Data.Tuple +import Data.Type.Bool +import Data.Type.Coercion +import Data.Type.Equality +#if defined(MIN_VERSION_base) +#if MIN_VERSION_base(4,16,0) +import Data.Type.Ord +#endif +#endif +import Data.Typeable +import Data.Unique +import Data.Version +import Data.Void +import Data.Word +import Numeric.Natural +import System.Console.GetOpt +import System.Exit +import System.IO +import System.IO.Error +import System.Mem.StableName +import System.Mem.Weak +import System.Posix.Internals +import System.Posix.Types +import System.Timeout +import Text.ParserCombinators.ReadP +import Text.ParserCombinators.ReadPrec +import Text.Printf +import Text.Read +import Text.Read.Lex +import Text.Show +import Type.Reflection +import Type.Reflection.Unsafe +import Unsafe.Coerce + +$(createProperties "base") + +main = runQuickCheckAll allProps quickCheckResult