Added All and Any monoids

`All` is a monoid build around `.&&.`. It is useful when writing
complex properties which check multiple conditions.  Since it is
a monoid it allows one to use `foldMap` which is often much more
ergonomic than using `conjoin`.

`All` satisfies `monoid` laws up to `isSuccess`, unless one is using
`checkCoverage` & `cover`.  I'd argue this is not a problem since
`checkCoverage` and `cover` are most often added at the top of the
property.

This patch also adds `Any` monoid build around `.||.`.

Tests are also included.

QuickCheck.cabal

@@ -105,6 +105,7 @@ library
     Test.QuickCheck.Gen,
     Test.QuickCheck.Gen.Unsafe,
     Test.QuickCheck.Monadic,
+    Test.QuickCheck.Monoids,
     Test.QuickCheck.Modifiers,
     Test.QuickCheck.Property,
     Test.QuickCheck.Test,
@@ -278,3 +279,10 @@ 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

src/Test/QuickCheck.hs

@@ -315,8 +315,10 @@ module Test.QuickCheck
   , (.&.)
   , (.&&.)
   , conjoin
+  , All (..)
   , (.||.)
   , disjoin
+  , Any (..)
     -- ** 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,54 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Test.QuickCheck.Monoids
+  ( All (..)
+  , Any (..)
+  ) where
+
+import Data.List.NonEmpty as NonEmpty
+import Data.Semigroup (Semigroup (..))
+import Test.QuickCheck.Property
+
+-- | Conjunction monoid build with `.&&.`.
+--
+-- Use `property @All` as an accessor which doesn't leak
+-- existential variables.
+--
+-- Note: monoid laws are satisfied up to `isSuccess` unless one is using
+-- `checkCoverage`.
+--
+data All = forall p. Testable p => All { getAll :: p }
+
+instance Testable All where
+    property (All p) = property p
+
+instance Semigroup All where
+    All p <> All p' = All (p .&&. p')
+    sconcat = All . conjoin . NonEmpty.toList
+
+instance Monoid All where
+    mempty = All True
+    mconcat = All . conjoin
+
+
+-- | Disjunction monoid build with `.||.`.
+--
+-- Use `property @Any` as an accessor which doesn't leak
+-- existential variables.
+--
+-- Note: monoid laws are satisfied up to `isSuccess` unless one is using
+-- `checkCoverage`.
+--
+data Any = forall p. Testable p => Any { getAny :: p }
+
+instance Testable Any where
+    property (Any p) = property p
+
+instance Semigroup Any where
+    Any p <> Any p' = Any (p .||. p')
+    sconcat = Any . disjoin . NonEmpty.toList
+
+instance Monoid Any where
+    mempty = Any False
+    mconcat = Any . disjoin
+

tests/Monoids.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Main (main) where
+
+import Data.List.NonEmpty
+import Data.Semigroup (Semigroup (..))
+
+import Test.QuickCheck
+
+instance Arbitrary All where
+    arbitrary = oneof [ pure $ All True
+                      , pure $ All False
+                      , pure $ All (counterexample "False" False)
+                      , pure $ All (counterexample "True" True)
+                      , pure $ All (ioProperty (return True))
+                      , pure $ All (ioProperty (return False))
+                      , pure $ All (checkCoverage $ cover 100 True "" True)
+                      , pure $ All (checkCoverage $ cover 100 True "" False)
+                      -- , pure $ All (checkCoverage $ cover 100 False "" True)
+                      -- , pure $ All (checkCoverage $ cover 100 False "" False)
+                      ]
+
+
+instance Arbitrary Any where
+    arbitrary = oneof [ pure $ Any True
+                      , pure $ Any False
+                      , pure $ Any (counterexample "False" False)
+                      , pure $ Any (counterexample "True" True)
+                      , pure $ Any (ioProperty (return True))
+                      , pure $ Any (ioProperty (return False))
+                      , pure $ Any (checkCoverage $ cover 100 True "" True)
+                      , pure $ Any (checkCoverage $ cover 100 True "" False)
+                      -- , pure $ Any (checkCoverage $ cover 100 False "" True)
+                      -- , pure $ Any (checkCoverage $ cover 100 False "" False)
+                      ]
+
+
+
+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)
+
+
+check_unit_law :: (Testable p, Monoid p) => Blind p -> Property
+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)
+
+
+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)
+
+
+check_mconcat_law :: (Testable p, Monoid p) => Blind p -> Blind p -> Property
+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_all_associative :: Blind All -> Blind All -> Blind All -> Property
+prop_all_associative = check_associative_law
+
+prop_all_unit :: Blind All -> Property
+prop_all_unit = check_unit_law
+
+prop_all_sconcat_law :: Blind All -> Blind All -> Property
+prop_all_sconcat_law = check_sconcat_law
+
+prop_all_mconcat_law :: Blind All -> Blind All -> Property
+prop_all_mconcat_law = check_mconcat_law
+
+prop_any_associative :: Blind Any -> Blind Any -> Blind Any -> Property
+prop_any_associative = check_associative_law
+
+prop_any_unit :: Blind Any -> Property
+prop_any_unit = check_unit_law
+
+prop_any_sconcat_law :: Blind Any -> Blind Any -> Property
+prop_any_sconcat_law = check_sconcat_law
+
+prop_any_mconcat_law :: Blind Any -> Blind Any -> Property
+prop_any_mconcat_law = check_mconcat_law
+
+return []
+main = $quickCheckAll
+