module Ribosome.Host.Interpreter.Responses where

import qualified Data.Map.Strict as Map
import Exon (exon)
import Conc (interpretAtomic)

import qualified Ribosome.Host.Data.RpcError as RpcError
import Ribosome.Host.Data.RpcError (RpcError)
import Ribosome.Host.Effect.Responses (Responses (Add, Respond, Wait))
import Ribosome.Host.Interpreter.Id (interpretInputNum)

failAbsentKey ::
  Show k =>
  Member (Stop RpcError) r =>
  k ->
  (a -> Sem r b) ->
  Maybe a ->
  Sem r b
failAbsentKey :: forall k (r :: EffectRow) a b.
(Show k, Member (Stop RpcError) r) =>
k -> (a -> Sem r b) -> Maybe a -> Sem r b
failAbsentKey k
k a -> Sem r b
f = \case
  Just a
resp ->
    a -> Sem r b
f a
resp
  Maybe a
Nothing ->
    RpcError -> Sem r b
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (Text -> RpcError
RpcError.Unexpected [exon|No response registered for #{show k}|])

waitAndRemove ::
  Ord k =>
  Members [AtomicState (Map k (MVar v)), Embed IO] r =>
  k ->
  MVar v ->
  Sem r v
waitAndRemove :: forall k v (r :: EffectRow).
(Ord k, Members '[AtomicState (Map k (MVar v)), Embed IO] r) =>
k -> MVar v -> Sem r v
waitAndRemove k
k MVar v
mv = do
  v
v <- IO v -> Sem r v
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (MVar v -> IO v
forall a. MVar a -> IO a
takeMVar MVar v
mv)
  v
v v -> Sem r () -> Sem r v
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Map k (MVar v) -> Map k (MVar v)) -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' (k -> Map k (MVar v) -> Map k (MVar v)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete k
k)

interpretResponsesAtomic ::
  ∀ k v r .
  Ord k =>
  Show k =>
  Members [Input k, AtomicState (Map k (MVar v)), Embed IO] r =>
  InterpreterFor (Responses k v !! RpcError) r
interpretResponsesAtomic :: forall k v (r :: EffectRow).
(Ord k, Show k,
 Members '[Input k, AtomicState (Map k (MVar v)), Embed IO] r) =>
InterpreterFor (Responses k v !! RpcError) r
interpretResponsesAtomic =
  (forall x (r0 :: EffectRow).
 Responses k v (Sem r0) x -> Sem (Stop RpcError : r) x)
-> InterpreterFor (Resumable RpcError (Responses k v)) r
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow).
FirstOrder eff "interpretResumable" =>
(forall x (r0 :: EffectRow).
 eff (Sem r0) x -> Sem (Stop err : r) x)
-> InterpreterFor (Resumable err eff) r
interpretResumable \case
    Responses k v (Sem r0) x
Add -> do
      x
k <- Sem (Stop RpcError : r) x
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
      MVar v
resp <- IO (MVar v) -> Sem (Stop RpcError : r) (MVar v)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO (MVar v)
forall a. IO (MVar a)
newEmptyMVar
      x
k x -> Sem (Stop RpcError : r) () -> Sem (Stop RpcError : r) x
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Map x (MVar v) -> Map x (MVar v)) -> Sem (Stop RpcError : r) ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' (x -> MVar v -> Map x (MVar v) -> Map x (MVar v)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert x
k MVar v
resp)
    Wait k
k -> do
      Maybe (MVar x)
v <- (Map k (MVar x) -> Maybe (MVar x))
-> Sem (Stop RpcError : r) (Maybe (MVar x))
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets (k -> Map k (MVar x) -> Maybe (MVar x)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k)
      k
-> (MVar x -> Sem (Stop RpcError : r) x)
-> Maybe (MVar x)
-> Sem (Stop RpcError : r) x
forall k (r :: EffectRow) a b.
(Show k, Member (Stop RpcError) r) =>
k -> (a -> Sem r b) -> Maybe a -> Sem r b
failAbsentKey k
k (k -> MVar x -> Sem (Stop RpcError : r) x
forall k v (r :: EffectRow).
(Ord k, Members '[AtomicState (Map k (MVar v)), Embed IO] r) =>
k -> MVar v -> Sem r v
waitAndRemove k
k) Maybe (MVar x)
v
    Respond k
k v
v -> do
      Maybe (MVar v)
stored <- (Map k (MVar v) -> Maybe (MVar v))
-> Sem (Stop RpcError : r) (Maybe (MVar v))
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets (k -> Map k (MVar v) -> Maybe (MVar v)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k)
      k
-> (MVar v -> Sem (Stop RpcError : r) ())
-> Maybe (MVar v)
-> Sem (Stop RpcError : r) ()
forall k (r :: EffectRow) a b.
(Show k, Member (Stop RpcError) r) =>
k -> (a -> Sem r b) -> Maybe a -> Sem r b
failAbsentKey k
k (Sem (Stop RpcError : r) Bool -> Sem (Stop RpcError : r) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem (Stop RpcError : r) Bool -> Sem (Stop RpcError : r) ())
-> (MVar v -> Sem (Stop RpcError : r) Bool)
-> MVar v
-> Sem (Stop RpcError : r) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> Sem (Stop RpcError : r) Bool
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Bool -> Sem (Stop RpcError : r) Bool)
-> (MVar v -> IO Bool) -> MVar v -> Sem (Stop RpcError : r) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar v -> v -> IO Bool) -> v -> MVar v -> IO Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip MVar v -> v -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar v
v) Maybe (MVar v)
stored

interpretResponses ::
  ∀ k v r .
  Ord k =>
  Num k =>
  Show k =>
  Member (Embed IO) r =>
  InterpreterFor (Responses k v !! RpcError) r
interpretResponses :: forall k v (r :: EffectRow).
(Ord k, Num k, Show k, Member (Embed IO) r) =>
InterpreterFor (Responses k v !! RpcError) r
interpretResponses =
  Map k (MVar v) -> InterpreterFor (AtomicState (Map k (MVar v))) r
forall a (r :: EffectRow).
Member (Embed IO) r =>
a -> InterpreterFor (AtomicState a) r
interpretAtomic (Map k (MVar v)
forall a. Monoid a => a
mempty :: Map k (MVar v)) (Sem (AtomicState (Map k (MVar v)) : r) a -> Sem r a)
-> (Sem ((Responses k v !! RpcError) : r) a
    -> Sem (AtomicState (Map k (MVar v)) : r) a)
-> Sem ((Responses k v !! RpcError) : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem (Input k : AtomicState (Map k (MVar v)) : r) a
-> Sem (AtomicState (Map k (MVar v)) : r) a
forall a (r :: EffectRow).
(Num a, Member (Embed IO) r) =>
InterpreterFor (Input a) r
interpretInputNum (Sem (Input k : AtomicState (Map k (MVar v)) : r) a
 -> Sem (AtomicState (Map k (MVar v)) : r) a)
-> (Sem ((Responses k v !! RpcError) : r) a
    -> Sem (Input k : AtomicState (Map k (MVar v)) : r) a)
-> Sem ((Responses k v !! RpcError) : r) a
-> Sem (AtomicState (Map k (MVar v)) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem
  ((Responses k v !! RpcError)
     : Input k : AtomicState (Map k (MVar v)) : r)
  a
-> Sem (Input k : AtomicState (Map k (MVar v)) : r) a
forall k v (r :: EffectRow).
(Ord k, Show k,
 Members '[Input k, AtomicState (Map k (MVar v)), Embed IO] r) =>
InterpreterFor (Responses k v !! RpcError) r
interpretResponsesAtomic (Sem
   ((Responses k v !! RpcError)
      : Input k : AtomicState (Map k (MVar v)) : r)
   a
 -> Sem (Input k : AtomicState (Map k (MVar v)) : r) a)
-> (Sem ((Responses k v !! RpcError) : r) a
    -> Sem
         ((Responses k v !! RpcError)
            : Input k : AtomicState (Map k (MVar v)) : r)
         a)
-> Sem ((Responses k v !! RpcError) : r) a
-> Sem (Input k : AtomicState (Map k (MVar v)) : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Sem ((Responses k v !! RpcError) : r) a
-> Sem
     ((Responses k v !! RpcError)
        : Input k : AtomicState (Map k (MVar v)) : r)
     a
forall (e2 :: (* -> *) -> * -> *) (e3 :: (* -> *) -> * -> *)
       (e1 :: (* -> *) -> * -> *) (r :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : e3 : r) a
raiseUnder2