{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Freer.Internal
(
Eff(..)
, Arr
, Arrs
, module Data.OpenUnion
, module Data.FTCQueue
, send
, sendM
, raise
, run
, runM
, handleRelay
, handleRelayS
, interpose
, interposeS
, replaceRelay
, replaceRelayS
, replaceRelayN
, qApp
, qComp
, NonDet(..)
) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Base (MonadBase, liftBase)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.FTCQueue
import Data.OpenUnion
type Arr effs a b = a -> Eff effs b
type Arrs effs a b = FTCQueue (Eff effs) a b
data Eff effs a
= Val a
| forall b. E (Union effs b) (Arrs effs b a)
qApp :: Arrs effs b w -> b -> Eff effs w
qApp :: Arrs effs b w -> b -> Eff effs w
qApp Arrs effs b w
q' b
x = case Arrs effs b w -> ViewL (Eff effs) b w
forall (m :: * -> *) a b. FTCQueue m a b -> ViewL m a b
tviewl Arrs effs b w
q' of
TOne b -> Eff effs w
k -> b -> Eff effs w
k b
x
b -> Eff effs x
k :| FTCQueue (Eff effs) x w
t -> case b -> Eff effs x
k b
x of
Val x
y -> FTCQueue (Eff effs) x w -> x -> Eff effs w
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp FTCQueue (Eff effs) x w
t x
y
E Union effs b
u Arrs effs b x
q -> Union effs b -> Arrs effs b w -> Eff effs w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b x
q Arrs effs b x -> FTCQueue (Eff effs) x w -> Arrs effs b w
forall (m :: * -> *) a x b.
FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
>< FTCQueue (Eff effs) x w
t)
qComp :: Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp :: Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs effs a b
g Eff effs b -> Eff effs' c
h a
a = Eff effs b -> Eff effs' c
h (Eff effs b -> Eff effs' c) -> Eff effs b -> Eff effs' c
forall a b. (a -> b) -> a -> b
$ Arrs effs a b -> a -> Eff effs b
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs effs a b
g a
a
instance Functor (Eff effs) where
fmap :: (a -> b) -> Eff effs a -> Eff effs b
fmap a -> b
f (Val a
x) = b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (a -> b
f a
x)
fmap a -> b
f (E Union effs b
u Arrs effs b a
q) = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b a
q Arrs effs b a -> (a -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> (b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (b -> Eff effs b) -> (a -> b) -> a -> Eff effs b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
{-# INLINE fmap #-}
instance Applicative (Eff effs) where
pure :: a -> Eff effs a
pure = a -> Eff effs a
forall (effs :: [* -> *]) a. a -> Eff effs a
Val
{-# INLINE pure #-}
Val a -> b
f <*> :: Eff effs (a -> b) -> Eff effs a -> Eff effs b
<*> Val a
x = b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (b -> Eff effs b) -> b -> Eff effs b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
Val a -> b
f <*> E Union effs b
u Arrs effs b a
q = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b a
q Arrs effs b a -> (a -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> (b -> Eff effs b
forall (effs :: [* -> *]) a. a -> Eff effs a
Val (b -> Eff effs b) -> (a -> b) -> a -> Eff effs b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
E Union effs b
u Arrs effs b (a -> b)
q <*> Eff effs a
m = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b (a -> b)
q Arrs effs b (a -> b) -> ((a -> b) -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> ((a -> b) -> Eff effs a -> Eff effs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Eff effs a
m))
{-# INLINE (<*>) #-}
instance Monad (Eff effs) where
Val a
x >>= :: Eff effs a -> (a -> Eff effs b) -> Eff effs b
>>= a -> Eff effs b
k = a -> Eff effs b
k a
x
E Union effs b
u Arrs effs b a
q >>= a -> Eff effs b
k = Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arrs effs b a
q Arrs effs b a -> (a -> Eff effs b) -> Arrs effs b b
forall (m :: * -> *) a x b.
FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
|> a -> Eff effs b
k)
{-# INLINE (>>=) #-}
instance (MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where
liftBase :: b α -> Eff effs α
liftBase = m α -> Eff effs α
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m α -> Eff effs α) -> (b α -> m α) -> b α -> Eff effs α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase
{-# INLINE liftBase #-}
instance (MonadIO m, LastMember m effs) => MonadIO (Eff effs) where
liftIO :: IO a -> Eff effs a
liftIO = m a -> Eff effs a
forall (m :: * -> *) (effs :: [* -> *]) a.
(Monad m, LastMember m effs) =>
m a -> Eff effs a
sendM (m a -> Eff effs a) -> (IO a -> m a) -> IO a -> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE liftIO #-}
send :: Member eff effs => eff a -> Eff effs a
send :: eff a -> Eff effs a
send eff a
t = Union effs a -> Arrs effs a a -> Eff effs a
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (eff a -> Union effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Union effs a
inj eff a
t) ((a -> Eff effs a) -> Arrs effs a a
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton a -> Eff effs a
forall (effs :: [* -> *]) a. a -> Eff effs a
Val)
{-# INLINE send #-}
sendM :: (Monad m, LastMember m effs) => m a -> Eff effs a
sendM :: m a -> Eff effs a
sendM = m a -> Eff effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send
{-# INLINE sendM #-}
run :: Eff '[] a -> a
run :: Eff '[] a -> a
run (Val a
x) = a
x
run Eff '[] a
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal:run - This (E) should never happen"
runM :: Monad m => Eff '[m] a -> m a
runM :: Eff '[m] a -> m a
runM (Val a
x) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
runM (E Union '[m] b
u Arrs '[m] b a
q) = case Union '[m] b -> m b
forall (t :: * -> *) a. Union '[t] a -> t a
extract Union '[m] b
u of
m b
mb -> m b
mb m b -> (b -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff '[m] a -> m a
forall (m :: * -> *) a. Monad m => Eff '[m] a -> m a
runM (Eff '[m] a -> m a) -> (b -> Eff '[m] a) -> b -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arrs '[m] b a -> b -> Eff '[m] a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs '[m] b a
q
replaceRelayS
:: s
-> (s -> a -> Eff (v ': effs) w)
-> (forall x. s -> t x -> (s -> Arr (v ': effs) x w) -> Eff (v ': effs) w)
-> Eff (t ': effs) a
-> Eff (v ': effs) w
replaceRelayS :: s
-> (s -> a -> Eff (v : effs) w)
-> (forall x.
s -> t x -> (s -> Arr (v : effs) x w) -> Eff (v : effs) w)
-> Eff (t : effs) a
-> Eff (v : effs) w
replaceRelayS s
s' s -> a -> Eff (v : effs) w
pure' forall x. s -> t x -> (s -> Arr (v : effs) x w) -> Eff (v : effs) w
bind = s -> Eff (t : effs) a -> Eff (v : effs) w
loop s
s'
where
loop :: s -> Eff (t : effs) a -> Eff (v : effs) w
loop s
s (Val a
x) = s -> a -> Eff (v : effs) w
pure' s
s a
x
loop s
s (E Union (t : effs) b
u' Arrs (t : effs) b a
q) = case Union (t : effs) b -> Either (Union effs b) (t b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (t : effs) b
u' of
Right t b
x -> s -> t b -> (s -> Arr (v : effs) b w) -> Eff (v : effs) w
forall x. s -> t x -> (s -> Arr (v : effs) x w) -> Eff (v : effs) w
bind s
s t b
x s -> Arr (v : effs) b w
k
Left Union effs b
u -> Union (v : effs) b -> Arrs (v : effs) b w -> Eff (v : effs) w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (v : effs) b
forall k (r :: [* -> *]) (a :: k) (any :: * -> *).
Union r a -> Union (any : r) a
weaken Union effs b
u) (Arr (v : effs) b w -> Arrs (v : effs) b w
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton (s -> Arr (v : effs) b w
k s
s))
where
k :: s -> Arr (v : effs) b w
k s
s'' b
x = s -> Eff (t : effs) a -> Eff (v : effs) w
loop s
s'' (Eff (t : effs) a -> Eff (v : effs) w)
-> Eff (t : effs) a -> Eff (v : effs) w
forall a b. (a -> b) -> a -> b
$ Arrs (t : effs) b a -> b -> Eff (t : effs) a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs (t : effs) b a
q b
x
{-# INLINE replaceRelayS #-}
replaceRelay
:: (a -> Eff (v ': effs) w)
-> (forall x. t x -> Arr (v ': effs) x w -> Eff (v ': effs) w)
-> Eff (t ': effs) a
-> Eff (v ': effs) w
replaceRelay :: (a -> Eff (v : effs) w)
-> (forall x. t x -> Arr (v : effs) x w -> Eff (v : effs) w)
-> Eff (t : effs) a
-> Eff (v : effs) w
replaceRelay a -> Eff (v : effs) w
pure' forall x. t x -> Arr (v : effs) x w -> Eff (v : effs) w
bind = Eff (t : effs) a -> Eff (v : effs) w
loop
where
loop :: Eff (t : effs) a -> Eff (v : effs) w
loop (Val a
x) = a -> Eff (v : effs) w
pure' a
x
loop (E Union (t : effs) b
u' Arrs (t : effs) b a
q) = case Union (t : effs) b -> Either (Union effs b) (t b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (t : effs) b
u' of
Right t b
x -> t b -> Arr (v : effs) b w -> Eff (v : effs) w
forall x. t x -> Arr (v : effs) x w -> Eff (v : effs) w
bind t b
x Arr (v : effs) b w
k
Left Union effs b
u -> Union (v : effs) b -> Arrs (v : effs) b w -> Eff (v : effs) w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (v : effs) b
forall k (r :: [* -> *]) (a :: k) (any :: * -> *).
Union r a -> Union (any : r) a
weaken Union effs b
u) (Arr (v : effs) b w -> Arrs (v : effs) b w
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr (v : effs) b w
k)
where
k :: Arr (v : effs) b w
k = Arrs (t : effs) b a
-> (Eff (t : effs) a -> Eff (v : effs) w) -> Arr (v : effs) b w
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs (t : effs) b a
q Eff (t : effs) a -> Eff (v : effs) w
loop
{-# INLINE replaceRelay #-}
replaceRelayN
:: forall gs t a effs w
. Weakens gs
=> (a -> Eff (gs :++: effs) w)
-> (forall x. t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w)
-> Eff (t ': effs) a
-> Eff (gs :++: effs) w
replaceRelayN :: (a -> Eff (gs :++: effs) w)
-> (forall x.
t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w)
-> Eff (t : effs) a
-> Eff (gs :++: effs) w
replaceRelayN a -> Eff (gs :++: effs) w
pure' forall x. t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w
bind = Eff (t : effs) a -> Eff (gs :++: effs) w
loop
where
loop :: Eff (t ': effs) a -> Eff (gs :++: effs) w
loop :: Eff (t : effs) a -> Eff (gs :++: effs) w
loop (Val a
x) = a -> Eff (gs :++: effs) w
pure' a
x
loop (E Union (t : effs) b
u' (Arrs (t : effs) b a
q :: Arrs (t ': effs) b a)) = case Union (t : effs) b -> Either (Union effs b) (t b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (t : effs) b
u' of
Right t b
x -> t b -> Arr (gs :++: effs) b w -> Eff (gs :++: effs) w
forall x. t x -> Arr (gs :++: effs) x w -> Eff (gs :++: effs) w
bind t b
x Arr (gs :++: effs) b w
k
Left Union effs b
u -> Union (gs :++: effs) b
-> Arrs (gs :++: effs) b w -> Eff (gs :++: effs) w
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (gs :++: effs) b
forall (q :: [* -> *]) k (r :: [* -> *]) (a :: k).
Weakens q =>
Union r a -> Union (q :++: r) a
weakens @gs Union effs b
u) (Arr (gs :++: effs) b w -> Arrs (gs :++: effs) b w
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr (gs :++: effs) b w
k)
where
k :: Arr (gs :++: effs) b w
k :: Arr (gs :++: effs) b w
k = Arrs (t : effs) b a
-> (Eff (t : effs) a -> Eff (gs :++: effs) w)
-> Arr (gs :++: effs) b w
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs (t : effs) b a
q Eff (t : effs) a -> Eff (gs :++: effs) w
loop
{-# INLINE replaceRelayN #-}
handleRelay
:: (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff (eff ': effs) a
-> Eff effs b
handleRelay :: (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff (eff : effs) a
-> Eff effs b
handleRelay a -> Eff effs b
ret forall v. eff v -> Arr effs v b -> Eff effs b
h = Eff (eff : effs) a -> Eff effs b
loop
where
loop :: Eff (eff : effs) a -> Eff effs b
loop (Val a
x) = a -> Eff effs b
ret a
x
loop (E Union (eff : effs) b
u' Arrs (eff : effs) b a
q) = case Union (eff : effs) b -> Either (Union effs b) (eff b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (eff : effs) b
u' of
Right eff b
x -> eff b -> Arr effs b b -> Eff effs b
forall v. eff v -> Arr effs v b -> Eff effs b
h eff b
x Arr effs b b
k
Left Union effs b
u -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr effs b b
k)
where
k :: Arr effs b b
k = Arrs (eff : effs) b a
-> (Eff (eff : effs) a -> Eff effs b) -> Arr effs b b
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs (eff : effs) b a
q Eff (eff : effs) a -> Eff effs b
loop
{-# INLINE handleRelay #-}
handleRelayS
:: s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff (eff ': effs) a
-> Eff effs b
handleRelayS :: s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff (eff : effs) a
-> Eff effs b
handleRelayS s
s' s -> a -> Eff effs b
ret forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h = s -> Eff (eff : effs) a -> Eff effs b
loop s
s'
where
loop :: s -> Eff (eff : effs) a -> Eff effs b
loop s
s (Val a
x) = s -> a -> Eff effs b
ret s
s a
x
loop s
s (E Union (eff : effs) b
u' Arrs (eff : effs) b a
q) = case Union (eff : effs) b -> Either (Union effs b) (eff b)
forall (t :: * -> *) (r :: [* -> *]) a.
Union (t : r) a -> Either (Union r a) (t a)
decomp Union (eff : effs) b
u' of
Right eff b
x -> s -> eff b -> (s -> Arr effs b b) -> Eff effs b
forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h s
s eff b
x s -> Arr effs b b
k
Left Union effs b
u -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton (s -> Arr effs b b
k s
s))
where
k :: s -> Arr effs b b
k s
s'' b
x = s -> Eff (eff : effs) a -> Eff effs b
loop s
s'' (Eff (eff : effs) a -> Eff effs b)
-> Eff (eff : effs) a -> Eff effs b
forall a b. (a -> b) -> a -> b
$ Arrs (eff : effs) b a -> b -> Eff (eff : effs) a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs (eff : effs) b a
q b
x
{-# INLINE handleRelayS #-}
interpose
:: Member eff effs
=> (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff effs a
-> Eff effs b
interpose :: (a -> Eff effs b)
-> (forall v. eff v -> Arr effs v b -> Eff effs b)
-> Eff effs a
-> Eff effs b
interpose a -> Eff effs b
ret forall v. eff v -> Arr effs v b -> Eff effs b
h = Eff effs a -> Eff effs b
loop
where
loop :: Eff effs a -> Eff effs b
loop (Val a
x) = a -> Eff effs b
ret a
x
loop (E Union effs b
u Arrs effs b a
q) = case Union effs b -> Maybe (eff b)
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
Union effs a -> Maybe (eff a)
prj Union effs b
u of
Just eff b
x -> eff b -> Arr effs b b -> Eff effs b
forall v. eff v -> Arr effs v b -> Eff effs b
h eff b
x Arr effs b b
k
Maybe (eff b)
_ -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton Arr effs b b
k)
where
k :: Arr effs b b
k = Arrs effs b a -> (Eff effs a -> Eff effs b) -> Arr effs b b
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs effs b a
q Eff effs a -> Eff effs b
loop
{-# INLINE interpose #-}
interposeS
:: Member eff effs
=> s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff effs a
-> Eff effs b
interposeS :: s
-> (s -> a -> Eff effs b)
-> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
-> Eff effs a
-> Eff effs b
interposeS s
s' s -> a -> Eff effs b
ret forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h = s -> Eff effs a -> Eff effs b
loop s
s'
where
loop :: s -> Eff effs a -> Eff effs b
loop s
s (Val a
x) = s -> a -> Eff effs b
ret s
s a
x
loop s
s (E Union effs b
u Arrs effs b a
q) = case Union effs b -> Maybe (eff b)
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
Union effs a -> Maybe (eff a)
prj Union effs b
u of
Just eff b
x -> s -> eff b -> (s -> Arr effs b b) -> Eff effs b
forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b
h s
s eff b
x s -> Arr effs b b
k
Maybe (eff b)
_ -> Union effs b -> Arrs effs b b -> Eff effs b
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E Union effs b
u (Arr effs b b -> Arrs effs b b
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton (s -> Arr effs b b
k s
s))
where
k :: s -> Arr effs b b
k s
s'' b
x = s -> Eff effs a -> Eff effs b
loop s
s'' (Eff effs a -> Eff effs b) -> Eff effs a -> Eff effs b
forall a b. (a -> b) -> a -> b
$ Arrs effs b a -> b -> Eff effs a
forall (effs :: [* -> *]) b w. Arrs effs b w -> b -> Eff effs w
qApp Arrs effs b a
q b
x
{-# INLINE interposeS #-}
raise :: Eff effs a -> Eff (e ': effs) a
raise :: Eff effs a -> Eff (e : effs) a
raise = Eff effs a -> Eff (e : effs) a
forall (effs :: [* -> *]) a (any :: * -> *).
Eff effs a -> Eff (any : effs) a
loop
where
loop :: Eff effs a -> Eff (any : effs) a
loop (Val a
x) = a -> Eff (any : effs) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
loop (E Union effs b
u Arrs effs b a
q) = Union (any : effs) b -> Arrs (any : effs) b a -> Eff (any : effs) a
forall (effs :: [* -> *]) a b.
Union effs b -> Arrs effs b a -> Eff effs a
E (Union effs b -> Union (any : effs) b
forall k (r :: [* -> *]) (a :: k) (any :: * -> *).
Union r a -> Union (any : r) a
weaken Union effs b
u) (Arrs (any : effs) b a -> Eff (any : effs) a)
-> ((b -> Eff (any : effs) a) -> Arrs (any : effs) b a)
-> (b -> Eff (any : effs) a)
-> Eff (any : effs) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> Eff (any : effs) a) -> Arrs (any : effs) b a
forall a (m :: * -> *) b. (a -> m b) -> FTCQueue m a b
tsingleton ((b -> Eff (any : effs) a) -> Eff (any : effs) a)
-> (b -> Eff (any : effs) a) -> Eff (any : effs) a
forall a b. (a -> b) -> a -> b
$ Arrs effs b a
-> (Eff effs a -> Eff (any : effs) a) -> b -> Eff (any : effs) a
forall (effs :: [* -> *]) a b (effs' :: [* -> *]) c.
Arrs effs a b -> (Eff effs b -> Eff effs' c) -> Arr effs' a c
qComp Arrs effs b a
q Eff effs a -> Eff (any : effs) a
loop
{-# INLINE raise #-}
data NonDet a where
MZero :: NonDet a
MPlus :: NonDet Bool
instance Member NonDet effs => Alternative (Eff effs) where
empty :: Eff effs a
empty = Eff effs a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
<|> :: Eff effs a -> Eff effs a -> Eff effs a
(<|>) = Eff effs a -> Eff effs a -> Eff effs a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
instance Member NonDet effs => MonadPlus (Eff effs) where
mzero :: Eff effs a
mzero = NonDet a -> Eff effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send NonDet a
forall a. NonDet a
MZero
mplus :: Eff effs a -> Eff effs a -> Eff effs a
mplus Eff effs a
m1 Eff effs a
m2 = NonDet Bool -> Eff effs Bool
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send NonDet Bool
MPlus Eff effs Bool -> (Bool -> Eff effs a) -> Eff effs a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
x -> if Bool
x then Eff effs a
m1 else Eff effs a
m2