{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
module Data.Functor.Foldable.Monadic
  ( cataM, anaM
  , paraM, apoM
  , histoM, futuM
  , zygoM, cozygoM
  , hyloM
  ) where

import           Control.Comonad            (Comonad (..))
import           Control.Comonad.Cofree     (Cofree (..))
import           Control.Monad              ((<=<), liftM2)
import           Control.Monad.Free         (Free (..))
import           Control.Monad.Trans.Class  (lift)
import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import           Data.Functor.Foldable      (Recursive (..), Corecursive (..), Base, Fix (..))


cataM :: (Monad m, Traversable (Base t), Recursive t)
      => (Base t a -> m a) -> t -> m a
cataM phi = h
  where h = phi <=< mapM h . project

anaM :: (Monad m, Traversable (Base t), Corecursive t)
     => (a -> m (Base t a)) -> a -> m t
anaM psi = h
  where h = (return . embed) <=< mapM h <=< psi

paraM :: (Monad m, Traversable (Base t), Recursive t)
      => (Base t (t, a) -> m a) -> t -> m a
paraM phi = h
  where h = phi <=< mapM (liftM2 (,) <$> return <*> h) . project

apoM :: (Monad m, Traversable (Base t), Corecursive t)
     => (a -> m (Base t (Either t a))) -> a -> m t
apoM psi = h
  where h = (return . embed) <=< mapM (either return h) <=< psi

histoM :: (Monad m, Traversable (Base t), Recursive t)
       => (Base t (Cofree (Base t) a) -> m a) -> t -> m a
histoM phi = return . extract <=< cataM f
  where f  = return . uncurry (:<) <=< (liftM2 (,) <$> phi <*> return)

futuM :: (Monad m, Traversable (Base t), Corecursive t)
      => (a -> m (Base t (Free (Base t) a))) -> a -> m t
futuM psi = anaM f . Pure
  where f (Pure  a) = psi a
        f (Free fb) = return fb

zygoM :: (Monad m, Traversable (Base t), Recursive t)
      => (Base t a -> m a) -> (Base t (a, b) -> m b) -> t -> m b
zygoM f phi = return . snd <=< cataM g
  where g = liftM2 (,) <$> (f <=< return . fmap fst) <*> phi

cozygoM :: (Monad m, Traversable (Base t), Corecursive t)
        => (a -> m (Base t a)) -> (b -> m (Base t (Either a b))) -> b -> m t
cozygoM f psi = anaM g . Right
  where g = either (return . fmap Left <=< f) psi

hyloM :: (Monad m, Traversable t)
      => (t b -> m b) -> (a -> m (t a)) -> a -> m b
hyloM phi psi = h
  where h = phi <=< mapM h <=< psi