Draft: Give a better implementation for (*>)

CHANGELOG.md

@@ -1,3 +1,7 @@
+## Version 1.6.1 (2025-05-19)
+
+* Improve Applicative's `(*>)` ([#546][546], [@L0neGamer][L0neGamer])
+
 ## Version 1.6 (2024-08-27)
 
 * Add callstacks to generators that can error ([#538][538], [@ChickenProp][ChickenProp])

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
@@ -511,6 +514,9 @@ instance Monad m => Applicative (GenT m) where
             runGenT size sf f `mzip`
             runGenT size sm m
 
+  (*>) a b = a >>= const b
+  (<*) a b = const a =<< b
+
 --
 -- implementation: satisfies law (ap = <*>)
 --
@@ -525,9 +531,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

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

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,19 +440,13 @@ 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 ->
         NodeT y $
           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