# ListT done right alternative

### From HaskellWiki

The following is an alternative implementation for ListT done right:

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)