{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Paramterized
-- Copyright   :  (C) 2008 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
----------------------------------------------------------------------------
module Control.Monad.Parameterized 
	( FixB(..)
	, BiffB(..)
	, PPointed(..)
	, PMonad(..)
	, (>>*=), (=*<<), (>>*)
	, paugment
	) where

import Control.Arrow ((|||), (+++))
import Control.Bifunctor
import Control.Bifunctor.Fix
import Control.Bifunctor.Biff
import Control.Monad.Identity
import Control.Functor.Extras
import Control.Functor.Pointed.Parameterized
import Control.Monad
import Control.Morphism.Cata

class PPointed f => PMonad f where
	pbind :: (a -> f b c) -> f a c -> f b c
	pbind f = pjoin . bimap f id
	pjoin :: f (f a b) b -> f a b
	pjoin = pbind id

(>>*=) :: PMonad f => f a c -> (a -> f b c) -> f b c
(>>*=) = flip pbind

(=*<<) :: PMonad f => (a -> f b c) -> f a c -> f b c
(=*<<) = pbind

-- (>>*) :: PMonad f => f a c -> f b c -> f b c 
m >>* n = m >>*= const n

{- Parameterized monad laws (from <http://crab.rutgers.edu/~pjohann/f14-ghani.pdf>)
> pbind preturn = id
> pbind g . preturn = g
> pbind (pbind g . j) = pbind g . pbind j
> pmap g . preturn = preturn
> pbind (pmap g . j) . pmap g = pmap g . pbind j 
-}

paugment :: PMonad f => (forall c. (f a c -> c) -> c) -> (a -> FixB f b) -> FixB f b
paugment g k = g (InB . pbind (outB . k))

instance PMonad f => Monad (FixB f) where
	return = InB . preturn
	m >>= k = paugment (flip bicata m) k

instance Functor f => PPointed (BiffB Either Identity f) where
        preturn = BiffB . Left . Identity

-- The Free Monad
instance Functor f => PMonad (BiffB Either Identity f) where
        pbind k = (k . runIdentity ||| BiffB . Right) . runBiffB

instance FunctorPlus f => PPointed (BiffB (,) Identity f) where
        preturn a = BiffB (Identity a,fzero)

-- The 'Cofree' Monad
instance FunctorPlus f => PMonad (BiffB (,) Identity f) where
        pbind k (BiffB ~(Identity a,as)) = BiffB (ib, fplus as bs) where BiffB (ib,bs) = k a