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 +5/−0
- extensible-effects-concurrent.cabal +5/−2
- src/Control/Eff/Concurrent/Api.hs +66/−0
- src/Control/Eff/Concurrent/Api/Client.hs +121/−0
- src/Control/Eff/Concurrent/Api/Internal.hs +45/−0
- src/Control/Eff/Concurrent/Api/Server.hs +99/−0
- src/Control/Eff/Concurrent/Examples.hs +12/−11
- src/Control/Eff/Concurrent/Examples2.hs +10/−8
- src/Control/Eff/Concurrent/GenServer.hs +0/−204
- src/Control/Eff/Concurrent/Observer.hs +7/−5
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