Define and inline liftA2

Control/Applicative/Lift.hs

@@ -35,8 +35,8 @@
 
 import Control.Applicative
 import Data.Functor.Constant
 import Data.Foldable (Foldable(foldMap))
 import Data.Traversable (Traversable(traverse))
 #ifdef __GLASGOW_HASKELL__
 import GHC.Generics
 #endif
@@ -99,6 +99,11 @@
     Pure f <*> ax = f <$> ax
     Other f <*> ax = Other (f <*> unLift ax)
     {-# INLINE (<*>) #-}
+    liftA2 f (Pure x) (Pure y) = Pure (f x y)
+    liftA2 f (Pure x) (Other y) = Other (f x <$> y)
+    liftA2 f (Other x) (Pure y) = Other ((`f` y) <$> x)
+    liftA2 f (Other x) (Other y) = Other (liftA2 f x y)
+    {-# INLINE liftA2 #-}
 
 -- | A combination is 'Pure' only either part is.
 instance (Alternative f) => Alternative (Lift f) where

Control/Monad/Trans/Accum.hs

@@ -189,6 +189,11 @@ instance (Monoid w, Monad m) => Applicative (AccumT w m) where
       ~(v, w'') <- runAccumT mv (w `mappend` w')
       return (f v, w' `mappend` w'')
     {-# INLINE (<*>) #-}
+    liftA2 f mx my = AccumT $ \ w -> do
+      ~(x, w')  <- runAccumT mx w
+      ~(y, w'') <- runAccumT my (w `mappend` w')
+      return (f x y, w' `mappend` w'')
+    {-# INLINE liftA2 #-}
 
 instance (Monoid w, Alternative m, Monad m) => Alternative (AccumT w m) where
     empty   = AccumT $ const empty

Control/Monad/Trans/Cont.hs

@@ -42,9 +42,11 @@ module Control.Monad.Trans.Cont (
     liftLocal,
   ) where
 
+import Control.Applicative (Applicative(..))
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class
 import Data.Functor.Identity
+import Prelude hiding (Applicative(..))
 
 import qualified Control.Monad.Fail as Fail
 #ifdef __GLASGOW_HASKELL__
@@ -169,6 +171,8 @@ instance Applicative (ContT r m) where
     {-# INLINE pure #-}
     f <*> v = ContT $ \ c -> runContT f $ \ g -> runContT v (c . g)
     {-# INLINE (<*>) #-}
+    liftA2 f x y = ContT $ \ c -> runContT x $ \ x' -> runContT y (c . f x')
+    {-# INLINE liftA2 #-}
     m *> k = m >>= \_ -> k
     {-# INLINE (*>) #-}
 

Control/Monad/Trans/Except.hs

@@ -59,8 +59,8 @@
 import qualified Control.Monad.Fail as Fail
 import Control.Monad.Fix
 import Control.Monad.Zip (MonadZip(mzipWith))
 import Data.Foldable (Foldable(foldMap))
 import Data.Traversable (Traversable(traverse))
 #ifdef __GLASGOW_HASKELL__
 import GHC.Generics
 #endif
@@ -195,6 +195,16 @@
                     Left e -> return (Left e)
                     Right x -> return (Right (k x))
     {-# INLINEABLE (<*>) #-}
+    liftA2 f (ExceptT x) (ExceptT y) = ExceptT $ do
+        mx <- x
+        case mx of
+            Left e -> return (Left e)
+            Right x' -> do
+                my <- y
+                case my of
+                    Left e -> return (Left e)
+                    Right y' -> return (Right (f x' y'))
+    {-# INLINEABLE liftA2 #-}
     m *> k = m >>= \_ -> k
     {-# INLINE (*>) #-}
 

Control/Monad/Trans/Identity.hs

@@ -41,7 +41,7 @@
 import Control.Monad.Fix (MonadFix(mfix))
 import Control.Monad.Zip (MonadZip(mzipWith))
 import Data.Foldable
 import Data.Traversable (Traversable(traverse))
 import Prelude hiding (foldr, foldr1, foldl, foldl1, null, length)
 #ifdef __GLASGOW_HASKELL__
 import GHC.Generics
@@ -107,6 +107,8 @@
     {-# INLINE pure #-}
     (<*>) = lift2IdentityT (<*>)
     {-# INLINE (<*>) #-}
+    liftA2 f = lift2IdentityT (liftA2 f)
+    {-# INLINE liftA2 #-}
     (*>) = lift2IdentityT (*>)
     {-# INLINE (*>) #-}
     (<*) = lift2IdentityT (<*)

Control/Monad/Trans/Maybe.hs

@@ -50,8 +50,8 @@
 import Control.Monad.Fix (MonadFix(mfix))
 import Control.Monad.Zip (MonadZip(mzipWith))
 import Data.Maybe (fromMaybe)
 import Data.Foldable (Foldable(foldMap))
 import Data.Traversable (Traversable(traverse))
 #ifdef __GLASGOW_HASKELL__
 import GHC.Generics
 #endif
@@ -144,6 +144,16 @@
                     Nothing -> return Nothing
                     Just x  -> return (Just (f x))
     {-# INLINE (<*>) #-}
+    liftA2 f mx my = MaybeT $ do
+        mb_x <- runMaybeT mx
+        case mb_x of
+            Nothing -> return Nothing
+            Just x  -> do
+                mb_y <- runMaybeT my
+                case mb_y of
+                    Nothing -> return Nothing
+                    Just y  -> return (Just (f x y))
+    {-# INLINE liftA2 #-}
     m *> k = m >>= \_ -> k
     {-# INLINE (*>) #-}
 

Control/Monad/Trans/RWS/CPS.hs

@@ -213,6 +213,12 @@ instance (Monad m) => Applicative (RWST r w s m) where
         return (f x, s'', w'')
     {-# INLINE (<*>) #-}
 
+    liftA2 f (RWST mx) (RWST my) = RWST $ \ r s w -> do
+        (x, s', w')   <- mx r s w
+        (y, s'', w'') <- my r s' w'
+        return (f x y, s'', w'')
+    {-# INLINE liftA2 #-}
+
 instance (Alternative m, Monad m) => Alternative (RWST r w s m) where
     empty = RWST $ \ _ _ _ -> empty
     {-# INLINE empty #-}

Control/Monad/Trans/RWS/Lazy.hs

@@ -186,6 +186,11 @@ instance (Monoid w, Monad m) => Applicative (RWST r w s m) where
         ~(x, s'',w') <- mx r s'
         return (f x, s'', w `mappend` w')
     {-# INLINE (<*>) #-}
+    liftA2 f (RWST mx) (RWST my) = RWST $ \ r s -> do
+        ~(x, s', w)  <- mx r s
+        ~(y, s'',w') <- my r s'
+        return (f x y, s'', w `mappend` w')
+    {-# INLINE liftA2 #-}
 
 instance (Monoid w, Alternative m, Monad m) => Alternative (RWST r w s m) where
     empty = RWST $ \ _ _ -> empty

Control/Monad/Trans/RWS/Strict.hs

@@ -190,6 +190,11 @@ instance (Monoid w, Monad m) => Applicative (RWST r w s m) where
         (x, s'',w') <- mx r s'
         return (f x, s'', w `mappend` w')
     {-# INLINE (<*>) #-}
+    liftA2 f (RWST mx) (RWST my) = RWST $ \ r s -> do
+        (x, s', w)  <- mx r s
+        (y, s'',w') <- my r s'
+        return (f x y, s'', w `mappend` w')
+    {-# INLINE liftA2 #-}
 
 instance (Monoid w, Alternative m, Monad m) => Alternative (RWST r w s m) where
     empty = RWST $ \ _ _ -> empty

Control/Monad/Trans/Select.hs

@@ -105,6 +105,12 @@ instance (Monad m) => Applicative (SelectT r m) where
         f <- gf ((>>= k) . h)
         h f
     {-# INLINE (<*>) #-}
+    liftA2 f (SelectT gx) (SelectT gy) = SelectT $ \ k -> do
+        let SelectT gf = fmap f (SelectT gx)
+            h fun = liftM fun (gy (k . fun))
+        fun <- gf ((>>= k) . h)
+        h fun
+    {-# INLINE liftA2 #-}
     m *> k = m >>= \_ -> k
     {-# INLINE (*>) #-}
 

Control/Monad/Trans/State/Lazy.hs

@@ -212,6 +212,11 @@ instance (Monad m) => Applicative (StateT s m) where
         ~(x, s'') <- mx s'
         return (f x, s'')
     {-# INLINE (<*>) #-}
+    liftA2 f (StateT mx) (StateT my) = StateT $ \ s -> do
+        ~(x, s') <- mx s
+        ~(y, s'') <- my s'
+        return (f x y, s'')
+    {-# INLINE liftA2 #-}
     m *> k = m >>= \_ -> k
     {-# INLINE (*>) #-}
 

Control/Monad/Trans/State/Strict.hs

@@ -205,6 +205,11 @@ instance (Monad m) => Applicative (StateT s m) where
         (x, s'') <- mx s'
         return (f x, s'')
     {-# INLINE (<*>) #-}
+    liftA2 f (StateT mx) (StateT my) = StateT $ \ s -> do
+        (x, s') <- mx s
+        (y, s'') <- my s'
+        return (f x y, s'')
+    {-# INLINE liftA2 #-}
     m *> k = m >>= \_ -> k
     {-# INLINE (*>) #-}
 

Control/Monad/Trans/Writer/CPS.hs

@@ -168,6 +168,12 @@ instance (Monad m) => Applicative (WriterT w m) where
         return (f x, w'')
     {-# INLINE (<*>) #-}
 
+    liftA2 f (WriterT mx) (WriterT my) = WriterT $ \ w -> do
+        (x, w') <- mx w
+        (y, w'') <- my w'
+        return (f x y, w'')
+    {-# INLINE liftA2 #-}
+
 instance (Alternative m, Monad m) => Alternative (WriterT w m) where
     empty = WriterT $ const empty
     {-# INLINE empty #-}

Control/Monad/Trans/Writer/Lazy.hs

@@ -58,7 +58,7 @@
 import Control.Monad.Signatures
 import Control.Monad.Zip (MonadZip(mzipWith))
 import Data.Foldable
 import Data.Traversable (Traversable(traverse))
 import Prelude hiding (null, length)
 #ifdef __GLASGOW_HASKELL__
 import GHC.Generics
@@ -188,6 +188,9 @@
     f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v)
       where k ~(a, w) ~(b, w') = (a b, w `mappend` w')
     {-# INLINE (<*>) #-}
+    liftA2 f x y = WriterT $ liftA2 k (runWriterT x) (runWriterT y)
+      where k ~(a, w) ~(b, w') = (f a b, w `mappend` w')
+    {-# INLINE liftA2 #-}
 
 instance (Monoid w, Alternative m) => Alternative (WriterT w m) where
     empty   = WriterT empty

Control/Monad/Trans/Writer/Strict.hs

@@ -61,7 +61,7 @@
 import Control.Monad.Signatures
 import Control.Monad.Zip (MonadZip(mzipWith))
 import Data.Foldable
 import Data.Traversable (Traversable(traverse))
 import Prelude hiding (null, length)
 #ifdef __GLASGOW_HASKELL__
 import GHC.Generics
@@ -191,6 +191,9 @@
     f <*> v = WriterT $ liftA2 k (runWriterT f) (runWriterT v)
       where k (a, w) (b, w') = (a b, w `mappend` w')
     {-# INLINE (<*>) #-}
+    liftA2 f x y = WriterT $ liftA2 k (runWriterT x) (runWriterT y)
+      where k (a, w) (b, w') = (f a b, w `mappend` w')
+    {-# INLINE liftA2 #-}
 
 instance (Monoid w, Alternative m) => Alternative (WriterT w m) where
     empty   = WriterT empty

Data/Functor/Constant.hs

@@ -112,6 +112,8 @@ instance (Monoid a) => Applicative (Constant a) where
     {-# INLINE pure #-}
     Constant x <*> Constant y = Constant (x `mappend` y)
     {-# INLINE (<*>) #-}
+    liftA2 _ (Constant x) (Constant y) = Constant (x `mappend` y)
+    {-# INLINE liftA2 #-}
 
 instance (Monoid a) => Monoid (Constant a b) where
     mempty = Constant mempty

Data/Functor/Reverse.hs

@@ -77,6 +77,8 @@ instance (Applicative f) => Applicative (Reverse f) where
     {-# INLINE pure #-}
     Reverse f <*> Reverse a = Reverse (f <*> a)
     {-# INLINE (<*>) #-}
+    liftA2 f (Reverse x) (Reverse y) = Reverse (liftA2 f x y)
+    {-# INLINE liftA2 #-}
 
 -- | Derived instance.
 instance (Alternative f) => Alternative (Reverse f) where