extensible-effects-concurrent 0.21.1 → 0.22.0

raw patch · 24 files changed

+647/−249 lines, 24 filesdep ~deepseqdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: deepseq, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +45/−0
• examples/example-1/Main.hs +8/−0
• examples/example-2/Main.hs +10/−2
• extensible-effects-concurrent.cabal +10/−3
• src/Control/Eff/Concurrent.hs +12/−9
• src/Control/Eff/Concurrent/Api.hs +2/−3
• src/Control/Eff/Concurrent/Api/Client.hs +72/−4
• src/Control/Eff/Concurrent/Api/GenServer.hs +49/−0
• src/Control/Eff/Concurrent/Api/Observer.hs +42/−17
• src/Control/Eff/Concurrent/Api/Observer/Queue.hs +12/−4
• src/Control/Eff/Concurrent/Api/Request.hs +21/−5
• src/Control/Eff/Concurrent/Api/Server.hs +27/−21
• src/Control/Eff/Concurrent/Process.hs +103/−120
• src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +27/−7
• src/Control/Eff/Concurrent/Process/Interactive.hs +2/−1
• src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +9/−9
• src/Control/Eff/Concurrent/Process/Timer.hs +27/−0
• src/Control/Eff/Log/MessageRenderer.hs +31/−3
• src/Control/Eff/LogWriter/Async.hs +1/−1
• src/Control/Eff/LogWriter/UnixSocket.hs +0/−18
• test/ForkIOScheduler.hs +5/−6
• test/ProcessBehaviourTestCases.hs +21/−14
• test/ServerForkIO.hs +110/−0
• test/SingleThreadedScheduler.hs +1/−2

@@ -1,5 +1,50 @@ # Changelog for extensible-effects-concurrent +## Plan for future 0.23.0++- Add `gen_server` behaviour clone:    +    - Disallow non-`Api`-messages+    - Add `Api AnyMsg 'Asynchronous` +    - Add `Api GetInfo ('Synchronous Text)`  +         +    - Every `Api` type instance now **must** be an `NFData` +      and a `ToLogText` instance+    - `call` will always require a `Timeout`+    - `call` now monitors the caller+    - `call` now monitors the called process+    - `call` now returns `Either TimeoutError a`   ++- Logging improvements:+    - Introduce `ToLogText`+    - Remove `ToLogMessage`+    - Remove `logXXX'` users have to use `logXXX` and `ToLogText` ++## 0.22.0    ++- Remove `SchedulerProxy` ruins ++- Make message sending strict:++  Ensure that every message sent from one process to another+  is reduced to normal form by the sender. ++    - Remove *all* lazy message selectors+    - Introduce a newtype wrapper `StrictDynamic` around `Dynamic`+      and export only a constructor that deeply evaluates the+      value to *rnf* before converting it to a `Dynamic` ++- Change the `Server` API for better system *vitality*:++- Add `callWithTimeout`: A `call` over `IO` with a `Timeout` parameter++- Add more efficient log renderer:+    - `renderLogMessageBodyNoLocation`+    - `renderRFC5424NoLocation`     +          +## 0.21.2++- Fix copy-paste error: Remove the `LogsTo` constraint from `withAsyncLogWriter`+ ## 0.21.1  - Remove dependency to the `socket` and `socket-unix` packages

@@ -8,6 +8,7 @@ import           Control.Eff.Concurrent import qualified Control.Exception             as Exc import qualified Data.Text as T+import           Control.DeepSeq  data TestApi   deriving Typeable@@ -18,6 +19,13 @@   Terminate :: Api TestApi ('Synchronous ())   TerminateError :: String -> Api TestApi ('Synchronous ())   deriving (Typeable)++instance NFData (Api TestApi x) where+  rnf (SayHello s) = rnf s+  rnf (Shout s) = rnf s+  rnf Terminate = ()+  rnf (TerminateError s) = rnf s+  data MyException = MyException     deriving Show

@@ -8,6 +8,7 @@ import           Control.Monad import           Data.Foldable import           Control.Concurrent+import           Control.DeepSeq  main :: IO () main = defaultMain (void counterExample)@@ -21,6 +22,10 @@   Cnt :: Api Counter ('Synchronous Integer)   deriving Typeable +instance NFData (Api Counter x) where+  rnf Inc = ()+  rnf Cnt = ()+ counterExample   :: (Member Logs q, Lifted IO q)   => Eff (InterruptableProcess q) ()@@ -57,8 +62,11 @@   Whoopediedoo :: Bool -> Api SupiDupi ('Synchronous (Maybe ()))   deriving Typeable -data CounterChanged = CounterChanged Integer-  deriving (Show, Typeable)+instance NFData (Api SupiDupi r) where+  rnf (Whoopediedoo b) = rnf b++newtype CounterChanged = CounterChanged Integer+  deriving (Show, Typeable, NFData)  spawnCounter   :: (Member Logs q)

@@ -1,6 +1,6 @@ cabal-version:  2.0 name:           extensible-effects-concurrent-version:        0.21.1+version:        0.22.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@@ -83,6 +83,7 @@                   Control.Eff.Concurrent.Api,                   Control.Eff.Concurrent.Api.Client,                   Control.Eff.Concurrent.Api.Server,+                  Control.Eff.Concurrent.Api.GenServer,                   Control.Eff.Concurrent.Process,                   Control.Eff.Concurrent.Process.Timer,                   Control.Eff.Concurrent.Process.ForkIOScheduler,@@ -134,11 +135,13 @@               , extensible-effects               , lens               , text+              , deepseq   ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes                       , BangPatterns                       , DataKinds+                      , DeriveGeneric                       , FlexibleContexts                       , FlexibleInstances                       , FunctionalDependencies@@ -164,6 +167,7 @@               , extensible-effects               , lens               , text+              , deepseq   ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes@@ -225,6 +229,7 @@               , extensible-effects               , deepseq               , text+              , deepseq   ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes@@ -255,22 +260,24 @@               , ForkIOScheduler               , Interactive               , LoggingTests+              , LogMessageIdeaTest               , LoopTests               , ProcessBehaviourTestCases+              , ServerForkIO               , SingleThreadedScheduler-              , LogMessageIdeaTest   ghc-options: -Wall -threaded -fno-full-laziness   build-depends:                 async               , base               , data-default+              , deepseq               , extensible-effects-concurrent               , extensible-effects               , tasty               , tasty-discover               , tasty-hunit+              , text               , containers-              , deepseq               , QuickCheck               , lens               , HUnit

@@ -68,12 +68,14 @@ where  import           Control.Eff.Concurrent.Process ( Process(..)+                                                , StrictDynamic()+                                                , toStrictDynamic+                                                , fromStrictDynamic+                                                , unwrapStrictDynamic                                                 , ProcessId(..)                                                 , fromProcessId                                                 , ConsProcess                                                 , ResumeProcess(..)-                                                , SchedulerProxy(..)-                                                , thisSchedulerProxy                                                 , ProcessState(..)                                                 , yieldProcess                                                 , sendMessage@@ -92,16 +94,14 @@                                                   ( runMessageSelector                                                   )                                                 , selectMessage-                                                , selectMessageLazy-                                                , selectMessageProxy-                                                , selectMessageProxyLazy+                                                , selectMessage                                                 , filterMessage-                                                , filterMessageLazy+                                                , filterMessage                                                 , selectMessageWith-                                                , selectMessageWithLazy+                                                , selectMessageWith                                                 , selectDynamicMessage-                                                , selectDynamicMessageLazy-                                                , selectAnyMessageLazy+                                                , selectDynamicMessage+                                                , selectAnyMessage                                                 , self                                                 , isProcessAlive                                                 , spawn@@ -156,8 +156,10 @@                                                 , sendAfter                                                 , startTimer                                                 , selectTimerElapsed+                                                , cancelTimer                                                 , receiveAfter                                                 , receiveSelectedAfter+                                                , receiveSelectedWithMonitorAfter                                                 )  import           Control.Eff.Concurrent.Api     ( Api@@ -170,6 +172,7 @@ import           Control.Eff.Concurrent.Api.Client                                                 ( cast                                                 , call+                                                , callWithTimeout                                                 , castRegistered                                                 , callRegistered                                                 , ServesApi

@@ -30,6 +30,7 @@ import           Data.Typeable                  ( Typeable                                                 , typeRep                                                 )+import Control.DeepSeq (NFData)  -- | This data family defines an API, a communication interface description -- between at least two processes. The processes act as __servers__ or@@ -57,7 +58,6 @@ -- > data family Api (api :: Type) (reply :: Synchronicity) - -- | The (promoted) constructors of this type specify (at the type level) the -- reply behavior of a specific constructor of an @Api@ instance. data Synchronicity =@@ -70,8 +70,7 @@ -- | This is a tag-type that wraps around a 'ProcessId' and holds an 'Api' index -- type. newtype Server api = Server { _fromServer :: ProcessId }-  deriving (Eq,Ord,Typeable)-+  deriving (Eq,Ord,Typeable, NFData)  instance Typeable api => Show (Server api) where   showsPrec d s@(Server c) =

@@ -5,6 +5,7 @@   ( -- * Calling APIs directly     cast   , call+  , callWithTimeout   -- * Server Process Registration   , castRegistered   , callRegistered@@ -20,6 +21,8 @@ import           Control.Eff.Concurrent.Api import           Control.Eff.Concurrent.Api.Request import           Control.Eff.Concurrent.Process+import           Control.Eff.Concurrent.Process.Timer+import           Control.Eff.Log import           Data.Typeable                  ( Typeable ) import           Control.DeepSeq import           GHC.Stack@@ -28,6 +31,8 @@ -- possible. The type signature enforces that the corresponding 'Api' clause is -- 'Asynchronous'. The operation never fails, if it is important to know if the -- message was delivered, use 'call' instead.+--+-- The message will be reduced to normal form ('rnf') in the caller process. cast   :: forall r q o    . ( HasCallStack@@ -35,33 +40,37 @@      , Member Interrupts r      , Typeable o      , Typeable (Api o 'Asynchronous)+     , NFData (Api o 'Asynchronous)      )   => Server o   -> Api o 'Asynchronous   -> Eff r ()-cast (Server pid) castMsg = sendMessage pid (Cast $! castMsg)+cast (Server pid) castMsg = sendMessage pid (Cast castMsg)  -- | Send an 'Api' request and wait for the server to return a result value. -- -- The type signature enforces that the corresponding 'Api' clause is -- 'Synchronous'.+--+-- __Always prefer 'callWithTimeout' over 'call'__ call   :: forall result api r q    . ( SetMember Process (Process q) r      , Member Interrupts r      , Typeable api      , Typeable (Api api ( 'Synchronous result))+     , NFData (Api api ( 'Synchronous result))      , Typeable result-     , HasCallStack      , NFData result      , Show result+     , HasCallStack      )   => Server api   -> Api api ( 'Synchronous result)   -> Eff r result call (Server pidInternal) req = do-  fromPid <- self   callRef <- makeReference+  fromPid <- self   let requestMessage = Call callRef fromPid $! req   sendMessage pidInternal requestMessage   let selectResult :: MessageSelector result@@ -74,6 +83,64 @@   resultOrError <- receiveWithMonitor pidInternal selectResult   either (interrupt . becauseProcessIsDown) return resultOrError ++-- | Send an 'Api' request and wait for the server to return a result value.+--+-- The type signature enforces that the corresponding 'Api' clause is+-- 'Synchronous'.+--+-- If the server that was called dies, this function interrupts the+-- process with 'ProcessDown'.+-- If the server takes longer to reply than the given timeout, this+-- function interrupts the process with 'ProcessTimeout'.+--+-- __Always prefer this function over 'call'__+--+-- @since 0.22.0+callWithTimeout+  :: forall result api r q+   . ( SetMember Process (Process q) r+     , Member Interrupts r+     , Typeable api+     , Typeable (Api api ( 'Synchronous result))+     , NFData (Api api ( 'Synchronous result))+     , Typeable result+     , NFData result+     , Show result+     , Member Logs r+     , Lifted IO q+     , Lifted IO r+     , HasCallStack+     )+  => Server api+  -> Api api ( 'Synchronous result)+  -> Timeout+  -> Eff r result+callWithTimeout serverP@(Server pidInternal) req timeOut = do+  fromPid <- self+  callRef <- makeReference+  let requestMessage = Call callRef fromPid $! req+  sendMessage pidInternal requestMessage+  let selectResult =+        let extractResult+              :: Reply (Api api ( 'Synchronous result)) -> Maybe result+            extractResult (Reply _pxResult callRefMsg result) =+              if callRefMsg == callRef then Just result else Nothing+        in selectMessageWith extractResult+  resultOrError <- receiveSelectedWithMonitorAfter pidInternal selectResult timeOut+  let onTimeout timerRef = do+        let msg = "call timed out after "+                  ++ show timeOut ++ " to server: "+                  ++ show serverP ++ " from "+                  ++ show fromPid ++ " "+                  ++ show timerRef+        logWarning' msg+        interrupt (ProcessTimeout msg)+      onProcDown p = do+        logWarning' ("call to dead server: "++ show serverP ++ " from " ++ show fromPid)+        interrupt (becauseProcessIsDown p)+  either (either onProcDown onTimeout) return resultOrError+ -- | Instead of passing around a 'Server' value and passing to functions like -- 'cast' or 'call', a 'Server' can provided by a 'Reader' effect, if there is -- only a __single server__ for a given 'Api' instance. This type alias is@@ -106,6 +173,7 @@      , HasCallStack      , NFData reply      , Show reply+     , NFData (Api o ( 'Synchronous reply))      , Member Interrupts r      )   => Api o ( 'Synchronous reply)@@ -117,7 +185,7 @@ -- | Like 'cast' but take the 'Server' from the reader provided by -- 'registerServer'. castRegistered-  :: (Typeable o, ServesApi o r q, HasCallStack, Member Interrupts r)+  :: (Typeable o, ServesApi o r q, HasCallStack, Member Interrupts r, NFData (Api o 'Asynchronous))   => Api o 'Asynchronous   -> Eff r () castRegistered method = do

@@ -0,0 +1,49 @@+-- | A better, more safe implementation of the Erlang/OTP gen_server behaviour.+-- **PLANNED TODO**+-- @since 0.23.0+module Control.Eff.Concurrent.Api.GenServer++   where++import Control.DeepSeq+import Control.Eff+import Control.Eff.Concurrent.Api+import Control.Eff.Concurrent.Process+import Control.Eff.Log+import Control.Eff.State.Lazy+import Data.Dynamic+import Data.Kind+import Data.Text as T++-- | A type class for 'Api' values that have an implementation+-- which handles the 'Api'.+class (Typeable (GenServerState a), NFData (GenServerState a)) =>+      GenServer a eff+  where+  type GenServerState a :: Type+  genServerInit :: ('[Interrupts, Logs] <:: eff, SetMember Process (Process q) eff) => a -> Eff eff (GenServerState a)+  genServerHandle ::+       ('[Interrupts, Logs] <:: eff, SetMember Process (Process q) eff)+    => Api a v+    -> Eff (State (GenServerState a) ': eff) (ApiReply v)+  genServerInterrupt ::+       ('[Interrupts, Logs] <:: eff, SetMember Process (Process q) eff)+    => InterruptReason+    -> Eff (State (GenServerState a) ': eff) ()+  genServerInfoCommand :: Api a ('Synchronous Text)++type family ApiReply (s :: Synchronicity) where+  ApiReply ('Synchronous t) = Maybe t+  ApiReply 'Asynchronous = ()++data SomeMessage a =+  MkSomeMessage++data instance  Api (SomeMessage a) s where+        SomeMessage :: a -> Api (SomeMessage a) 'Asynchronous++runGenServer ::+     forall q e h a. (GenServer a e, SetMember Process (Process q) e, Member Interrupts e, LogsTo h e)+  => a+  -> Eff e (Server a)+runGenServer initArg = error "TODO"

@@ -26,14 +26,18 @@ import           Control.Eff.Concurrent.Api.Client import           Control.Eff.Concurrent.Api.Server import           Control.Eff.State.Strict+import           Control.Eff.Log import           Control.Lens+import           Data.Data                     (typeOf) import           Data.Dynamic import           Data.Foldable import           Data.Proxy import           Data.Set                       ( Set ) import qualified Data.Set                      as Set+import           Data.Text                      ( pack ) import           Data.Typeable                  ( typeRep ) import           GHC.Stack+import Control.DeepSeq (NFData(rnf))  -- * Observers @@ -45,9 +49,12 @@ -- @since 0.16.0 data Observer o where   Observer-    :: (Show (Server p), Typeable p, Typeable o)+    :: (Show (Server p), Typeable p, Typeable o, NFData o, NFData (Api p 'Asynchronous))     => (o -> Maybe (Api p 'Asynchronous)) -> Server p -> Observer o +instance (NFData o) => NFData (Observer o) where+  rnf (Observer k s) = rnf k `seq` rnf s+ instance Show (Observer o) where   showsPrec d (Observer _ p) = showParen     (d >= 10)@@ -72,6 +79,7 @@      , HasCallStack      , Member Interrupts r      , Typeable o+     , NFData o      )   => Observer o   -> Server (ObserverRegistry o)@@ -87,6 +95,7 @@      , HasCallStack      , Member Interrupts r      , Typeable o+     , NFData o      )   => Observer o   -> Server (ObserverRegistry o)@@ -106,14 +115,18 @@   --   -- @since 0.16.1   Observed :: o -> Api (Observer o) 'Asynchronous+  deriving Typeable +instance NFData o => NFData (Api (Observer o) 'Asynchronous) where+  rnf (Observed o) = rnf o+ -- | Based on the 'Api' instance for 'Observer' this simplified writing -- a callback handler for observations. In order to register to -- and 'ObserverRegistry' use 'toObserver'. -- -- @since 0.16.0 handleObservations-  :: (HasCallStack, Typeable o, SetMember Process (Process q) r)+  :: (HasCallStack, Typeable o, SetMember Process (Process q) r, NFData (Observer o))   => (o -> Eff r CallbackResult)   -> MessageCallback (Observer o) r handleObservations k = handleCasts@@ -124,7 +137,7 @@ -- | Use a 'Server' as an 'Observer' for 'handleObservations'. -- -- @since 0.16.0-toObserver :: Typeable o => Server (Observer o) -> Observer o+toObserver :: (NFData o, Typeable o, NFData (Api (Observer o) 'Asynchronous)) => Server (Observer o) -> Observer o toObserver = toObserverFor Observed  -- | Create an 'Observer' that conditionally accepts all observations of the@@ -133,7 +146,7 @@ -- -- @since 0.16.0 toObserverFor-  :: (Typeable a, Typeable o)+  :: (Typeable a, NFData (Api a 'Asynchronous), Typeable o, NFData o)   => (o -> Api a 'Asynchronous)   -> Server a   -> Observer o@@ -156,12 +169,16 @@   --   received.   --   -- @since 0.16.1-  RegisterObserver :: Observer o -> Api (ObserverRegistry o) 'Asynchronous+  RegisterObserver :: NFData o => Observer o -> Api (ObserverRegistry o) 'Asynchronous   -- | This message denotes that the given 'Observer' should not receive observations anymore.   --   -- @since 0.16.1-  ForgetObserver :: Observer o -> Api (ObserverRegistry o) 'Asynchronous+  ForgetObserver :: NFData o => Observer o -> Api (ObserverRegistry o) 'Asynchronous+  deriving Typeable +instance NFData (Api (ObserverRegistry o) r) where+  rnf (RegisterObserver o) = rnf o+  rnf (ForgetObserver o) = rnf o  -- ** Api for integrating 'ObserverRegistry' into processes. @@ -175,20 +192,27 @@      , Typeable o      , SetMember Process (Process q) r      , Member (ObserverState o) r+     , Member Logs r      )   => MessageCallback (ObserverRegistry o) r handleObserverRegistration = handleCasts   (\case-    RegisterObserver ob ->-      get @(Observers o)-        >>= put-        .   over observers (Set.insert ob)-        >>  pure AwaitNext-    ForgetObserver ob ->-      get @(Observers o)-        >>= put-        .   over observers (Set.delete ob)-        >>  pure AwaitNext+    RegisterObserver ob -> do+      os <- get @(Observers o)+      logDebug ("registering "+               <> pack (show (typeOf ob))+               <> " current number of observers: "+               <> pack (show (Set.size (view observers os))))+      put (over observers (Set.insert ob)os)+      pure AwaitNext+    ForgetObserver ob -> do+      os <- get @(Observers o)+      logDebug ("forgetting "+               <> pack (show (typeOf ob))+               <> " current number of observers: "+               <> pack (show (Set.size (view observers os))))+      put (over observers (Set.delete ob) os)+      pure AwaitNext   )  @@ -201,7 +225,7 @@ manageObservers = evalState (Observers Set.empty)  -- | Internal state for 'manageObservers'-data Observers o =+newtype Observers o =   Observers { _observers :: Set (Observer o) }  -- | Alias for the effect that contains the observers managed by 'manageObservers'@@ -219,6 +243,7 @@    . ( SetMember Process (Process q) r      , Member (ObserverState o) r      , Member Interrupts r+   --  , NFData (Api o 'Asynchronous)      )   => o   -> Eff r ()

@@ -11,12 +11,14 @@ where  import           Control.Concurrent.STM+import           Control.DeepSeq (NFData) import           Control.Eff-import           Control.Eff.ExceptionExtra     ( )-import           Control.Eff.Concurrent.Process-import           Control.Eff.Log+import           Control.Eff.Concurrent.Api import           Control.Eff.Concurrent.Api.Observer import           Control.Eff.Concurrent.Api.Server+import           Control.Eff.Concurrent.Process+import           Control.Eff.ExceptionExtra     ( )+import           Control.Eff.Log import           Control.Eff.Reader.Strict import           Control.Exception.Safe        as Safe import           Control.Monad.IO.Class@@ -134,7 +136,13 @@ -- @since 0.18.0 spawnLinkObservationQueueWriter   :: forall o q-   . (Typeable o, Show o, Member Logs q, Lifted IO q, HasCallStack)+   . ( Typeable o+     , Show o+     , NFData o+     , NFData (Api (Observer o) 'Asynchronous)+     , Member Logs q+     , Lifted IO q+     , HasCallStack)   => ObservationQueue o   -> Eff (InterruptableProcess q) (Observer o) spawnLinkObservationQueueWriter (ObservationQueue q) = do

@@ -24,20 +24,29 @@ -- -- @since 0.15.0 data Request api where-  Call :: forall api reply . (Typeable api, Typeable reply, Typeable (Api api ('Synchronous reply)))+  Call :: forall api reply . (Typeable api, Typeable reply, NFData reply, Typeable (Api api ('Synchronous reply)), NFData (Api api ('Synchronous reply)))          => Int -> ProcessId -> Api api ('Synchronous reply) -> Request api -  Cast :: forall api . (Typeable api, Typeable (Api api 'Asynchronous))+  Cast :: forall api . (Typeable api, Typeable (Api api 'Asynchronous), NFData (Api api 'Asynchronous ))          => Api api 'Asynchronous -> Request api   deriving Typeable +instance NFData (Request api) where+  rnf (Call i p req) = rnf i `seq` rnf p `seq` rnf req+  rnf (Cast req)     = rnf req+ -- | The wrapper around replies to 'Call's. -- -- @since 0.15.0 data Reply request where-  Reply :: (Typeable api, Typeable reply) => Proxy (Api api ('Synchronous reply)) -> Int -> reply -> Reply (Api api ('Synchronous reply))+  Reply :: (Typeable api, Typeable reply, NFData reply)+        => Proxy (Api api ('Synchronous reply)) -> Int -> reply -> Reply (Api api ('Synchronous reply))   deriving Typeable +instance NFData (Reply request) where+  rnf (Reply _ i r) = rnf i `seq` rnf r++ -- | Get the @reply@ of an @Api foo ('Synchronous reply)@. -- -- @since 0.15.0@@ -61,12 +70,18 @@ -- @since 0.15.0 data RequestOrigin request =   RequestOrigin { _requestOriginPid :: !ProcessId, _requestOriginCallRef :: !Int}-  deriving (Eq, Ord, Typeable, Show, Generic)+  deriving (Eq, Ord, Typeable, Generic) +instance Show (RequestOrigin r) where+  showsPrec d (RequestOrigin o r) =+    showParen (d >= 10) (showString "caller: " . shows o . showChar ' ' . shows r)+ instance NFData (RequestOrigin request) where  -- | Send a 'Reply' to a 'Call'. --+-- The reply will be deeply evaluated to 'rnf'.+-- -- @since 0.15.0 sendReply   :: forall request reply api eff q@@ -77,10 +92,11 @@      , ReplyType request ~ reply      , request ~ Api api ( 'Synchronous reply)      , Typeable reply+     , NFData reply      )   => RequestOrigin request   -> reply   -> Eff eff () sendReply origin reply = sendMessage   (_requestOriginPid origin)-  (Reply (Proxy @request) (_requestOriginCallRef origin) $! reply)+  (Reply (Proxy @request) (_requestOriginCallRef origin) $! force reply)

@@ -41,7 +41,7 @@ import           Control.Eff import           Control.Eff.Extend import           Control.Eff.Log-import           Control.Eff.State.Lazy+import           Control.Eff.State.Strict import           Control.Eff.Concurrent.Api import           Control.Eff.Concurrent.Api.Request import           Control.Eff.Concurrent.Process@@ -55,6 +55,7 @@ import           Data.Text as T import           GHC.Stack + -- | /Serve/ an 'Api' in a newly spawned process. -- -- @since 0.13.2@@ -85,7 +86,7 @@ -- @since 0.13.2 spawnApiServerStateful   :: forall api eff state-   . (HasCallStack, ToServerPids api)+   . (HasCallStack, ToServerPids api, NFData state)   => Eff (InterruptableProcess eff) state   -> MessageCallback api (State state ': InterruptableProcess eff)   -> InterruptCallback (State state ': ConsProcess eff)@@ -96,12 +97,15 @@     evalState state $ receiveSelectedLoop sel $ \msg -> case msg of       Left  m -> invokeIntCb m       Right m -> do-        s <- get-        r <- raise (provideInterrupts (evalState s (cb m)))+        r <- do s <- force <$> get+                raise (provideInterrupts (runState s (cb m)))         case r of-          Left  i              -> invokeIntCb i-          Right (StopServer i) -> invokeIntCb i-          Right AwaitNext      -> return Nothing+          Left  i                  -> invokeIntCb i+          Right (x , s')           -> do+            put (force s')+            case x of+              (StopServer i) -> invokeIntCb i+              AwaitNext      -> return Nothing  where   invokeIntCb j = do     l <- intCb j@@ -201,7 +205,7 @@ -- | An existential wrapper around  a 'MessageSelector' and a function that -- handles the selected message. The @api@ type parameter is a phantom type. ----- The return value if the handler function is a 'CallbackResult'.+-- The return value of the handler function is a 'CallbackResult'. -- -- @since 0.13.2 data MessageCallback api eff where@@ -213,7 +217,7 @@  instance Monoid (MessageCallback api eff) where   mappend = (<>)-  mempty  = MessageCallback selectAnyMessageLazy (const (pure AwaitNext))+  mempty  = MessageCallback selectAnyMessage (const (pure AwaitNext))  instance Default (MessageCallback api eff) where   def = mempty@@ -245,20 +249,21 @@ handleAnyMessages   :: forall eff    . HasCallStack-  => (Dynamic -> Eff eff CallbackResult)+  => (StrictDynamic -> Eff eff CallbackResult)   -> MessageCallback '[] eff-handleAnyMessages = MessageCallback selectAnyMessageLazy+handleAnyMessages = MessageCallback selectAnyMessage  -- | A smart constructor for 'MessageCallback's -- -- @since 0.13.2 handleCasts   :: forall api eff-   . (HasCallStack, Typeable api, Typeable (Api api 'Asynchronous))+   . ( HasCallStack, Typeable api, Typeable (Api api 'Asynchronous)+     , NFData (Request api))   => (Api api 'Asynchronous -> Eff eff CallbackResult)   -> MessageCallback api eff handleCasts h = MessageCallback-  (selectMessageWithLazy+  (selectMessageWith     (\case       cr@(Cast _ :: Request api) -> Just cr       _callReq                   -> Nothing@@ -291,14 +296,14 @@      , Member Interrupts eff      )   => (  forall secret reply-      . (Typeable reply, Typeable (Api api ( 'Synchronous reply)))+      . (NFData reply, Typeable reply, Typeable (Api api ( 'Synchronous reply)))      => Api api ( 'Synchronous reply)      -> (Eff eff (Maybe reply, CallbackResult) -> secret)      -> secret      )   -> MessageCallback api eff handleCalls h = MessageCallback-  (selectMessageWithLazy+  (selectMessageWith     (\case       (Cast _ :: Request api) -> Nothing       callReq                 -> Just callReq@@ -322,12 +327,13 @@    . ( HasCallStack      , Typeable api      , Typeable (Api api 'Asynchronous)+     , NFData (Request api)      , SetMember Process (Process effScheduler) eff      , Member Interrupts eff      )   => (Api api 'Asynchronous -> Eff eff CallbackResult)   -> (  forall secret reply-      . (Typeable reply, Typeable (Api api ( 'Synchronous reply)))+      . (Typeable reply, Typeable (Api api ( 'Synchronous reply)), NFData reply)      => Api api ( 'Synchronous reply)      -> (Eff eff (Maybe reply, CallbackResult) -> secret)      -> secret@@ -347,14 +353,14 @@      , Member Interrupts eff      )   => (  forall reply-      . (Typeable reply, Typeable (Api api ( 'Synchronous reply)))+      . (Typeable reply, NFData reply, Typeable (Api api ( 'Synchronous reply)))      => RequestOrigin (Api api ( 'Synchronous reply))      -> Api api ( 'Synchronous reply)      -> Eff eff CallbackResult      )   -> MessageCallback api eff handleCallsDeferred h = MessageCallback-  (selectMessageWithLazy+  (selectMessageWith     (\case       (Cast _ :: Request api) -> Nothing       callReq                 -> Just callReq@@ -410,13 +416,13 @@ -- @since 0.13.2 dropUnhandledMessages :: forall eff . HasCallStack => MessageCallback '[] eff dropUnhandledMessages =-  MessageCallback selectAnyMessageLazy (const (return AwaitNext))+  MessageCallback selectAnyMessage (const (return AwaitNext))  -- | A 'fallbackHandler' that terminates if there are unhandled messages. -- -- @since 0.13.2 exitOnUnhandled :: forall eff . HasCallStack => MessageCallback '[] eff-exitOnUnhandled = MessageCallback selectAnyMessageLazy $ \msg ->+exitOnUnhandled = MessageCallback selectAnyMessage $ \msg ->   return (StopServer (ProcessError ("unhandled message " <> show msg)))  -- | A 'fallbackHandler' that drops the left-over messages.@@ -426,7 +432,7 @@   :: forall eff    . (Member Logs eff, HasCallStack)   => MessageCallback '[] eff-logUnhandledMessages = MessageCallback selectAnyMessageLazy $ \msg -> do+logUnhandledMessages = MessageCallback selectAnyMessage $ \msg -> do   logWarning ("ignoring unhandled message " <> T.pack (show msg))   return AwaitNext 

@@ -15,14 +15,16 @@   ( -- * Process Effect     -- ** Effect Type Handling     Process(..)+  , -- ** Message Data+    StrictDynamic()+  , toStrictDynamic+  , fromStrictDynamic+  , unwrapStrictDynamic     -- ** ProcessId Type   , ProcessId(..)   , fromProcessId   , ConsProcess   , ResumeProcess(..)-  -- ** Scheduler Effect Identification-  , SchedulerProxy(..)-  , thisSchedulerProxy   -- ** Process State   , ProcessState(..)   -- ** Yielding@@ -45,16 +47,10 @@   -- ** Selecting Messages to Receive   , MessageSelector(runMessageSelector)   , selectMessage-  , selectMessageLazy-  , selectMessageProxy-  , selectMessageProxyLazy   , filterMessage-  , filterMessageLazy   , selectMessageWith-  , selectMessageWithLazy   , selectDynamicMessage-  , selectDynamicMessageLazy-  , selectAnyMessageLazy+  , selectAnyMessage   -- ** Process Life Cycle Management   , self   , isProcessAlive@@ -135,6 +131,7 @@ import qualified Data.Text                     as T import qualified Control.Exception             as Exc + -- | The process effect is the basis for message passing concurrency. This -- effect describes an interface for concurrent, communicating isolated -- processes identified uniquely by a process-id.@@ -160,7 +157,7 @@ -- * when the first process exists, all process should be killed immediately data Process (r :: [Type -> Type]) b where   -- | Remove all messages from the process' message queue-  FlushMessages ::Process r (ResumeProcess [Dynamic])+  FlushMessages ::Process r (ResumeProcess [StrictDynamic])   -- | In cooperative schedulers, this will give processing time to the   -- scheduler. Every other operation implicitly serves the same purpose.   --@@ -190,7 +187,7 @@   -- message should __always succeed__ and return __immediately__, even if the   -- destination process does not exist, or does not accept messages of the   -- given type.-  SendMessage ::ProcessId -> Dynamic -> Process r (ResumeProcess ())+  SendMessage :: ProcessId -> StrictDynamic -> Process r (ResumeProcess ())   -- | Receive a message that matches a criteria.   -- This should block until an a message was received. The message is returned   -- as a 'ResumeProcess' value. The function should also return if an exception@@ -261,6 +258,40 @@     Link      l                -> showString "link " . shows l     Unlink    l                -> showString "unlink " . shows l +-- | Data flows between 'Process'es via these messages.+--+-- This is just a newtype wrapper around 'Dynamic'.+-- The reason this type exists is to force construction through the code in this+-- module, which always evaluates a message to /normal form/ __before__+-- sending it to another process.+--+-- @since 0.22.0+newtype StrictDynamic where+  MkDynamicMessage :: Dynamic -> StrictDynamic+  deriving Typeable++instance Show StrictDynamic where+  show (MkDynamicMessage d) = show d++-- | Deeply evaluate the given value and wrap it into a 'StrictDynamic'.+--+-- @since 0.22.0+toStrictDynamic :: (Typeable a, NFData a) => a -> StrictDynamic+toStrictDynamic x = force x `seq` toDyn (force x) `seq` MkDynamicMessage (toDyn (force x))++-- | Convert a 'StrictDynamic' back to a value.+--+-- @since 0.22.0+fromStrictDynamic :: Typeable a => StrictDynamic -> Maybe a+fromStrictDynamic (MkDynamicMessage d) = fromDynamic d+++-- | Convert a 'StrictDynamic' back to an unwrapped 'Dynamic'.+--+-- @since 0.22.0+unwrapStrictDynamic :: StrictDynamic -> Dynamic+unwrapStrictDynamic (MkDynamicMessage d) = d+ -- | Every 'Process' action returns it's actual result wrapped in this type. It -- will allow to signal errors as well as pass on normal results such as -- incoming messages.@@ -292,7 +323,7 @@ -- >   Left <$> selectTimeout<|> Right <$> selectString -- newtype MessageSelector a =-  MessageSelector {runMessageSelector :: Dynamic -> Maybe a }+  MessageSelector {runMessageSelector :: StrictDynamic -> Maybe a }   deriving (Semigroup, Monoid, Functor)  instance Applicative MessageSelector where@@ -305,111 +336,47 @@   (MessageSelector l) <|> (MessageSelector r) =     MessageSelector (\dyn -> l dyn <|> r dyn) --- | Create a message selector for a value that can be obtained by 'fromDynamic'.--- It will also 'force' the result.------ @since 0.9.1-selectMessage :: (NFData t, Typeable t) => MessageSelector t-selectMessage = selectDynamicMessage fromDynamic---- | Create a message selector for a value that can be obtained by 'fromDynamic'.--- It will also 'force' the result.+-- | Create a message selector for a value that can be obtained by 'fromStrictDynamic'. -- -- @since 0.9.1-selectMessageLazy :: Typeable t => MessageSelector t-selectMessageLazy = selectDynamicMessageLazy fromDynamic+selectMessage :: Typeable t => MessageSelector t+selectMessage = selectDynamicMessage fromStrictDynamic --- | Create a message selector from a predicate. It will 'force' the result.+-- | Create a message selector from a predicate. -- -- @since 0.9.1-filterMessage :: (Typeable a, NFData a) => (a -> Bool) -> MessageSelector a+filterMessage :: Typeable a => (a -> Bool) -> MessageSelector a filterMessage predicate = selectDynamicMessage-  (\d -> case fromDynamic d of-    Just a | predicate a -> Just a-    _                    -> Nothing-  )---- | Create a message selector from a predicate. It will 'force' the result.------ @since 0.9.1-filterMessageLazy :: Typeable a => (a -> Bool) -> MessageSelector a-filterMessageLazy predicate = selectDynamicMessageLazy-  (\d -> case fromDynamic d of+  (\d -> case fromStrictDynamic d of     Just a | predicate a -> Just a     _                    -> Nothing   )  -- | Select a message of type @a@ and apply the given function to it. -- If the function returns 'Just' The 'ReceiveSelectedMessage' function will--- return the result (sans @Maybe@). It will 'force' the result.+-- return the result (sans @Maybe@). -- -- @since 0.9.1 selectMessageWith-  :: (Typeable a, NFData b) => (a -> Maybe b) -> MessageSelector b-selectMessageWith f = selectDynamicMessage (fromDynamic >=> f)---- | Select a message of type @a@ and apply the given function to it.--- If the function returns 'Just' The 'ReceiveSelectedMessage' function will--- return the result (sans @Maybe@). It will 'force' the result.------ @since 0.9.1-selectMessageWithLazy :: Typeable a => (a -> Maybe b) -> MessageSelector b-selectMessageWithLazy f = selectDynamicMessageLazy (fromDynamic >=> f)---- | Create a message selector. It will 'force' the result.------ @since 0.9.1-selectDynamicMessage :: NFData a => (Dynamic -> Maybe a) -> MessageSelector a-selectDynamicMessage = MessageSelector . (force .)+  :: Typeable a => (a -> Maybe b) -> MessageSelector b+selectMessageWith f = selectDynamicMessage (fromStrictDynamic >=> f)  -- | Create a message selector. -- -- @since 0.9.1-selectDynamicMessageLazy :: (Dynamic -> Maybe a) -> MessageSelector a-selectDynamicMessageLazy = MessageSelector+selectDynamicMessage :: (StrictDynamic -> Maybe a) -> MessageSelector a+selectDynamicMessage = MessageSelector  -- | Create a message selector that will match every message. This is /lazy/ -- because the result is not 'force'ed. -- -- @since 0.9.1-selectAnyMessageLazy :: MessageSelector Dynamic-selectAnyMessageLazy = MessageSelector Just---- | Create a message selector for a value that can be obtained by 'fromDynamic'--- with a proxy argument. It will also 'force' the result.------ @since 0.9.1-selectMessageProxy-  :: forall proxy t . (NFData t, Typeable t) => proxy t -> MessageSelector t-selectMessageProxy _ = selectDynamicMessage fromDynamic---- | Create a message selector for a value that can be obtained by 'fromDynamic'--- with a proxy argument. It will also 'force' the result.------ @since 0.9.1-selectMessageProxyLazy-  :: forall proxy t . (Typeable t) => proxy t -> MessageSelector t-selectMessageProxyLazy _ = selectDynamicMessageLazy fromDynamic---- | Every function for 'Process' things needs such a proxy value--- for the low-level effect list, i.e. the effects identified by--- @__r__@ in @'Process' r : r@, this might be dependent on the--- scheduler implementation.-data SchedulerProxy :: [Type -> Type] -> Type where-  -- | Tell the type checker what effects we have below 'Process'-  SchedulerProxy ::SchedulerProxy q-  -- | Like 'SchedulerProxy' but shorter-  SP ::SchedulerProxy q-  -- | Like 'SP' but different-  Scheduler ::SchedulerProxy q+selectAnyMessage :: MessageSelector StrictDynamic+selectAnyMessage = MessageSelector Just  -- | /Cons/ 'Process' onto a list of effects. type ConsProcess r = Process r ': r --- | Return a 'SchedulerProxy' for a 'Process' effect.-thisSchedulerProxy :: Eff (Process r ': r) (SchedulerProxy r)-thisSchedulerProxy = return SchedulerProxy- -- | The state that a 'Process' is currently in. data ProcessState =     ProcessBooting              -- ^ The process has just been started but not@@ -453,6 +420,7 @@ toExitRecovery = \case   ProcessFinished           -> Recoverable   (ProcessNotRunning    _)  -> Recoverable+  (ProcessTimeout       _)  -> Recoverable   (LinkedProcessCrashed _)  -> Recoverable   (ProcessError         _)  -> Recoverable   ExitNormally              -> NoRecovery@@ -493,42 +461,46 @@     --     -- @since 0.13.2     ProcessFinished-      ::ExitReason 'Recoverable+      :: ExitReason 'Recoverable     -- | A process that should be running was not running.     ProcessNotRunning-      ::ProcessId -> ExitReason 'Recoverable+      :: ProcessId -> ExitReason 'Recoverable+    -- | A 'Recoverable' timeout has occurred.+    ProcessTimeout+      :: String -> ExitReason 'Recoverable     -- | A linked process is down     LinkedProcessCrashed-      ::ProcessId -> ExitReason 'Recoverable-    -- | An exit reason that has an error message but isn't 'Recoverable'.+      :: ProcessId -> ExitReason 'Recoverable+    -- | An exit reason that has an error message and is 'Recoverable'.     ProcessError-      ::String -> ExitReason 'Recoverable+      :: String -> ExitReason 'Recoverable     -- | A process function returned or exited without any error.     ExitNormally-      ::ExitReason 'NoRecovery+      :: ExitReason 'NoRecovery     -- | An unhandled 'Recoverable' allows 'NoRecovery'.     NotRecovered-      ::(ExitReason 'Recoverable) -> ExitReason 'NoRecovery+      :: (ExitReason 'Recoverable) -> ExitReason 'NoRecovery     -- | An unexpected runtime exception was thrown, i.e. an exception     --    derived from 'Control.Exception.Safe.SomeException'     UnexpectedException-      ::String -> String -> ExitReason 'NoRecovery+      :: String -> String -> ExitReason 'NoRecovery     -- | A process was cancelled (e.g. killed, in 'Async.cancel')     Killed-      ::ExitReason 'NoRecovery+      :: ExitReason 'NoRecovery   deriving Typeable  instance Show (ExitReason x) where   showsPrec d =     showParen (d >= 10)       . (\case-          ProcessFinished     -> showString "process finished"-          ProcessNotRunning p -> showString "process not running: " . shows p+          ProcessFinished        -> showString "process finished"+          ProcessNotRunning p    -> showString "process not running: " . shows p+          ProcessTimeout reason -> showString "timeout: " . showString reason           LinkedProcessCrashed m ->             showString "linked process " . shows m . showString " crashed"-          ProcessError reason -> showString "error: " . showString reason-          ExitNormally        -> showString "exit normally"-          NotRecovered e      -> showString "not recovered from: " . shows e+          ProcessError reason   -> showString "error: " . showString reason+          ExitNormally          -> showString "exit normally"+          NotRecovered e        -> showString "not recovered from: " . shows e           UnexpectedException w m ->             showString "unhandled runtime exception: "               . showString m@@ -543,11 +515,12 @@ instance NFData (ExitReason x) where   rnf ProcessFinished               = rnf ()   rnf (ProcessNotRunning    !l)     = rnf l+  rnf (ProcessTimeout       !l)     = rnf l   rnf (LinkedProcessCrashed !l)     = rnf l   rnf (ProcessError         !l)     = rnf l   rnf ExitNormally                  = rnf ()   rnf (NotRecovered !l            ) = rnf l-  rnf (UnexpectedException !l1 !l2) = rnf l1 `seq` rnf l2 `seq` ()+  rnf (UnexpectedException !l1 !l2) = rnf l1 `seq` rnf l2   rnf Killed                        = rnf ()  instance Ord (ExitReason x) where@@ -557,6 +530,9 @@   compare (ProcessNotRunning l)    (ProcessNotRunning r)    = compare l r   compare (ProcessNotRunning _)    _                        = LT   compare _                        (ProcessNotRunning    _) = GT+  compare (ProcessTimeout l)       (ProcessTimeout r)       = compare l r+  compare (ProcessTimeout _) _                              = LT+  compare _                        (ProcessTimeout _)       = GT   compare (LinkedProcessCrashed l) (LinkedProcessCrashed r) = compare l r   compare (LinkedProcessCrashed _) _                        = LT   compare _                        (LinkedProcessCrashed _) = GT@@ -577,6 +553,7 @@   (==) ProcessFinished          ProcessFinished          = True   (==) (ProcessNotRunning l)    (ProcessNotRunning r)    = (==) l r   (==) ExitNormally             ExitNormally             = True+  (==) (ProcessTimeout l)       (ProcessTimeout r)       = l == r   (==) (LinkedProcessCrashed l) (LinkedProcessCrashed r) = l == r   (==) (ProcessError         l) (ProcessError         r) = (==) l r   (==) (NotRecovered         l) (NotRecovered         r) = (==) l r@@ -590,6 +567,7 @@ isBecauseDown mp = \case   ProcessFinished         -> False   ProcessNotRunning    _  -> False+  ProcessTimeout       _  -> False   LinkedProcessCrashed p  -> maybe True (== p) mp   ProcessError         _  -> False   ExitNormally            -> False@@ -710,10 +688,11 @@ fromSomeExitReason (SomeExitReason e) = case e of   recoverable@ProcessFinished          -> Right recoverable   recoverable@(ProcessNotRunning    _) -> Right recoverable+  recoverable@(ProcessTimeout       _) -> Right recoverable   recoverable@(LinkedProcessCrashed _) -> Right recoverable   recoverable@(ProcessError         _) -> Right recoverable   noRecovery@ExitNormally              -> Left noRecovery-  noRecovery@(NotRecovered _         ) -> Left noRecovery+  noRecovery@(NotRecovered          _) -> Left noRecovery   noRecovery@(UnexpectedException _ _) -> Left noRecovery   noRecovery@Killed                    -> Left noRecovery @@ -796,18 +775,21 @@ -- | Send a message to a process addressed by the 'ProcessId'. -- See 'SendMessage'. --+-- The message will be reduced to normal form ('rnf') by/in the caller process. sendMessage   :: forall r q o    . ( SetMember Process (Process q) r      , HasCallStack      , Member Interrupts r      , Typeable o+     , NFData o      )   => ProcessId   -> o   -> Eff r () sendMessage pid message =-  executeAndResumeOrThrow (SendMessage pid $! toDyn $! message)+  rnf pid `seq` toStrictDynamic message+          `seq` executeAndResumeOrThrow (SendMessage pid (toStrictDynamic message))  -- | Send a 'Dynamic' value to a process addressed by the 'ProcessId'. -- See 'SendMessage'.@@ -815,10 +797,10 @@   :: forall r q    . (SetMember Process (Process q) r, HasCallStack, Member Interrupts r)   => ProcessId-  -> Dynamic+  -> StrictDynamic   -> Eff r () sendAnyMessage pid message =-  rnf pid `seq` executeAndResumeOrThrow (SendMessage pid $! message)+  executeAndResumeOrThrow (SendMessage pid message)  -- | Exit a process addressed by the 'ProcessId'. The process will exit, -- it might do some cleanup, but is ultimately unrecoverable.@@ -910,9 +892,9 @@ receiveAnyMessage   :: forall r q    . (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)-  => Eff r Dynamic+  => Eff r StrictDynamic receiveAnyMessage =-  executeAndResumeOrThrow (ReceiveSelectedMessage selectAnyMessageLazy)+  executeAndResumeOrThrow (ReceiveSelectedMessage selectAnyMessage)  -- | Block until a message was received, that is not 'Nothing' after applying -- a callback to it.@@ -935,12 +917,13 @@   :: forall a r q    . ( HasCallStack      , Typeable a+     , NFData a      , Show a      , SetMember Process (Process q) r      , Member Interrupts r      )   => Eff r a-receiveMessage = receiveSelectedMessage (MessageSelector fromDynamic)+receiveMessage = receiveSelectedMessage (MessageSelector fromStrictDynamic)  -- | Remove and return all messages currently enqueued in the process message -- queue.@@ -949,7 +932,7 @@ flushMessages   :: forall r q    . (HasCallStack, SetMember Process (Process q) r, Member Interrupts r)-  => Eff r [Dynamic]+  => Eff r [StrictDynamic] flushMessages = executeAndResumeOrThrow @q FlushMessages  -- | Enter a loop to receive messages and pass them to a callback, until the@@ -974,22 +957,22 @@   maybe (receiveSelectedLoop selector handlers) return mRes  -- | Like 'receiveSelectedLoop' but /not selective/.--- See also 'selectAnyMessageLazy', 'receiveSelectedLoop'.+-- See also 'selectAnyMessage', 'receiveSelectedLoop'. receiveAnyLoop   :: forall r q endOfLoopResult    . (SetMember Process (Process q) r, HasCallStack)-  => (Either InterruptReason Dynamic -> Eff r (Maybe endOfLoopResult))+  => (Either InterruptReason StrictDynamic -> Eff r (Maybe endOfLoopResult))   -> Eff r endOfLoopResult-receiveAnyLoop = receiveSelectedLoop selectAnyMessageLazy+receiveAnyLoop = receiveSelectedLoop selectAnyMessage  -- | Like 'receiveSelectedLoop' but refined to casting to a specific 'Typeable'--- using 'selectMessageLazy'.+-- using 'selectMessage'. receiveLoop   :: forall r q a endOfLoopResult-   . (SetMember Process (Process q) r, HasCallStack, Typeable a)+   . (SetMember Process (Process q) r, HasCallStack, NFData a, Typeable a)   => (Either InterruptReason a -> Eff r (Maybe endOfLoopResult))   -> Eff r endOfLoopResult-receiveLoop = receiveSelectedLoop selectMessageLazy+receiveLoop = receiveSelectedLoop selectMessage  -- | Returns the 'ProcessId' of the current process. self :: (HasCallStack, SetMember Process (Process q) r) => Eff r ProcessId@@ -1121,7 +1104,7 @@ -- @since 0.12.0 selectProcessDown :: MonitorReference -> MessageSelector ProcessDown selectProcessDown ref0 =-  filterMessageLazy (\(ProcessDown ref _reason) -> ref0 == ref)+  filterMessage (\(ProcessDown ref _reason) -> ref0 == ref)  -- | Connect the calling process to another process, such that -- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other

@@ -44,7 +44,6 @@                                                 , control                                                 ) import           Data.Default-import           Data.Dynamic import           Data.Foldable import           Data.Function                  ( fix ) import           Data.Kind                      ( )@@ -63,9 +62,9 @@ -- * Process Types  -- | A message queue of a process, contains the actual queue and maybe an--- exit reason. The message queue is backed by a 'Seq' sequence with 'Dynamic' values.+-- exit reason. The message queue is backed by a 'Seq' sequence with 'StrictDynamic' values. data MessageQ = MessageQ-  { _incomingMessages :: Seq Dynamic+  { _incomingMessages :: Seq StrictDynamic   , _shutdownRequests :: Maybe SomeExitReason   } @@ -109,6 +108,25 @@  makeLenses ''SchedulerState +logSchedulerState :: (HasCallStack, Member Logs e, Lifted IO e) => SchedulerState -> Eff e ()+logSchedulerState s = do+  (np, pt, pct, pm, nm) <- lift $ atomically $ do+    np  <- T.pack . show <$> readTVar (s ^. nextPid)+    pt  <- fmap (T.pack . show) <$> readTVar (s ^. processTable)+    pct <- fmap (T.pack . show) . Map.keys <$> readTVar (s ^. processCancellationTable)+    pm  <- fmap (T.pack . show) . Set.toList <$> readTVar (s ^. processMonitors)+    nm  <- T.pack . show <$> readTVar (s ^. nextMonitorIndex)+    return (np, pt, pct, pm, nm)+  logDebug "ForkIO Scheduler info"+  logDebug $ "nextPid: " <> np+  logDebug $ "process table:"+  traverse_ logDebug pt+  logDebug $ "process cancellation table:"+  traverse_ logDebug pct+  logDebug $ "process monitors:"+  traverse_ logDebug pm+  logDebug $ "nextMonitorIndex: " <> nm+ -- | Add monitor: If the process is dead, enqueue a 'ProcessDown' message into the -- owners message queue addMonitoring@@ -126,7 +144,7 @@         let processDownMessage =               ProcessDown monitorRef (SomeExitReason (ProcessNotRunning target))         in  enqueueMessageOtherProcess owner-                                       (toDyn processDownMessage)+                                       (toStrictDynamic processDownMessage)                                        schedulerState   return monitorRef @@ -145,7 +163,7 @@     (monitoredProcess mr == downPid)     (do       let processDownMessage = ProcessDown mr reason-      enqueueMessageOtherProcess owner (toDyn processDownMessage) schedulerState+      enqueueMessageOtherProcess owner (toStrictDynamic processDownMessage) schedulerState       removeMonitoring mr schedulerState     ) @@ -462,6 +480,8 @@     interpretGetProcessState !toPid = do       setMyProcessState ProcessBusy       schedulerState <- getSchedulerState+      when (toPid == 1) $+        logSchedulerState schedulerState       let procInfoVar = schedulerState ^. processTable       lift $ atomically $ do         procInfoTable <- readTVar procInfoVar@@ -495,7 +515,7 @@         >>= lift         .   atomically         .   enqueueShutdownRequest toPid msg-    interpretFlush :: Eff SchedulerIO (ResumeProcess [Dynamic])+    interpretFlush :: Eff SchedulerIO (ResumeProcess [StrictDynamic])     interpretFlush = do       setMyProcessState ProcessBusyReceiving       lift $ atomically $ do@@ -689,7 +709,7 @@ getSchedulerState = ask  enqueueMessageOtherProcess-  :: HasCallStack => ProcessId -> Dynamic -> SchedulerState -> STM ()+  :: HasCallStack => ProcessId -> StrictDynamic -> SchedulerState -> STM () enqueueMessageOtherProcess toPid msg schedulerState =   view (at toPid) <$> readTVar (schedulerState ^. processTable) >>= maybe     (return ())

@@ -132,7 +132,7 @@ -- | Combination of 'submit' and 'cast'. submitCast   :: forall o r-   . (SetMember Lift (Lift IO) r, Typeable o, Member Interrupts r)+   . (SetMember Lift (Lift IO) r, Typeable o, NFData (Api o 'Asynchronous), Member Interrupts r)   => SchedulerSession r   -> Server o   -> Api o 'Asynchronous@@ -148,6 +148,7 @@      , NFData q      , Show q      , Member Interrupts r+     , NFData (Api o ('Synchronous q))      )   => SchedulerSession r   -> Server o

@@ -30,11 +30,11 @@ import qualified Data.Set                      as Set import           GHC.Stack import           Data.Kind                      ( )-import           Data.Dynamic import           Data.Foldable import           Data.Monoid import qualified Control.Monad.State.Strict    as State import Data.Function (fix)+import Data.Dynamic (dynTypeRep)  -- ----------------------------------------------------------------------------- --  STS@@ -43,7 +43,7 @@ data STS r m = STS   { _nextPid :: !ProcessId   , _nextRef :: !Int-  , _msgQs :: !(Map.Map ProcessId (Seq Dynamic))+  , _msgQs :: !(Map.Map ProcessId (Seq StrictDynamic))   , _monitors :: !(Set.Set (MonitorReference, ProcessId))   , _processLinks :: !(Set.Set (ProcessId, ProcessId))   , _runEff :: forall a . Eff r a -> m a@@ -66,7 +66,7 @@         (foldMap           (\(pid, msgs) ->             Endo (showString "  " . shows pid . showString ": ")-              <> foldMap (Endo . shows . dynTypeRep) (toList msgs)+              <> foldMap (Endo . shows . dynTypeRep . unwrapStrictDynamic) (toList msgs)           )           (sts ^.. msgQs . itraversed . withIndex)         )@@ -84,7 +84,7 @@ incRef :: STS r m -> (Int, STS r m) incRef sts = (sts ^. nextRef, sts & nextRef %~ (+ 1)) -enqueueMsg :: ProcessId -> Dynamic -> STS r m -> STS r m+enqueueMsg :: ProcessId -> StrictDynamic -> STS r m -> STS r m enqueueMsg toPid msg = msgQs . ix toPid %~ (:|> msg)  newProcessQ :: Maybe ProcessId -> STS r m -> (ProcessId, STS r m)@@ -98,7 +98,7 @@             let (Nothing, stsQL) = addLink pid (sts ^. nextPid) stsQ in stsQL   ) -flushMsgs :: ProcessId -> STS m r -> ([Dynamic], STS m r)+flushMsgs :: ProcessId -> STS m r -> ([StrictDynamic], STS m r) flushMsgs pid = State.runState $ do   msgs <- msgQs . ix pid <<.= Empty   return (toList msgs)@@ -134,7 +134,7 @@       if Map.member target pt         then monitors %= Set.insert (mref, owner)         else let pdown = ProcessDown mref (SomeExitReason (ProcessNotRunning target))-              in State.modify' (enqueueMsg owner (toDyn pdown))+              in State.modify' (enqueueMsg owner (toStrictDynamic pdown))     return mref  removeMonitoring :: MonitorReference -> STS m r -> STS m r@@ -148,7 +148,7 @@   go (mr, owner) = when     (monitoredProcess mr == downPid)     (let pdown = ProcessDown mr reason-     in  State.modify' (enqueueMsg owner (toDyn pdown) . removeMonitoring mr)+     in  State.modify' (enqueueMsg owner (toStrictDynamic pdown) . removeMonitoring mr)     )  addLink :: ProcessId -> ProcessId -> STS m r -> (Maybe InterruptReason, STS m r)@@ -258,7 +258,7 @@ -- | Internal data structure that is part of the coroutine based scheduler -- implementation. data OnYield r a where-  OnFlushMessages :: (ResumeProcess [Dynamic] -> Eff r (OnYield r a))+  OnFlushMessages :: (ResumeProcess [StrictDynamic] -> Eff r (OnYield r a))                   -> OnYield r a   OnYield :: (ResumeProcess () -> Eff r (OnYield r a))          -> OnYield r a@@ -273,7 +273,7 @@   OnInterrupt :: ExitReason 'Recoverable                 -> (ResumeProcess b -> Eff r (OnYield r a))                 -> OnYield r a-  OnSend :: !ProcessId -> !Dynamic+  OnSend :: !ProcessId -> !StrictDynamic          -> (ResumeProcess () -> Eff r (OnYield r a))          -> OnYield r a   OnRecv :: MessageSelector b -> (ResumeProcess b -> Eff r (OnYield r a))

@@ -14,6 +14,7 @@   , selectTimerElapsed   , receiveAfter   , receiveSelectedAfter+  , receiveSelectedWithMonitorAfter   )    -- , receiveSelectedAfter, receiveAnyAfter, sendMessageAfter) where@@ -68,6 +69,32 @@   timerRef <- startTimer t   res      <- receiveSelectedMessage     (Left <$> selectTimerElapsed timerRef <|> Right <$> sel)+  cancelTimer timerRef+  return res++-- | Like 'receiveWithMonitor' combined with 'receiveSelectedAfter'.+--+-- @since 0.22.0+receiveSelectedWithMonitorAfter+  :: forall a r q+   . ( Lifted IO q+     , HasCallStack+     , SetMember Process (Process q) r+     , Member Interrupts r+     , Show a+     )+  => ProcessId+  -> MessageSelector a+  -> Timeout+  -> Eff r (Either (Either ProcessDown TimerElapsed) a)+receiveSelectedWithMonitorAfter pid sel t = do+  timerRef <- startTimer t+  res      <- withMonitor pid $ \pidMon -> do+                receiveSelectedMessage+                  (   Left . Left  <$> selectProcessDown pidMon+                  <|> Left . Right <$> selectTimerElapsed timerRef+                  <|> Right        <$> sel+                  )   cancelTimer timerRef   return res 

@@ -11,12 +11,14 @@   , renderRFC3164WithRFC5424Timestamps   , renderRFC3164WithTimestamp   , renderRFC5424-+  , renderRFC5424Header+  , renderRFC5424NoLocation    -- ** Partial Log Message Text Rendering   , renderSyslogSeverityAndFacility   , renderLogMessageSrcLoc   , renderMaybeLogMessageLens+  , renderLogMessageBodyNoLocation   , renderLogMessageBody   , renderLogMessageBodyFixWidth @@ -76,9 +78,15 @@ -- | Print the thread id, the message and the source file location, seperated by simple white space. renderLogMessageBody :: LogMessageRenderer T.Text renderLogMessageBody = T.unwords . filter (not . T.null) <$> sequence+  [ renderLogMessageBodyNoLocation+  , fromMaybe "" <$> renderLogMessageSrcLoc+  ]++-- | Print the thread id, the message and the source file location, seperated by simple white space.+renderLogMessageBodyNoLocation :: LogMessageRenderer T.Text+renderLogMessageBodyNoLocation = T.unwords . filter (not . T.null) <$> sequence   [ renderShowMaybeLogMessageLens "" lmThreadId   , view lmMessage-  , fromMaybe "" <$> renderLogMessageSrcLoc   ]  -- | Print the /body/ of a 'LogMessage' with fix size fields (60) for the message itself@@ -184,8 +192,28 @@       ]  -- | Render a 'LogMessage' according to the rules in the RFC-5424.+--+-- Equivalent to @'renderRFC5424Header' <> const " " <> 'renderLogMessageBody'@.+--+-- @since 0.21.0 renderRFC5424 :: LogMessageRenderer T.Text-renderRFC5424 l@(MkLogMessage _ _ ts hn an pid mi sd _ _ _) =+renderRFC5424  = renderRFC5424Header <> const " " <> renderLogMessageBody++-- | Render a 'LogMessage' according to the rules in the RFC-5424, like 'renderRFC5424' but+-- suppress the source location information.+--+-- Equivalent to @'renderRFC5424Header' <> const " " <> 'renderLogMessageBodyNoLocation'@.+--+-- @since 0.21.0+renderRFC5424NoLocation :: LogMessageRenderer T.Text+renderRFC5424NoLocation  = renderRFC5424Header <> const " " <> renderLogMessageBodyNoLocation++-- | Render the header and strucuted data of  a 'LogMessage' according to the rules in the RFC-5424, but do not+-- render the 'lmMessage'.+--+-- @since 0.22.0+renderRFC5424Header :: LogMessageRenderer T.Text+renderRFC5424Header l@(MkLogMessage _ _ ts hn an pid mi sd _ _ _) =   T.unwords     . filter (not . T.null)     $ [ renderSyslogSeverityAndFacility l <> "1" -- PRI VERSION

@@ -35,7 +35,7 @@ -- > -- withAsyncLogging-  :: (LogsTo IO e, Lifted IO e, MonadBaseControl IO (Eff e), Integral len)+  :: (Lifted IO e, MonadBaseControl IO (Eff e), Integral len)   => LogWriter IO   -> len -- ^ Size of the log message input queue. If the queue is full, message          -- are dropped silently.

@@ -8,9 +8,7 @@ import           Control.Eff                   as Eff import           Control.Eff.Log import           Control.Eff.LogWriter.IO-import           Control.Eff.LogWriter.Console import           Data.Text                     as T-import           Data.Text.IO                  as T import           Data.Text.Encoding            as T import qualified Control.Exception.Safe        as Safe import           Control.Monad                  ( void )@@ -70,19 +68,3 @@             )           )   )-  -- (Socket.socket :: IO (Socket.Socket Unix Datagram Socket.Default))-  -- (Safe.try @IO @Catch.SomeException . Socket.close)-  -- (\s -> case socketAddressUnixPath (T.encodeUtf8 (T.pack socketPath)) of-  --   Just addr -> do-  --     Socket.connect s addr-  --     ioE-  --       (mkLogWriterIO-  --         (\lmStr -> void-  --           $ Socket.send s (T.encodeUtf8 (render lmStr)) Socket.msgNoSignal-  --         )-  --       )--  --   Nothing -> do-  --     T.putStrLn $ "could not open unix domain socket: " <> T.pack socketPath-  --     ioE consoleLogWriter-  -- )

@@ -15,7 +15,6 @@                                                 ) import           Test.Tasty import           Test.Tasty.HUnit-import           Data.Dynamic import           Common  test_IOExceptionsIsolated :: TestTree@@ -54,10 +53,10 @@           assertBool "the other process was still running" wasStillRunningP1   | (busyWith , busyEffect) <-     [ ( "receiving"-      , void (send (ReceiveSelectedMessage @SchedulerIO selectAnyMessageLazy))+      , void (send (ReceiveSelectedMessage @SchedulerIO selectAnyMessage))       )     , ( "sending"-      , void (send (SendMessage @SchedulerIO 44444 (toDyn ("test message" :: String))))+      , void (send (SendMessage @SchedulerIO 44444 (toStrictDynamic ("test message" :: String))))       )     , ( "sending shutdown"       , void (send (SendShutdown @SchedulerIO 44444 ExitNormally))@@ -68,7 +67,7 @@         (send           (Spawn @SchedulerIO             (void-              (send (ReceiveSelectedMessage @SchedulerIO selectAnyMessageLazy))+              (send (ReceiveSelectedMessage @SchedulerIO selectAnyMessage))             )           )         )@@ -162,7 +161,7 @@             testMsg :: Float             testMsg   = 123             flushMessagesLoop = do-              res <- receiveSelectedAfter (selectDynamicMessageLazy Just) 0+              res <- receiveSelectedAfter (selectDynamicMessage Just) 0               case res of                 Left  _to -> return ()                 Right _   -> flushMessagesLoop@@ -177,7 +176,7 @@           res <- receiveAfter @Float 1000000           lift (res @?= Just testMsg)         flushMessagesLoop-        res <- receiveSelectedAfter (selectDynamicMessageLazy Just) 10000+        res <- receiveSelectedAfter (selectDynamicMessage Just) 10000         case res of           Left  _ -> return ()           Right x -> lift (False @? "unexpected message in queue " ++ show x)

@@ -2,7 +2,6 @@  import           Data.List                      ( sort ) import           Data.Foldable                  ( traverse_ )-import qualified Data.Dynamic                  as Dynamic import           Data.Typeable import           Control.Exception import           Control.Concurrent@@ -29,7 +28,9 @@ import           Common import           Control.Applicative import           Data.Void-import Control.Lens (view)+import           Control.Lens (view)+import           Control.DeepSeq+import GHC.Generics (Generic)  testInterruptReason :: InterruptReason testInterruptReason = ProcessError "test interrupt"@@ -87,6 +88,10 @@   ReturnToSender :: ProcessId -> String -> Api ReturnToSender ('Synchronous Bool)   StopReturnToSender :: Api ReturnToSender ('Synchronous ()) +instance NFData (Api ReturnToSender r) where+  rnf (ReturnToSender p s) = rnf p `seq` rnf s+  rnf StopReturnToSender = ()+ deriving instance Show (Api ReturnToSender x)  deriving instance Typeable (Api ReturnToSender x)@@ -214,12 +219,14 @@         )  -data Ping = Ping ProcessId-  deriving (Eq, Show)+newtype Ping = Ping ProcessId+  deriving (Eq, Show, Typeable, NFData)  data Pong = Pong-  deriving (Eq, Show)+  deriving (Eq, Show, Generic) +instance NFData Pong+ pingPongTests   :: forall r    . (Lifted IO r, LogsTo IO r)@@ -360,7 +367,7 @@               (spawn                 (do                   m <- receiveAnyMessage-                  void (sendMessage me m)+                  void (sendAnyMessage me m)                 )               )             )@@ -492,7 +499,7 @@               )             )           , ( "sending"-            , void (send (SendMessage @r 44444 (Dynamic.toDyn ("test message" :: String))))+            , void (send (SendMessage @r 44444 (toStrictDynamic ("test message" :: String))))             )           , ( "sending shutdown"             , void (send (SendShutdown @r 44444 ExitNormally))@@ -502,7 +509,7 @@             , void               (send                 (Spawn @r-                  (void (send (ReceiveSelectedMessage @r selectAnyMessageLazy)))+                  (void (send (ReceiveSelectedMessage @r selectAnyMessage)))                 )               )             )@@ -524,7 +531,7 @@               )             )           , ( "sending"-            , void (send (SendMessage @r 44444 (Dynamic.toDyn ("test message"::String))))+            , void (send (SendMessage @r 44444 (toStrictDynamic ("test message"::String))))             )           , ( "sending shutdown"             , void (send (SendShutdown @r 44444 ExitNormally))@@ -534,7 +541,7 @@             , void               (send                 (Spawn @r-                  (void (send (ReceiveSelectedMessage @r selectAnyMessageLazy)))+                  (void (send (ReceiveSelectedMessage @r selectAnyMessage)))                 )               )             )@@ -570,7 +577,7 @@               )             )           , ( "sending"-            , void (send (SendMessage @r 44444 (Dynamic.toDyn ("test message"::String))))+            , void (send (SendMessage @r 44444 (toStrictDynamic ("test message"::String))))             )           , ( "sending shutdown"             , void (send (SendShutdown @r 44444 ExitNormally))@@ -580,7 +587,7 @@             , void               (send                 (Spawn @r-                  (void (send (ReceiveSelectedMessage @r selectAnyMessageLazy)))+                  (void (send (ReceiveSelectedMessage @r selectAnyMessage)))                 )               )             )@@ -630,7 +637,7 @@         me    <- self         other <- spawn           (do-            untilInterrupted (SendMessage @r 666666 (Dynamic.toDyn ("test"::String)))+            untilInterrupted (SendMessage @r 666666 (toStrictDynamic ("test"::String)))             void (sendMessage me ("OK"::String))           )         void (sendInterrupt other testInterruptReason)@@ -642,7 +649,7 @@         me    <- self         other <- spawn           (do-            untilInterrupted (ReceiveSelectedMessage @r selectAnyMessageLazy)+            untilInterrupted (ReceiveSelectedMessage @r selectAnyMessage)             void (sendMessage me ("OK" :: String))           )         void (sendInterrupt other testInterruptReason)

@@ -0,0 +1,110 @@+module ServerForkIO where++import           Control.Concurrent+import           Control.Eff.Extend+import           Control.Eff.State.Strict+import           Control.Eff.Concurrent+import           Control.Eff.Concurrent.Process.ForkIOScheduler+                                               as Scheduler+import           Control.Monad                  ( )+import           Test.Tasty                    hiding (Timeout)+import           Test.Tasty.HUnit+import           Common+import           Data.Typeable                 hiding ( cast )+import           Control.DeepSeq++data TestServer deriving Typeable++data instance Api TestServer x where+  TestGetStringLength :: String -> Api TestServer ('Synchronous Int)+  TestSetNextDelay :: Timeout -> Api TestServer 'Asynchronous+  deriving Typeable++instance NFData (Api TestServer x) where+  rnf (TestGetStringLength x) = rnf x+  rnf (TestSetNextDelay x) = rnf x++test_ServerCallTimeout :: TestTree+test_ServerCallTimeout =+  setTravisTestOptions+    $ testCase "Server call timeout"+    $ do+         runLift . withTraceLogging "test" local0 allLogMessages . Scheduler.schedule+               $ do  let backendDelay  = 100000+                         clientTimeout = 1000+                     s <- spawnBackend+                     linkProcess (_fromServer s)+                     logInfo "====================== All Servers Started ========================"+                     cast s (TestSetNextDelay backendDelay)+                     let testData = "this is a nice string" :: String+                         expected = 2 * length testData+                         testAction = callWithTimeout+                                       s+                                       (TestGetStringLength testData)++                     actual <- handleInterrupts+                                  (\i -> do+                                      logNotice' ("caught interrupt: " ++ show i)+                                      logNotice "adapting server delay"+                                      cast s (TestSetNextDelay clientTimeout)+                                      res <- testAction backendDelay+                                      logNotice "Yeah!! Got a result..."+                                      return (res * 2)+                                  ) +                                  (testAction clientTimeout)+                     lift (expected @=? actual)+         threadDelay 1000+++spawnRelay :: Timeout -> Server TestServer -> Eff InterruptableProcEff (Server TestServer)+spawnRelay callTimeout target = spawnApiServer hm hi+  where+    hi = InterruptCallback $ \i -> do+            logAlert' (show i)+            pure AwaitNext+    hm :: MessageCallback TestServer InterruptableProcEff+    hm = handleCastsAndCalls onCast onCall+      where+        onCast :: Api TestServer 'Asynchronous -> Eff InterruptableProcEff CallbackResult+        onCast (TestSetNextDelay x) = do+          logDebug "relaying delay"+          cast target (TestSetNextDelay x)+          pure AwaitNext++        onCall :: (NFData l, Typeable l)+               => Api TestServer ('Synchronous l)+               -> (Eff InterruptableProcEff (Maybe l, CallbackResult) -> k)+               -> k+        onCall (TestGetStringLength s) runHandler = runHandler $ do+          logDebug "relaying get string length"+          l <- callWithTimeout target (TestGetStringLength s) callTimeout+          logDebug' ("got result: " ++ show l)+          return (Just l, AwaitNext)+++spawnBackend :: Eff InterruptableProcEff (Server TestServer)+spawnBackend = spawnApiServerStateful (return (1000000 :: Timeout)) hm hi+  where+    hi = InterruptCallback $ \i -> do+            logAlert' (show i)+            pure AwaitNext+    hm :: MessageCallback TestServer (State Timeout ': InterruptableProcEff)+    hm = handleCastsAndCalls onCast onCall+      where+        onCast :: Api TestServer 'Asynchronous -> Eff (State Timeout ': InterruptableProcEff) CallbackResult+        onCast (TestSetNextDelay x) = do+          logDebug' ("setting delay: " ++ show x)+          put x+          pure AwaitNext++        onCall :: (NFData l, Typeable l)+               => Api TestServer ('Synchronous l)+               -> (Eff (State Timeout ': InterruptableProcEff) (Maybe l, CallbackResult) -> k)+               -> k+        onCall (TestGetStringLength s) runHandler = runHandler $ do+          logDebug' ("calculating string length: " ++ show s)+          t <- get+          logDebug' ("sleeping for: " ++ show t)+          lift (threadDelay (fromTimeoutMicros t))+          logDebug "sending result"+          return (Just (length s), AwaitNext)

@@ -7,7 +7,6 @@ import           Control.Monad import           Test.Tasty import           Test.Tasty.HUnit-import           Data.Dynamic import           Common  test_pureScheduler :: TestTree@@ -61,7 +60,7 @@                         void exitNormally                         error "This should not happen (child)!!"                     )-                sendMessage child (toDyn ("test" :: String))+                sendMessage child ("test" :: String)                 void exitNormally                 error "This should not happen!!"             )