ListT done right alternative

The following is an alternative implementation for ListT done right. You will find a similar implementation in the "list-t" package.

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.Cont

import Control.Arrow

newtype ListT m a = ListT { runListT :: m (Maybe (a, ListT m a)) }

foldListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b
foldListT c n (ListT m) = maybe n (\(x,l) -> c x (foldListT c n l)) =<< m

-- In ListT from Control.Monad this one is the data constructor ListT, so sadly, this code can't be a drop-in replacement.
liftList :: Monad m => [a] -> ListT m a
liftList [] = ListT $ return Nothing
liftList (x:xs) = ListT . return $ Just (x, liftList xs)

instance Functor m => Functor (ListT m) where
  fmap f (ListT m) = ListT $ fmap (fmap $ f *** fmap f) m where

instance (Monad m) => Monad (ListT m) where
  return x = ListT . return $ Just (x, mzero)
  m >>= f = ListT $ 
    foldListT (\x l -> runListT $ f x `mplus` ListT l) (return Nothing) m

instance MonadTrans ListT where
  lift = ListT . liftM (\x -> Just (x, mzero))

instance Monad m => MonadPlus (ListT m) where
  mzero = ListT $ return Nothing
  ListT m1 `mplus` ListT m2 = ListT $ 
    maybe m2 (return . Just . second (`mplus` ListT m2)) =<< m1

-- These things typecheck, but I haven't made sure what they do is sensible.
instance (MonadIO m, Functor m) => MonadIO (ListT m) where
  liftIO = lift . liftIO

instance (MonadReader s m, Functor m) => MonadReader s (ListT m) where
  ask     = lift ask
  local f = ListT . local f . runListT

instance (MonadState s m, Functor m) => MonadState s (ListT m) where
  get = lift get
  put = lift . put

instance MonadCont m => MonadCont (ListT m) where
  callCC f = ListT $
    callCC $ \c -> runListT . f $ \a ->
      ListT . c $ Just (a, ListT $ return Nothing)

instance (MonadError e m) => MonadError e (ListT m) where
  throwError = lift . throwError
  -- I can't really decide between those two possible implementations.
  -- The first one is more like the IO monad works, the second one catches
  -- all possible errors in the list.
--  ListT m `catchError` h = ListT $ m `catchError` \e -> runListT (h e)
  (m :: ListT m a) `catchError` h = deepCatch m where
    deepCatch :: ListT m a -> ListT m a
    deepCatch (ListT xs) = ListT $ liftM (fmap $ second deepCatch) xs 
      `catchError` \e -> runListT (h e)