Added All and Any monoids

QuickCheck.cabal

@@ -92,13 +92,17 @@ library
   else
     Build-depends: splitmix >= 0.1.0.2 && <0.2
 
+  if impl(hugs)
+    cpp-options: -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS
+
   -- Modules that are always built.
   Exposed-Modules:
     Test.QuickCheck,
     Test.QuickCheck.Arbitrary,
     Test.QuickCheck.Gen,
     Test.QuickCheck.Gen.Unsafe,
     Test.QuickCheck.Monadic,
+    Test.QuickCheck.Monoids,
     Test.QuickCheck.Modifiers,
     Test.QuickCheck.Property,
     Test.QuickCheck.Test,
@@ -127,7 +131,7 @@ library
     cpp-options: -DNO_TEMPLATE_HASKELL
 
   if !impl(ghc >= 8.0)
-    cpp-options: -DNO_CALLSTACK
+    cpp-options: -DNO_CALLSTACK -DNO_SEMIGROUP
 
   if !impl(ghc >= 7.4)
     cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS
@@ -272,3 +276,14 @@ Test-Suite test-quickcheck-discard
     hs-source-dirs: tests
     main-is: DiscardRatio.hs
     build-depends: base, QuickCheck
+
+Test-Suite test-quickcheck-monoids
+    type: exitcode-stdio-1.0
+    Default-language: Haskell2010
+    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

make-hugs

@@ -19,6 +19,7 @@ find "$TOPDIR/src" -name '*.hs' | while read -r src; do
     -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \
     -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \
     -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE -DNO_CALLSTACK \
+    -DNO_SEMIGROUP -DNO_EXISTENTIAL_FIELD_SELECTORS \
     "$src" > "$tgt"
 done
 

src/Test/QuickCheck.hs

@@ -315,8 +315,10 @@ module Test.QuickCheck
   , (.&.)
   , (.&&.)
   , conjoin
+  , Every (..)
   , (.||.)
   , disjoin
+  , Some (..)
     -- ** What to do on failure
 #ifndef NO_TYPEABLE
   , Witness(..)
@@ -355,6 +357,7 @@ module Test.QuickCheck
 import Test.QuickCheck.Gen
 import Test.QuickCheck.Arbitrary
 import Test.QuickCheck.Modifiers
+import Test.QuickCheck.Monoids
 import Test.QuickCheck.Property hiding ( Result(..) )
 import Test.QuickCheck.Test
 import Test.QuickCheck.Exception

src/Test/QuickCheck/Monoids.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Test.QuickCheck.Monoids
+  ( Every (..)
+  , Some (..)
+  ) where
+
+#ifndef NO_SEMIGROUP
+import Data.List.NonEmpty as NonEmpty
+import Data.Semigroup (Semigroup (..))
+#else
+import Data.Monoid (Monoid (..))
+#endif
+import Test.QuickCheck.Property
+
+-- | Conjunction monoid built with `.&&.`.
+--
+-- Use `property @Every` as an accessor which doesn't leak
+-- existential variables.
+--
+-- Note: monoid laws are satisfied up to `isSuccess` unless one is using
+-- `checkCoverage`.
+--
+#ifndef NO_EXISTENTIAL_FIELD_SELECTORS
+data Every = forall p. Testable p => Every { getEvery :: p }
+#else
+data Every = forall p. Testable p => Every p
+#endif
+
+instance Testable Every where
+    property (Every p) = property p
+
+#ifndef NO_SEMIGROUP
+instance Semigroup Every where
+    Every p <> Every p' = Every (p .&&. p')
+    sconcat = Every . conjoin . NonEmpty.toList
+
+instance Monoid Every where
+    mempty = Every True
+    mappend = (<>)
+    mconcat = Every . conjoin
+#else
+instance Monoid Every where
+    mempty = Every True
+    mappend (Every p) (Every p') = Every (p .&&. p')
+    mconcat = Every . conjoin
+#endif
+
+
+-- | Disjunction monoid built with `.||.`.
+--
+-- Use `property @Some` as an accessor which doesn't leak
+-- existential variables.
+--
+-- Note: monoid laws are satisfied up to `isSuccess` unless one is using
+-- `checkCoverage`.
+--
+#ifndef NO_EXISTENTIAL_FIELD_SELECTORS
+data Some = forall p. Testable p => Some { getSome :: p }
+#else
+data Some = forall p. Testable p => Some p
+#endif
+
+instance Testable Some where
+    property (Some p) = property p
+
+#ifndef NO_SEMIGROUP
+instance Semigroup Some where
+    Some p <> Some p' = Some (p .||. p')
+    sconcat = Some . disjoin . NonEmpty.toList
+
+instance Monoid Some where
+    mempty = Some False
+    mappend = (<>)
+    mconcat = Some . disjoin
+#else
+instance Monoid Some where
+    mempty = Some False
+    mappend (Some p) (Some p') = Some (p .||. p')
+    mconcat = Some . disjoin
+#endif

tests/Monoids.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell  #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+#if __GLASGOW_HASKELL__ >= 800
+{-# OPTIONS_GHC -Wno-orphans #-}
+#endif
+{-# LANGUAGE FlexibleInstances #-}
+
+module Main (main) where
+
+#ifndef NO_SEMIGROUP_CLASS
+import Data.List.NonEmpty
+import Data.Semigroup (Semigroup (..))
+#else
+import Data.Monoid (Monoid (..), (<>))
+#endif
+
+import Test.QuickCheck
+
+#ifdef NO_SEMIGROUP_CLASS
+type Semigroup = Monoid
+sconcat :: Monoid a => [a] -> a
+sconcat = mconcat
+#endif
+
+instance Arbitrary Every where
+    arbitrary = oneof [ pure $ Every True
+                      , pure $ Every False
+                      , pure $ Every (counterexample "False" False)
+                      , pure $ Every (counterexample "True" True)
+                      , pure $ Every (ioProperty (return True))
+                      , pure $ Every (ioProperty (return False))
+                      , pure $ Every (checkCoverage $ cover 100 True "" True)
+                      , pure $ Every (checkCoverage $ cover 100 True "" False)
+                      , pure $ Every (checkCoverage $ cover 100 False "" False)
+                      ]
+
+
+instance Arbitrary Some where
+    arbitrary = oneof [ pure $ Some True
+                      , pure $ Some False
+                      , pure $ Some (counterexample "False" False)
+                      , pure $ Some (counterexample "True" True)
+                      , pure $ Some (ioProperty (return True))
+                      , pure $ Some (ioProperty (return False))
+                      , pure $ Some (checkCoverage $ cover 100 True  "" True)
+                      , pure $ Some (checkCoverage $ cover 100 True  "" False)
+                      , pure $ Some (checkCoverage $ cover 100 False "" True)
+                      , pure $ Some (checkCoverage $ cover 100 False "" False)
+                      ]
+
+
+newtype Fail a = Fail a
+
+instance Arbitrary (Fail Every) where
+    arbitrary = oneof [ Fail <$> (arbitrary :: Gen Every)
+                      , pure $ Fail $ Every (checkCoverage $ cover 100 False "" True)
+                      ]
+
+
+check_associative_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Blind p -> Property
+check_associative_law (Blind a) (Blind b) (Blind c) = ioProperty $ do
+    x <- isSuccess <$> quickCheckWithResult args (a <> (b <> c))
+    y <- isSuccess <$> quickCheckWithResult args ((a <> b) <> c)
+    return (x == y)
+
+
+#ifndef NO_SEMIGROUP_SUPERCLASS
+check_unit_law :: (Testable p, Monoid p) => Blind p -> Property
+#else
+check_unit_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Property
+#endif
+check_unit_law (Blind a) = ioProperty $ do
+    x <- isSuccess <$> quickCheckWithResult args (a <> mempty)
+    y <- isSuccess <$> quickCheckWithResult args (mempty <> a)
+    z <- isSuccess <$> quickCheckWithResult args a
+    return (x == y .&&. y == z)
+
+
+#ifndef NO_SEMIGROUP_CLASS
+check_sconcat_law :: (Testable p, Semigroup p) => Blind p -> Blind p -> Property
+check_sconcat_law (Blind a) (Blind b) = ioProperty $ do
+    x <- isSuccess <$> quickCheckWithResult args (sconcat $ a :| [b])
+    y <- isSuccess <$> quickCheckWithResult args (a <> b)
+    return (x == y)
+#endif
+
+
+#ifndef NO_SEMIGROUP_SUPERCLASS
+check_mconcat_law :: (Testable p, Monoid p) => Blind p -> Blind p -> Property
+#else
+check_mconcat_law :: (Testable p, Monoid p, Semigroup p) => Blind p -> Blind p -> Property
+#endif
+check_mconcat_law (Blind a) (Blind b) = ioProperty $ do
+    x <- isSuccess <$> quickCheckWithResult args (mconcat [a, b])
+    y <- isSuccess <$> quickCheckWithResult args (a <> b)
+    return (x == y)
+
+
+--
+-- Auxiliary definitions
+--
+
+args :: Args
+args = stdArgs { chatty = False, maxShrinks = 0 }
+
+--
+-- Properties
+--
+
+prop_every_associative :: Blind Every -> Blind Every -> Blind Every -> Property
+prop_every_associative = check_associative_law
+
+prop_every_unit :: Blind Every -> Property
+prop_every_unit = check_unit_law
+
+prop_every_unit_fail :: Blind (Fail Every) -> Property
+prop_every_unit_fail (Blind (Fail a)) =
+    expectFailure $ check_unit_law (Blind a)
+
+#ifndef NO_SEMIGROUP_CLASS
+prop_every_sconcat_law :: Blind Every -> Blind Every -> Property
+prop_every_sconcat_law = check_sconcat_law
+#endif
+
+prop_every_mconcat_law :: Blind Every -> Blind Every -> Property
+prop_every_mconcat_law = check_mconcat_law
+
+prop_some_associative :: Blind Some -> Blind Some -> Blind Some -> Property
+prop_some_associative = check_associative_law
+
+prop_some_unit :: Blind Some -> Property
+prop_some_unit = check_unit_law
+
+#ifndef NO_SEMIGROUP_CLASS
+prop_some_sconcat_law :: Blind Some -> Blind Some -> Property
+prop_some_sconcat_law = check_sconcat_law
+#endif
+
+prop_some_mconcat_law :: Blind Some -> Blind Some -> Property
+prop_some_mconcat_law = check_mconcat_law
+
+return []
+main = $quickCheckAll
+