packages feed

extensible-effects-concurrent 0.1.2.2 → 0.1.3.0

raw patch · 10 files changed

+370/−230 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

- Control.Eff.Concurrent.GenServer: ApiHandler :: (Typeable p, Typeable (Api p 'Asynchronous), HasCallStack) => Api p 'Asynchronous -> Eff r e -> (forall x. (Typeable p, Typeable (Api p ( 'Synchronous x)), Typeable x, HasCallStack) => Api p ( 'Synchronous x) -> (x -> Eff r Bool) -> Eff r e) -> (Typeable p, HasCallStack) => String -> Eff r () -> ApiHandler p r e
- Control.Eff.Concurrent.GenServer: Asynchronous :: Synchronicity
- Control.Eff.Concurrent.GenServer: Server :: ProcessId -> Server genServerModule
- Control.Eff.Concurrent.GenServer: Synchronous :: Type -> Synchronicity
- Control.Eff.Concurrent.GenServer: [_fromServer] :: Server genServerModule -> ProcessId
- Control.Eff.Concurrent.GenServer: asServer :: forall genServerModule. ProcessId -> Server genServerModule
- Control.Eff.Concurrent.GenServer: call :: forall result genServerModule r. (Member MessagePassing r, Member Process r, Typeable genServerModule, Typeable (Api genServerModule ( 'Synchronous result)), Typeable result, HasCallStack) => Server genServerModule -> Api genServerModule ( 'Synchronous result) -> Eff r (Message result)
- Control.Eff.Concurrent.GenServer: cast :: forall r o. (HasCallStack, Member MessagePassing r, Typeable o, Typeable (Api o 'Asynchronous)) => Server o -> Api o 'Asynchronous -> Eff r Bool
- Control.Eff.Concurrent.GenServer: cast_ :: forall r o. (HasCallStack, Member MessagePassing r, Typeable o, Typeable (Api o 'Asynchronous)) => Server o -> Api o 'Asynchronous -> Eff r ()
- Control.Eff.Concurrent.GenServer: data ApiHandler p r e
- Control.Eff.Concurrent.GenServer: data Synchronicity
- Control.Eff.Concurrent.GenServer: fromServer :: forall genServerModule_agQU genServerModule_ah0L. Iso (Server genServerModule_agQU) (Server genServerModule_ah0L) ProcessId ProcessId
- Control.Eff.Concurrent.GenServer: instance Data.Typeable.Internal.Typeable genServerModule => GHC.Show.Show (Control.Eff.Concurrent.GenServer.Server genServerModule)
- Control.Eff.Concurrent.GenServer: instance GHC.Classes.Eq (Control.Eff.Concurrent.GenServer.Server genServerModule)
- Control.Eff.Concurrent.GenServer: instance GHC.Classes.Ord (Control.Eff.Concurrent.GenServer.Server genServerModule)
- Control.Eff.Concurrent.GenServer: instance GHC.Read.Read (Control.Eff.Concurrent.GenServer.Server genServerModule)
- Control.Eff.Concurrent.GenServer: newtype Server genServerModule
- Control.Eff.Concurrent.GenServer: proxyAsServer :: proxy genServerModule -> ProcessId -> Server genServerModule
- Control.Eff.Concurrent.GenServer: serve :: forall r p e. (Typeable p, Member MessagePassing r, Member Process r, HasCallStack) => ApiHandler p r e -> Eff r (Message e)
- Control.Eff.Concurrent.GenServer: serve_ :: forall r p. (Typeable p, Member MessagePassing r, Member Process r, HasCallStack) => ApiHandler p r () -> Eff r ()
- Control.Eff.Concurrent.GenServer: unhandledCallError :: (Show (Api p ( 'Synchronous x)), Typeable p, Typeable (Api p ( 'Synchronous x)), Typeable x, HasCallStack, Member Process r) => Api p ( 'Synchronous x) -> (x -> Eff r Bool) -> Eff r e
- Control.Eff.Concurrent.GenServer: unhandledCastError :: (Show (Api p 'Asynchronous), Typeable p, Typeable (Api p 'Asynchronous), HasCallStack, Member Process r) => Api p 'Asynchronous -> Eff r e
- Control.Eff.Concurrent.Observer: instance GHC.Show.Show (Control.Eff.Concurrent.Observer.Observation o) => GHC.Show.Show (Control.Eff.Concurrent.GenServer.Api (Control.Eff.Concurrent.Observer.CallbackObserver o) r)
+ Control.Eff.Concurrent.Api: Asynchronous :: Synchronicity
+ Control.Eff.Concurrent.Api: Server :: ProcessId -> Server api
+ Control.Eff.Concurrent.Api: Synchronous :: Type -> Synchronicity
+ Control.Eff.Concurrent.Api: [_fromServer] :: Server api -> ProcessId
+ Control.Eff.Concurrent.Api: asServer :: forall api. ProcessId -> Server api
+ Control.Eff.Concurrent.Api: data Synchronicity
+ Control.Eff.Concurrent.Api: fromServer :: forall api_agR7 api_ah0Y. Iso (Server api_agR7) (Server api_ah0Y) ProcessId ProcessId
+ Control.Eff.Concurrent.Api: instance Data.Typeable.Internal.Typeable api => GHC.Show.Show (Control.Eff.Concurrent.Api.Server api)
+ Control.Eff.Concurrent.Api: instance GHC.Classes.Eq (Control.Eff.Concurrent.Api.Server api)
+ Control.Eff.Concurrent.Api: instance GHC.Classes.Ord (Control.Eff.Concurrent.Api.Server api)
+ Control.Eff.Concurrent.Api: instance GHC.Read.Read (Control.Eff.Concurrent.Api.Server api)
+ Control.Eff.Concurrent.Api: newtype Server api
+ Control.Eff.Concurrent.Api: proxyAsServer :: proxy api -> ProcessId -> Server api
+ Control.Eff.Concurrent.Api.Client: call :: forall result api r. (Member MessagePassing r, Member Process r, Typeable api, Typeable (Api api ( 'Synchronous result)), Typeable result, HasCallStack) => Server api -> Api api ( 'Synchronous result) -> Eff r (Message result)
+ Control.Eff.Concurrent.Api.Client: callRegistered :: (Typeable reply, ServesApi o r) => Api o ( 'Synchronous reply) -> Eff r (Message reply)
+ Control.Eff.Concurrent.Api.Client: callRegisteredA :: (Alternative f, Typeable f, Typeable reply, ServesApi o r) => Api o ( 'Synchronous (f reply)) -> Eff r (f reply)
+ Control.Eff.Concurrent.Api.Client: cast :: forall r o. (HasCallStack, Member MessagePassing r, Typeable o, Typeable (Api o 'Asynchronous)) => Server o -> Api o 'Asynchronous -> Eff r ()
+ Control.Eff.Concurrent.Api.Client: castChecked :: forall r o. (HasCallStack, Member MessagePassing r, Typeable o, Typeable (Api o 'Asynchronous)) => Server o -> Api o 'Asynchronous -> Eff r Bool
+ Control.Eff.Concurrent.Api.Client: castRegistered :: (Typeable o, ServesApi o r) => Api o 'Asynchronous -> Eff r ()
+ Control.Eff.Concurrent.Api.Client: registerServer :: Server o -> Eff (Reader (Server o) : r) a -> Eff r a
+ Control.Eff.Concurrent.Api.Client: type ServesApi o r = (Typeable o, Member MessagePassing r, Member Process r, Member (Reader (Server o)) r)
+ Control.Eff.Concurrent.Api.Server: [ApiHandler] :: {_handleCast :: (Typeable p, Typeable (Api p 'Asynchronous), HasCallStack) => Api p 'Asynchronous -> Eff r e, _handleCall :: forall x. (Typeable p, Typeable (Api p ( 'Synchronous x)), Typeable x, HasCallStack) => Api p ( 'Synchronous x) -> (x -> Eff r Bool) -> Eff r e, _handleTerminate :: (Typeable p, HasCallStack) => String -> Eff r ()} -> ApiHandler p r e
+ Control.Eff.Concurrent.Api.Server: data ApiHandler p r e
+ Control.Eff.Concurrent.Api.Server: serve :: forall r p e. (Typeable p, Member MessagePassing r, Member Process r, HasCallStack) => ApiHandler p r e -> Eff r (Message e)
+ Control.Eff.Concurrent.Api.Server: serve_ :: forall r p. (Typeable p, Member MessagePassing r, Member Process r, HasCallStack) => ApiHandler p r () -> Eff r ()
+ Control.Eff.Concurrent.Api.Server: unhandledCallError :: (Show (Api p ( 'Synchronous x)), Typeable p, Typeable (Api p ( 'Synchronous x)), Typeable x, HasCallStack, Member Process r) => Api p ( 'Synchronous x) -> (x -> Eff r Bool) -> Eff r e
+ Control.Eff.Concurrent.Api.Server: unhandledCastError :: (Show (Api p 'Asynchronous), Typeable p, Typeable (Api p 'Asynchronous), HasCallStack, Member Process r) => Api p 'Asynchronous -> Eff r e
+ Control.Eff.Concurrent.Observer: instance GHC.Show.Show (Control.Eff.Concurrent.Observer.Observation o) => GHC.Show.Show (Control.Eff.Concurrent.Api.Api (Control.Eff.Concurrent.Observer.CallbackObserver o) r)

Files

ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for extensible-effects-concurrent +## 0.1.3.0+	* Rename and split `GenServer` to `Api`, `Api.Client`, `Api.Server`+	* Add `registerServer`, `callRegistered` and `castRegistered`+	* Remove the variant of `cast` that returns a boolean+ ## 0.1.2.2 	* Try to fix version bounds for hackage 
extensible-effects-concurrent.cabal view
@@ -1,5 +1,5 @@ name:           extensible-effects-concurrent-version:        0.1.2.2+version:        0.1.3.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@@ -45,11 +45,14 @@       Control.Eff.ExceptionExtra,       Control.Eff.Interactive,       Control.Eff.Log,+      Control.Eff.Concurrent.Api,+      Control.Eff.Concurrent.Api.Client,+      Control.Eff.Concurrent.Api.Server,       Control.Eff.Concurrent.Dispatcher,-      Control.Eff.Concurrent.GenServer,       Control.Eff.Concurrent.MessagePassing,       Control.Eff.Concurrent.Observer   other-modules:+      Control.Eff.Concurrent.Api.Internal,       Paths_extensible_effects_concurrent,       Control.Eff.Concurrent.Examples,       Control.Eff.Concurrent.Examples2
+ src/Control/Eff/Concurrent/Api.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++-- | Type safe /server/ API processes++module Control.Eff.Concurrent.Api+  ( Api+  , Synchronicity(..)+  , Server(..)+  , fromServer+  , proxyAsServer+  , asServer+  )+where++import           GHC.Stack+import           Data.Kind+import           Control.Eff+import           Control.Lens+import           Control.Monad+import           Data.Typeable (Typeable, typeRep)+import           Data.Proxy+import           Control.Eff.Reader.Lazy+import           Control.Eff.Concurrent.MessagePassing++-- | This data family defines an API implemented by a server.+-- The first parameter is the API /index/ and the second parameter+-- (the @* -> *@)+data family Api (api :: Type) (reply :: Synchronicity)++data Synchronicity = Synchronous Type | Asynchronous+    deriving (Typeable)++newtype Server api = Server { _fromServer :: ProcessId }+  deriving (Eq,Ord,Typeable)++instance Read (Server api) where+  readsPrec _ ('[':'#':rest1) =+    case reads (dropWhile (/= '#') rest1) of+      [(c, ']':rest2)] -> [(Server c, rest2)]+      _ -> []+  readsPrec _ _ = []++instance Typeable api => Show (Server api) where+  show s@(Server c) =+    "[#" ++ show (typeRep s) ++ "#" ++ show c ++ "]"++makeLenses ''Server++proxyAsServer :: proxy api -> ProcessId -> Server api+proxyAsServer = const Server++asServer :: forall api . ProcessId -> Server api+asServer = Server
+ src/Control/Eff/Concurrent/Api/Client.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++-- | Type safe /server/ API processes++module Control.Eff.Concurrent.Api.Client+  ( cast+  , castChecked+  , call+  , castRegistered+  , callRegistered+  , callRegisteredA+  , ServesApi+  , registerServer+  )+where++import           Control.Applicative+import           Control.Eff+import           Control.Eff.Reader.Lazy+import           Control.Eff.Concurrent.Api+import           Control.Eff.Concurrent.Api.Internal+import           Control.Eff.Concurrent.MessagePassing+import           Control.Monad+import           Data.Proxy+import           Data.Typeable (Typeable, typeRep)+import           GHC.Stack++castChecked+  :: forall r o+   . ( HasCallStack+     , Member MessagePassing r+     , Typeable o+     , Typeable (Api o 'Asynchronous)+     )+  => Server o+  -> Api o 'Asynchronous+  -> Eff r Bool+castChecked (Server pid) callMsg = sendMessage pid (Cast callMsg)++cast+  :: forall r o+   . ( HasCallStack+     , Member MessagePassing r+     , Typeable o+     , Typeable (Api o 'Asynchronous)+     )+  => Server o+  -> Api o 'Asynchronous+  -> Eff r ()+cast = ((.) . (.)) void castChecked++call+  :: forall result api r+   . ( Member MessagePassing r+     , Member Process r+     , Typeable api+     , Typeable (Api api ( 'Synchronous result))+     , Typeable result+     , HasCallStack+     )+  => Server api+  -> Api api ( 'Synchronous result)+  -> Eff r (Message result)+call (Server pidInt) req = do+  fromPid <- self+  let requestMessage = Call fromPid req+  wasSent <- sendMessage pidInt requestMessage+  if wasSent+    then+      let extractResult :: Response api result -> result+          extractResult (Response _pxResult result) = result+      in  do+            mResp <- receiveMessage (Proxy @(Response api result))+            return (extractResult <$> mResp)+    else raiseError+      ("Could not send request message " ++ show (typeRep requestMessage))+++type ServesApi o r =+  ( Typeable o+  , Member MessagePassing r+  , Member Process r+  , Member (Reader (Server o)) r+  )++registerServer :: Server o -> Eff ( Reader (Server o) ': r ) a -> Eff r a+registerServer = flip runReader++callRegistered :: (Typeable reply, ServesApi o r)+      => Api o ('Synchronous reply) -> Eff r (Message reply)+callRegistered method = do+  serverPid <- ask+  call serverPid method++callRegisteredA+  :: (Alternative f, Typeable f, Typeable reply, ServesApi o r)+  => Api o ('Synchronous (f reply))+  -> Eff r (f reply)+callRegisteredA method = do+  m <- callRegistered method+  case m of+    ProcessControlMessage _pm -> return empty+    Message r                 -> return r++castRegistered :: (Typeable o, ServesApi o r) => Api o 'Asynchronous -> Eff r ()+castRegistered method = do+  serverPid <- ask+  cast serverPid method
+ src/Control/Eff/Concurrent/Api/Internal.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++-- | Type safe /server/ API processes++module Control.Eff.Concurrent.Api.Internal+  ( Request (..)+  , Response (..)+  )+where++import           GHC.Stack+import           Data.Kind+import           Control.Eff+import           Control.Lens+import           Control.Monad+import           Data.Typeable (Typeable, typeRep)+import           Data.Proxy++import           Control.Eff.Concurrent.Api+import           Control.Eff.Concurrent.MessagePassing+++data Request api where+  Call :: forall api apiCallReplyType . (Typeable api, Typeable apiCallReplyType, Typeable (Api api ('Synchronous apiCallReplyType)))+         => 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 -> apiCallReplyType -> Response api apiCallReplyType+  deriving Typeable
+ src/Control/Eff/Concurrent/Api/Server.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE GADTs #-}++-- | Type safe /server/ API processes++module Control.Eff.Concurrent.Api.Server+  ( ApiHandler (..), serve, serve_, unhandledCallError, unhandledCastError )+where++import           Control.Eff+import           Control.Eff.Concurrent.Api+import           Control.Eff.Concurrent.Api.Internal+import           Control.Eff.Concurrent.MessagePassing+import           Control.Lens+import           Control.Monad+import           Data.Kind+import           Data.Proxy+import           Data.Typeable (Typeable, typeRep)+import           GHC.Stack++data ApiHandler p r e where+  ApiHandler ::+     { _handleCast+         :: (Typeable p, Typeable (Api p 'Asynchronous), HasCallStack)+         => Api p 'Asynchronous -> Eff r e+     , _handleCall+         :: forall x . (Typeable p, Typeable (Api p ('Synchronous x)), Typeable x, HasCallStack)+         => Api p ('Synchronous x) -> (x -> Eff r Bool) -> Eff r e+     , _handleTerminate+         :: (Typeable p, HasCallStack)+         => String -> Eff r ()+     } -> ApiHandler p r e++serve_+  :: forall r p+   . (Typeable p, Member MessagePassing r, Member Process r, HasCallStack)+  => ApiHandler p r ()+  -> Eff r ()+serve_ = void . serve++serve+  :: forall r p e+   . (Typeable p, Member MessagePassing r, Member Process r, HasCallStack)+  => ApiHandler p r e+  -> Eff r (Message e)+serve (ApiHandler handleCast handleCall handleTerminate) = do+  mReq <- receiveMessage (Proxy @(Request p))+  mapM receiveCallReq mReq >>= catchProcessControlMessage+ where+  catchProcessControlMessage :: Message e -> Eff r (Message e)+  catchProcessControlMessage s@(ProcessControlMessage msg) =+    handleTerminate msg >> return s+  catchProcessControlMessage s = return s++  receiveCallReq :: Request p -> Eff r e+  receiveCallReq (Cast request        ) = handleCast request+  receiveCallReq (Call fromPid request) = handleCall request+                                                     (sendReply request)+   where+    sendReply :: Typeable x => Api p ( 'Synchronous x) -> x -> Eff r Bool+    sendReply _ reply = sendMessage fromPid (Response (Proxy :: Proxy p) reply)++unhandledCallError+  :: ( Show (Api p ( 'Synchronous x))+     , Typeable p+     , Typeable (Api p ( 'Synchronous x))+     , Typeable x+     , HasCallStack+     , Member Process r+     )+  => Api p ( 'Synchronous x)+  -> (x -> Eff r Bool)+  -> Eff r e+unhandledCallError api _ = raiseError+  ("Unhandled call: (" ++ show api ++ " :: " ++ show (typeRep api) ++ ")")++unhandledCastError+  :: ( Show (Api p 'Asynchronous)+     , Typeable p+     , Typeable (Api p 'Asynchronous)+     , HasCallStack+     , Member Process r+     )+  => Api p 'Asynchronous+  -> Eff r e+unhandledCastError api = raiseError+  ("Unhandled cast: (" ++ show api ++ " :: " ++ show (typeRep api) ++ ")")
src/Control/Eff/Concurrent/Examples.hs view
@@ -21,8 +21,10 @@ import Control.Eff.Lift import Control.Monad import Data.Dynamic+import Control.Eff.Concurrent.Api+import Control.Eff.Concurrent.Api.Client+import Control.Eff.Concurrent.Api.Server import Control.Eff.Concurrent.MessagePassing-import Control.Eff.Concurrent.GenServer import Control.Eff.Concurrent.Dispatcher import Control.Eff.Log import qualified Control.Exception as Exc@@ -47,7 +49,6 @@ main :: IO () main = defaultMain example - example   :: ( HasCallStack     , Member (Logs String) r@@ -67,24 +68,24 @@         x <- lift getLine         case x of           ('k':_) -> do-            call server Terminate+            callRegistered Terminate             go           ('c':_) -> do-            cast_ server (Shout x)+            castRegistered (Shout x)             go           ('t':'0':_) -> do-            call server (SetTrapExit False)+            callRegistered (SetTrapExit False)             go           ('t':'1':_) -> do-            call server (SetTrapExit True)+            callRegistered (SetTrapExit True)             go           ('q':_) ->-            logMessage "Done."+            logMsg "Done."           _ ->-            do res <- ignoreProcessError (call server (SayHello x))-               logMessage ("Result: " ++ show res)+            do res <- ignoreProcessError (callRegistered (SayHello x))+               logMsg ("Result: " ++ show res)                go-  go+  registerServer server go  testServerLoop   :: forall r. (HasCallStack, Member MessagePassing r, Member Process r@@ -112,7 +113,7 @@     handleCall (SayHello "self") reply = do       me <- self       logMessage (show me ++ " casting to self")-      cast_ (asServer @TestApi me) (Shout "from me")+      cast (asServer @TestApi me) (Shout "from me")       void (reply False)     handleCall (SayHello "die") reply = do       me <- self
src/Control/Eff/Concurrent/Examples2.hs view
@@ -20,7 +20,9 @@ import Data.Dynamic import Control.Eff import Control.Eff.Concurrent.Dispatcher-import Control.Eff.Concurrent.GenServer+import Control.Eff.Concurrent.Api+import Control.Eff.Concurrent.Api.Server+import Control.Eff.Concurrent.Api.Client import Control.Eff.Concurrent.MessagePassing import Control.Eff.Concurrent.Observer import Control.Eff.Log@@ -90,25 +92,25 @@                   logMsg (show sv ++ " " ++ show r)   server1 <- asServer @Counter <$> spawn counterServerLoop   server2 <- asServer @Counter <$> spawn counterServerLoop-  cast_ server1 Inc+  cast server1 Inc   cnt server1   cnt server2   co1 <- logCounterObservations   co2 <- logCounterObservations   registerObserver co1 server1   registerObserver co2 server2-  cast_ server1 Inc+  cast server1 Inc   cnt server1-  cast_ server2 Inc+  cast server2 Inc   cnt server2   registerObserver co2 server1   registerObserver co1 server2-  cast_ server1 Inc+  cast server1 Inc   cnt server1-  cast_ server2 Inc+  cast server2 Inc   cnt server2   forgetObserver co2 server1-  cast_ server1 Inc+  cast server1 Inc   cnt server1-  cast_ server2 Inc+  cast server2 Inc   cnt server2
− src/Control/Eff/Concurrent/GenServer.hs
@@ -1,204 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE GADTs #-}---- | Type safe /server/ API processes--module Control.Eff.Concurrent.GenServer-  ( Api-  , Synchronicity(..)-  , ApiHandler(ApiHandler)-  , Server(..)-  , fromServer-  , proxyAsServer-  , asServer-  , cast-  , cast_-  , call-  , serve-  , serve_-  , unhandledCallError-  , unhandledCastError-  )-where--import           GHC.Stack-import           Data.Kind-import           Control.Eff-import           Control.Lens-import           Control.Monad-import           Data.Typeable (Typeable, typeRep)-import           Data.Proxy--import           Control.Eff.Concurrent.MessagePassing---- | This data family defines an API implemented by a server.--- The first parameter is the API /index/ and the second parameter--- (the @* -> *@)-data family Api (genServerModule :: Type) (replyType :: Synchronicity)--data Synchronicity =-  Synchronous Type | Asynchronous-    deriving (Typeable)--newtype Server genServerModule = Server { _fromServer :: ProcessId }-  deriving (Eq,Ord,Typeable)--instance Read (Server genServerModule) where-  readsPrec _ ('[':'#':rest1) =-    case reads (dropWhile (/= '#') rest1) of-      [(c, ']':rest2)] -> [(Server c, rest2)]-      _ -> []-  readsPrec _ _ = []--instance Typeable genServerModule => Show (Server genServerModule) where-  show s@(Server c) =-    "[#" ++ show (typeRep s) ++ "#" ++ show c ++ "]"--makeLenses ''Server--proxyAsServer :: proxy genServerModule -> ProcessId -> Server genServerModule-proxyAsServer = const Server--asServer :: forall genServerModule . ProcessId -> Server genServerModule-asServer = Server--data Request genServerModule where-  Call :: forall genServerModule apiCallReplyType . (Typeable genServerModule, Typeable apiCallReplyType, Typeable (Api genServerModule ('Synchronous apiCallReplyType)))-         => ProcessId -> Api genServerModule ('Synchronous apiCallReplyType) -> Request genServerModule-  Cast :: forall genServerModule . (Typeable genServerModule, Typeable (Api genServerModule 'Asynchronous))-         => Api genServerModule 'Asynchronous -> Request genServerModule-  deriving Typeable--data Response genServerModule apiCallReplyType where-  Response :: (Typeable genServerModule, Typeable apiCallReplyType) => Proxy genServerModule -> apiCallReplyType -> Response genServerModule apiCallReplyType-  deriving Typeable--cast-  :: forall r o-   . ( HasCallStack-     , Member MessagePassing r-     , Typeable o-     , Typeable (Api o 'Asynchronous)-     )-  => Server o-  -> Api o 'Asynchronous-  -> Eff r Bool-cast (Server pid) callMsg = sendMessage pid (Cast callMsg)--cast_-  :: forall r o-   . ( HasCallStack-     , Member MessagePassing r-     , Typeable o-     , Typeable (Api o 'Asynchronous)-     )-  => Server o-  -> Api o 'Asynchronous-  -> Eff r ()-cast_ = ((.) . (.)) void cast--call-  :: forall result genServerModule r-   . ( Member MessagePassing r-     , Member Process r-     , Typeable genServerModule-     , Typeable (Api genServerModule ( 'Synchronous result))-     , Typeable result-     , HasCallStack-     )-  => Server genServerModule-  -> Api genServerModule ( 'Synchronous result)-  -> Eff r (Message result)-call (Server pidInt) req = do-  fromPid <- self-  let requestMessage = Call fromPid req-  wasSent <- sendMessage pidInt requestMessage-  if wasSent-    then-      let extractResult :: Response genServerModule result -> result-          extractResult (Response _pxResult result) = result-      in  do-            mResp <- receiveMessage (Proxy @(Response genServerModule result))-            return (extractResult <$> mResp)-    else raiseError-      ("Could not send request message " ++ show (typeRep requestMessage))--data ApiHandler p r e where-  ApiHandler ::-     { _handleCast-         :: (Typeable p, Typeable (Api p 'Asynchronous), HasCallStack)-         => Api p 'Asynchronous -> Eff r e-     , _handleCall-         :: forall x . (Typeable p, Typeable (Api p ('Synchronous x)), Typeable x, HasCallStack)-         => Api p ('Synchronous x) -> (x -> Eff r Bool) -> Eff r e-     , _handleTerminate-         :: (Typeable p, HasCallStack)-         => String -> Eff r ()-     } -> ApiHandler p r e--serve_-  :: forall r p-   . (Typeable p, Member MessagePassing r, Member Process r, HasCallStack)-  => ApiHandler p r ()-  -> Eff r ()-serve_ = void . serve--serve-  :: forall r p e-   . (Typeable p, Member MessagePassing r, Member Process r, HasCallStack)-  => ApiHandler p r e-  -> Eff r (Message e)-serve (ApiHandler handleCast handleCall handleTerminate) = do-  mReq <- receiveMessage (Proxy @(Request p))-  mapM receiveCallReq mReq >>= catchProcessControlMessage- where-  catchProcessControlMessage :: Message e -> Eff r (Message e)-  catchProcessControlMessage s@(ProcessControlMessage msg) =-    handleTerminate msg >> return s-  catchProcessControlMessage s = return s--  receiveCallReq :: Request p -> Eff r e-  receiveCallReq (Cast request        ) = handleCast request-  receiveCallReq (Call fromPid request) = handleCall request-                                                     (sendReply request)-   where-    sendReply :: Typeable x => Api p ( 'Synchronous x) -> x -> Eff r Bool-    sendReply _ reply = sendMessage fromPid (Response (Proxy :: Proxy p) reply)--unhandledCallError-  :: ( Show (Api p ( 'Synchronous x))-     , Typeable p-     , Typeable (Api p ( 'Synchronous x))-     , Typeable x-     , HasCallStack-     , Member Process r-     )-  => Api p ( 'Synchronous x)-  -> (x -> Eff r Bool)-  -> Eff r e-unhandledCallError api _ = raiseError-  ("Unhandled call: (" ++ show api ++ " :: " ++ show (typeRep api) ++ ")")--unhandledCastError-  :: ( Show (Api p 'Asynchronous)-     , Typeable p-     , Typeable (Api p 'Asynchronous)-     , HasCallStack-     , Member Process r-     )-  => Api p 'Asynchronous-  -> Eff r e-unhandledCastError api = raiseError-  ("Unhandled cast: (" ++ show api ++ " :: " ++ show (typeRep api) ++ ")")
src/Control/Eff/Concurrent/Observer.hs view
@@ -3,7 +3,7 @@ -- This module supports the implementation of observers and observables. One -- more concrete perspective might be to understand observers as event listeners -- and observables as event sources. The tools in this module are tailored--- towards 'Control.Eff.Concurrent.GenServer.Api' endpoints+-- towards 'Control.Eff.Concurrent.Api.Api' endpoints {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ConstraintKinds #-}@@ -44,7 +44,9 @@ import qualified Data.Set as Set import Control.Eff import Control.Eff.Concurrent.MessagePassing-import Control.Eff.Concurrent.GenServer+import Control.Eff.Concurrent.Api+import Control.Eff.Concurrent.Api.Client+import Control.Eff.Concurrent.Api.Server import Control.Eff.Concurrent.Dispatcher import Control.Eff.Log import Control.Eff.State.Lazy@@ -80,7 +82,7 @@                  )                => Server p -> Server o -> Observation o -> Eff r () notifyObserver observer observed observation =-  cast_ observer (observationMessage observed observation)+  cast observer (observationMessage observed observation)  -- | Send the 'registerObserverMessage' registerObserver :: ( Member Process r@@ -91,7 +93,7 @@                  )                => Server p -> Server o -> Eff r () registerObserver observer observed =-  cast_ observed (registerObserverMessage (SomeObserver observer))+  cast observed (registerObserverMessage (SomeObserver observer))  -- | Send the 'forgetObserverMessage' forgetObserver :: ( Member Process r@@ -100,7 +102,7 @@                 , Observer p o)               => Server p -> Server o -> Eff r () forgetObserver observer observed =-  cast_ observed (forgetObserverMessage (SomeObserver observer))+  cast observed (forgetObserverMessage (SomeObserver observer))  -- ** Generalized observation