module Algebra.Monad.Foldable (
MonadList(..),
ListT,_listT,
TreeT(..),_TreeT,
MaybeT(..),_MaybeT
) where
import Algebra.Monad.Base
import Algebra.Monad.RWS
import Data.Tree (Tree(..))
instance MonadList [] where fork = id
newtype ListT m a = ListT (Compose' [] m a)
deriving (Semigroup,Monoid,
Functor,Applicative,Unit,Monad,
Foldable,Traversable,MonadTrans)
_listT :: Iso (ListT m a) (ListT m' a') (m [a]) (m' [a'])
_listT = _Compose'.iso ListT (\(ListT l) -> l)
instance Monad m => MonadList (ListT m) where
fork = by _listT . return
instance MonadFix m => MonadFix (ListT m) where
mfix f = by _listT (mfix (yb _listT . f . head))
instance MonadState s m => MonadState s (ListT m) where
get = get_ ; modify = modify_ ; put = put_
instance MonadWriter w m => MonadWriter w (ListT m) where
tell = lift.tell
listen = _listT-.map sequence.listen.-_listT
censor = _listT-.censor.map (\l -> (fst<$>l,compose (snd<$>l))).-_listT
instance Monad m => MonadError Void (ListT m) where
throw = const zero
catch f mm = mm & _listT %%~ (\m -> m >>= \_l -> case _l of
[] -> f zero^.._listT; l -> pure l)
newtype TreeT m a = TreeT (Compose' Tree m a)
deriving (Functor,Unit,Applicative,Monad,MonadFix,
Foldable,Traversable,MonadTrans)
_TreeT :: Iso (TreeT m a) (TreeT n b) (m (Tree a)) (n (Tree b))
_TreeT = _Compose'.iso TreeT (\(TreeT t) -> t)
newtype MaybeT m a = MaybeT (Compose' Maybe m a)
deriving (Functor,Unit,Applicative,Monad,MonadFix,
Foldable,Traversable,MonadTrans)
_MaybeT :: Iso (MaybeT m a) (MaybeT m' b) (m (Maybe a)) (m' (Maybe b))
_MaybeT = _Compose'.iso MaybeT (\(MaybeT m) -> m)