{-# OPTIONS_HADDOCK not-home #-}
module Cleff.Internal.Monad
(
InternalHandler (InternalHandler, runHandler)
, Eff (Eff, unEff)
, Env
, HandlerPtr
, emptyEnv
, adjustEnv
, peekEnv
, readEnv
, writeEnv
, replaceEnv
, appendEnv
, updateEnv
, (:>)
, (:>>)
, KnownList
, Subset
, send
, sendVia
) where
import Cleff.Internal
import Cleff.Internal.Rec (KnownList, Rec, Subset, type (:>))
import qualified Cleff.Internal.Rec as Rec
import Cleff.Internal.Vec (Vec)
import qualified Cleff.Internal.Vec as Vec
import Control.Applicative (Applicative (liftA2))
import Control.Monad.Fix (MonadFix (mfix))
import Data.Kind (Constraint)
newtype InternalHandler e = InternalHandler { InternalHandler e
-> forall (es :: [Effect]) a. e (Eff es) a -> Eff es a
runHandler :: ∀ es. e (Eff es) ~> Eff es }
type role Eff nominal representational
newtype Eff es a = Eff { Eff es a -> Env es -> IO a
unEff :: Env es -> IO a }
instance Functor (Eff es) where
fmap :: (a -> b) -> Eff es a -> Eff es b
fmap a -> b
f (Eff Env es -> IO a
x) = (Env es -> IO b) -> Eff es b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff ((a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (IO a -> IO b) -> (Env es -> IO a) -> Env es -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env es -> IO a
x)
{-# INLINE fmap #-}
a
x <$ :: a -> Eff es b -> Eff es a
<$ Eff Env es -> IO b
y = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> a
x a -> IO b -> IO a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ Env es -> IO b
y Env es
es
{-# INLINE (<$) #-}
instance Applicative (Eff es) where
pure :: a -> Eff es a
pure = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff ((Env es -> IO a) -> Eff es a)
-> (a -> Env es -> IO a) -> a -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Env es -> IO a
forall a b. a -> b -> a
const (IO a -> Env es -> IO a) -> (a -> IO a) -> a -> Env es -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
{-# INLINE pure #-}
Eff Env es -> IO (a -> b)
f <*> :: Eff es (a -> b) -> Eff es a -> Eff es b
<*> Eff Env es -> IO a
x = (Env es -> IO b) -> Eff es b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> Env es -> IO (a -> b)
f Env es
es IO (a -> b) -> IO a -> IO b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Env es -> IO a
x Env es
es
{-# INLINE (<*>) #-}
Eff Env es -> IO a
x <* :: Eff es a -> Eff es b -> Eff es a
<* Eff Env es -> IO b
y = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> Env es -> IO a
x Env es
es IO a -> IO b -> IO a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* Env es -> IO b
y Env es
es
{-# INLINE (<*) #-}
Eff Env es -> IO a
x *> :: Eff es a -> Eff es b -> Eff es b
*> Eff Env es -> IO b
y = (Env es -> IO b) -> Eff es b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> Env es -> IO a
x Env es
es IO a -> IO b -> IO b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> Env es -> IO b
y Env es
es
{-# INLINE (*>) #-}
liftA2 :: (a -> b -> c) -> Eff es a -> Eff es b -> Eff es c
liftA2 a -> b -> c
f (Eff Env es -> IO a
x) (Eff Env es -> IO b
y) = (Env es -> IO c) -> Eff es c
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f (Env es -> IO a
x Env es
es) (Env es -> IO b
y Env es
es)
{-# INLINE liftA2 #-}
instance Monad (Eff es) where
Eff Env es -> IO a
x >>= :: Eff es a -> (a -> Eff es b) -> Eff es b
>>= a -> Eff es b
f = (Env es -> IO b) -> Eff es b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> Env es -> IO a
x Env es
es IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x' -> Eff es b -> Env es -> IO b
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff (a -> Eff es b
f a
x') Env es
es
{-# INLINE (>>=) #-}
>> :: Eff es a -> Eff es b -> Eff es b
(>>) = Eff es a -> Eff es b -> Eff es b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
(*>)
{-# INLINE (>>) #-}
instance MonadFix (Eff es) where
mfix :: (a -> Eff es a) -> Eff es a
mfix a -> Eff es a
f = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es
es -> (a -> IO a) -> IO a
forall (m :: Type -> Type) a. MonadFix m => (a -> m a) -> m a
mfix \a
x -> Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff (a -> Eff es a
f a
x) Env es
es
{-# INLINE mfix #-}
type role Env nominal
data Env (es :: [Effect]) = Env
{-# UNPACK #-} !Int
{-# UNPACK #-} !(Rec es)
!(Vec Any)
emptyEnv :: Env '[]
emptyEnv :: Env '[]
emptyEnv = Int -> Rec '[] -> Vec Any -> Env '[]
forall (es :: [Effect]). Int -> Rec es -> Vec Any -> Env es
Env Int
0 Rec '[]
Rec.empty Vec Any
forall a. Vec a
Vec.empty
{-# INLINE emptyEnv #-}
adjustEnv :: ∀ es' es. (Rec es -> Rec es') -> Env es -> Env es'
adjustEnv :: (Rec es -> Rec es') -> Env es -> Env es'
adjustEnv Rec es -> Rec es'
f = \(Env Int
n Rec es
re Vec Any
mem) -> Int -> Rec es' -> Vec Any -> Env es'
forall (es :: [Effect]). Int -> Rec es -> Vec Any -> Env es
Env Int
n (Rec es -> Rec es'
f Rec es
re) Vec Any
mem
{-# INLINE adjustEnv #-}
peekEnv :: ∀ e es. Env es -> HandlerPtr e
peekEnv :: Env es -> HandlerPtr e
peekEnv (Env Int
n Rec es
_ Vec Any
_) = Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr Int
n
{-# INLINE peekEnv #-}
readEnv :: ∀ e es. e :> es => Env es -> InternalHandler e
readEnv :: Env es -> InternalHandler e
readEnv (Env Int
_ Rec es
re Vec Any
mem) = Any -> InternalHandler e
forall a. Any -> a
fromAny (Any -> InternalHandler e) -> Any -> InternalHandler e
forall a b. (a -> b) -> a -> b
$ Int -> Vec Any -> Any
forall a. Int -> Vec a -> a
Vec.lookup (HandlerPtr e -> Int
forall (e :: Effect). HandlerPtr e -> Int
unHandlerPtr (Rec es -> HandlerPtr e
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
Rec es -> HandlerPtr e
Rec.index @e Rec es
re)) Vec Any
mem
{-# INLINE readEnv #-}
writeEnv :: ∀ e es. HandlerPtr e -> InternalHandler e -> Env es -> Env es
writeEnv :: HandlerPtr e -> InternalHandler e -> Env es -> Env es
writeEnv (HandlerPtr Int
m) InternalHandler e
x (Env Int
n Rec es
re Vec Any
mem) = Int -> Rec es -> Vec Any -> Env es
forall (es :: [Effect]). Int -> Rec es -> Vec Any -> Env es
Env Int
n Rec es
re (Int -> Any -> Vec Any -> Vec Any
forall a. Int -> a -> Vec a -> Vec a
Vec.update Int
m (InternalHandler e -> Any
forall a. a -> Any
Any InternalHandler e
x) Vec Any
mem)
{-# INLINE writeEnv #-}
replaceEnv :: ∀ e es. e :> es => InternalHandler e -> Env es -> Env es
replaceEnv :: InternalHandler e -> Env es -> Env es
replaceEnv InternalHandler e
x (Env Int
n Rec es
re Vec Any
mem) = Int -> Rec es -> Vec Any -> Env es
forall (es :: [Effect]). Int -> Rec es -> Vec Any -> Env es
Env (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (HandlerPtr e -> Rec es -> Rec es
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
HandlerPtr e -> Rec es -> Rec es
Rec.update @e (Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr Int
n) Rec es
re) (Vec Any -> Any -> Vec Any
forall a. Vec a -> a -> Vec a
Vec.snoc Vec Any
mem (InternalHandler e -> Any
forall a. a -> Any
Any InternalHandler e
x))
{-# INLINE replaceEnv #-}
appendEnv :: ∀ e es. InternalHandler e -> Env es -> Env (e : es)
appendEnv :: InternalHandler e -> Env es -> Env (e : es)
appendEnv InternalHandler e
x (Env Int
n Rec es
re Vec Any
mem) = Int -> Rec (e : es) -> Vec Any -> Env (e : es)
forall (es :: [Effect]). Int -> Rec es -> Vec Any -> Env es
Env (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (HandlerPtr e -> Rec es -> Rec (e : es)
forall (e :: Effect) (es :: [Effect]).
HandlerPtr e -> Rec es -> Rec (e : es)
Rec.cons (Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr Int
n) Rec es
re) (Vec Any -> Any -> Vec Any
forall a. Vec a -> a -> Vec a
Vec.snoc Vec Any
mem (InternalHandler e -> Any
forall a. a -> Any
Any InternalHandler e
x))
{-# INLINE appendEnv #-}
updateEnv :: ∀ es es'. Env es' -> Env es -> Env es
updateEnv :: Env es' -> Env es -> Env es
updateEnv (Env Int
n Rec es'
_ Vec Any
mem) (Env Int
_ Rec es
re' Vec Any
_) = Int -> Rec es -> Vec Any -> Env es
forall (es :: [Effect]). Int -> Rec es -> Vec Any -> Env es
Env Int
n Rec es
re' Vec Any
mem
{-# INLINE updateEnv #-}
type family xs :>> es :: Constraint where
'[] :>> _ = ()
(x : xs) :>> es = (x :> es, xs :>> es)
infix 0 :>>
send :: e :> es => e (Eff es) ~> Eff es
send :: e (Eff es) ~> Eff es
send = (Eff es ~> Eff es) -> e (Eff es) ~> Eff es
forall (e :: Effect) (es' :: [Effect]) (es :: [Effect]).
(e :> es') =>
(Eff es ~> Eff es') -> e (Eff es) ~> Eff es'
sendVia forall a. a -> a
Eff es ~> Eff es
id
{-# INLINE send #-}
sendVia :: e :> es' => (Eff es ~> Eff es') -> e (Eff es) ~> Eff es'
sendVia :: (Eff es ~> Eff es') -> e (Eff es) ~> Eff es'
sendVia Eff es ~> Eff es'
f e (Eff es) a
e = (Env es' -> IO a) -> Eff es' a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es'
es -> Eff es' a -> Env es' -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff (Eff es a -> Eff es' a
Eff es ~> Eff es'
f (InternalHandler e -> e (Eff es) a -> Eff es a
forall (e :: Effect).
InternalHandler e
-> forall (es :: [Effect]) a. e (Eff es) a -> Eff es a
runHandler (Env es' -> InternalHandler e
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
Env es -> InternalHandler e
readEnv Env es'
es) e (Eff es) a
e)) Env es'
es
{-# INLINE sendVia #-}