From 61c967a7c28f67876929ba389c8db4130ed2389f Mon Sep 17 00:00:00 2001
From: Benjamin McRae <benjamin@supercede.com>
Date: Mon, 19 May 2025 09:36:59 +0100
Subject: [PATCH 1/2] comment on the Applicative instance

---
 hedgehog/src/Hedgehog/Internal/Gen.hs | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/hedgehog/src/Hedgehog/Internal/Gen.hs b/hedgehog/src/Hedgehog/Internal/Gen.hs
index 0168c037..daca8626 100644
--- a/hedgehog/src/Hedgehog/Internal/Gen.hs
+++ b/hedgehog/src/Hedgehog/Internal/Gen.hs
@@ -499,6 +499,9 @@ instance Functor m => Functor (GenT m) where
 --
 -- implementation: parallel shrinking
 --
+-- | This Applicative instance is not lawful with regards to the Monad instance.
+-- This is because using applicative allows us to do parallel shrinking, but
+-- Monad does not allow that.
 instance Monad m => Applicative (GenT m) where
   pure =
     fromTreeMaybeT . pure

From 8d4f68464e698c45f0c13020fbb5afe021bc3532 Mon Sep 17 00:00:00 2001
From: Benjamin McRae <benjamin@supercede.com>
Date: Mon, 19 May 2025 09:55:22 +0100
Subject: [PATCH 2/2] remove unneeded methods and instances

---
 hedgehog/src/Hedgehog/Internal/Gen.hs      |  3 ---
 hedgehog/src/Hedgehog/Internal/Property.hs | 10 +--------
 hedgehog/src/Hedgehog/Internal/Tree.hs     | 24 ++++++++--------------
 3 files changed, 10 insertions(+), 27 deletions(-)

diff --git a/hedgehog/src/Hedgehog/Internal/Gen.hs b/hedgehog/src/Hedgehog/Internal/Gen.hs
index daca8626..c111b614 100644
--- a/hedgehog/src/Hedgehog/Internal/Gen.hs
+++ b/hedgehog/src/Hedgehog/Internal/Gen.hs
@@ -528,9 +528,6 @@ instance Monad m => Applicative (GenT m) where
 --          runGenT size sm m
 
 instance Monad m => Monad (GenT m) where
-  return =
-    pure
-
   (>>=) m k =
     GenT $ \size seed ->
       case Seed.split seed of
diff --git a/hedgehog/src/Hedgehog/Internal/Property.hs b/hedgehog/src/Hedgehog/Internal/Property.hs
index f4a2ca68..332c76b0 100644
--- a/hedgehog/src/Hedgehog/Internal/Property.hs
+++ b/hedgehog/src/Hedgehog/Internal/Property.hs
@@ -245,6 +245,7 @@ newtype TestT m a =
     } deriving (
       Functor
     , Applicative
+    , Monad
     , MonadIO
     , MonadBase b
     , MonadThrow
@@ -690,15 +691,6 @@ newtype Coverage a =
 ------------------------------------------------------------------------
 -- TestT
 
-instance Monad m => Monad (TestT m) where
-  return =
-    pure
-
-  (>>=) m k =
-    TestT $
-      unTest m >>=
-      unTest . k
-
 instance Monad m => MonadFail (TestT m) where
   fail err =
     TestT . ExceptT . pure . Left $ Failure Nothing err Nothing
diff --git a/hedgehog/src/Hedgehog/Internal/Tree.hs b/hedgehog/src/Hedgehog/Internal/Tree.hs
index f11af46a..0970ec12 100644
--- a/hedgehog/src/Hedgehog/Internal/Tree.hs
+++ b/hedgehog/src/Hedgehog/Internal/Tree.hs
@@ -11,6 +11,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-} -- MonadBase
+{-# LANGUAGE DeriveFunctor #-}
 #if __GLASGOW_HASKELL__ < 802
 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
 #endif
@@ -105,6 +106,9 @@ newtype TreeT m a =
   TreeT {
       runTreeT :: m (NodeT m a)
     }
+  deriving
+    ( Functor
+    )
 
 instance MonadBaseControl b m => MonadBaseControl b (TreeT m) where
   type StM (TreeT m) a = StM m (NodeT m a)
@@ -134,7 +138,11 @@ data NodeT m a =
 
       -- | The children of this 'NodeT'.
     , nodeChildren :: [TreeT m a]
-    } deriving (Eq)
+    }
+  deriving
+    ( Eq
+    , Functor
+    )
 
 -- | Extracts the 'Node' from a 'Tree'.
 --
@@ -417,14 +425,6 @@ instance (Eq1 m, Eq a) => Eq (TreeT m a) where
   TreeT m0 == TreeT m1 =
     liftEq (==) m0 m1
 
-instance Functor m => Functor (NodeT m) where
-  fmap f (NodeT x xs) =
-    NodeT (f x) (fmap (fmap f) xs)
-
-instance Functor m => Functor (TreeT m) where
-  fmap f =
-    TreeT . fmap (fmap f) . runTreeT
-
 instance Applicative m => Applicative (NodeT m) where
   pure x =
     NodeT x []
@@ -440,9 +440,6 @@ instance Applicative m => Applicative (TreeT m) where
       liftA2 (<*>) mab ma
 
 instance Monad m => Monad (NodeT m) where
-  return =
-    pure
-
   (>>=) (NodeT x xs) k =
     case k x of
       NodeT y ys ->
@@ -450,9 +447,6 @@ instance Monad m => Monad (NodeT m) where
           fmap (TreeT . fmap (>>= k) . runTreeT) xs ++ ys
 
 instance Monad m => Monad (TreeT m) where
-  return =
-    pure
-
   (>>=) m k =
     TreeT $ do
       NodeT x xs <- runTreeT m