{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Effects.ObsReader (
ObsReader(..)
, ask
, handleRead) where
import Prog ( call, discharge, Member, Prog(..) )
import Env ( Env, ObsVar, Observable(..) )
import Util ( safeHead, safeTail )
data ObsReader env a where
Ask :: Observable env x a
=> ObsVar x
-> ObsReader env (Maybe a)
ask :: forall env es x a. (Member (ObsReader env) es, Observable env x a)
=> ObsVar x
-> Prog es (Maybe a)
ask :: forall (env :: [Assign Symbol (*)]) (es :: [* -> *]) (x :: Symbol)
a.
(Member (ObsReader env) es, Observable env x a) =>
ObsVar x -> Prog es (Maybe a)
ask ObsVar x
x = ObsReader env (Maybe a) -> Prog es (Maybe a)
forall (e :: * -> *) (es :: [* -> *]) x.
Member e es =>
e x -> Prog es x
call (forall (env :: [Assign Symbol (*)]) (x :: Symbol) a.
Observable env x a =>
ObsVar x -> ObsReader env (Maybe a)
Ask @env ObsVar x
x)
handleRead ::
Env env
-> Prog (ObsReader env ': es) a
-> Prog es a
handleRead :: forall (env :: [Assign Symbol (*)]) (es :: [* -> *]) a.
Env env -> Prog (ObsReader env : es) a -> Prog es a
handleRead Env env
env (Val a
x) = a -> Prog es a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
handleRead Env env
env (Op EffectSum (ObsReader env : es) x
op x -> Prog (ObsReader env : es) a
k) = case EffectSum (ObsReader env : es) x
-> Either (EffectSum es x) (ObsReader env x)
forall (e :: * -> *) (es :: [* -> *]) x.
EffectSum (e : es) x -> Either (EffectSum es x) (e x)
discharge EffectSum (ObsReader env : es) x
op of
Right (Ask ObsVar x
x) ->
let vs :: [a]
vs = ObsVar x -> Env env -> [a]
forall (env :: [Assign Symbol (*)]) (x :: Symbol) a.
Observable env x a =>
ObsVar x -> Env env -> [a]
get ObsVar x
x Env env
env
maybe_v :: Maybe a
maybe_v = [a] -> Maybe a
forall a. [a] -> Maybe a
safeHead [a]
vs
env' :: Env env
env' = ObsVar x -> [a] -> Env env -> Env env
forall (env :: [Assign Symbol (*)]) (x :: Symbol) a.
Observable env x a =>
ObsVar x -> [a] -> Env env -> Env env
set ObsVar x
x ([a] -> [a]
forall a. [a] -> [a]
safeTail [a]
vs) Env env
env
in Env env -> Prog (ObsReader env : es) a -> Prog es a
forall (env :: [Assign Symbol (*)]) (es :: [* -> *]) a.
Env env -> Prog (ObsReader env : es) a -> Prog es a
handleRead Env env
env' (x -> Prog (ObsReader env : es) a
k x
Maybe a
maybe_v)
Left EffectSum es x
op' -> EffectSum es x -> (x -> Prog es a) -> Prog es a
forall (es :: [* -> *]) x a.
EffectSum es x -> (x -> Prog es a) -> Prog es a
Op EffectSum es x
op' (Env env -> Prog (ObsReader env : es) a -> Prog es a
forall (env :: [Assign Symbol (*)]) (es :: [* -> *]) a.
Env env -> Prog (ObsReader env : es) a -> Prog es a
handleRead Env env
env (Prog (ObsReader env : es) a -> Prog es a)
-> (x -> Prog (ObsReader env : es) a) -> x -> Prog es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Prog (ObsReader env : es) a
k)