{-# LANGUAGE UndecidableInstances #-}
module Algebra.Monad.Foldable (
  -- * The MonadList class
  MonadList(..),
  
  -- * Foldable monads transformers
  -- ** The List transformer
  ListT,_listT,
  -- ** The Tree transformer
  TreeT(..),_TreeT,
  -- ** The Maybe transformer
  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)