From 05329b59df5f2c0fe3b518068e8a66c35ffe5c9e Mon Sep 17 00:00:00 2001
From: chessai <chessai1996@gmail.com>
Date: Sat, 23 Mar 2019 20:01:17 -0400
Subject: [PATCH] fix bug which caused bad foldMap/fold to pass if they
 evaluated things in a weird order

---
 src/Hedgehog/Classes/Common/Gen.hs | 4 ++++
 src/Hedgehog/Classes/Foldable.hs   | 6 +++---
 2 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/src/Hedgehog/Classes/Common/Gen.hs b/src/Hedgehog/Classes/Common/Gen.hs
index 2f60124..d1fd489 100644
--- a/src/Hedgehog/Classes/Common/Gen.hs
+++ b/src/Hedgehog/Classes/Common/Gen.hs
@@ -2,6 +2,7 @@
 
 module Hedgehog.Classes.Common.Gen
   ( genSmallList
+  , genVerySmallList 
   , genSmallNonEmptyList
   , genShowReadPrecedence
   , genSmallString
@@ -37,6 +38,9 @@ genSmallNonEmptyList gen = Gen.list (Range.linear 1 7) gen
 genSmallList :: Gen a -> Gen [a]
 genSmallList gen = Gen.list (Range.linear 0 6) gen
 
+genVerySmallList :: Gen a -> Gen [a]
+genVerySmallList gen = Gen.list (Range.linear 0 2) gen
+
 genSmallString :: Gen String
 genSmallString = Gen.string (Range.linear 0 6) Gen.ascii
 
diff --git a/src/Hedgehog/Classes/Foldable.hs b/src/Hedgehog/Classes/Foldable.hs
index 71c38a2..9f48720 100644
--- a/src/Hedgehog/Classes/Foldable.hs
+++ b/src/Hedgehog/Classes/Foldable.hs
@@ -51,7 +51,7 @@ foldableFold ::
   , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x)
   ) => (forall x. Gen x -> Gen (f x)) -> Property
 foldableFold fgen = property $ do
-  a <- forAll $ fgen genSmallSum
+  a <- forAll $ fgen $ genVerySmallList genSmallInteger
   let lhs = Foldable.fold a
   let rhs = Foldable.foldMap id a
   let ctx = contextualise $ LawContext
@@ -76,7 +76,7 @@ foldableFoldMap ::
 foldableFoldMap fgen = property $ do
   a <- forAll $ fgen genSmallInteger
   e <- forAll genQuadraticEquation
-  let f = Sum . runQuadraticEquation e
+  let f = (:[]) . runQuadraticEquation e
   let lhs = Foldable.foldMap f a
   let rhs = Foldable.foldr (mappend . f) mempty a
   let ctx = contextualise $ LawContext
@@ -85,7 +85,7 @@ foldableFoldMap fgen = property $ do
         , lawContextTcName = "Foldable"
         , lawContextTcProp =
             let showA = show a
-                showF = "Sum $ " ++ show e
+                showF = "(:[]) $ " ++ show e
             in lawWhere
               [ "foldMap f a" `congruency` "foldr (mappend . f) mempty  a, where"
               , "f = " ++ showF