{-# 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 = i'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 lazy (traverse Strict _l) of
                                   [] -> f zero^..listT
                                   [x] -> pure [x]
                                   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 = i'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 = i'Compose'.iso MaybeT (\(MaybeT m) -> m)