From 9a3ef90169a1cab8f62ca4aa465f15fb75e33112 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Mon, 3 Mar 2014 00:30:20 -0500
Subject: More instances for TraversableT (based on Control.Monad.Trans.List)

---
 TraversableT.hs | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 61 insertions(+), 5 deletions(-)

(limited to 'TraversableT.hs')

diff --git a/TraversableT.hs b/TraversableT.hs
index 6446fcc9..cd04731c 100644
--- a/TraversableT.hs
+++ b/TraversableT.hs
@@ -1,11 +1,41 @@
 module TraversableT where
 
 import Data.Traversable
-import Control.Monad (join)
+import Control.Monad (join,MonadPlus(..))
+import Control.Monad.Trans.Class
+import Control.Applicative
+import Data.Foldable (Foldable(foldMap))
 
-newtype TraversableT m t a = TraversableT { runTraversableT :: m (t a) }
+-- | 
+--
+-- /Note:/ this does not yield a monad unless the argument monad is commutative.
+newtype TraversableT t m a = TraversableT { runTraversableT :: m (t a) }
 
-instance (Monad m, Traversable t, Monad t) => Monad (TraversableT m t) where
+-- | Map between 'TraversableT' computations.
+--
+-- * @'runTraversableT' ('mapTraversableT' f m) = f ('runTraversableT' m)@
+mapTraversableT :: (m (t a) -> n (t b)) -> TraversableT t m a -> TraversableT t n b
+mapTraversableT f m = TraversableT $ f (runTraversableT m)
+
+
+instance (Functor m, Functor t) => Functor (TraversableT t m) where
+    fmap f = mapTraversableT $ fmap $ fmap f
+
+instance (Foldable f, Foldable t) => Foldable (TraversableT t f) where
+    foldMap f (TraversableT a) = foldMap (foldMap f) a
+
+instance (Traversable f, Traversable t) => Traversable (TraversableT t f) where
+    traverse f (TraversableT a) = TraversableT <$> traverse (traverse f) a
+
+instance (Applicative m,Applicative t) => Applicative (TraversableT t m) where
+    pure a  = TraversableT $ pure (pure a)
+    f <*> v = TraversableT $ (<*>) <$> runTraversableT f <*> runTraversableT v
+
+instance (Applicative m, Alternative t) => Alternative (TraversableT t m) where
+    empty   = TraversableT $ pure empty
+    m <|> n = TraversableT $ (<|>) <$> runTraversableT m <*> runTraversableT n
+
+instance (Monad m, Traversable t, Monad t) => Monad (TraversableT t m) where
     return = TraversableT . return . return
     m >>= k  = TraversableT $ do
         a <- runTraversableT m
@@ -13,10 +43,36 @@ instance (Monad m, Traversable t, Monad t) => Monad (TraversableT m t) where
         return (join b)
     fail s = TraversableT $ return (fail s)
 
-liftT :: Monad m => t a -> TraversableT m t a
+instance (Monad m, Traversable t, MonadPlus t) => MonadPlus (TraversableT t m) where
+    mzero       = TraversableT $ return mzero
+    m `mplus` n = TraversableT $ do
+        a <- runTraversableT m
+        b <- runTraversableT n
+        return (a `mplus` b)
+
+instance Applicative t => MonadTrans (TraversableT t) where
+    lift m = TraversableT $ do
+        a <- m
+        return (pure a)
+
+liftT :: Monad m => t a -> TraversableT t m a
 liftT = TraversableT . return
 
-liftMT :: m (t a) -> TraversableT m t a
+liftMT :: m (t a) -> TraversableT t m a
 liftMT = TraversableT
 
+-- | Lift a @callCC@ operation to the new monad.
+liftCallCC :: Applicative t =>
+    ((( (t a) -> m (t b)) -> m (t a)) -> m (t a)) ->
+    ((a -> TraversableT t m b) -> TraversableT t m a) -> TraversableT t m a
+liftCallCC callCC f = TraversableT $
+    callCC $ \c ->
+    runTraversableT (f (\a -> TraversableT $ c (pure a)))
+
+-- | Lift a @catchError@ operation to the new monad.
+liftCatch :: (m (t a) -> (e -> m (t a)) -> m (t a)) ->
+    TraversableT t m a -> (e -> TraversableT t m a) -> TraversableT t m a
+liftCatch catchError m h = TraversableT $ runTraversableT m
+    `catchError` \e -> runTraversableT (h e)
+
 
-- 
cgit v1.2.3