extensible-effects-concurrent 0.29.1 → 0.29.2

raw patch · 8 files changed

+268/−188 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• examples/example-embedded-protocols/Main.hs +65/−26
• extensible-effects-concurrent.cabal +1/−1
• src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +1/−1
• src/Control/Eff/Concurrent/Protocol/StatefulServer.hs +2/−0
• src/Control/Eff/Concurrent/Protocol/Supervisor.hs +185/−152
• src/Control/Eff/Concurrent/Protocol/Supervisor/InternalState.hs +3/−3
• test/SupervisorTests.hs +7/−5

@@ -1,5 +1,9 @@ # Changelog for extensible-effects-concurrent +## 0.29.2+- Improve `Supervisor` API: Use `Init` from the effectful server as start+  argument type.+ ## 0.29.1 - Add more constraints to `Embeds` - Improve the `CallbackServer`

@@ -1,39 +1,56 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NumericUnderscores #-} -- | Another  example for the library that uses embedded protocols with multiple server back--- ends and a polymorphic client.+-- ends and a polymorphic client, as well as the 'Supervisor.Sup' module to start multiple+-- back-ends. -- -- @since 0.29.0 module Main where  import           Control.DeepSeq import           Control.Eff+import           Control.Eff.State.Lazy as State import           Control.Eff.Concurrent-import           Control.Eff.Concurrent.Protocol.StatefulServer as Server+import           Control.Eff.Concurrent.Process.Timer+import           Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful+import           Control.Eff.Concurrent.Protocol.StatefulServer as Stateful+import           Control.Eff.Concurrent.Protocol.Supervisor as Supervisor import           Control.Lens import           Control.Monad import           Data.Dynamic import           Data.Foldable import           Data.Functor.Contravariant (contramap)+import           Data.String import qualified Data.Text as T+import GHC.Stack (HasCallStack)  main :: IO () main =   defaultMain (void embeddedExample) -embeddedExample :: Eff Effects ()+embeddedExample :: HasCallStack => Eff Effects () embeddedExample = do-  b1 <- Server.start InitBackend1-  b2 <- Server.start InitBackend2-  app <- Server.start InitApp+  b1 <- Stateful.start InitBackend1+  b2Sup <- startBackend2Sup+  b2 <- Supervisor.spawnOrLookup @Backend2 b2Sup 1+  _ <- Supervisor.spawnOrLookup b2Sup 2+  b2_2 <- Supervisor.spawnOrLookup b2Sup 2+  b2_3 <- Supervisor.spawnOrLookup b2Sup 3+  app <- Stateful.start InitApp   cast app DoThis   cast app DoThis   cast app DoThis   call app (SetBackend (Just (SomeBackend b1)))   cast app DoThis   cast app DoThis-  cast app DoThis-  cast app DoThis+  spawn_ "sub-process" $ do+    logNotice "spawned sub process"+    b1_2 <- Stateful.startLink InitBackend1+    call app (SetBackend (Just (SomeBackend b1_2)))+    cast app DoThis+    cast app DoThis+    exitWithError "test-error"   call app (SetBackend Nothing)   cast app DoThis   cast app DoThis@@ -41,18 +58,26 @@   call app (SetBackend (Just (SomeBackend b1)))   cast app DoThis   cast app DoThis+  call app (SetBackend Nothing)   cast app DoThis   call app (SetBackend (Just (SomeBackend b2)))   cast app DoThis   cast app DoThis+  call app (SetBackend (Just (SomeBackend b2_2)))   cast app DoThis-  call app (SetBackend Nothing)+  _ <- Supervisor.stopChild b2Sup 2+  cast app DoThis+  call app (SetBackend (Just (SomeBackend b2_3)))+  cast app DoThis+  Supervisor.stopSupervisor b2Sup+  cast app DoThis + ------------------------------ Server Instances  -- Application layer -instance Server.Server App Effects where+instance Stateful.Server App Effects where   type instance Model App = Maybe SomeBackend   data instance StartArgument App Effects = InitApp   update me _x e =@@ -63,11 +88,13 @@         traverse_ (`backendForgetObserver` me) oldB         traverse_ (`backendRegisterObserver` me) b         sendReply rt ()+      OnCast (AppBackendEvent be) ->+        logInfo ("got backend event: " <> T.pack (show be))       OnCast DoThis ->         do m <- getModel @App            case m of             Nothing -> logInfo "doing this without backend"-            Just b -> do+            Just b -> handleInterrupts (logWarning . T.pack . show) $ do                 doSomeBackendWork b                 bi <- getSomeBackendInfo b                 logInfo ("doing this. Backend: " <> T.pack bi)@@ -174,7 +201,7 @@  data Backend1 deriving Typeable -instance Server.Server Backend1 Effects where+instance Stateful.Server Backend1 Effects where   type instance Protocol Backend1 = (Backend, ObserverRegistry BackendEvent)   type instance Model Backend1 = (Int, ObserverRegistry BackendEvent)   data instance StartArgument Backend1 Effects = InitBackend1@@ -184,7 +211,7 @@     case e of       OnCall rt (ToPduLeft GetBackendInfo) ->         sendReply-          (toEmbeddedReplyTarget @(Server.Protocol Backend1) @Backend rt)+          (toEmbeddedReplyTarget @(Stateful.Protocol Backend1) @Backend rt)           ("Backend1 " <> show me <> " " <> show (model ^. _1))       OnCast (ToPduLeft BackendWork) -> do         logInfo "working..."@@ -199,7 +226,7 @@           logNotice "observer removed"       _ -> logWarning ("unexpected: " <> T.pack (show e)) --- Backend 2+-- Backend 2 is behind a supervisor  data Backend2 deriving Typeable @@ -228,29 +255,41 @@   fromPdu (B2ObserverRegistry x) = Just x   fromPdu _ = Nothing -instance Server.Server Backend2 Effects where-  type instance Model Backend2 = (Int, ObserverRegistry BackendEvent)-  data instance StartArgument Backend2 Effects = InitBackend2-  setup _ _ = pure ( (0, emptyObserverRegistry), () )-  update me _ e = do-    model <- getModel @Backend2+instance Effectful.Server Backend2 Effects where+  type instance ServerEffects Backend2 Effects = State Int ': ObserverRegistryState BackendEvent ': Effects+  data instance Init Backend2 Effects = InitBackend2 Int+  serverTitle (InitBackend2 x) = fromString ("backend-2: " ++ show x)+  runEffects _me _ e =  evalObserverRegistryState (evalState 0 e)+  onEvent me _ e = do+    myIndex <- get @Int     case e of       OnCall rt (B2BackendWork GetBackendInfo) ->-        sendReply rt ("Backend2 " <> show me <> " " <> show (model ^. _1))+        sendReply rt ("Backend2 " <> show me <> " " <> show myIndex)       OnCast (B2BackendWork BackendWork) -> do         logInfo "working..."-        oldM <- getAndModifyModel @Backend2 (over _1 (+ 1))-        when (fst oldM `mod` 2 == 0)-          (zoomModel @Backend2 _2 (observerRegistryNotify (BackendEvent "even!")))+        put @Int (myIndex + 1)+        when (myIndex `mod` 2 == 0)+          (observerRegistryNotify (BackendEvent "even!"))       OnCast (B2ObserverRegistry x) -> do         logInfo "event registration stuff ..."-        zoomModel @Backend2 _2 (observerRegistryHandlePdu x)+        observerRegistryHandlePdu @BackendEvent x+      OnInterrupt NormalExitRequested+        | even myIndex -> do+          logNotice "Kindly exitting -_-"+          exitNormally+        | otherwise ->+          logNotice "Ignoring exit request! :P"       OnDown pd -> do         logWarning (T.pack (show pd))-        wasObserver <- zoomModel @Backend2 _2 (observerRegistryRemoveProcess @BackendEvent (downProcess pd))+        wasObserver <- observerRegistryRemoveProcess @BackendEvent (downProcess pd)         when wasObserver $           logNotice "observer removed"       _ -> logWarning ("unexpected: " <> T.pack (show e))++type instance Supervisor.ChildId Backend2 = Int++startBackend2Sup :: Eff Effects (Endpoint (Supervisor.Sup Backend2))+startBackend2Sup = Supervisor.startSupervisor (Supervisor.MkSupConfig (TimeoutMicros 1_000_000) InitBackend2)  -- EXPERIMENTING data EP a where

@@ -1,6 +1,6 @@ cabal-version:  2.0 name:           extensible-effects-concurrent-version:        0.29.1+version:        0.29.2 description:    Please see the README on GitHub at <https://github.com/sheyll/extensible-effects-concurrent#readme> synopsis:       Message passing concurrency as extensible-effect homepage:       https://github.com/sheyll/extensible-effects-concurrent#readme

@@ -623,7 +623,7 @@   logAppendProcInfo pid =     let addProcessId = over           lmProcessId-          (maybe (Just (T.pack (printf "% 9s" (show pid)))) Just)+          (maybe (Just (T.pack (printf "% 9s" (show title ++ show pid)))) Just)     in  censorLogs @(Lift IO) addProcessId   triggerProcessLinksAndMonitors     :: ProcessId -> Interrupt e -> TVar (Set ProcessId) -> Eff BaseEffects ()

@@ -3,6 +3,8 @@ -- @since 0.24.0 module Control.Eff.Concurrent.Protocol.StatefulServer   ( Server(..)+  , Stateful+  , Effectful.Init(..)   , start   , startLink   , ModelState

@@ -48,19 +48,20 @@ -- -- @since 0.23.0 module Control.Eff.Concurrent.Protocol.Supervisor-  ( Sup()-  , ChildId-  , StartArgument(MkSupConfig)-  , supConfigChildStopTimeout-  , SpawnErr(AlreadyStarted)-  , startSupervisor+  ( startSupervisor   , stopSupervisor   , isSupervisorAlive   , monitorSupervisor   , getDiagnosticInfo   , spawnChild+  , spawnOrLookup   , lookupChild   , stopChild+  , Sup()+  , ChildId+  , Stateful.StartArgument(MkSupConfig)+  , supConfigChildStopTimeout+  , SpawnErr(AlreadyStarted)   ) where  import Control.DeepSeq (NFData(rnf))@@ -68,7 +69,8 @@ import Control.Eff.Concurrent.Protocol import Control.Eff.Concurrent.Protocol.Client import Control.Eff.Concurrent.Protocol.Wrapper-import Control.Eff.Concurrent.Protocol.StatefulServer as Server+import qualified Control.Eff.Concurrent.Protocol.EffectfulServer as Effectful+import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful import Control.Eff.Concurrent.Protocol.Supervisor.InternalState import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Process.Timer@@ -88,6 +90,165 @@ import Control.Applicative ((<|>))  -- * Supervisor Server API+++-- ** Functions++-- | Start and link a new supervisor process with the given 'SpawnFun'unction.+--+-- To spawn new child processes use 'spawnChild'.+--+-- @since 0.23.0+startSupervisor+  :: forall p e+  . ( HasCallStack+    , LogIo (Processes e)+    , TangibleSup p+    , Stateful.Server (Sup p) (Processes e)+    )+  => Stateful.StartArgument (Sup p) (Processes e)+  -> Eff (Processes e) (Endpoint (Sup p))+startSupervisor = Stateful.start++-- | Stop the supervisor and shutdown all processes.+--+-- Block until the supervisor has finished.+--+-- @since 0.23.0+stopSupervisor+  :: ( HasCallStack+     , HasProcesses e q+     , Member Logs e+     , Lifted IO e+     , TangibleSup p+     )+  => Endpoint (Sup p)+  -> Eff e ()+stopSupervisor ep = do+  logInfo ("stopping supervisor: " <> pack (show ep))+  mr <- monitor (_fromEndpoint ep)+  sendInterrupt (_fromEndpoint ep) NormalExitRequested+  r <- receiveSelectedMessage (selectProcessDown mr)+  logInfo ("supervisor stopped: " <> pack (show ep) <> " " <> pack (show r))++-- | Check if a supervisor process is still alive.+--+-- @since 0.23.0+isSupervisorAlive+  :: forall p q0 e .+     ( HasCallStack+     , Member Logs e+     , Typeable p+     , HasProcesses e q0+     )+  => Endpoint (Sup p)+  -> Eff e Bool+isSupervisorAlive x = isProcessAlive (_fromEndpoint x)++-- | Monitor a supervisor process.+--+-- @since 0.23.0+monitorSupervisor+  :: forall p q0 e .+     ( HasCallStack+     , Member Logs e+     , HasProcesses e q0+     , TangibleSup p+     )+  => Endpoint (Sup p)+  -> Eff e MonitorReference+monitorSupervisor x = monitor (_fromEndpoint x)++-- | Start and monitor a new child process using the 'SpawnFun' passed+-- to 'startSupervisor'.+--+-- @since 0.23.0+spawnChild+  :: forall p q0 e .+     ( HasCallStack+     , Member Logs e+     , HasProcesses e q0+     , TangibleSup p+     , Typeable (Effectful.ServerPdu p)+     )+  => Endpoint (Sup p)+  -> ChildId p+  -> Eff e (Either (SpawnErr p) (Endpoint (Effectful.ServerPdu p)))+spawnChild ep cId = call ep (StartC cId)++-- | Start and monitor a new child process using the 'SpawnFun' passed+-- to 'startSupervisor'.+--+-- Call 'spawnChild' and unpack the 'Either' result,+-- ignoring the 'AlreadyStarted' error.+--+-- @since 0.29.2+spawnOrLookup+  :: forall p q0 e .+     ( HasCallStack+     , Member Logs e+     , HasProcesses e q0+     , TangibleSup p+     , Typeable (Effectful.ServerPdu p)+     )+  => Endpoint (Sup p)+  -> ChildId p+  -> Eff e (Endpoint (Effectful.ServerPdu p))+spawnOrLookup supEp cId =+  do res <- spawnChild supEp cId+     pure $+      case res of+        Left (AlreadyStarted _ ep) -> ep+        Right ep -> ep++-- | Lookup the given child-id and return the output value of the 'SpawnFun'+--   if the client process exists.+--+-- @since 0.23.0+lookupChild ::+    forall p e q0 .+     ( HasCallStack+     , Member Logs e+     , HasProcesses e q0+     , TangibleSup p+     , Typeable (Effectful.ServerPdu p)+     )+  => Endpoint (Sup p)+  -> ChildId p+  -> Eff e (Maybe (Endpoint (Effectful.ServerPdu p)))+lookupChild ep cId = call ep (LookupC @p cId)++-- | Stop a child process, and block until the child has exited.+--+-- Return 'True' if a process with that ID was found, 'False' if no process+-- with the given ID was running.+--+-- @since 0.23.0+stopChild ::+    forall p e q0 .+     ( HasCallStack+     , Member Logs e+     , HasProcesses e q0+     , TangibleSup p+     )+  => Endpoint (Sup p)+  -> ChildId p+  -> Eff e Bool+stopChild ep cId = call ep (StopC @p cId (TimeoutMicros 4000000))++-- | Return a 'Text' describing the current state of the supervisor.+--+-- @since 0.23.0+getDiagnosticInfo+  :: forall p e q0 .+     ( HasCallStack+     , HasProcesses e q0+     , TangibleSup p+     )+  => Endpoint (Sup p)+  -> Eff e Text+getDiagnosticInfo s = call s (GetDiagnosticInfo @p)+ -- ** Types  -- | The index type of 'Server' supervisors.@@ -106,9 +267,9 @@   --   -- @since 0.23.0   data instance  Pdu (Sup p) r where-          StartC :: ChildId p -> Pdu (Sup p) ('Synchronous (Either (SpawnErr p) (Endpoint (Protocol p))))+          StartC :: ChildId p -> Pdu (Sup p) ('Synchronous (Either (SpawnErr p) (Endpoint (Effectful.ServerPdu p))))           StopC :: ChildId p -> Timeout -> Pdu (Sup p) ('Synchronous Bool)-          LookupC :: ChildId p -> Pdu (Sup p) ('Synchronous (Maybe (Endpoint (Protocol p))))+          LookupC :: ChildId p -> Pdu (Sup p) ('Synchronous (Maybe (Endpoint (Effectful.ServerPdu p))))           GetDiagnosticInfo :: Pdu (Sup p) ('Synchronous Text)       deriving Typeable @@ -147,8 +308,10 @@   ( LogIo q   , TangibleSup p   , Tangible (ChildId p)-  , Server p (Processes q)-  ) => Server (Sup p) (Processes q) where+  , Typeable (Effectful.ServerPdu p)+  , Effectful.Server p (Processes q)+  , HasProcesses (Effectful.ServerEffects p (Processes q)) q+  ) => Stateful.Server (Sup p) (Processes q) where    -- | Options that control the 'Sup p' process.   --@@ -163,13 +326,13 @@       -- , supConfigChildRestartPolicy :: ChildRestartPolicy       -- , supConfigResilience :: Resilience       supConfigChildStopTimeout :: Timeout-    , supConfigStartFun :: ChildId p -> Server.StartArgument p (Processes q)+    , supConfigStartFun :: ChildId p -> Effectful.Init p (Processes q)     }    type Model (Sup p) = Children (ChildId p) p    setup _ _cfg = pure (def, ())-  update _ supConfig (OnCall rt req) =+  update _ supConfig (Stateful.OnCall rt req) =     case req of       GetDiagnosticInfo ->  do         p <- (pack . show <$> getChildren @(ChildId p) @p)@@ -191,7 +354,7 @@         mExisting <- lookupChildById @(ChildId p) @p i         case mExisting of           Nothing -> do-            childEp <- raise (raise (Server.start (supConfigStartFun supConfig i)))+            childEp <- raise (raise (Effectful.start (supConfigStartFun supConfig i)))             let childPid = _fromEndpoint childEp             cMon <- monitor childPid             putChild i (MkChild @p childEp cMon)@@ -199,7 +362,7 @@           Just existingChild ->             sendReply rt (Left (AlreadyStarted i (existingChild ^. childEndpoint))) -  update _ _supConfig (OnDown pd) = do+  update _ _supConfig (Stateful.OnDown pd) = do       oldEntry <- lookupAndRemoveChildByMonitor @(ChildId p) @p (downReference pd)       case oldEntry of         Nothing -> logWarning ("unexpected: " <> pack (show pd))@@ -210,7 +373,7 @@                   <> " => "                   <> pack (show (_childEndpoint c))                   )-  update _ supConfig (OnInterrupt e) = do+  update _ supConfig (Stateful.OnInterrupt e) = do       let (logSev, exitReason) =             case e of               NormalExitRequested ->@@ -227,147 +390,15 @@ -- | Runtime-Errors occurring when spawning child-processes. -- -- @since 0.23.0-data SpawnErr p = AlreadyStarted (ChildId p) (Endpoint (Protocol p))+data SpawnErr p = AlreadyStarted (ChildId p) (Endpoint (Effectful.ServerPdu p))   deriving (Typeable, Generic)  deriving instance Eq (ChildId p) => Eq (SpawnErr p) deriving instance Ord (ChildId p) => Ord (SpawnErr p)-deriving instance (Typeable (Protocol p), Show (ChildId p)) => Show (SpawnErr p)+deriving instance (Typeable (Effectful.ServerPdu p), Show (ChildId p)) => Show (SpawnErr p)  instance NFData (ChildId p) => NFData (SpawnErr p) ---- ** Functions--- | Start and link a new supervisor process with the given 'SpawnFun'unction.------ To spawn new child processes use 'spawnChild'.------ @since 0.23.0-startSupervisor-  :: forall p e-  . ( HasCallStack-    , LogIo (Processes e)-    , TangibleSup p-    , Server (Sup p) (Processes e)-    )-  => StartArgument (Sup p) (Processes e)-  -> Eff (Processes e) (Endpoint (Sup p))-startSupervisor = Server.start---- | Stop the supervisor and shutdown all processes.------ Block until the supervisor has finished.------ @since 0.23.0-stopSupervisor-  :: ( HasCallStack-     , HasProcesses e q-     , Member Logs e-     , Lifted IO e-     , TangibleSup p-     )-  => Endpoint (Sup p)-  -> Eff e ()-stopSupervisor ep = do-  logInfo ("stopping supervisor: " <> pack (show ep))-  mr <- monitor (_fromEndpoint ep)-  sendInterrupt (_fromEndpoint ep) NormalExitRequested-  r <- receiveSelectedMessage (selectProcessDown mr)-  logInfo ("supervisor stopped: " <> pack (show ep) <> " " <> pack (show r))---- | Check if a supervisor process is still alive.------ @since 0.23.0-isSupervisorAlive-  :: forall p q0 e .-     ( HasCallStack-     , Member Logs e-     , Typeable p-     , HasProcesses e q0-     )-  => Endpoint (Sup p)-  -> Eff e Bool-isSupervisorAlive x = isProcessAlive (_fromEndpoint x)---- | Monitor a supervisor process.------ @since 0.23.0-monitorSupervisor-  :: forall p q0 e .-     ( HasCallStack-     , Member Logs e-     , HasProcesses e q0-     , TangibleSup p-     )-  => Endpoint (Sup p)-  -> Eff e MonitorReference-monitorSupervisor x = monitor (_fromEndpoint x)---- | Start, link and monitor a new child process using the 'SpawnFun' passed--- to 'startSupervisor'.------ @since 0.23.0-spawnChild-  :: forall p q0 e .-     ( HasCallStack-     , Member Logs e-     , HasProcesses e q0-     , TangibleSup p-     , Typeable (Protocol p)-     )-  => Endpoint (Sup p)-  -> ChildId p-  -> Eff e (Either (SpawnErr p) (Endpoint (Protocol p)))-spawnChild ep cId = call ep (StartC cId)---- | Lookup the given child-id and return the output value of the 'SpawnFun'---   if the client process exists.------ @since 0.23.0-lookupChild ::-    forall p e q0 .-     ( HasCallStack-     , Member Logs e-     , HasProcesses e q0-     , TangibleSup p-     , Typeable (Protocol p)-     )-  => Endpoint (Sup p)-  -> ChildId p-  -> Eff e (Maybe (Endpoint (Protocol p)))-lookupChild ep cId = call ep (LookupC @p cId)---- | Stop a child process, and block until the child has exited.------ Return 'True' if a process with that ID was found, 'False' if no process--- with the given ID was running.------ @since 0.23.0-stopChild ::-    forall p e q0 .-     ( HasCallStack-     , Member Logs e-     , HasProcesses e q0-     , TangibleSup p-     )-  => Endpoint (Sup p)-  -> ChildId p-  -> Eff e Bool-stopChild ep cId = call ep (StopC @p cId (TimeoutMicros 4000000))---- | Return a 'Text' describing the current state of the supervisor.------ @since 0.23.0-getDiagnosticInfo-  :: forall p e q0 .-     ( HasCallStack-     , HasProcesses e q0-     , TangibleSup p-     )-  => Endpoint (Sup p)-  -> Eff e Text-getDiagnosticInfo s = call s (GetDiagnosticInfo @p)- -- Internal Functions  stopOrKillChild@@ -379,7 +410,7 @@      , Member Logs e      , Member (State (Children (ChildId p) p)) e      , TangibleSup p-     , Typeable (Protocol p)+     , Typeable (Effectful.ServerPdu p)      )   => ChildId p   -> Child p@@ -392,6 +423,8 @@         sendInterrupt (_fromEndpoint (c^.childEndpoint)) NormalExitRequested         r1 <- receiveSelectedMessage (   Right <$> selectProcessDown (c^.childMonitoring)                                      <|> Left  <$> selectTimerElapsed t )+        demonitor (c^.childMonitoring)+        unlinkProcess (_fromEndpoint (c^.childEndpoint))         case r1 of           Left timerElapsed -> do             logWarning (pack (show timerElapsed) <> ": child "<> pack (show cId) <>" => " <> pack(show (c^.childEndpoint)) <>" did not shutdown in time")@@ -413,7 +446,7 @@      , Member Logs e      , Member (State (Children (ChildId p) p)) e      , TangibleSup p-     , Typeable (Protocol p)+     , Typeable (Effectful.ServerPdu p)      )   => Timeout -> Eff e () stopAllChildren stopTimeout = removeAllChildren @(ChildId p) @p >>= pure . Map.assocs >>= traverse_ xxx

@@ -4,7 +4,7 @@ import Control.Eff as Eff import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Protocol-import Control.Eff.Concurrent.Protocol.StatefulServer+import Control.Eff.Concurrent.Protocol.EffectfulServer import Control.Eff.State.Strict as Eff import Control.Lens hiding ((.=), use) import Data.Default@@ -14,14 +14,14 @@   data Child p = MkChild-  { _childEndpoint :: Endpoint (Protocol p)+  { _childEndpoint :: Endpoint (ServerPdu p)   , _childMonitoring :: MonitorReference   }   deriving (Generic, Typeable, Eq, Ord)  instance NFData (Child o) -instance Typeable (Protocol p) => Show (Child p) where+instance Typeable (ServerPdu p) => Show (Child p) where   showsPrec d c = showParen (d>=10)     (showString "supervised process: " . shows (_childEndpoint c)  . showChar ' ' . shows (_childMonitoring c) ) 

@@ -7,7 +7,8 @@ import Control.DeepSeq import Control.Eff import Control.Eff.Concurrent-import Control.Eff.Concurrent.Protocol.StatefulServer as Server+import Control.Eff.Concurrent.Protocol.EffectfulServer (Event(..))+import qualified Control.Eff.Concurrent.Protocol.StatefulServer as Stateful import Control.Eff.Concurrent.Protocol.Supervisor as Sup import Control.Eff.Concurrent.Process.Timer import Data.Either (fromRight, isLeft, isRight)@@ -24,7 +25,7 @@   testGroup     "Supervisor"     (let startTestSup = startTestSupWith ExitWhenRequested (TimeoutMicros 500000)-         startTestSupWith e t = Sup.startSupervisor (MkSupConfig t (TestServerArgs e))+         startTestSupWith e t = Sup.startSupervisor (MkSupConfig t (Stateful.Init . TestServerArgs e))          spawnTestChild sup i = Sup.spawnChild sup i >>= either (lift . assertFailure . show) pure       in [ runTestCase "The supervisor starts and is shut down" $ do              outerSelf <- self@@ -37,7 +38,7 @@                  () <- receiveMessage                  Sup.stopSupervisor sup              unlinkProcess testWorker-             sup <- receiveMessage :: Eff Effects  (Endpoint (Sup.Sup TestProtocol))+             sup <- receiveMessage :: Eff Effects  (Endpoint (Sup.Sup (Stateful.Stateful TestProtocol)))              supAliveAfter1 <- isSupervisorAlive sup              logInfo ("still alive 1: " <> pack (show supAliveAfter1))              lift (supAliveAfter1 @=? True)@@ -265,7 +266,7 @@   | ExitWhenRequested   deriving Eq -instance Server TestProtocol Effects where+instance Stateful.Server TestProtocol Effects where   update _me (TestServerArgs testMode tId) evt =     case evt of       OnCast (TestInterruptWith i) -> do@@ -286,4 +287,5 @@         logDebug (pack (show tId) <> ": got some info: " <> pack (show evt))   data instance StartArgument TestProtocol Effects = TestServerArgs TestProtocolServerMode Int -type instance ChildId TestProtocol = Int+type instance ChildId (Stateful.Stateful TestProtocol) = Int+