extensible-effects-concurrent 0.26.1 → 0.27.0

raw patch · 19 files changed

+599/−573 lines, 19 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• examples/example-1/Main.hs +9/−18
• examples/example-2/Main.hs +6/−8
• extensible-effects-concurrent.cabal +3/−2
• src/Control/Eff/Concurrent.hs +3/−3
• src/Control/Eff/Concurrent/Process/Interactive.hs +2/−2
• src/Control/Eff/Concurrent/Protocol.hs +148/−129
• src/Control/Eff/Concurrent/Protocol/CallbackServer.hs +119/−0
• src/Control/Eff/Concurrent/Protocol/Client.hs +11/−11
• src/Control/Eff/Concurrent/Protocol/EffectfulServer.hs +16/−128
• src/Control/Eff/Concurrent/Protocol/Observer.hs +11/−11
• src/Control/Eff/Concurrent/Protocol/Observer/Queue.hs +3/−3
• src/Control/Eff/Concurrent/Protocol/Request.hs +0/−225
• src/Control/Eff/Concurrent/Protocol/StatefulServer.hs +12/−8
• src/Control/Eff/Concurrent/Protocol/Supervisor.hs +7/−7
• src/Control/Eff/Concurrent/Protocol/Wrapper.hs +225/−0
• test/GenServerTests.hs +10/−10
• test/ProcessBehaviourTestCases.hs +5/−6
• test/SupervisorTests.hs +2/−2

@@ -1,5 +1,12 @@ # Changelog for extensible-effects-concurrent +## 0.27.0+- Improve/fix `EmbedProtocol` type class+- Add a _this_ like parameter to the methods of `EffectfulServer`+- Rename `IsPdu` to `HasPdu`+- Remove `GenServer` from `EffectfulServer` and put it into a +  new module: `Control.Eff.Concurrent.Protocol.CallbackServer`+- Rename `Control.Eff.Concurrent.Protocol.Request` to `(...).Wrapper`  ## 0.26.1 - Documentation fixes

@@ -6,6 +6,7 @@ import           Control.Monad import           Data.Dynamic import           Control.Eff.Concurrent+import qualified Control.Eff.Concurrent.Protocol.CallbackServer as Callback import           Control.Eff.Concurrent.Protocol.EffectfulServer as Server import qualified Control.Exception             as Exc import qualified Data.Text as T@@ -17,7 +18,7 @@  type instance ToPretty TestProtocol = PutStr "test" -instance Typeable x => IsPdu TestProtocol x where+instance Typeable x => HasPdu TestProtocol x where   data instance Pdu TestProtocol x where     SayHello :: String -> Pdu TestProtocol ('Synchronous Bool)     Shout :: String -> Pdu TestProtocol 'Asynchronous@@ -75,19 +76,17 @@   go  testServerLoop :: Eff Effects (Endpoint TestProtocol)-testServerLoop = start (genServer (const id) handleReq "test-server-1")+testServerLoop = Callback.start (\ _ e -> e) handleReq "test-server-1"  where-  handleReq :: GenServerId TestProtocol -> Event TestProtocol -> Eff Effects ()-  handleReq _myId (OnCall rt cm) =+  handleReq :: Endpoint TestProtocol -> Event TestProtocol -> Eff Effects ()+  handleReq me (OnCall rt cm) =     case cm of       Terminate -> do-        me <- self         logInfo (T.pack (show me ++ " exiting"))         sendReply rt ()         interrupt NormalExitRequested        TerminateError e -> do-        me <- self         logInfo (T.pack (show me ++ " exiting with error: " ++ e))         sendReply rt ()         interrupt (ErrorInterrupt e)@@ -95,43 +94,35 @@       SayHello mx ->         case mx of           "e1" -> do-            me <- self             logInfo (T.pack (show me ++ " raising an error"))             interrupt (ErrorInterrupt "No body loves me... :,(")            "e2" -> do-            me <- self             logInfo (T.pack (show me ++ " throwing a MyException "))             void (lift (Exc.throw MyException))            "self" -> do-            me <- self             logInfo (T.pack (show me ++ " casting to self"))-            cast (asEndpoint @TestProtocol me) (Shout "from me")+            cast me (Shout "from me")             sendReply rt False            "stop" -> do-            me <- self             logInfo (T.pack (show me ++ " stopping me"))             sendReply rt False             interrupt (ErrorInterrupt "test error")            x -> do-            me <- self             logInfo (T.pack (show me ++ " Got Hello: " ++ x))             sendReply rt (length x > 3) -  handleReq _myId (OnCast (Shout x)) = do-    me <- self+  handleReq me (OnCast (Shout x)) = do     logInfo (T.pack (show me ++ " Shouting: " ++ x)) -  handleReq _myId (OnInterrupt msg) = do-    me <- self+  handleReq me (OnInterrupt msg) = do     logInfo (T.pack (show me ++ " is exiting: " ++ show msg))     logProcessExit msg     interrupt msg -  handleReq _myId wtf = do-    me <- self+  handleReq me wtf =     logCritical (T.pack (show me ++ " WTF: " ++ show wtf)) 

@@ -23,7 +23,7 @@  type instance ToPretty Counter = PutStr "counter" -instance Typeable x => IsPdu Counter x where+instance Typeable x => HasPdu Counter x where   data instance Pdu Counter x where     Inc :: Pdu Counter 'Asynchronous     Cnt :: Pdu Counter ('Synchronous Integer)@@ -67,7 +67,7 @@  type instance ToPretty SupiDupi = PutStr "supi dupi" -instance Typeable r => IsPdu SupiDupi r where+instance Typeable r => HasPdu SupiDupi r where   data instance Pdu SupiDupi r where     Whoopediedoo :: Bool -> Pdu SupiDupi ('Synchronous (Maybe ()))     deriving Typeable@@ -98,9 +98,9 @@    data instance StartArgument SupiCounter (Processes q) = MkEmptySupiCounter -  setup _ = return ((0, emptyObservers, Nothing), ())+  setup _ _ = return ((0, emptyObservers, Nothing), ()) -  update _ = \case+  update _ _ = \case     OnCall rt callReq ->       case callReq of         ToPdu1 Cnt ->@@ -139,10 +139,8 @@ instance Member Logs q => Server (Observer CounterChanged) (Processes q) where   data StartArgument (Observer CounterChanged) (Processes q) = OCCStart   type Model (Observer CounterChanged) = Observers CounterChanged-  type Settings (Observer CounterChanged) = ()-  type Protocol (Observer CounterChanged) = Observer CounterChanged-  setup _ = pure (emptyObservers, ())-  update _ =+  setup _ _ = pure (emptyObservers, ())+  update _ _ =     \case       OnCast r -> handleObservations (\msg -> logInfo' ("observed: " ++ show msg)) r       wtf -> logNotice (T.pack (show wtf))

@@ -1,6 +1,6 @@ cabal-version:  2.0 name:           extensible-effects-concurrent-version:        0.26.1+version:        0.27.0 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@@ -85,11 +85,12 @@                   Control.Eff.Concurrent.Pure,                   Control.Eff.Concurrent.SingleThreaded,                   Control.Eff.Concurrent.Protocol,+                  Control.Eff.Concurrent.Protocol.CallbackServer,                   Control.Eff.Concurrent.Protocol.Client,                   Control.Eff.Concurrent.Protocol.EffectfulServer,                   Control.Eff.Concurrent.Protocol.StatefulServer,-                  Control.Eff.Concurrent.Protocol.Request,                   Control.Eff.Concurrent.Protocol.Supervisor,+                  Control.Eff.Concurrent.Protocol.Wrapper,                   Control.Eff.Concurrent.Process,                   Control.Eff.Concurrent.Process.Timer,                   Control.Eff.Concurrent.Process.ForkIOScheduler,

@@ -32,7 +32,7 @@     module Control.Eff.Concurrent.Protocol.Client   ,     -- ** /Protocol-Server/ Support Functions for building protocol servers-    module Control.Eff.Concurrent.Protocol.Request+    module Control.Eff.Concurrent.Protocol.Wrapper   ,     -- ** /Observer/ Functions for Events and Event Listener     module Control.Eff.Concurrent.Protocol.Observer@@ -178,7 +178,7 @@                                                 )  import           Control.Eff.Concurrent.Protocol-                                                ( IsPdu(..)+                                                ( HasPdu(..)                                                 , Pdu(..)                                                 , Synchronicity(..)                                                 , ProtocolReply@@ -234,7 +234,7 @@                                                 , withObservationQueue                                                 , spawnLinkObservationQueueWriter                                                 )-import           Control.Eff.Concurrent.Protocol.Request+import           Control.Eff.Concurrent.Protocol.Wrapper                                                 ( Request(..)                                                 , sendReply                                                 , ReplyTarget(..)

@@ -131,7 +131,7 @@ submitCast   :: forall o r    . ( SetMember Lift (Lift IO) r-     , IsPdu o 'Asynchronous+     , HasPdu o 'Asynchronous      , Member Interrupts r)   => SchedulerSession r   -> Endpoint o@@ -144,7 +144,7 @@   :: forall o q r    . ( SetMember Lift (Lift IO) r      , Member Interrupts r-     , IsPdu o ('Synchronous q)+     , HasPdu o ('Synchronous q)      , Tangible q      )   => SchedulerSession r

@@ -1,21 +1,40 @@--- | This module contains a mechanism to specify what kind of messages (aka--- /requests/) a 'Endpoint' ('Process') can handle, and if the caller blocks and--- waits for an answer, which the server process provides.+-- | Types and functions for type-safe(er) interaction between processes. ----- The type magic in the 'Pdu' type family allows to define a related set of /requests/ along+-- All messages sent between processes are eventually converted to 'Dynamic' values+-- which carry little type information.+--+-- A step towards a more controlled and type safe process interaction model is+-- done with the facilities defined in this module.+--+-- The metaphor for communication is a /stateles protocol/ that describes the+-- messages handled by a process.+--+-- A /protocol/ is represented by a custom data type, often a /phantom/ type,+-- which is then used to form specific instances of type classes data/type families,+-- to determine the messages, the replies, the servers and clients, associated with+-- specific task, that needs to be executed concurrently.+--+-- This module contains a mechanism to specify what kind of messages (aka+-- /requests/) an 'Endpoint' can handle.+--+-- The Endpoint wraps a 'ProcessId' and carries the protocol phantom-type, to indicate the messages+-- that a process repsonds to.+--+-- The associated data type 'Pdu' defines the messages or /requests/ along -- with the corresponding responses. -- -- Request handling can be either blocking, if a response is required, or -- non-blocking. ----- A process can /serve/ a specific 'Pdu' instance by using the functions provided by--- the "Control.Eff.Concurrent.Pdu.Server" module.+-- A process can /serve/ a specific protocol by using the functions provided by+-- the "Control.Eff.Concurrent.Protocol.EffectfulServer" and+-- "Control.Eff.Concurrent.Protocol.EffectfulServer" modules. ----- To enable a process to use such a /service/, the functions provided by--- the "Control.Eff.Concurrent.Pdu.Client" should be used.+-- To enable a process to use such a /service/, the functions provided in+-- "Control.Eff.Concurrent.Protocol.Client" should be used. -- module Control.Eff.Concurrent.Protocol-  ( IsPdu(..)+  ( HasPdu(..)   , Pdu(..)   , Synchronicity(..)   , ProtocolReply@@ -61,7 +80,7 @@ -- > -- > data BookShop deriving Typeable -- >--- > instance IsPdu BookShop r where+-- > instance HasPdu BookShop r where -- >   data instance Pdu BookShop r where -- >     RentBook  :: BookId   -> Pdu BookShop ('Synchronous (Either RentalError RentalId)) -- >     BringBack :: RentalId -> Pdu BookShop 'Asynchronous@@ -73,7 +92,11 @@ -- > -- -- @since 0.25.1-class (NFData (Pdu protocol reply), Show (Pdu protocol reply), Typeable protocol, Typeable reply) => IsPdu (protocol :: Type) (reply :: Synchronicity) where+class (NFData (Pdu protocol reply), Show (Pdu protocol reply), Typeable protocol, Typeable reply) => HasPdu (protocol :: Type) (reply :: Synchronicity) where++  -- | The __protocol data unit__ type for the given protocol.+  data family Pdu protocol reply+   -- | Deserialize a 'Pdu' from a 'Dynamic' i.e. from a message received by a process.   --   -- @since 0.25.1@@ -82,14 +105,10 @@   default deserializePdu :: (Typeable (Pdu protocol reply)) => Dynamic -> Maybe (Pdu protocol reply)   deserializePdu = fromDynamic -  -- | The __protocol data unit__ type for the given protocol.-  data family Pdu protocol reply-   --  type family PrettyPdu protocol reply :: PrettyType   --  type instance PrettyPdu protocol reply =   --      PrettySurrounded (PutStr "<") (PutStr ">") ("protocol" <:> ToPretty protocol <+> ToPretty reply) - type instance ToPretty (Pdu x y) =   PrettySurrounded (PutStr "<") (PutStr ">") ("protocol" <:> ToPretty x <+> ToPretty y) @@ -173,6 +192,100 @@  makeLenses ''Endpoint +instance (HasPdu a1 r, HasPdu a2 r) => HasPdu (a1, a2) r where+  data instance Pdu (a1, a2) r where+          ToPduLeft :: Pdu a1 r -> Pdu (a1, a2) r+          ToPduRight :: Pdu a2 r -> Pdu (a1, a2) r++  deserializePdu d =+    case deserializePdu d of+      Just (x :: Pdu a1 r) ->+        Just (embedPdu x)+      Nothing ->+        case deserializePdu d of+          Just (x :: Pdu a2 r) ->+            Just (embedPdu x)+          Nothing ->+            Nothing++instance (HasPdu a1 r, HasPdu a2 r, HasPdu a3 r) => HasPdu (a1, a2, a3) r where+  data instance Pdu (a1, a2, a3) r where+    ToPdu1 :: Pdu a1 r -> Pdu (a1, a2, a3) r+    ToPdu2 :: Pdu a2 r -> Pdu (a1, a2, a3) r+    ToPdu3 :: Pdu a3 r -> Pdu (a1, a2, a3) r++  deserializePdu d =+    case deserializePdu d of+      Just (x :: Pdu a1 r) ->+        Just (embedPdu x)+      Nothing ->+        case deserializePdu d of+          Just (x :: Pdu a2 r) ->+            Just (embedPdu x)+          Nothing ->+            case deserializePdu d of+              Just (x :: Pdu a3 r) ->+                Just (embedPdu x)+              Nothing ->+                Nothing++instance (HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r) => HasPdu (a1, a2, a3, a4) r where+  data instance Pdu (a1, a2, a3, a4) r where+    ToPdu1Of4 :: Pdu a1 r -> Pdu (a1, a2, a3, a4) r+    ToPdu2Of4 :: Pdu a2 r -> Pdu (a1, a2, a3, a4) r+    ToPdu3Of4 :: Pdu a3 r -> Pdu (a1, a2, a3, a4) r+    ToPdu4Of4 :: Pdu a4 r -> Pdu (a1, a2, a3, a4) r++  deserializePdu d =+    case deserializePdu d of+      Just (x :: Pdu a1 r) ->+        Just (embedPdu x)+      Nothing ->+        case deserializePdu d of+          Just (x :: Pdu a2 r) ->+            Just (embedPdu x)+          Nothing ->+            case deserializePdu d of+              Just (x :: Pdu a3 r) ->+                Just (embedPdu x)+              Nothing ->+                case deserializePdu d of+                  Just (x :: Pdu a4 r) ->+                    Just (embedPdu x)+                  Nothing ->+                    Nothing++instance (HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r, HasPdu a5 r) => HasPdu (a1, a2, a3, a4, a5) r where+  data instance Pdu (a1, a2, a3, a4, a5) r where+    ToPdu1Of5 :: Pdu a1 r -> Pdu (a1, a2, a3, a4, a5) r+    ToPdu2Of5 :: Pdu a2 r -> Pdu (a1, a2, a3, a4, a5) r+    ToPdu3Of5 :: Pdu a3 r -> Pdu (a1, a2, a3, a4, a5) r+    ToPdu4Of5 :: Pdu a4 r -> Pdu (a1, a2, a3, a4, a5) r+    ToPdu5Of5 :: Pdu a5 r -> Pdu (a1, a2, a3, a4, a5) r++  deserializePdu d =+    case deserializePdu d of+      Just (x :: Pdu a1 r) ->+        Just (embedPdu x)+      Nothing ->+        case deserializePdu d of+          Just (x :: Pdu a2 r) ->+            Just (embedPdu x)+          Nothing ->+            case deserializePdu d of+              Just (x :: Pdu a3 r) ->+                Just (embedPdu x)+              Nothing ->+                case deserializePdu d of+                  Just (x :: Pdu a4 r) ->+                    Just (embedPdu x)+                  Nothing ->+                    case deserializePdu d of+                      Just (x :: Pdu a5 r) ->+                        Just (embedPdu x)+                      Nothing ->+                        Nothing+ -- | Tag a 'ProcessId' with an 'Pdu' type index to mark it a 'Endpoint' process -- handling that API proxyAsEndpoint :: proxy protocol -> ProcessId -> Endpoint protocol@@ -189,17 +302,17 @@ -- Laws: @embeddedPdu = prism' embedPdu fromPdu@ -- -- @since 0.24.0-class EmbedProtocol protocol embeddedProtocol where+class EmbedProtocol protocol embeddedProtocol (result :: Synchronicity) where   -- | A 'Prism' for the embedded 'Pdu's.   embeddedPdu :: Prism' (Pdu protocol result) (Pdu embeddedProtocol result)   embeddedPdu = prism' embedPdu fromPdu   -- | Embed the 'Pdu' value of an embedded protocol into the corresponding   --  'Pdu' value.-  embedPdu :: Pdu embeddedProtocol r -> Pdu protocol r+  embedPdu :: Pdu embeddedProtocol result -> Pdu protocol result   embedPdu = review embeddedPdu   -- | Examine a 'Pdu' value from the outer protocol, and return it, if it embeds a 'Pdu' of   -- embedded protocol, otherwise return 'Nothing'/-  fromPdu :: Pdu protocol r -> Maybe (Pdu embeddedProtocol r)+  fromPdu :: Pdu protocol result -> Maybe (Pdu embeddedProtocol result)   fromPdu = preview embeddedPdu  @@ -208,7 +321,7 @@ -- See 'EmbedProtocol', 'fromEmbeddedEndpoint'. -- -- @since 0.25.1-toEmbeddedEndpoint :: forall inner outer . EmbedProtocol outer inner => Endpoint outer -> Endpoint inner+toEmbeddedEndpoint :: forall inner outer r . EmbedProtocol outer inner r => Endpoint outer -> Endpoint inner toEmbeddedEndpoint = coerce  -- | Convert an 'Endpoint' to an endpoint for a server, that embeds the protocol.@@ -216,30 +329,14 @@ -- See 'EmbedProtocol', 'toEmbeddedEndpoint'. -- -- @since 0.25.1-fromEmbeddedEndpoint ::  forall outer inner. EmbedProtocol outer inner => Endpoint inner -> Endpoint outer+fromEmbeddedEndpoint ::  forall outer inner r . EmbedProtocol outer inner r => Endpoint inner -> Endpoint outer fromEmbeddedEndpoint = coerce -instance EmbedProtocol a a where+instance EmbedProtocol a a r where   embeddedPdu = prism' id Just   embedPdu = id   fromPdu = Just -instance (IsPdu a1 r, IsPdu a2 r) => IsPdu (a1, a2) r where-  data instance Pdu (a1, a2) r where-          ToPduLeft :: Pdu a1 r -> Pdu (a1, a2) r-          ToPduRight :: Pdu a2 r -> Pdu (a1, a2) r--  deserializePdu d =-    case deserializePdu d of-      Just (x :: Pdu a1 r) ->-        Just (embedPdu x)-      Nothing ->-        case deserializePdu d of-          Just (x :: Pdu a2 r) ->-            Just (embedPdu x)-          Nothing ->-            Nothing- instance (NFData (Pdu a1 r), NFData (Pdu a2 r)) => NFData (Pdu (a1, a2) r) where   rnf (ToPduLeft x) = rnf x   rnf (ToPduRight y) = rnf y@@ -248,38 +345,17 @@   showsPrec d (ToPduLeft x) = showsPrec d x   showsPrec d (ToPduRight y) = showsPrec d y -instance EmbedProtocol (a1, a2) a1 where+instance EmbedProtocol (a1, a2) a1 r where   embedPdu = ToPduLeft   fromPdu (ToPduLeft l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2) a2 where+instance EmbedProtocol (a1, a2) a2 r where   embeddedPdu =     prism' ToPduRight $ \case       ToPduRight r -> Just r       ToPduLeft _ -> Nothing -instance (IsPdu a1 r, IsPdu a2 r, IsPdu a3 r) => IsPdu (a1, a2, a3) r where-  data instance Pdu (a1, a2, a3) r where-    ToPdu1 :: Pdu a1 r -> Pdu (a1, a2, a3) r-    ToPdu2 :: Pdu a2 r -> Pdu (a1, a2, a3) r-    ToPdu3 :: Pdu a3 r -> Pdu (a1, a2, a3) r--  deserializePdu d =-    case deserializePdu d of-      Just (x :: Pdu a1 r) ->-        Just (embedPdu x)-      Nothing ->-        case deserializePdu d of-          Just (x :: Pdu a2 r) ->-            Just (embedPdu x)-          Nothing ->-            case deserializePdu d of-              Just (x :: Pdu a3 r) ->-                Just (embedPdu x)-              Nothing ->-                Nothing- instance (NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r)) => NFData (Pdu (a1, a2, a3) r) where   rnf (ToPdu1 x) = rnf x   rnf (ToPdu2 y) = rnf y@@ -290,47 +366,21 @@   showsPrec d (ToPdu2 y) = showsPrec d y   showsPrec d (ToPdu3 z) = showsPrec d z -instance EmbedProtocol (a1, a2, a3) a1 where+instance EmbedProtocol (a1, a2, a3) a1 r where   embedPdu = ToPdu1   fromPdu (ToPdu1 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3) a2 where+instance EmbedProtocol (a1, a2, a3) a2 r where   embedPdu = ToPdu2   fromPdu (ToPdu2 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3) a3 where+instance EmbedProtocol (a1, a2, a3) a3 r where   embedPdu = ToPdu3   fromPdu (ToPdu3 l) = Just l   fromPdu _ = Nothing -instance (IsPdu a1 r, IsPdu a2 r, IsPdu a3 r, IsPdu a4 r) => IsPdu (a1, a2, a3, a4) r where-  data instance Pdu (a1, a2, a3, a4) r where-    ToPdu1Of4 :: Pdu a1 r -> Pdu (a1, a2, a3, a4) r-    ToPdu2Of4 :: Pdu a2 r -> Pdu (a1, a2, a3, a4) r-    ToPdu3Of4 :: Pdu a3 r -> Pdu (a1, a2, a3, a4) r-    ToPdu4Of4 :: Pdu a4 r -> Pdu (a1, a2, a3, a4) r--  deserializePdu d =-    case deserializePdu d of-      Just (x :: Pdu a1 r) ->-        Just (embedPdu x)-      Nothing ->-        case deserializePdu d of-          Just (x :: Pdu a2 r) ->-            Just (embedPdu x)-          Nothing ->-            case deserializePdu d of-              Just (x :: Pdu a3 r) ->-                Just (embedPdu x)-              Nothing ->-                case deserializePdu d of-                  Just (x :: Pdu a4 r) ->-                    Just (embedPdu x)-                  Nothing ->-                    Nothing- instance (NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r), NFData (Pdu a4 r)) => NFData (Pdu (a1, a2, a3, a4) r) where   rnf (ToPdu1Of4 x) = rnf x   rnf (ToPdu2Of4 y) = rnf y@@ -343,57 +393,26 @@   showsPrec d (ToPdu3Of4 z) = showsPrec d z   showsPrec d (ToPdu4Of4 w) = showsPrec d w -instance EmbedProtocol (a1, a2, a3, a4) a1 where+instance EmbedProtocol (a1, a2, a3, a4) a1 r where   embedPdu = ToPdu1Of4   fromPdu (ToPdu1Of4 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3, a4) a2 where+instance EmbedProtocol (a1, a2, a3, a4) a2 r where   embedPdu = ToPdu2Of4   fromPdu (ToPdu2Of4 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3, a4) a3 where+instance EmbedProtocol (a1, a2, a3, a4) a3 r where   embedPdu = ToPdu3Of4   fromPdu (ToPdu3Of4 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3, a4) a4 where+instance EmbedProtocol (a1, a2, a3, a4) a4 r where   embedPdu = ToPdu4Of4   fromPdu (ToPdu4Of4 l) = Just l   fromPdu _ = Nothing -instance (IsPdu a1 r, IsPdu a2 r, IsPdu a3 r, IsPdu a4 r, IsPdu a5 r) => IsPdu (a1, a2, a3, a4, a5) r where-  data instance Pdu (a1, a2, a3, a4, a5) r where-    ToPdu1Of5 :: Pdu a1 r -> Pdu (a1, a2, a3, a4, a5) r-    ToPdu2Of5 :: Pdu a2 r -> Pdu (a1, a2, a3, a4, a5) r-    ToPdu3Of5 :: Pdu a3 r -> Pdu (a1, a2, a3, a4, a5) r-    ToPdu4Of5 :: Pdu a4 r -> Pdu (a1, a2, a3, a4, a5) r-    ToPdu5Of5 :: Pdu a5 r -> Pdu (a1, a2, a3, a4, a5) r--  deserializePdu d =-    case deserializePdu d of-      Just (x :: Pdu a1 r) ->-        Just (embedPdu x)-      Nothing ->-        case deserializePdu d of-          Just (x :: Pdu a2 r) ->-            Just (embedPdu x)-          Nothing ->-            case deserializePdu d of-              Just (x :: Pdu a3 r) ->-                Just (embedPdu x)-              Nothing ->-                case deserializePdu d of-                  Just (x :: Pdu a4 r) ->-                    Just (embedPdu x)-                  Nothing ->-                    case deserializePdu d of-                      Just (x :: Pdu a5 r) ->-                        Just (embedPdu x)-                      Nothing ->-                        Nothing- instance (NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r), NFData (Pdu a4 r), NFData (Pdu a5 r)) => NFData (Pdu (a1, a2, a3, a4, a5) r) where   rnf (ToPdu1Of5 x) = rnf x   rnf (ToPdu2Of5 y) = rnf y@@ -408,27 +427,27 @@   showsPrec d (ToPdu4Of5 w) = showsPrec d w   showsPrec d (ToPdu5Of5 v) = showsPrec d v -instance EmbedProtocol (a1, a2, a3, a4, a5) a1 where+instance EmbedProtocol (a1, a2, a3, a4, a5) a1 r where   embedPdu = ToPdu1Of5   fromPdu (ToPdu1Of5 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3, a4, a5) a2 where+instance EmbedProtocol (a1, a2, a3, a4, a5) a2 r where   embedPdu = ToPdu2Of5   fromPdu (ToPdu2Of5 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3, a4, a5) a3 where+instance EmbedProtocol (a1, a2, a3, a4, a5) a3 r where   embedPdu = ToPdu3Of5   fromPdu (ToPdu3Of5 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3, a4, a5) a4 where+instance EmbedProtocol (a1, a2, a3, a4, a5) a4 r where   embedPdu = ToPdu4Of5   fromPdu (ToPdu4Of5 l) = Just l   fromPdu _ = Nothing -instance EmbedProtocol (a1, a2, a3, a4, a5) a5 where+instance EmbedProtocol (a1, a2, a3, a4, a5) a5 r where   embedPdu = ToPdu5Of5   fromPdu (ToPdu5Of5 l) = Just l   fromPdu _ = Nothing

@@ -0,0 +1,119 @@+-- | Build a "Control.Eff.Concurrent.EffectfulServer" from callbacks.+--+-- This module contains in instance of 'E.Server' that delegates to+-- callback functions.+--+-- @since 0.27.0+module Control.Eff.Concurrent.Protocol.CallbackServer+  ( start+  , startLink+  , Server+  , ServerId(..)+  , Event(..)+  , TangibleCallbacks+  )+  where++import Control.DeepSeq+import Control.Eff+import Control.Eff.Extend ()+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.Log+import Data.Kind+import Data.String+import Data.Typeable+import qualified Data.Text as T+import GHC.Stack (HasCallStack)+++-- | Execute the server loop.+--+-- @since 0.27.0+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)++-- | Execute the server loop.+--+-- @since 0.27.0+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)++-- | Phantom type to indicate a callback based 'E.Server' instance.+--+-- @since 0.27.0+data Server tag eLoop deriving Typeable++-- | The constraints for a /tangible/ 'Server' instance.+--+-- @since 0.27.0+type TangibleCallbacks tag eLoop e =+       ( LogIo e+       , SetMember Process (Process e) eLoop+       , Member Interrupts eLoop+       , Typeable e+       , Typeable eLoop+       , Typeable tag+       )++-- | The name/id of a 'Server' for logging purposes.+--+-- @since 0.24.0+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 " :: "+      . prettyTypeableShows (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 ' ' . prettyTypeableShows (typeRep (Proxy @tag))+      . showString " callback-server"+      )+

@@ -21,7 +21,7 @@ import           Control.Eff import           Control.Eff.Reader.Strict import           Control.Eff.Concurrent.Protocol-import           Control.Eff.Concurrent.Protocol.Request+import           Control.Eff.Concurrent.Protocol.Wrapper import           Control.Eff.Concurrent.Process import           Control.Eff.Concurrent.Process.Timer import           Control.Eff.Log@@ -40,9 +40,9 @@    . ( HasCallStack      , SetMember Process (Process q) r      , Member Interrupts r-     , IsPdu o' 'Asynchronous-     , IsPdu o 'Asynchronous-     , EmbedProtocol o' o+     , HasPdu o' 'Asynchronous+     , HasPdu o 'Asynchronous+     , EmbedProtocol o' o 'Asynchronous      )   => Endpoint o'   -> Pdu o 'Asynchronous@@ -61,7 +61,7 @@      , Member Interrupts r      , TangiblePdu protocol' ( 'Synchronous result)      , TangiblePdu protocol ( 'Synchronous result)-     , EmbedProtocol protocol' protocol+     , EmbedProtocol protocol' protocol ( 'Synchronous result)      , Tangible result      , HasCallStack      )@@ -104,7 +104,7 @@      , Member Interrupts r      , TangiblePdu protocol' ( 'Synchronous result)      , TangiblePdu protocol ( 'Synchronous result)-     , EmbedProtocol protocol' protocol+     , EmbedProtocol protocol' protocol ( 'Synchronous result)      , Tangible result      , Member Logs r      , Lifted IO q@@ -192,7 +192,7 @@      ( ServesProtocol o r q      , HasCallStack      , Member Interrupts r-     , IsPdu o 'Asynchronous+     , HasPdu o 'Asynchronous      )   => Pdu o 'Asynchronous   -> Eff r ()@@ -210,7 +210,7 @@ callSingleton   :: forall outer inner reply q e   . ( HasCallStack-    , EmbedProtocol outer inner+    , EmbedProtocol outer inner  ( 'Synchronous reply)     , Member (EndpointReader outer) e     , SetMember Process (Process q) e     , Member Interrupts e@@ -232,12 +232,12 @@ castSingleton   :: forall outer inner q e   . ( HasCallStack-    , EmbedProtocol outer inner+    , EmbedProtocol outer inner 'Asynchronous     , Member (EndpointReader outer) e     , SetMember Process (Process q) e     , Member Interrupts e-    , IsPdu outer 'Asynchronous-    , IsPdu inner 'Asynchronous+    , HasPdu outer 'Asynchronous+    , HasPdu inner 'Asynchronous     )   => Pdu inner 'Asynchronous   -> Eff e ()

@@ -7,11 +7,6 @@   , start   , startLink   , protocolServerLoop-  -- * GenServer-  , TangibleGenServer-  , GenServer-  , GenServerId(..)-  , genServer   )   where @@ -22,7 +17,7 @@ import Control.Eff.Concurrent.Process import Control.Eff.Concurrent.Process.Timer import Control.Eff.Concurrent.Protocol-import Control.Eff.Concurrent.Protocol.Request+import Control.Eff.Concurrent.Protocol.Wrapper import Control.Eff.Log import Control.Lens import Data.Kind@@ -71,16 +66,16 @@   serverTitle _ = fromString $ prettyTypeableShows (typeRep (Proxy @(ServerPdu a))) "-server"    -- | Process the effects of the implementation-  runEffects :: Init a e -> Eff (ServerEffects a e) x -> Eff e x+  runEffects :: Endpoint (ServerPdu a) -> Init a e -> Eff (ServerEffects a e) x -> Eff e x -  default runEffects :: ServerEffects a e ~ e => Init a e -> Eff (ServerEffects a e) x -> Eff e x-  runEffects = const id+  default runEffects :: ServerEffects a e ~ e => Endpoint (ServerPdu a) -> Init a e -> Eff (ServerEffects a e) x -> Eff e x+  runEffects _ = const id    -- | Update the 'Model' based on the 'Event'.-  onEvent :: Init a e -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()+  onEvent :: Endpoint (ServerPdu a) -> Init a e -> Event (ServerPdu a) -> Eff (ServerEffects a e) () -  default onEvent :: (Show (Init a e),  Member Logs (ServerEffects a e)) => Init a e -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()-  onEvent i e = logInfo ("unhandled: " <> T.pack (show i) <> " " <> T.pack (show e))+  default onEvent :: (Show (Init a e),  Member Logs (ServerEffects a e)) => Endpoint (ServerPdu a) -> Init a e -> Event (ServerPdu a) -> Eff (ServerEffects a e) ()+  onEvent _ i e = logInfo ("unhandled: " <> T.pack (show i) <> " " <> T.pack (show e))   -- | Execute the server loop.@@ -129,10 +124,11 @@        )   => Init a (Processes q) -> Eff (Processes q) () protocolServerLoop a = do-  myEp <- T.pack . show . asEndpoint @(ServerPdu a) <$> self-  censorLogs (lmAddEp myEp) $ do+  myEp <- asEndpoint @(ServerPdu a) <$> self+  let myEpTxt = T.pack . show $ myEp+  censorLogs (lmAddEp myEpTxt) $ do     logDebug ("starting")-    runEffects a (receiveSelectedLoop sel mainLoop)+    runEffects  myEp a (receiveSelectedLoop sel (mainLoop myEp))     return ()   where     lmAddEp myEp = lmProcessId ?~ myEp@@ -145,12 +141,13 @@         onRequest :: Request (ServerPdu a) -> Event (ServerPdu a)         onRequest (Call o m) = OnCall (replyTarget (MkSerializer toStrictDynamic) o) m         onRequest (Cast m) = OnCast m-    handleInt i = onEvent a (OnInterrupt i) *> pure Nothing+    handleInt myEp i = onEvent myEp a (OnInterrupt i) *> pure Nothing     mainLoop :: (Typeable a)-      => Either (Interrupt 'Recoverable) (Event (ServerPdu a))+      => Endpoint (ServerPdu a)+      -> Either (Interrupt 'Recoverable) (Event (ServerPdu a))       -> Eff (ServerEffects a (Processes q)) (Maybe ())-    mainLoop (Left i) = handleInt i-    mainLoop (Right i) = onEvent a i *> pure Nothing+    mainLoop myEp (Left i) = handleInt myEp i+    mainLoop myEp (Right i) = onEvent myEp a i *> pure Nothing  -- | This event sum-type is used to communicate incoming messages and other events to the -- instances of 'Server'.@@ -191,112 +188,3 @@        OnMessage r -> r `seq` ()  type instance ToPretty (Event a) = ToPretty a <+> PutStr "event"---- * GenServer---- | Make a 'Server' from a /data record/ instead of type-class instance.------ Sometimes it is much more concise to create an inline server-loop. In those cases--- it might not be practical to go through all this type class boilerplate.------ In these cases specifying a server by from a set of callback functions seems--- much more appropriate.------ This is such a helper. The @GenServer@ is a record with to callbacks,--- and a 'Server' instance that simply invokes the given callbacks.------ 'Server's that are directly based on 'LogIo' and 'Processes' effects.------ The name prefix @Gen@ indicates the inspiration from Erlang's @gen_server@ module.------ @since 0.24.1-data GenServer tag eLoop e where-  MkGenServer-    :: (TangibleGenServer tag eLoop e, HasCallStack) =>-    { genServerRunEffects :: forall x . (Eff eLoop x -> Eff (Processes e) x)-    , genServerOnEvent :: Event tag -> Eff eLoop ()-    } -> GenServer tag eLoop e-  deriving Typeable---- | The constraints for a /tangible/ 'GenServer' instance.------ @since 0.24.1-type TangibleGenServer tag eLoop e =-       ( LogIo e-       , SetMember Process (Process e) eLoop-       , Member Interrupts eLoop-       , Typeable e-       , Typeable eLoop-       , Typeable tag-       )---- | The name/id of a 'GenServer' for logging purposes.------ @since 0.24.0-newtype GenServerId tag =-  MkGenServerId { _fromGenServerId :: T.Text }-  deriving (Typeable, NFData, Ord, Eq, IsString)--instance (Typeable k, Typeable (tag :: k)) => Show (GenServerId tag) where-  showsPrec d px@(MkGenServerId x) =-    showParen-      (d >= 10)-      (showString (T.unpack x)-      . showString " :: "-      . prettyTypeableShows (typeOf px)-      )--instance (TangibleGenServer tag eLoop e) => Server (GenServer (tag :: Type) eLoop e) (Processes e) where-  type ServerPdu (GenServer tag eLoop e) = tag-  type ServerEffects (GenServer tag eLoop e) (Processes e) = eLoop-  data instance Init (GenServer tag eLoop e) (Processes e) =-        GenServerInit-         { genServerCallbacks :: GenServer tag eLoop e-         , genServerId :: GenServerId tag-         } deriving Typeable-  runEffects (GenServerInit cb cId) m =-    censorLogs-      (lmMessage <>~ (" | " <> _fromGenServerId cId))-      (genServerRunEffects cb m)-  onEvent (GenServerInit cb _cId) req = genServerOnEvent cb req--instance NFData (Init (GenServer tag eLoop e) (Processes e)) where-  rnf (GenServerInit _ x) = rnf x--instance Typeable tag => Show (Init (GenServer tag eLoop e) (Processes e)) where-  showsPrec d (GenServerInit _ x) =-    showParen (d>=10)-      ( showsPrec 11 x-      . showChar ' ' . prettyTypeableShows (typeRep (Proxy @tag))-      . showString " gen-server"-      )---- | Create a 'GenServer'.------ This requires the callback for 'Event's, a initial 'Model' and a 'GenServerId'.------ There must be a 'GenServerProtocol' instance.------ This is Haskell, so if this functions is partially applied--- to some 'Event' callback, you get a function back,--- that generates 'Init's from 'GenServerId's, like a /factory/------ @since 0.24.0-genServer-  :: forall tag eLoop e .-     ( HasCallStack-     , TangibleGenServer tag eLoop e-     , Server (GenServer tag eLoop e) (Processes e)-     )-  => (forall x . GenServerId tag -> Eff eLoop x -> Eff (Processes e) x)-  -> (GenServerId tag -> Event tag -> Eff eLoop ())-  -> GenServerId tag-  -> Init (GenServer tag eLoop e) (Processes e)-genServer initCb stepCb i =-  GenServerInit-    { genServerId = i-    , genServerCallbacks =-        MkGenServer { genServerRunEffects = initCb i-                    , genServerOnEvent = stepCb i-                    }-    }

@@ -54,7 +54,7 @@ data Observer o where   Observer     :: ( Tangible o-       , IsPdu p 'Asynchronous+       , HasPdu p 'Asynchronous        , Tangible (Endpoint p)        , Typeable p        )@@ -65,7 +65,7 @@ -- -- @since 0.24.0 type TangibleObserver o =-  ( Tangible o, IsPdu (Observer o) 'Asynchronous)+  ( Tangible o, HasPdu (Observer o) 'Asynchronous)  type instance ToPretty (Observer o) =   PrettyParens ("observing" <:> ToPretty o)@@ -97,8 +97,8 @@      , HasCallStack      , Member Interrupts r      , TangibleObserver o-     , EmbedProtocol x (ObserverRegistry o)-     , IsPdu x 'Asynchronous+     , EmbedProtocol x (ObserverRegistry o) 'Asynchronous+     , HasPdu x 'Asynchronous      )   => Observer o   -> Endpoint x@@ -115,8 +115,8 @@      , Member Interrupts r      , Typeable o      , NFData o-     , EmbedProtocol x (ObserverRegistry o)-     , IsPdu x 'Asynchronous+     , EmbedProtocol x (ObserverRegistry o) 'Asynchronous+     , HasPdu x 'Asynchronous      )   => Observer o   -> Endpoint x@@ -131,7 +131,7 @@ -- any other 'Asynchronous' 'Pdu' message type for receiving observations. -- -- @since 0.16.0-instance (NFData o, Show o, Typeable o, Typeable r) => IsPdu (Observer o) r where+instance (NFData o, Show o, Typeable o, Typeable r) => HasPdu (Observer o) r where   data instance Pdu (Observer o) r where     -- | This message denotes that the given value was 'observed'.     --@@ -161,8 +161,8 @@ -- @since 0.16.0 toObserver   :: forall o p-  . ( IsPdu p 'Asynchronous-    , EmbedProtocol p (Observer o)+  . ( HasPdu p 'Asynchronous+    , EmbedProtocol p (Observer o) 'Asynchronous     , TangibleObserver o     )   => Endpoint p@@ -175,7 +175,7 @@ -- -- @since 0.16.0 toObserverFor-  :: (TangibleObserver o, Typeable a, IsPdu a 'Asynchronous)+  :: (TangibleObserver o, Typeable a, HasPdu a 'Asynchronous)   => (o -> Pdu a 'Asynchronous)   -> Endpoint a   -> Observer o@@ -193,7 +193,7 @@ type instance ToPretty (ObserverRegistry o) =   PrettyParens ("observer registry" <:> ToPretty o) -instance (Typeable o, Typeable r) => IsPdu (ObserverRegistry o) r where+instance (Typeable o, Typeable r) => HasPdu (ObserverRegistry o) r where   -- | Protocol for managing observers. This can be added to any server for any number of different observation types.   -- The functions 'manageObservers' and 'handleObserverRegistration' are used to include observer handling;   --

@@ -137,7 +137,7 @@ spawnLinkObservationQueueWriter   :: forall o q h    . ( TangibleObserver o-     , IsPdu (Observer o) 'Asynchronous+     , HasPdu (Observer o) 'Asynchronous      , Member Logs q      , Lifted IO q      , LogsTo h (Processes q)@@ -148,13 +148,13 @@   cbo <- startLink (MkObservationQueue q)   pure (toObserver cbo) -instance (TangibleObserver o, IsPdu (Observer o) 'Asynchronous, Lifted IO q, Member Logs q) => Server (ObservationQueue o) (Processes q) where+instance (TangibleObserver o, HasPdu (Observer o) 'Asynchronous, Lifted IO q, Member Logs q) => Server (ObservationQueue o) (Processes q) where   type Protocol (ObservationQueue o) = Observer o    data instance StartArgument (ObservationQueue o) (Processes q) =      MkObservationQueue (ObservationQueue o) -  update (MkObservationQueue (ObservationQueue q)) =+  update _ (MkObservationQueue (ObservationQueue q)) =     \case       OnCast r ->         handleObservations (lift . atomically . writeTBQueue q) r

@@ -1,225 +0,0 @@--- | Proxies and containers for casts and calls.------ @since 0.15.0-module Control.Eff.Concurrent.Protocol.Request-  ( Request(..)-  , sendReply-  , ReplyTarget(..)-  , replyTarget-  , replyTargetOrigin-  , replyTargetSerializer-  , embeddedReplyTarget-  , toEmbeddedReplyTarget-  , RequestOrigin(..)-  , embedRequestOrigin-  , toEmbeddedOrigin-  , Reply(..)-  , embedReplySerializer-  , makeRequestOrigin-  )-  where--import Control.DeepSeq-import Control.Eff-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Protocol-import Control.Lens-import Data.Kind (Type)-import Data.Typeable (Typeable)-import Data.Semigroup-import GHC.Generics---- | A wrapper sum type for calls and casts for the 'Pdu's of a protocol------ @since 0.15.0-data Request protocol where-  Call-    :: forall protocol reply.-       ( Tangible reply-       , TangiblePdu protocol ('Synchronous reply)-       )-    => RequestOrigin protocol reply-    -> Pdu protocol ('Synchronous reply)-    -> Request protocol-  Cast-    :: forall protocol. (TangiblePdu protocol 'Asynchronous, NFData (Pdu protocol 'Asynchronous))-    => Pdu protocol 'Asynchronous-    -> Request protocol-  deriving (Typeable)--instance Show (Request protocol) where-  showsPrec d (Call o r) =-    showParen (d >= 10) (showString "call-request: " . showsPrec 11 o . showString ": " . showsPrec 11 r)-  showsPrec d (Cast r) =-    showParen (d >= 10) (showString "cast-request: " . showsPrec 11 r)--instance NFData (Request protocol) where-  rnf (Call o req) = rnf o `seq` rnf req-  rnf (Cast req) = rnf req----- | The wrapper around replies to 'Call's.------ @since 0.15.0-data Reply protocol reply where-  Reply :: (Tangible reply) =>-    { _replyTo :: RequestOrigin protocol reply-    , _replyValue :: reply-    } -> Reply protocol reply-  deriving (Typeable)--instance NFData (Reply p r) where-  rnf (Reply i r) = rnf i `seq` rnf r--instance Show r => Show (Reply p r) where-  showsPrec d (Reply o r) =-    showParen (d >= 10) (showString "request-reply: " . showsPrec 11 o . showString ": " . showsPrec 11 r)---- | Wraps the source 'ProcessId' and a unique identifier for a 'Call'.------ @since 0.15.0-data RequestOrigin (proto :: Type) reply = RequestOrigin-  { _requestOriginPid     :: !ProcessId-  , _requestOriginCallRef :: !Int-  } deriving (Typeable, Generic, Eq, Ord)--instance Show (RequestOrigin p r) where-  showsPrec d (RequestOrigin o r) =-    showParen (d >= 10) (showString "origin: " . showsPrec 10 o . showChar ' ' . showsPrec 10 r)---- | Create a new, unique 'RequestOrigin' value for the current process.------ @since 0.24.0-makeRequestOrigin-  :: ( Typeable r-     , NFData r-     , SetMember Process (Process q0) e-     , '[Interrupts] <:: e)-  => Eff e (RequestOrigin p r)-makeRequestOrigin = RequestOrigin <$> self <*> makeReference--instance NFData (RequestOrigin p r)---- | Turn an 'RequestOrigin' to an origin for an embedded request (See 'EmbedProtocol').------ This is useful of a server delegates the @calls@ and @casts@ for an embedded protocol--- to functions, that require the 'Serializer' and 'RequestOrigin' in order to call--- 'sendReply'.------ See also 'embedReplySerializer'.------ @since 0.24.3-toEmbeddedOrigin-  :: forall outer inner reply . EmbedProtocol outer inner-  => RequestOrigin outer reply-  -> RequestOrigin inner reply-toEmbeddedOrigin (RequestOrigin !pid !ref) = RequestOrigin pid ref---- | Turn an /embedded/ 'RequestOrigin' to a 'RequestOrigin' for the /bigger/ request.------ This is the inverse of 'toEmbeddedOrigin'.------ This function is strict in all parameters.------ @since 0.24.2-embedRequestOrigin :: forall outer inner reply . EmbedProtocol outer inner => RequestOrigin inner reply -> RequestOrigin outer reply-embedRequestOrigin (RequestOrigin !pid !ref) = RequestOrigin pid ref---- | Turn a 'Serializer' for a 'Pdu' instance that contains embedded 'Pdu' values--- into a 'Reply' 'Serializer' for the embedded 'Pdu'.------ This is useful of a server delegates the @calls@ and @casts@ for an embedded protocol--- to functions, that require the 'Serializer' and 'RequestOrigin' in order to call--- 'sendReply'.------ See also 'toEmbeddedOrigin'.------ @since 0.24.2-embedReplySerializer :: forall outer inner reply . EmbedProtocol outer inner => Serializer (Reply outer reply) -> Serializer (Reply inner reply)-embedReplySerializer = contramap embedReply---- | Turn an /embedded/ 'Reply' to a 'Reply' for the /bigger/ request.------ This function is strict in all parameters.------ @since 0.24.2-embedReply :: forall outer inner reply . EmbedProtocol outer inner => Reply inner reply -> Reply outer reply-embedReply (Reply (RequestOrigin !pid !ref) !v) = Reply (RequestOrigin pid ref) v----- | Answer a 'Call' by sending the reply value to the client process.------ The 'ProcessId', the 'RequestOrigin' and the 'Reply' 'Serializer' are--- stored in the 'ReplyTarget'.------ @since 0.25.1-sendReply-  :: ( SetMember Process (Process q) eff-     , Member Interrupts eff-     , Tangible reply-     , Typeable protocol-     )-  => ReplyTarget protocol reply-  -> reply-  -> Eff eff ()-sendReply (MkReplyTarget (Arg o ser)) r =-  sendAnyMessage (_requestOriginPid o) $! runSerializer ser $! Reply o r---- | Target of a 'Call' reply.------ This combines a 'RequestOrigin' with a 'Serializer' for a 'Reply' using 'Arg'.--- There are to smart constructors for this type: 'replyTarget' and 'embeddedReplyTarget'.------ Because of 'Arg' the 'Eq' and 'Ord' instances are implemented via--- the 'RequestOrigin' instances.------ @since 0.26.0-newtype ReplyTarget p r =-  MkReplyTarget (Arg (RequestOrigin p r) (Serializer (Reply p r)))-    deriving (Eq, Ord, Typeable)--instance Show (ReplyTarget p r) where-  showsPrec d (MkReplyTarget (Arg o _s)) = showParen (d>=10) (showString "reply-target: " . shows o)--instance NFData (ReplyTarget p r) where-  rnf (MkReplyTarget (Arg x y)) = rnf x `seq` y `seq` ()---- | Smart constructor for a 'ReplyTarget'.------ To build a @ReplyTarget@ for an 'EmbedProtocol' instance use 'embeddedReplyTarget'.------ @since 0.26.0-replyTarget :: Serializer (Reply p reply) -> RequestOrigin p reply -> ReplyTarget p reply-replyTarget ser orig =  MkReplyTarget (Arg orig ser)---- | A simple 'Lens' for the 'RequestOrigin' of a 'ReplyTarget'.------ @since 0.26.0-replyTargetOrigin :: Lens' (ReplyTarget p reply) (RequestOrigin p reply)-replyTargetOrigin f (MkReplyTarget (Arg o x)) =-  (\o' -> MkReplyTarget (Arg o' x)) <$> f o---- | A simple 'Lens' for the 'Reply' 'Serializer' of a 'ReplyTarget'.------ @since 0.26.0-replyTargetSerializer :: Lens' (ReplyTarget p reply) (Serializer (Reply p reply))-replyTargetSerializer f (MkReplyTarget (Arg x o)) =-  (\o' -> MkReplyTarget (Arg x o')) <$> f o---- | Smart constructor for an /embedded/ 'ReplyTarget'.------ This combines 'replyTarget' and 'toEmbeddedReplyTarget'.------ @since 0.26.0-embeddedReplyTarget :: EmbedProtocol outer inner => Serializer (Reply outer reply) -> RequestOrigin outer reply -> ReplyTarget inner reply-embeddedReplyTarget ser orig = toEmbeddedReplyTarget $ replyTarget ser orig---- | Convert a 'ReplyTarget' to be usable for /embedded/ replies.------ This combines a 'toEmbeddedOrigin' with 'embedReplySerializer' to produce a--- 'ReplyTarget' that can be passed to functions defined soley on an embedded protocol.------ @since 0.26.0-toEmbeddedReplyTarget :: EmbedProtocol outer inner => ReplyTarget outer r -> ReplyTarget inner r-toEmbeddedReplyTarget (MkReplyTarget (Arg orig ser)) =-  MkReplyTarget (Arg (toEmbeddedOrigin orig) (embedReplySerializer ser))

@@ -74,24 +74,28 @@    -- | Return an initial 'Model' and 'Settings'   setup ::-       StartArgument a q+       Endpoint (Protocol a)+    -> StartArgument a q     -> Eff q (Model a, Settings a)    default setup ::        (Default (Model a), Default (Settings a))-    => StartArgument a q+    => Endpoint (Protocol a)+    -> StartArgument a q     -> Eff q (Model a, Settings a)-  setup _ = pure (def, def)+  setup _ _ = pure (def, def)    -- | Update the 'Model' based on the 'Event'.   update ::-       StartArgument a q+       Endpoint (Protocol a)+    -> StartArgument a q     -> Effectful.Event (Protocol a)     -> Eff (ModelState a ': SettingsReader a ': q) ()  -- | This type is used to build stateful 'EffectfulServer' instances. ----- The types that are suitable to be have to be instances of 'Server'+-- It is a variant of 'EffectfulServer', that comes pre-installed+-- with 'State' and 'Reader' effects. -- -- @since 0.24.0 data Stateful a deriving Typeable@@ -101,11 +105,11 @@   type ServerPdu (Stateful a) = Protocol a   type ServerEffects (Stateful a) q = ModelState a ': SettingsReader a ': q -  runEffects (Init sa) m = do-    (st, env) <- setup sa+  runEffects selfEndpoint (Init sa) m = do+    (st, env) <- setup selfEndpoint sa     runReader env (evalState st m) -  onEvent (Init sa) = update sa+  onEvent selfEndpoint (Init sa) = update selfEndpoint sa   -- | Execute the server loop.

@@ -67,7 +67,7 @@ import Control.Eff as Eff import Control.Eff.Concurrent.Protocol import Control.Eff.Concurrent.Protocol.Client-import Control.Eff.Concurrent.Protocol.Request+import Control.Eff.Concurrent.Protocol.Wrapper import Control.Eff.Concurrent.Protocol.StatefulServer as Server import Control.Eff.Concurrent.Protocol.Supervisor.InternalState import Control.Eff.Concurrent.Process@@ -100,7 +100,7 @@ -- @since 0.24.0 data Sup (p :: Type) deriving Typeable -instance (NFData (Pdu (Sup p) r), Show (Pdu (Sup p) r), Typeable p, Typeable r) => IsPdu (Sup p) r where+instance (NFData (Pdu (Sup p) r), Show (Pdu (Sup p) r), Typeable p, Typeable r) => HasPdu (Sup p) r where   -- | The 'Pdu' instance contains methods to start, stop and lookup a child   -- process, as well as a diagnostic callback.   --@@ -168,8 +168,8 @@    type Model (Sup p) = Children (ChildId p) p -  setup _cfg = pure (def, ())-  update supConfig (OnCall rt req) =+  setup _ _cfg = pure (def, ())+  update _ supConfig (OnCall rt req) =     case req of       GetDiagnosticInfo ->  do         p <- (pack . show <$> getChildren @(ChildId p) @p)@@ -199,7 +199,7 @@           Just existingChild ->             sendReply rt (Left (AlreadyStarted i (existingChild ^. childEndpoint))) -  update _supConfig (OnDown (ProcessDown mrChild reason)) = do+  update _ _supConfig (OnDown (ProcessDown mrChild reason)) = do       oldEntry <- lookupAndRemoveChildByMonitor @(ChildId p) @p mrChild       case oldEntry of         Nothing ->@@ -218,7 +218,7 @@                   <> " => "                   <> pack (show (_childEndpoint c))                   )-  update supConfig (OnInterrupt e) = do+  update _ supConfig (OnInterrupt e) = do       let (logSev, exitReason) =             case e of               NormalExitRequested ->@@ -229,7 +229,7 @@       logWithSeverity logSev ("supervisor stopping: " <> pack (show e))       exitBecause exitReason -  update _supConfig o = logWarning ("unexpected: " <> pack (show o))+  update _ _supConfig o = logWarning ("unexpected: " <> pack (show o))   -- | Runtime-Errors occurring when spawning child-processes.

@@ -0,0 +1,225 @@+-- | Proxies and containers for casts and calls.+--+-- @since 0.15.0+module Control.Eff.Concurrent.Protocol.Wrapper+  ( Request(..)+  , sendReply+  , ReplyTarget(..)+  , replyTarget+  , replyTargetOrigin+  , replyTargetSerializer+  , embeddedReplyTarget+  , toEmbeddedReplyTarget+  , RequestOrigin(..)+  , embedRequestOrigin+  , toEmbeddedOrigin+  , Reply(..)+  , embedReplySerializer+  , makeRequestOrigin+  )+  where++import Control.DeepSeq+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Concurrent.Protocol+import Control.Lens+import Data.Kind (Type)+import Data.Typeable (Typeable)+import Data.Semigroup+import GHC.Generics++-- | A wrapper sum type for calls and casts for the 'Pdu's of a protocol+--+-- @since 0.15.0+data Request protocol where+  Call+    :: forall protocol reply.+       ( Tangible reply+       , TangiblePdu protocol ('Synchronous reply)+       )+    => RequestOrigin protocol reply+    -> Pdu protocol ('Synchronous reply)+    -> Request protocol+  Cast+    :: forall protocol. (TangiblePdu protocol 'Asynchronous, NFData (Pdu protocol 'Asynchronous))+    => Pdu protocol 'Asynchronous+    -> Request protocol+  deriving (Typeable)++instance Show (Request protocol) where+  showsPrec d (Call o r) =+    showParen (d >= 10) (showString "call-request: " . showsPrec 11 o . showString ": " . showsPrec 11 r)+  showsPrec d (Cast r) =+    showParen (d >= 10) (showString "cast-request: " . showsPrec 11 r)++instance NFData (Request protocol) where+  rnf (Call o req) = rnf o `seq` rnf req+  rnf (Cast req) = rnf req+++-- | The wrapper around replies to 'Call's.+--+-- @since 0.15.0+data Reply protocol reply where+  Reply :: (Tangible reply) =>+    { _replyTo :: RequestOrigin protocol reply+    , _replyValue :: reply+    } -> Reply protocol reply+  deriving (Typeable)++instance NFData (Reply p r) where+  rnf (Reply i r) = rnf i `seq` rnf r++instance Show r => Show (Reply p r) where+  showsPrec d (Reply o r) =+    showParen (d >= 10) (showString "request-reply: " . showsPrec 11 o . showString ": " . showsPrec 11 r)++-- | Wraps the source 'ProcessId' and a unique identifier for a 'Call'.+--+-- @since 0.15.0+data RequestOrigin (proto :: Type) reply = RequestOrigin+  { _requestOriginPid     :: !ProcessId+  , _requestOriginCallRef :: !Int+  } deriving (Typeable, Generic, Eq, Ord)++instance Show (RequestOrigin p r) where+  showsPrec d (RequestOrigin o r) =+    showParen (d >= 10) (showString "origin: " . showsPrec 10 o . showChar ' ' . showsPrec 10 r)++-- | Create a new, unique 'RequestOrigin' value for the current process.+--+-- @since 0.24.0+makeRequestOrigin+  :: ( Typeable r+     , NFData r+     , SetMember Process (Process q0) e+     , '[Interrupts] <:: e)+  => Eff e (RequestOrigin p r)+makeRequestOrigin = RequestOrigin <$> self <*> makeReference++instance NFData (RequestOrigin p r)++-- | Turn an 'RequestOrigin' to an origin for an embedded request (See 'EmbedProtocol').+--+-- This is useful of a server delegates the @calls@ and @casts@ for an embedded protocol+-- to functions, that require the 'Serializer' and 'RequestOrigin' in order to call+-- 'sendReply'.+--+-- See also 'embedReplySerializer'.+--+-- @since 0.24.3+toEmbeddedOrigin+  :: forall outer inner reply . EmbedProtocol outer inner ('Synchronous reply)+  => RequestOrigin outer reply+  -> RequestOrigin inner reply+toEmbeddedOrigin (RequestOrigin !pid !ref) = RequestOrigin pid ref++-- | Turn an /embedded/ 'RequestOrigin' to a 'RequestOrigin' for the /bigger/ request.+--+-- This is the inverse of 'toEmbeddedOrigin'.+--+-- This function is strict in all parameters.+--+-- @since 0.24.2+embedRequestOrigin :: forall outer inner reply . EmbedProtocol outer inner ('Synchronous reply) => RequestOrigin inner reply -> RequestOrigin outer reply+embedRequestOrigin (RequestOrigin !pid !ref) = RequestOrigin pid ref++-- | Turn a 'Serializer' for a 'Pdu' instance that contains embedded 'Pdu' values+-- into a 'Reply' 'Serializer' for the embedded 'Pdu'.+--+-- This is useful of a server delegates the @calls@ and @casts@ for an embedded protocol+-- to functions, that require the 'Serializer' and 'RequestOrigin' in order to call+-- 'sendReply'.+--+-- See also 'toEmbeddedOrigin'.+--+-- @since 0.24.2+embedReplySerializer :: forall outer inner reply . EmbedProtocol outer inner ('Synchronous reply) => Serializer (Reply outer reply) -> Serializer (Reply inner reply)+embedReplySerializer = contramap embedReply++-- | Turn an /embedded/ 'Reply' to a 'Reply' for the /bigger/ request.+--+-- This function is strict in all parameters.+--+-- @since 0.24.2+embedReply :: forall outer inner reply . EmbedProtocol outer inner ('Synchronous reply) => Reply inner reply -> Reply outer reply+embedReply (Reply (RequestOrigin !pid !ref) !v) = Reply (RequestOrigin pid ref) v+++-- | Answer a 'Call' by sending the reply value to the client process.+--+-- The 'ProcessId', the 'RequestOrigin' and the 'Reply' 'Serializer' are+-- stored in the 'ReplyTarget'.+--+-- @since 0.25.1+sendReply+  :: ( SetMember Process (Process q) eff+     , Member Interrupts eff+     , Tangible reply+     , Typeable protocol+     )+  => ReplyTarget protocol reply+  -> reply+  -> Eff eff ()+sendReply (MkReplyTarget (Arg o ser)) r =+  sendAnyMessage (_requestOriginPid o) $! runSerializer ser $! Reply o r++-- | Target of a 'Call' reply.+--+-- This combines a 'RequestOrigin' with a 'Serializer' for a 'Reply' using 'Arg'.+-- There are to smart constructors for this type: 'replyTarget' and 'embeddedReplyTarget'.+--+-- Because of 'Arg' the 'Eq' and 'Ord' instances are implemented via+-- the 'RequestOrigin' instances.+--+-- @since 0.26.0+newtype ReplyTarget p r =+  MkReplyTarget (Arg (RequestOrigin p r) (Serializer (Reply p r)))+    deriving (Eq, Ord, Typeable)++instance Show (ReplyTarget p r) where+  showsPrec d (MkReplyTarget (Arg o _s)) = showParen (d>=10) (showString "reply-target: " . shows o)++instance NFData (ReplyTarget p r) where+  rnf (MkReplyTarget (Arg x y)) = rnf x `seq` y `seq` ()++-- | Smart constructor for a 'ReplyTarget'.+--+-- To build a @ReplyTarget@ for an 'EmbedProtocol' instance use 'embeddedReplyTarget'.+--+-- @since 0.26.0+replyTarget :: Serializer (Reply p reply) -> RequestOrigin p reply -> ReplyTarget p reply+replyTarget ser orig =  MkReplyTarget (Arg orig ser)++-- | A simple 'Lens' for the 'RequestOrigin' of a 'ReplyTarget'.+--+-- @since 0.26.0+replyTargetOrigin :: Lens' (ReplyTarget p reply) (RequestOrigin p reply)+replyTargetOrigin f (MkReplyTarget (Arg o x)) =+  (\o' -> MkReplyTarget (Arg o' x)) <$> f o++-- | A simple 'Lens' for the 'Reply' 'Serializer' of a 'ReplyTarget'.+--+-- @since 0.26.0+replyTargetSerializer :: Lens' (ReplyTarget p reply) (Serializer (Reply p reply))+replyTargetSerializer f (MkReplyTarget (Arg x o)) =+  (\o' -> MkReplyTarget (Arg x o')) <$> f o++-- | Smart constructor for an /embedded/ 'ReplyTarget'.+--+-- This combines 'replyTarget' and 'toEmbeddedReplyTarget'.+--+-- @since 0.26.0+embeddedReplyTarget :: EmbedProtocol outer inner ('Synchronous reply) => Serializer (Reply outer reply) -> RequestOrigin outer reply -> ReplyTarget inner reply+embeddedReplyTarget ser orig = toEmbeddedReplyTarget $ replyTarget ser orig++-- | Convert a 'ReplyTarget' to be usable for /embedded/ replies.+--+-- This combines a 'toEmbeddedOrigin' with 'embedReplySerializer' to produce a+-- 'ReplyTarget' that can be passed to functions defined soley on an embedded protocol.+--+-- @since 0.26.0+toEmbeddedReplyTarget :: EmbedProtocol outer inner ('Synchronous reply) => ReplyTarget outer reply -> ReplyTarget inner reply+toEmbeddedReplyTarget (MkReplyTarget (Arg orig ser)) =+  MkReplyTarget (Arg (toEmbeddedOrigin orig) (embedReplySerializer ser))

@@ -23,7 +23,7 @@  type instance ToPretty Small = PutStr "small" -instance Typeable r => IsPdu Small r where+instance Typeable r => HasPdu Small r where   data instance  Pdu Small r where           SmallCall :: Bool -> Pdu Small ('Synchronous Bool)           SmallCast :: String -> Pdu Small 'Asynchronous@@ -43,7 +43,7 @@ instance LogIo e => S.Server Small (Processes e) where   data StartArgument Small (Processes e) = MkSmall   type Model Small = String-  update MkSmall x =+  update _me MkSmall x =     case x of       E.OnCall rt (SmallCall f) ->        sendReply rt f@@ -58,11 +58,11 @@  type instance ToPretty Big = PutStr "big" -instance Typeable r => IsPdu Big r where+instance Typeable r => HasPdu Big r where   data instance  Pdu Big r where-          BigCall :: Bool -> Pdu Big ('Synchronous Bool)-          BigCast :: String -> Pdu Big 'Asynchronous-          BigSmall :: Pdu Small r -> Pdu Big r+    BigCall :: Bool -> Pdu Big ('Synchronous Bool)+    BigCast :: String -> Pdu Big 'Asynchronous+    BigSmall :: Pdu Small r -> Pdu Big r       deriving Typeable  instance NFData (Pdu Big r) where@@ -75,7 +75,7 @@   showsPrec d (BigCast x) = showParen (d > 10) (showString "SmallCast " . showString x)   showsPrec d (BigSmall x) = showParen (d > 10) (showString "BigSmall " . showsPrec 11 x) -instance EmbedProtocol Big Small where+instance EmbedProtocol Big Small r where   embeddedPdu =     prism'       BigSmall@@ -88,17 +88,17 @@ instance LogIo e => S.Server Big (Processes e) where   data instance StartArgument Big (Processes e) = MkBig   type Model Big = String-  update MkBig = \case+  update me MkBig = \case     E.OnCall rt req ->           case req of             BigCall o -> do               logNotice ("BigCall " <> pack (show o))               sendReply rt o-            BigSmall x -> S.update MkSmall (S.OnCall (toEmbeddedReplyTarget rt) x)+            BigSmall x -> S.update (toEmbeddedEndpoint me) MkSmall (S.OnCall (toEmbeddedReplyTarget rt) x)     E.OnCast req ->         case req of           BigCast o -> S.putModel @Big o-          BigSmall x -> S.update MkSmall (S.OnCast x)+          BigSmall x -> S.update (toEmbeddedEndpoint me) MkSmall (S.OnCast x)     other ->       interrupt (ErrorInterrupt (show other)) -- ----------------------------------------------------------------------------

@@ -7,8 +7,9 @@ import           Control.Eff.Concurrent.Process import           Control.Eff.Concurrent.Process.Timer import           Control.Eff.Concurrent.Protocol-import           Control.Eff.Concurrent.Protocol.Request+import           Control.Eff.Concurrent.Protocol.Wrapper import           Control.Eff.Concurrent.Protocol.Client+import qualified Control.Eff.Concurrent.Protocol.CallbackServer as Callback import           Control.Eff.Concurrent.Protocol.EffectfulServer import qualified Control.Eff.Concurrent.Process.ForkIOScheduler                                                as ForkIO@@ -91,7 +92,7 @@  type instance ToPretty ReturnToSender = PutStr "ReturnToSender" -instance Typeable r => IsPdu ReturnToSender r where+instance Typeable r => HasPdu ReturnToSender r where  data instance Pdu ReturnToSender r where    ReturnToSender :: ProcessId -> String -> Pdu ReturnToSender ('Synchronous Bool)    StopReturnToSender :: Pdu ReturnToSender ('Synchronous ())@@ -127,8 +128,8 @@   :: forall q    . (HasCallStack, Lifted IO q, LogsTo IO q, Member Logs q, Typeable q)   => Eff (Processes q) (Endpoint ReturnToSender)-returnToSenderServer = start-  (genServer @ReturnToSender+returnToSenderServer =+  Callback.start @ReturnToSender     (const id)     (\_me evt ->       case evt of@@ -144,8 +145,6 @@         other -> interrupt (ErrorInterrupt (show other))     )     "return-to-sender"-  )-  selectiveReceiveTests   :: forall r

@@ -246,7 +246,7 @@  type instance ToPretty TestProtocol = PutStr "test" -instance Typeable x => IsPdu TestProtocol x where+instance Typeable x => HasPdu TestProtocol x where   data instance Pdu TestProtocol x where     TestGetStringLength :: String -> Pdu TestProtocol ('Synchronous Int)     TestInterruptWith :: Interrupt 'Recoverable -> Pdu TestProtocol 'Asynchronous@@ -266,7 +266,7 @@   deriving Eq  instance Server TestProtocol Effects where-  update (TestServerArgs testMode tId) evt =+  update _me (TestServerArgs testMode tId) evt =     case evt of       OnCast (TestInterruptWith i) -> do         logInfo (pack (show tId) <> ": stopping with: " <> pack (show i))