module Control.Eff.Concurrent.Protocol.StatefulServer
( Server(..)
, Stateful
, Effectful.Init(..)
, startLink
, start
, ModelState
, modifyModel
, getAndModifyModel
, modifyAndGetModel
, getModel
, putModel
, getAndPutModel
, useModel
, preuseModel
, zoomModel
, logModel
, SettingsReader
, askSettings
, viewSettings
, mapEffects
, coerceEffects
, Effectful.Event(..)
)
where
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 Effectful
import Control.Eff.Extend ()
import Control.Eff.Log
import Control.Eff.Reader.Strict
import Control.Eff.State.Strict
import Control.Lens
import Data.Coerce
import Data.Default
import Data.Kind
import Data.String (fromString)
import Data.Text (Text, pack)
import Data.Typeable
import GHC.Stack (HasCallStack)
import Control.Eff.Extend (raise)
import Data.Monoid (First)
class (Typeable (Protocol a)) => Server (a :: Type) q where
data StartArgument a
type Protocol a :: Type
type Protocol a = a
data family Model a :: Type
type Settings a :: Type
type Settings a = ()
title :: StartArgument a -> ProcessTitle
default title :: Typeable a => StartArgument a -> ProcessTitle
title _ = fromString $ showSTypeable @a ""
setup ::
Endpoint (Protocol a)
-> StartArgument a
-> Eff q (Model a, Settings a)
default setup ::
(Default (Model a), Default (Settings a))
=> Endpoint (Protocol a)
-> StartArgument a
-> Eff q (Model a, Settings a)
setup _ _ = pure (def, def)
update ::
Endpoint (Protocol a)
-> StartArgument a
-> Effectful.Event (Protocol a)
-> Eff (ModelState a ': SettingsReader a ': q) ()
data Stateful a deriving Typeable
instance Server a q => Effectful.Server (Stateful a) q where
data Init (Stateful a) = Init (StartArgument a)
type ServerPdu (Stateful a) = Protocol a
type ServerEffects (Stateful a) q = ModelState a ': SettingsReader a ': q
runEffects selfEndpoint (Init sa) m = do
(st, env) <- setup selfEndpoint sa
runReader env (evalState st m)
onEvent selfEndpoint (Init sa) = update selfEndpoint sa
serverTitle (Init startArg) = title @_ @q startArg
startLink
:: forall a r q
. ( HasCallStack
, Typeable a
, FilteredLogging (Processes q)
, Effectful.Server (Stateful a) (Processes q)
, Server a (Processes q)
, HasProcesses r q
)
=> StartArgument a -> Eff r (Endpoint (Protocol a))
startLink = Effectful.startLink . Init
start
:: forall a r q
. ( HasCallStack
, Typeable a
, Effectful.Server (Stateful a) (Processes q)
, Server a (Processes q)
, FilteredLogging (Processes q)
, HasProcesses r q
)
=> StartArgument a -> Eff r (Endpoint (Protocol a))
start = Effectful.start . Init
type ModelState a = State (Model a)
modifyModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e ()
modifyModel f = getModel @a >>= putModel @a . f
getAndModifyModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a)
getAndModifyModel f = getModel @a <* modify f
modifyAndGetModel :: forall a e . Member (ModelState a) e => (Model a -> Model a) -> Eff e (Model a)
modifyAndGetModel f = modifyModel @a f *> getModel @a
getModel :: forall a e . Member (ModelState a) e => Eff e (Model a)
getModel = get
useModel :: forall a b e . Member (ModelState a) e => Getting b (Model a) b -> Eff e b
useModel l = view l <$> getModel @a
preuseModel :: forall a b e . Member (ModelState a) e => Getting (First b) (Model a) b -> Eff e (Maybe b)
preuseModel l = preview l <$> getModel @a
putModel :: forall a e . Member (ModelState a) e => Model a -> Eff e ()
putModel = put
getAndPutModel :: forall a e . Member (ModelState a) e => Model a -> Eff e (Model a)
getAndPutModel m = getModel @a <* putModel @a m
zoomModel :: forall a b c e. Member (ModelState a) e => Lens' (Model a) b -> Eff (State b ': e) c -> Eff e c
zoomModel l a = do
m0 <- getModel @a
(c, m1) <- runState (view l m0) a
modifyModel @a (l .~ m1)
return c
logModel
:: forall m e q. ( Show (Model m)
, Member Logs e
, HasProcesses e q
, Member (ModelState m) e)
=> Text -> Eff e ()
logModel x =
getModel @m >>= logDebug . (x <>) . pack . show
type SettingsReader a = Reader (Settings a)
askSettings :: forall a e . Member (SettingsReader a) e => Eff e (Settings a)
askSettings = ask
viewSettings :: forall a b e . Member (SettingsReader a) e => Getting b (Settings a) b -> Eff e b
viewSettings l = view l <$> askSettings @a
mapEffects
:: forall inner outer a e.
(Settings outer -> Settings inner)
-> Lens' (Model outer) (Model inner)
-> Eff (ModelState inner : SettingsReader inner : e) a
-> Eff (ModelState outer : SettingsReader outer : e) a
mapEffects innerSettings innerStateLens innerEff =
do st0 <- getModel @outer
s0 <- askSettings @outer
(res, st1) <-
raise
(raise
(runReader
@(Settings inner)
(innerSettings s0)
(runState
@(Model inner)
(st0 ^. innerStateLens)
innerEff)))
modifyModel @outer (innerStateLens .~ st1)
return res
coerceEffects
:: forall inner outer a e.
( Coercible (Model inner) (Model outer)
, Coercible (Model outer) (Model inner)
, Coercible (Settings outer) (Settings inner)
)
=> Eff (ModelState inner : SettingsReader inner : e) a
-> Eff (ModelState outer : SettingsReader outer : e) a
coerceEffects innerEff =
do st0 <- getModel @outer
s0 <- askSettings @outer
(res, st1) <-
raise
(raise
(runReader
@(Settings inner)
(coerce s0)
(runState
(coerce @(Model outer) st0)
innerEff)))
putModel @outer (coerce st1)
return res