{-# LANGUAGE TypeOperators, LambdaCase, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, DeriveFunctor, StandaloneDeriving, DeriveAnyClass, Safe #-}
module Control.Monad.Coproducts3 (module Control.Monad.EtaInverse, module Control.Monad.Free.Class, module Data.Functor.Sum, Free'(..), toF2, execCoproduct) where
import Data.Functor.Sum
import Control.Monad
import Control.Monad.Free
import Control.Monad.Free.Class
import Data.Functor.Classes
import Data.Maybe
import Control.Monad.EtaInverse
data Free' f f2 t = Free' { unFree' :: f(f2 t) }
| Pure' t deriving Functor
instance (Functor f, MonadFree f f2) => Monad(Free' f f2) where
return = Pure'
Pure' x >>= f = f x
Free' f>>= f2 = Free'((\x->x>>= \x -> case f2 x of
Free' x2 -> wrap x2
Pure' x2-> return x2) <$> f)
instance (Functor f, MonadFree f f2) => Applicative(Free' f f2) where
pure = return
(<*>) = ap
toF2 (Free' x) = wrap x
toF2 (Pure' x) = return x
instance (Functor f, MonadFree f f2) => MonadFree f(Free' f f2) where
wrap x = Free'$ toF2 <$> x
deriving instance (Show1 f, Show1 f2) => Show1(Free' f f2)
deriving instance (Show(f(f2 t)), Show(f2 t), Show t) => Show(Free' f f2 t)
execCoproduct_ :: (EtaInverse f, EtaInverse f2, MonadFree(Sum f f2) f3)=>
Sum f f2(Free'(Sum f f2) f3 t) -> Free'(Sum f f2) f3 t
execCoproduct_ = \ case
InL f | isJust(etaInv f) -> fromJust(etaInv f)
InR f | isJust(etaInv f) -> fromJust(etaInv f)
InL f -> Free'$InL$ f >>= \ case
Free'(InL x) -> x
Free' (InR x2) | isJust(etaInv x2) -> return$!fromJust(etaInv x2)
Free' x@(InR _) -> return$!wrap x
Pure' x -> return$!return x
InR f -> Free'$InR$ f >>= \ case
Free'(InR x) -> x
Free' (InL x2) | isJust(etaInv x2) -> return$!fromJust(etaInv x2)
Free' x@(InL _) -> return$!wrap x
Pure' x -> return$!return x
execCoproduct :: (EtaInverse f, EtaInverse f2, MonadFree(Sum f f2) f3)=>
Free(Sum f f2) t -> Free'(Sum f f2) f3 t
execCoproduct = iter execCoproduct_.(return<$>)