module Control.Monad.Eff
( Union (..)
, decomp
, Member
, Arrs
, Eff (..)
, send
, kApp
, run
, runM
, module Data.TAQueue
) where
import Data.TAQueue
data Union (r :: [ * -> * ]) v where
UNow :: t v -> Union (t ': r) v
UNext :: Union r v -> Union (any ': r) v
decomp :: Union (t ': r) v -> Either (Union r v) (t v)
decomp (UNow e) = Right e
decomp (UNext u) = Left u
data Nat = Z | S Nat
class Member' (n :: Nat) (f :: * -> *) rs where
inj' :: f v -> Union rs v
prj' :: Union rs v -> Maybe (f v)
instance rs ~ (f ': rs') => Member' 'Z f rs where
inj' = UNow
prj' (UNow x) = Just x
prj' _ = Nothing
instance (Member' n f rs', rs ~ (r ': rs')) => Member' ('S n) f rs where
inj' v = UNext (inj' @n v)
prj' UNow{} = Nothing
prj' (UNext u) = prj' @n u
class (Member' (FindElem t r) t r ) => Member t r where
inj :: t v -> Union r v
instance (Member' (FindElem t r) t r ) => Member t r where
inj = inj' @(FindElem t r)
type family FindElem (t :: * -> *) (r :: [ * -> * ]) :: Nat where
FindElem t (t ': r) = 'Z
FindElem t (any ': r) = 'S (FindElem t r)
type Arrs r a b = TAQueue (Eff r) a b
data Eff r a
= Val a
| forall x . Eff (Union r x) (Arrs r x a)
instance Functor (Eff r) where
fmap f (Val a) = Val (f a)
fmap f (Eff u as) = Eff u (snoc as (Val . f))
instance Applicative (Eff r) where
pure = Val
Val f <*> Val a = Val (f a)
Val f <*> Eff u as = Eff u (snoc as (Val . f))
Eff u k <*> Val a = Eff u (snoc k (Val . ($ a)))
Eff u k <*> Eff u' k' = Eff u (snoc k (\f -> Eff u' (snoc k' (\a -> Val (f a)))))
instance Monad (Eff r) where
Val a >>= f = f a
Eff u as >>= f = Eff u (snoc as f)
kApp :: Arrs r a b -> a -> Eff r b
kApp k0 a =
case viewl k0 of
Singleton k -> k a
Cons k t -> app (k a) t
where
app :: Eff r x -> Arrs r x b -> Eff r b
app (Val y) k = kApp k y
app (Eff u k) k' = Eff u (append k k')
send :: Member t r => t v -> Eff r v
send t = Eff (inj t) (singleton Val)
run :: Eff '[] a -> a
run (Val x ) = x
run (Eff u _) = case u of {}
runM :: Monad m => Eff '[m] a -> m a
runM (Val a) = return a
runM (Eff u k) =
case decomp u of
Right m -> m >>= runM . kApp k
Left u' -> case u' of {}