QuickCheck 2.16.0.0 → 2.17.0.0

raw patch · 14 files changed

+667/−129 lines, 14 filesdep +data-array-bytedep +hintdep +splitdep −ghc-primdep −old-localedep −old-timedep ~basedep ~randomdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: data-array-byte, hint, split

Dependencies removed: ghc-prim, old-locale, old-time

Dependency ranges changed: base, random, template-haskell, transformers

API changes (from Hackage documentation)

Files

• QuickCheck.cabal +48/−59
• changelog +7/−0
• src/Test/QuickCheck/All.hs +1/−0
• src/Test/QuickCheck/Arbitrary.hs +271/−27
• src/Test/QuickCheck/Exception.hs +2/−2
• src/Test/QuickCheck/Function.hs +8/−6
• src/Test/QuickCheck/Gen.hs +1/−2
• src/Test/QuickCheck/Monadic.hs +0/−7
• src/Test/QuickCheck/Property.hs +4/−3
• src/Test/QuickCheck/Random.hs +21/−8
• src/Test/QuickCheck/Test.hs +15/−15
• test-mhs +25/−0
• tests/CollectDataTypes.hs +175/−0
• tests/RunCollectDataTypes.hs +89/−0

@@ -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 <koen@chalmers.se> Maintainer: Nick Smallbone <nick@smallbone.se> 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

@@ -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

@@ -20,6 +20,7 @@   verboseCheckAll,   forAllProperties,   allProperties,+  runQuickCheckAll,   -- ** Testing polymorphic properties   polyQuickCheck,   polyVerboseCheck,

@@ -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

@@ -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

@@ -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 

@@ -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

@@ -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

@@ -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`

@@ -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

@@ -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)

@@ -0,0 +1,25 @@+#!/bin/sh++set -e++mcabal -r install++die() {+    echo "TEST FAILED"+    exit 1+}++dotest() {+  cat >Main.hs <<EOF+import $1+main = $2+EOF+  mhs Main.hs -oMain && ./Main | tee mhs.output+  grep -q "$3" mhs.output || die+}++# Simple tests+dotest Test.QuickCheck 'quickCheck $ \xs -> 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!'

@@ -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

@@ -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