{-# LANGUAGE UndecidableInstances #-}
module Control.Eff.Concurrent.Api.Request
( Request(..)
, Reply(..)
, mkRequestOrigin
, RequestOrigin(..)
, sendReply
)
where
import Data.Typeable ( Typeable )
import Data.Proxy
import Control.Eff
import Control.Eff.Concurrent.Api
import Control.Eff.Concurrent.Process
import GHC.TypeLits
import Control.DeepSeq
import GHC.Generics
data Request api where
Call :: forall api reply . (Typeable api, Typeable reply, Typeable (Api api ('Synchronous reply)))
=> Int -> ProcessId -> Api api ('Synchronous reply) -> Request api
Cast :: forall api . (Typeable api, Typeable (Api api 'Asynchronous))
=> Api api 'Asynchronous -> Request api
deriving Typeable
data Reply request where
Reply :: (Typeable api, Typeable reply) => Proxy (Api api ('Synchronous reply)) -> Int -> reply -> Reply (Api api ('Synchronous reply))
deriving Typeable
type family ReplyType request where
ReplyType (Api api ('Synchronous reply)) = reply
ReplyType (Api api 'Asynchronous) = TypeError ('Text "Asynchronous requests (aka casts) have no reply type." )
type family ApiType request where
ApiType (Api api 'Asynchronous) = api
ApiType (Api api ('Synchronous reply)) = api
mkRequestOrigin :: request -> ProcessId -> Int -> RequestOrigin request
mkRequestOrigin _ = RequestOrigin
data RequestOrigin request =
RequestOrigin { _requestOriginPid :: !ProcessId, _requestOriginCallRef :: !Int}
deriving (Eq, Ord, Typeable, Show, Generic)
instance NFData (RequestOrigin request) where
sendReply
:: forall request reply api eff q
. ( SetMember Process (Process q) eff
, Member Interrupts eff
, Typeable api
, ApiType request ~ api
, ReplyType request ~ reply
, request ~ Api api ( 'Synchronous reply)
, Typeable reply
)
=> RequestOrigin request
-> reply
-> Eff eff ()
sendReply origin reply = sendMessage
(_requestOriginPid origin)
(Reply (Proxy @request) (_requestOriginCallRef origin) $! reply)