{-# LANGUAGE UndecidableInstances #-}
module Control.Eff.Concurrent.Protocol.CallbackServer
( start
, startLink
, Server
, ServerId(..)
, Event(..)
, TangibleCallbacks
, Callbacks
, callbacks
, onEvent
, CallbacksEff
, callbacksEff
, onEventEff
)
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 :: Type) eLoop q e.
( HasCallStack
, TangibleCallbacks tag eLoop q
, E.Server (Server tag eLoop q) (Processes q)
, FilteredLogging (Processes q)
, HasProcesses e q
)
=> CallbacksEff tag eLoop q
-> Eff e (Endpoint tag)
start = E.start
startLink
:: forall (tag :: Type) eLoop q e.
( HasCallStack
, TangibleCallbacks tag eLoop q
, E.Server (Server tag eLoop q) (Processes q)
, FilteredLogging (Processes q)
, HasProcesses e q
)
=> CallbacksEff tag eLoop q
-> Eff e (Endpoint tag)
startLink = E.startLink
data Server tag eLoop e deriving Typeable
type TangibleCallbacks tag eLoop 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 e) (Processes e) where
type ServerPdu (Server tag eLoop e) = tag
type ServerEffects (Server tag eLoop e) (Processes e) = eLoop
data instance Init (Server tag eLoop 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 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 e)) where
showsPrec d svr =
showParen (d>=10)
( showsPrec 11 (genServerId svr)
. showChar ' ' . showSTypeRep (typeRep (Proxy @tag))
. showString " callback-server"
)
type Callbacks tag e = CallbacksEff tag (Processes e) e
callbacks
:: forall tag q.
( HasCallStack
, TangibleCallbacks tag (Processes q) q
, E.Server (Server tag (Processes q) q) (Processes q)
, FilteredLogging q
)
=> (Endpoint tag -> Event tag -> Eff (Processes q) ())
-> ServerId tag
-> Callbacks tag q
callbacks evtCb i = callbacksEff (const id) evtCb i
onEvent
:: forall tag q .
( HasCallStack
, TangibleCallbacks tag (Processes q) q
, E.Server (Server tag (Processes q) q) (Processes q)
, FilteredLogging q
)
=> (Event tag -> Eff (Processes q) ())
-> ServerId (tag :: Type)
-> Callbacks tag q
onEvent = onEventEff id
type CallbacksEff tag eLoop e = E.Init (Server tag eLoop e)
callbacksEff
:: forall tag eLoop q.
( HasCallStack
, TangibleCallbacks tag eLoop q
, E.Server (Server tag eLoop q) (Processes q)
, FilteredLogging q
)
=> (forall x . Endpoint tag -> Eff eLoop x -> Eff (Processes q) x)
-> (Endpoint tag -> Event tag -> Eff eLoop ())
-> ServerId tag
-> CallbacksEff tag eLoop q
callbacksEff a b c = MkServer c a b
onEventEff
::
( HasCallStack
, TangibleCallbacks tag eLoop q
, E.Server (Server tag eLoop q) (Processes q)
, FilteredLogging q
)
=> (forall a. Eff eLoop a -> Eff (Processes q) a)
-> (Event tag -> Eff eLoop ())
-> ServerId (tag :: Type)
-> CallbacksEff tag eLoop q
onEventEff h f i = callbacksEff (const h) (const f) i