module Control.Eff.Concurrent.Protocol.CallbackServer
( start
, startLink
, Server
, ServerId(..)
, Event(..)
, TangibleCallbacks
)
where
import Control.DeepSeq
import Control.Eff
import Control.Eff.Concurrent.Misc
import Control.Eff.Concurrent.Process
import Control.Eff.Concurrent.Protocol
import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as E
import Control.Eff.Concurrent.Protocol.EffectfulServer (Event(..))
import Control.Eff.Extend ()
import Control.Eff.Log
import Data.Kind
import Data.String
import Data.Typeable
import qualified Data.Text as T
import GHC.Stack (HasCallStack)
start
:: forall tag eLoop q h.
( HasCallStack
, TangibleCallbacks tag eLoop q
, E.Server (Server tag eLoop) (Processes q)
, LogsTo h (Processes q)
)
=> (forall x . Endpoint tag -> Eff eLoop x -> Eff (Processes q) x)
-> (Endpoint tag -> Event tag -> Eff eLoop ())
-> ServerId tag
-> Eff (Processes q) (Endpoint tag)
start initCb eventCb serverId = E.start (MkServer serverId initCb eventCb)
startLink
:: forall tag eLoop q h.
( HasCallStack
, TangibleCallbacks tag eLoop q
, E.Server (Server tag eLoop) (Processes q)
, LogsTo h (Processes q)
)
=> (forall x . Endpoint tag -> Eff eLoop x -> Eff (Processes q) x)
-> (Endpoint tag -> Event tag -> Eff eLoop ())
-> ServerId tag
-> Eff (Processes q) (Endpoint tag)
startLink initCb eventCb serverId = E.startLink (MkServer serverId initCb eventCb)
data Server tag eLoop deriving Typeable
type TangibleCallbacks tag eLoop e =
( LogIo e
, HasProcesses eLoop e
, Typeable e
, Typeable eLoop
, Typeable tag
)
newtype ServerId (tag :: Type) =
MkServerId { _fromServerId :: T.Text }
deriving (Typeable, NFData, Ord, Eq, IsString)
instance (Typeable tag) => Show (ServerId tag) where
showsPrec d px@(MkServerId x) =
showParen
(d >= 10)
(showString (T.unpack x)
. showString " :: "
. showSTypeRep (typeOf px)
)
instance (TangibleCallbacks tag eLoop e) => E.Server (Server (tag :: Type) eLoop) (Processes e) where
type ServerPdu (Server tag eLoop) = tag
type ServerEffects (Server tag eLoop) (Processes e) = eLoop
data instance Init (Server tag eLoop) (Processes e) =
MkServer
{ genServerId :: ServerId tag
, genServerRunEffects :: forall x . (Endpoint tag -> Eff eLoop x -> Eff (Processes e) x)
, genServerOnEvent :: Endpoint tag -> Event tag -> Eff eLoop ()
} deriving Typeable
runEffects myEp svr = genServerRunEffects svr myEp
onEvent myEp svr = genServerOnEvent svr myEp
instance (TangibleCallbacks tag eLoop e) => NFData (E.Init (Server (tag :: Type) eLoop) (Processes e)) where
rnf (MkServer x y z) = rnf x `seq` y `seq` z `seq` ()
instance (TangibleCallbacks tag eLoop e) => Show (E.Init (Server (tag :: Type) eLoop) (Processes e)) where
showsPrec d svr =
showParen (d>=10)
( showsPrec 11 (genServerId svr)
. showChar ' ' . showSTypeRep (typeRep (Proxy @tag))
. showString " callback-server"
)