From 4017519bff4280be2432f62a5309d59cc77173ba Mon Sep 17 00:00:00 2001
From: Marcin Szamotulski <coot@coot.me>
Date: Fri, 26 Apr 2024 16:14:14 +0200
Subject: [PATCH] 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               |  15 +++-
 make-hugs                      |   1 +
 src/Test/QuickCheck.hs         |   3 +
 src/Test/QuickCheck/Monoids.hs |  82 +++++++++++++++++++++
 tests/Monoids.hs               | 127 +++++++++++++++++++++++++++++++++
 5 files changed, 227 insertions(+), 1 deletion(-)
 create mode 100644 src/Test/QuickCheck/Monoids.hs
 create mode 100644 tests/Monoids.hs

diff --git a/QuickCheck.cabal b/QuickCheck.cabal
index c6468b16..cab49a2c 100644
--- a/QuickCheck.cabal
+++ b/QuickCheck.cabal
@@ -92,6 +92,9 @@ 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,
@@ -99,6 +102,7 @@ library
     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,12 @@ 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)
+      ghc-options: -DNO_SEMIGROUP_SUPERCLASS
diff --git a/make-hugs b/make-hugs
index ccc67f4d..3dc3ff55 100755
--- a/make-hugs
+++ b/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
 
diff --git a/src/Test/QuickCheck.hs b/src/Test/QuickCheck.hs
index 78cbaa1e..2f3266c4 100644
--- a/src/Test/QuickCheck.hs
+++ b/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
diff --git a/src/Test/QuickCheck/Monoids.hs b/src/Test/QuickCheck/Monoids.hs
new file mode 100644
index 00000000..559386bb
--- /dev/null
+++ b/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
diff --git a/tests/Monoids.hs b/tests/Monoids.hs
new file mode 100644
index 00000000..597e26d9
--- /dev/null
+++ b/tests/Monoids.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell  #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Main (main) where
+
+import Data.List.NonEmpty
+import Data.Semigroup (Semigroup (..))
+
+import Test.QuickCheck
+
+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)
+
+
+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)
+
+
+#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)
+
+prop_every_sconcat_law :: Blind Every -> Blind Every -> Property
+prop_every_sconcat_law = check_sconcat_law
+
+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
+
+prop_some_sconcat_law :: Blind Some -> Blind Some -> Property
+prop_some_sconcat_law = check_sconcat_law
+
+prop_some_mconcat_law :: Blind Some -> Blind Some -> Property
+prop_some_mconcat_law = check_mconcat_law
+
+return []
+main = $quickCheckAll
+