{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
module Control.Eff.Concurrent.Examples where
import GHC.Stack
import Control.Eff
import Control.Eff.Lift
import Control.Monad
import Data.Dynamic
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
data TestApi
deriving Typeable
data instance Api TestApi x where
SayHello :: String -> Api TestApi ('Synchronous Bool)
Shout :: String -> Api TestApi 'Asynchronous
SetTrapExit :: Bool -> Api TestApi ('Synchronous ())
Terminate :: Api TestApi ('Synchronous ())
deriving (Typeable)
data MyException = MyException
deriving Show
instance Exc.Exception MyException
deriving instance Show (Api TestApi x)
runExample :: IO (Either Exc.SomeException ())
runExample =
Exc.try
(runLoggingT
(logChannelBracket (Just "hello") (Just "KTHXBY") (runMainProcess example))
(print :: String -> IO ()))
example
:: ( HasCallStack
, Member (Logs String) r
, HasDispatcherIO r
, Member MessagePassing r
, Member Process r
, MonadLog String (Eff r)
, SetMember Lift (Lift IO) r)
=> Eff r ()
example = do
me <- self
trapExit True
logMessage ("I am " ++ show me)
server <- asServer @TestApi <$> spawn testServerLoop
logMessage ("Started server " ++ show server)
let go = do
x <- lift getLine
res <- ignoreProcessError (call server (SayHello x))
logMessage ("Result: " ++ show res)
case x of
('k':_) -> do
call server Terminate
logMessage ("terminated: " ++ show server)
go
('t':'0':_) -> do
call server (SetTrapExit False)
go
('t':'1':_) -> do
call server (SetTrapExit True)
go
('q':_) -> logMessage "Done."
_ ->
go
go
testServerLoop
:: forall r. (HasCallStack, Member MessagePassing r, Member Process r
, MonadLog String (Eff r)
, SetMember Lift (Lift IO) r)
=> Eff r ()
testServerLoop =
-- trapExit True
-- >>
(forever $ serve_ $ ApiHandler handleCast handleCall handleTerminate)
where
handleCast :: Api TestApi 'Asynchronous -> Eff r ()
handleCast (Shout x) = do
me <- self
logMessage (show me ++ " Shouting: " ++ x)
handleCall :: Api TestApi ('Synchronous x) -> (x -> Eff r Bool) -> Eff r ()
handleCall (SayHello "e1") _reply = do
me <- self
logMessage (show me ++ " raising an error")
raiseError "No body loves me... :,("
handleCall (SayHello "e2") _reply = do
me <- self
logMessage (show me ++ " throwing a MyException ")
lift (Exc.throw MyException)
handleCall (SayHello "self") reply = do
me <- self
logMessage (show me ++ " casting to self")
cast_ (asServer @TestApi me) (Shout "from me")
void (reply False)
handleCall (SayHello "die") reply = do
me <- self
logMessage (show me ++ " throwing and catching ")
catchProcessError
(\ er -> logMessage ("WOW: " ++ show er ++ " - No. This is wrong!"))
(raiseError "No body loves me... :,(")
void (reply True)
handleCall (SayHello x) reply = do
me <- self
logMessage (show me ++ " Got Hello: " ++ x)
void (reply (length x > 3))
handleCall (SetTrapExit x) reply = do
me <- self
logMessage (show me ++ " setting trap exit to " ++ show x)
trapExit x
void (reply ())
handleCall Terminate reply = do
me <- self
logMessage (show me ++ " exitting")
void (reply ())
raiseError "DONE"
handleTerminate msg = do
me <- self
logMessage (show me ++ " is exiting: " ++ msg)
raiseError msg