extensible-effects-concurrent 0.14.3 → 0.15.0

raw patch · 10 files changed

+166/−53 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−1
• examples/example-2/Main.hs +41/−3
• extensible-effects-concurrent.cabal +2/−2
• src/Control/Eff/Concurrent.hs +10/−0
• src/Control/Eff/Concurrent/Api.hs +5/−2
• src/Control/Eff/Concurrent/Api/Client.hs +4/−3
• src/Control/Eff/Concurrent/Api/Internal.hs +0/−23
• src/Control/Eff/Concurrent/Api/Request.hs +87/−0
• src/Control/Eff/Concurrent/Api/Server.hs +2/−6
• src/Control/Eff/Concurrent/Api/Server2.hs +9/−13

@@ -1,5 +1,10 @@ # Changelog for extensible-effects-concurrent +## 0.15.0++- Add `Api` `Request` and `Reply` types+- Add `RequestOrigin` which can be used in `Server2` based Api servers to queue and defer replies to `Call`s+ ## 0.14.3  - Export the functions introduced in 0.14.2 in `Control.Eff.Concurrent`.@@ -27,7 +32,7 @@ ## 0.13.1  - Remove misguided `MonadCatch` constraints in the `ObservationQueueReader`-    functions, and use `Interrupts` instead+  functions, and use `Interrupts` instead  ## 0.13.0 

@@ -7,6 +7,7 @@ import           Control.Eff.Concurrent import           Control.Eff.State.Strict import           Control.Monad+import           Data.Foldable import           Control.Concurrent  main :: IO ()@@ -32,7 +33,7 @@   => SchedulerProxy q   -> Eff (InterruptableProcess q) () altCounterExample px = do-  (c, cp) <- altCounter+  (c, (_sdp, cp)) <- altCounter   lift (threadDelay 500000)   o <- logCounterObservations px   lift (threadDelay 500000)@@ -58,12 +59,21 @@   lift (threadDelay 500000)   lift (threadDelay 500000) +data SupiDupi deriving Typeable +data instance Api SupiDupi r where+  Whoopediedoo :: Bool -> Api SupiDupi ('Synchronous (Maybe ()))+  deriving Typeable+ altCounter   :: (Member (Logs LogMessage) q)-  => Eff (InterruptableProcess q) (Server Counter, ProcessId)+  => Eff+       (InterruptableProcess q)+       (Server Counter, (Server SupiDupi, ProcessId)) altCounter = spawnApiServerEffectful-  (manageObservers @Counter . evalState (0 :: Integer))+  (manageObservers @Counter . evalState (0 :: Integer) . evalState+    (Nothing :: Maybe (RequestOrigin (Api SupiDupi ( 'Synchronous (Maybe ())))))+  )   (  handleCalls       SP       (\case@@ -80,6 +90,17 @@            let val' = val + 1            notifyObservers SP (CountChanged val')            put val'+           when (val' > 5) $ do+             get+               @( Maybe+                   (RequestOrigin (Api SupiDupi ( 'Synchronous (Maybe ()))))+               )+               >>= traverse_ (flip sendReply (Just ()))+             put+               (Nothing :: Maybe+                   (RequestOrigin (Api SupiDupi ( 'Synchronous (Maybe ()))))+               )+            return AwaitNext          ObserveCounter s -> do            addObserver s@@ -87,6 +108,23 @@          UnobserveCounter s -> do            removeObserver s            return AwaitNext+       )+  ^: handleCallsDeferred+       SP+       (\origin ->+         (\case+           Whoopediedoo c -> do+             if c+               then put (Just origin)+               else+                 put+                   (Nothing :: Maybe+                       ( RequestOrigin+                           (Api SupiDupi ( 'Synchronous (Maybe ())))+                       )+                   )+             pure AwaitNext+         )        )   ^: logUnhandledMessages   )

@@ -1,5 +1,5 @@ name:           extensible-effects-concurrent-version:        0.14.3+version:        0.15.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@@ -73,7 +73,7 @@                   Control.Eff.Concurrent.Api.Observer                   Control.Eff.Concurrent.Api.Observer.Queue   other-modules:-                Control.Eff.Concurrent.Api.Internal,+                Control.Eff.Concurrent.Api.Request,                 Paths_extensible_effects_concurrent   default-extensions:                      BangPatterns,

@@ -20,6 +20,9 @@     -- ** /Server/ Functions for Providing APIs (new experimental)     module Control.Eff.Concurrent.Api.Server2   ,+    -- ** Encapsulate 'Api's 'Cast's as well as 'Call's and their 'Reply's+    module Control.Eff.Concurrent.Api.Request+  ,     -- ** /Observer/ Functions for Events and Event Listener     module Control.Eff.Concurrent.Api.Observer   ,@@ -154,6 +157,13 @@                                                 , registerServer                                                 , whereIsServer                                                 , ServerReader+                                                )+import           Control.Eff.Concurrent.Api.Request+                                                ( Request(..)+                                                , Reply(..)+                                                , mkRequestOrigin+                                                , RequestOrigin(..)+                                                , sendReply                                                 ) import           Control.Eff.Concurrent.Api.Server2                                                 ( spawnApiServer

@@ -24,12 +24,15 @@   ) where -import           Data.Kind+import           Control.DeepSeq+import           Control.Eff+import           Control.Eff.Concurrent.Process import           Control.Lens+import           Data.Kind import           Data.Typeable                  ( Typeable                                                 , typeRep                                                 )-import           Control.Eff.Concurrent.Process+import           GHC.Generics  -- | This data family defines an API, a communication interface description -- between at least two processes. The processes act as __servers__ or

@@ -18,7 +18,7 @@ import           Control.Eff import           Control.Eff.Reader.Strict import           Control.Eff.Concurrent.Api-import           Control.Eff.Concurrent.Api.Internal+import           Control.Eff.Concurrent.Api.Request import           Control.Eff.Concurrent.Process import           Data.Typeable                  ( Typeable ) import           Control.DeepSeq@@ -68,8 +68,9 @@   sendMessage px pidInternal requestMessage   let selectResult :: MessageSelector result       selectResult =-        let extractResult :: Response api result -> Maybe result-            extractResult (Response _pxResult callRefMsg result) =+        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   rres <- receiveWithMonitor px pidInternal selectResult

@@ -1,23 +0,0 @@--- | Internal request and response type for casts and calls--module Control.Eff.Concurrent.Api.Internal-  ( Request(..)-  , Response(..)-  )-where--import           Data.Typeable                  ( Typeable )-import           Data.Proxy-import           Control.Eff.Concurrent.Api-import           Control.Eff.Concurrent.Process--data Request api where-  Call :: forall api apiCallReplyType . (Typeable api, Typeable apiCallReplyType, Typeable (Api api ('Synchronous apiCallReplyType)))-         => Int -> ProcessId -> Api api ('Synchronous apiCallReplyType) -> Request api-  Cast :: forall api . (Typeable api, Typeable (Api api 'Asynchronous))-         => Api api 'Asynchronous -> Request api-  deriving Typeable--data Response api apiCallReplyType where-  Response :: (Typeable api, Typeable apiCallReplyType) => Proxy api -> Int -> apiCallReplyType -> Response api apiCallReplyType-  deriving Typeable

@@ -0,0 +1,87 @@+{-# LANGUAGE UndecidableInstances #-}+-- | Proxies and containers for casts and calls.+--+-- @since 0.15.0+module Control.Eff.Concurrent.Api.Request+  ( Request(..)+  , Reply(..)+  , mkRequestOrigin+  , RequestOrigin(..)+  , sendReply+  )+where++import           Data.Typeable                  ( Typeable )+import           Data.Proxy+import           Control.Eff+import           Control.Eff.Concurrent.Api+import           Control.Eff.Concurrent.Process+import           GHC.TypeLits+import           Control.DeepSeq+import           GHC.Generics++-- | A wrapper sum type for calls and casts for the methods of an 'Api' subtype+--+-- @since 0.15.0+data Request api where+  Call :: forall api reply . (Typeable api, Typeable reply, Typeable (Api api ('Synchronous reply)))+         => Int -> ProcessId -> Api api ('Synchronous reply) -> Request api++  Cast :: forall api . (Typeable api, Typeable (Api api 'Asynchronous))+         => Api api 'Asynchronous -> Request api+  deriving Typeable++-- | 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))+  deriving Typeable++-- | Get the @reply@ of an @Api foo ('Synchronous reply)@.+--+-- @since 0.15.0+type family ReplyType request where+  ReplyType (Api api ('Synchronous reply)) = reply+  ReplyType (Api api 'Asynchronous) = TypeError ('Text "Asynchronous requests (aka casts) have no reply type." )++-- | Get the @reply@ of an @Api foo ('Synchronous reply)@.+--+-- @since 0.15.0+type family ApiType request where+  ApiType (Api api 'Asynchronous) = api+  ApiType (Api api ('Synchronous reply)) = api++-- | TODO remove+mkRequestOrigin :: request -> ProcessId -> Int -> RequestOrigin request+mkRequestOrigin _ = RequestOrigin++-- | Wraps the source 'ProcessId' and a unique identifier for a 'Call'.+--+-- @since 0.15.0+data RequestOrigin request =+  RequestOrigin { _requestOriginPid :: !ProcessId, _requestOriginCallRef :: !Int}+  deriving (Eq, Ord, Typeable, Show, Generic)++instance NFData (RequestOrigin request) where++-- | Send a 'Reply' to a 'Call'.+--+-- @since 0.15.0+sendReply+  :: forall request reply api eff q+   . ( SetMember Process (Process q) eff+     , Member Interrupts eff+     , Typeable api+     , ApiType request ~ api+     , ReplyType request ~ reply+     , request ~ Api api ( 'Synchronous reply)+     , Typeable reply+     )+  => RequestOrigin request+  -> reply+  -> Eff eff ()+sendReply origin reply = sendMessage+  SP+  (_requestOriginPid origin)+  (Reply (Proxy @request) (_requestOriginCallRef origin) $! reply)

@@ -32,7 +32,7 @@  import           Control.Eff import           Control.Eff.Concurrent.Api-import           Control.Eff.Concurrent.Api.Internal+import           Control.Eff.Concurrent.Api.Request import           Control.Eff.Concurrent.Process import           Control.Eff.Exception import           Control.Eff.Log@@ -369,11 +369,7 @@   (unhandledCallError px)   (_callCallback handlers)   request-  sendReply- where-  sendReply :: Typeable reply => reply -> Eff eff ()-  sendReply reply =-    sendMessage px fromPid (Response (Proxy @api) callRef $! reply)+  (sendReply (mkRequestOrigin request fromPid callRef))  -- | A default handler to use in '_callCallback' in 'ApiHandler'. It will call -- 'raiseError' with a nice error message.

@@ -46,7 +46,7 @@ import           Control.Eff.State.Lazy import           Control.Eff.Concurrent.Api import           Control.Eff.Concurrent.Api.Observer-import           Control.Eff.Concurrent.Api.Internal+import           Control.Eff.Concurrent.Api.Request import           Control.Eff.Concurrent.Process import           Control.Monad                  ( (>=>) ) import           Data.Proxy@@ -310,14 +310,10 @@     req     (\resAction -> do       (mReply, cbResult) <- resAction-      traverse_ (sendReply fromPid callRef) mReply+      traverse_ (sendReply (mkRequestOrigin req fromPid callRef)) mReply       return cbResult     )   )- where-  sendReply :: (Typeable reply) => ProcessId -> Int -> reply -> Eff eff ()-  sendReply fromPid callRef reply =-    sendMessage px fromPid (Response (Proxy @api) callRef $! reply)   -- | A smart constructor for 'MessageCallback's@@ -357,8 +353,8 @@   => SchedulerProxy effScheduler   -> (  forall reply       . (Typeable reply, Typeable (Api api ( 'Synchronous reply)))-     => Api api ( 'Synchronous reply)-     -> (reply -> Eff eff ())+     => RequestOrigin (Api api ( 'Synchronous reply))+     -> Api api ( 'Synchronous reply)      -> Eff eff CallbackResult      )   -> MessageCallback api eff@@ -370,12 +366,12 @@     )   )   (\(Call callRef fromPid req :: Request api) ->-    h req (sendReply fromPid callRef)+    h (RequestOrigin fromPid callRef) req   )- where-  sendReply :: (Typeable reply) => ProcessId -> Int -> reply -> Eff eff ()-  sendReply fromPid callRef reply =-    sendMessage px fromPid (Response (Proxy @api) callRef $! reply)++type family ResponseType request where+  ResponseType (Api a ('Synchronous r)) = r+  -- | A smart constructor for 'MessageCallback's --