module Control.Monad.Eff.Internal where
import Data.OpenUnion
import Data.FTCQueue
type Arr r a b = a -> Eff r b
type Arrs r a b = FTCQueue (Eff r) a b
data Eff r a where
Pure :: a -> Eff r a
Impure :: Union r x -> Arrs r x a -> Eff r a
qApp :: Arrs r b w -> b -> Eff r w
qApp q x =
case tviewl q of
TOne k -> k x
k :| t -> case k x of
Pure y -> qApp t y
Impure u q -> Impure u (q >< t)
qComp :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arr r' a c
qComp g h = h . qApp g
qComps :: Arrs r a b -> (Eff r b -> Eff r' c) -> Arrs r' a c
qComps g h = tsingleton (qComp g h)
instance Functor (Eff r) where
fmap f (Pure x) = Pure (f x)
fmap f (Impure u q) = Impure u (q |> (Pure . f))
instance Applicative (Eff r) where
pure = Pure
Pure f <*> Pure x = Pure (f x)
Pure f <*> Impure u q = Impure u (q |> (Pure . f))
Impure u q <*> Pure x = Impure u (q |> (Pure . ($ x)))
Impure u q <*> m = Impure u (q |> (`fmap` m))
instance Monad (Eff r) where
Pure x >>= k = k x
Impure u q >>= k = Impure u (q |> k)
send :: Member t r => t v -> Eff r v
send t = Impure (inj t) (tsingleton Pure)
run :: Eff '[] w -> w
run (Pure x) = x
run _ = error "run: Impure should never happen"
type Handler t r w = forall v. t v -> Arr r v w -> Eff r w
type HandlerS s t r w = forall v. s -> t v -> (s -> Arr r v w) -> Eff r w
handleRelay :: (a -> Eff r w) -> Handler t r w -> Eff (t ': r) a -> Eff r w
handleRelay ret _ (Pure x) = ret x
handleRelay ret h (Impure u q) = case decomp u of
Right x -> h x k
Left u -> Impure u (tsingleton k)
where k = qComp q (handleRelay ret h)
handleRelayS :: s -> (s -> a -> Eff r w) -> HandlerS s t r w -> Eff (t ': r) a -> Eff r w
handleRelayS s ret _ (Pure x) = ret s x
handleRelayS s ret h (Impure u q) = case decomp u of
Right x -> h s x k
Left u -> Impure u (tsingleton (k s))
where k s x = handleRelayS s ret h (qApp q x)
interpose :: Member t r =>
(a -> Eff r w) -> (forall v. t v -> Arr r v w -> Eff r w) ->
Eff r a -> Eff r w
interpose ret h (Pure x) = ret x
interpose ret h (Impure u q) = case prj u of
Just x -> h x k
_ -> Impure u (tsingleton k)
where k = qComp q (interpose ret h)