From 68eb6075962fc786bc840ce354eb1290837d938e Mon Sep 17 00:00:00 2001
From: David Feuer <David.Feuer@gmail.com>
Date: Fri, 20 Aug 2021 17:44:45 -0400
Subject: [PATCH] A few tweaks, mostly performance

* Use `fmap` instead of `liftM` in case the underlying monad
  has a better `fmap` than `>>=`.
* Define more `Applicative` methods for performance.
* Define `Alternative` methods less indirectly (still not great,
  but this change is very conservative).
* Use a `go` function in `>>=` so GHC can inline the passed
  function if it's so inclined.

Closes #20.
---
 library/ListT.hs | 44 ++++++++++++++++++++++++++++----------------
 1 file changed, 28 insertions(+), 16 deletions(-)

diff --git a/library/ListT.hs b/library/ListT.hs
index e1e7620..bed6663 100644
--- a/library/ListT.hs
+++ b/library/ListT.hs
@@ -117,24 +117,36 @@ instance (Monad m, Functor m) => Applicative (ListT m) where
     return
   (<*>) = 
     ap
+  -- This is just like liftM2, but it uses fmap over the second
+  -- action. liftM2 can't do that, because it has to deal with
+  -- the possibility that someone defines liftA2 = liftM2 and
+  -- fmap f = (pure f <*>) (leaving (<*>) to the default).
+  liftA2 f m1 m2 = do
+    x1 <- m1
+    fmap (f x1) m2
+  (*>) = (>>)
 
 instance (Monad m, Functor m) => Alternative (ListT m) where
   empty = 
-    inline mzero
+    inline mempty
   (<|>) = 
-    inline mplus
+    inline mappend
 
 instance Monad m => Monad (ListT m) where
   return a =
     ListT $ return (Just (a, (ListT (return Nothing))))
-  (>>=) s1 k2 =
-    ListT $
-      uncons s1 >>=
-        \case
-          Nothing ->
-            return Nothing
-          Just (h1, t1) ->
-            uncons $ k2 h1 <> (t1 >>= k2)
+  -- We use a go function so GHC can inline k2
+  -- if it likes.
+  (>>=) s10 k2 = go s10
+    where
+      go s1 =
+        ListT $
+          uncons s1 >>=
+            \case
+              Nothing ->
+                return Nothing
+              Just (h1, t1) ->
+                uncons $ k2 h1 <> go t1
 #if !MIN_VERSION_base(4,11,0)
   fail _ =
     mempty
@@ -152,7 +164,7 @@ instance Monad m => MonadPlus (ListT m) where
 
 instance MonadTrans ListT where
   lift =
-    ListT . liftM (\a -> Just (a, mempty))
+    ListT . fmap (\a -> Just (a, mempty))
 
 instance MonadIO m => MonadIO (ListT m) where
   liftIO =
@@ -160,7 +172,7 @@ instance MonadIO m => MonadIO (ListT m) where
 
 instance MFunctor ListT where
   hoist f =
-    ListT . f . (liftM . fmap) (id *** hoist f) . uncons
+    ListT . f . (fmap . fmap) (id *** hoist f) . uncons
 
 instance MMonad ListT where
   embed f (ListT m) =
@@ -221,21 +233,21 @@ uncons (ListT m) =
 {-# INLINABLE head #-}
 head :: Monad m => ListT m a -> m (Maybe a)
 head =
-  liftM (fmap fst) . uncons
+  fmap (fmap fst) . uncons
 
 -- |
 -- Execute, getting the tail. Returns nothing if it's empty.
 {-# INLINABLE tail #-}
 tail :: Monad m => ListT m a -> m (Maybe (ListT m a))
 tail =
-  liftM (fmap snd) . uncons
+  fmap (fmap snd) . uncons
 
 -- |
 -- Execute, checking whether it's empty.
 {-# INLINABLE null #-}
 null :: Monad m => ListT m a -> m Bool
 null =
-  liftM (maybe True (const False)) . uncons
+  fmap (maybe True (const False)) . uncons
 
 -- |
 -- Execute in the inner monad,
@@ -271,7 +283,7 @@ fold s r =
 {-# INLINABLE foldMaybe #-}
 foldMaybe :: Monad m => (r -> a -> m (Maybe r)) -> r -> ListT m a -> m r
 foldMaybe s r l =
-  liftM (maybe r id) $ runMaybeT $ do
+  fmap (maybe r id) $ runMaybeT $ do
     (h, t) <- MaybeT $ uncons l
     r' <- MaybeT $ s r h
     lift $ foldMaybe s r' t