{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
module Control.Eff.Concurrent.Api.Client
( cast
, castChecked
, call
, castRegistered
, callRegistered
, callRegisteredA
, ServesApi
, registerServer
)
where
import Control.Applicative
import Control.Eff
import Control.Eff.Reader.Lazy
import Control.Eff.Concurrent.Api
import Control.Eff.Concurrent.Api.Internal
import Control.Eff.Concurrent.Process
import Data.Dynamic
import Data.Typeable ( Typeable
, typeRep
)
import GHC.Stack
castChecked
:: forall r q o
. ( HasCallStack
, SetMember Process (Process q) r
, Typeable o
, Typeable (Api o 'Asynchronous)
)
=> SchedulerProxy q
-> Server o
-> Api o 'Asynchronous
-> Eff r Bool
castChecked px (Server pid) castMsg =
sendMessageChecked px pid (toDyn $! (Cast $! castMsg))
cast
:: forall r q o
. ( HasCallStack
, SetMember Process (Process q) r
, Typeable o
, Typeable (Api o 'Asynchronous)
)
=> SchedulerProxy q
-> Server o
-> Api o 'Asynchronous
-> Eff r ()
cast px toServer apiRequest = do
_ <- castChecked px toServer apiRequest
return ()
call
:: forall result api r q
. ( SetMember Process (Process q) r
, Typeable api
, Typeable (Api api ( 'Synchronous result))
, Typeable result
, HasCallStack
)
=> SchedulerProxy q
-> Server api
-> Api api ( 'Synchronous result)
-> Eff r result
call px (Server pidInt) req = do
fromPid <- self px
let requestMessage = Call fromPid $! req
wasSent <- sendMessageChecked px pidInt (toDyn $! requestMessage)
if wasSent
then
let extractResult :: Response api result -> result
extractResult (Response _pxResult result) = result
in extractResult <$> receiveMessageAs px
else raiseError
px
("Could not send request message " ++ show (typeRep requestMessage))
type ServesApi o r q =
( Typeable o
, SetMember Process (Process q) r
, Member (Reader (Server o)) r
)
registerServer :: Server o -> Eff (Reader (Server o) ': r) a -> Eff r a
registerServer = flip runReader
callRegistered
:: (Typeable reply, ServesApi o r q)
=> SchedulerProxy q
-> Api o ( 'Synchronous reply)
-> Eff r reply
callRegistered px method = do
serverPid <- ask
call px serverPid method
callRegisteredA
:: forall r q o f reply
. (Alternative f, Typeable f, Typeable reply, ServesApi o r q)
=> SchedulerProxy q
-> Api o ( 'Synchronous (f reply))
-> Eff r (f reply)
callRegisteredA px method = do
catchRaisedError px (const (return (empty @f))) (callRegistered px method)
castRegistered
:: (Typeable o, ServesApi o r q)
=> SchedulerProxy q
-> Api o 'Asynchronous
-> Eff r ()
castRegistered px method = do
serverPid <- ask
cast px serverPid method