{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

{- | The effect for reading observable variables from a model environment.
-}

module Effects.ObsReader (
    ObsReader(..)
  , ask
  , handleRead) where

import Prog ( call, discharge, Member, Prog(..) )
import Env ( Env, ObsVar, Observable(..) )
import Util ( safeHead, safeTail )

-- | The effect for reading observed values from a model environment @env@
data ObsReader env a where
  -- | Given the observable variable @x@ is assigned a list of type @[a]@ in @env@, attempt to retrieve its head value.
  Ask :: Observable env x a
    => ObsVar x                 -- ^ variable @x@ to read from
    -> ObsReader env (Maybe a)  -- ^ the head value from @x@'s list

-- | Wrapper function for calling @Ask@
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)

-- | Handle the @Ask@ requests of observable variables
handleRead ::
  -- | initial model environment
     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)