-- | A complete example for the library
module Main where
import GHC.Stack
import Control.Eff
import Control.Eff.Lift
import Control.Monad
import Data.Dynamic
import Control.Eff.Concurrent
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
Terminate :: Api TestApi ('Synchronous ())
TerminateError :: String -> Api TestApi ('Synchronous ())
deriving (Typeable)
data MyException = MyException
deriving Show
instance Exc.Exception MyException
deriving instance Show (Api TestApi x)
main :: IO ()
main = defaultMain (example forkIoScheduler)
mainProcessSpawnsAChildAndReturns
:: (HasCallStack, SetMember Process (Process q) r)
=> SchedulerProxy q
-> Eff r ()
mainProcessSpawnsAChildAndReturns px = void (spawn (void (receiveMessage px)))
example
:: ( HasCallStack
, SetMember Process (Process q) r
, HasLoggingIO r
, HasLoggingIO q
)
=> SchedulerProxy q
-> Eff r ()
example px = do
me <- self px
logInfo ("I am " ++ show me)
server <- testServerLoop px
logInfo ("Started server " ++ show server)
let go = do
lift (putStr "Enter something: ")
x <- lift getLine
case x of
('K' : rest) -> do
callRegistered px (TerminateError rest)
go
('S' : _) -> do
callRegistered px Terminate
go
('C' : _) -> do
castRegistered px (Shout x)
go
('R' : rest) -> do
replicateM_ (read rest) (castRegistered px (Shout x))
go
('q' : _) -> logInfo "Done."
_ -> do
res <- ignoreProcessError px (callRegistered px (SayHello x))
logInfo ("Result: " ++ show res)
go
registerServer server go
testServerLoop
:: forall r q
. (HasCallStack, SetMember Process (Process q) r, HasLoggingIO q)
=> SchedulerProxy q
-> Eff r (Server TestApi)
testServerLoop px = spawnServer px
$ apiHandler handleCastTest handleCallTest handleTerminateTest
where
handleCastTest
:: Api TestApi 'Asynchronous -> Eff (Process q ': q) ApiServerCmd
handleCastTest (Shout x) = do
me <- self px
logInfo (show me ++ " Shouting: " ++ x)
return HandleNextRequest
handleCallTest
:: Api TestApi ( 'Synchronous x)
-> (x -> Eff (Process q ': q) ())
-> Eff (Process q ': q) ApiServerCmd
handleCallTest (SayHello "e1") _reply = do
me <- self px
logInfo (show me ++ " raising an error")
raiseError px "No body loves me... :,("
handleCallTest (SayHello "e2") _reply = do
me <- self px
logInfo (show me ++ " throwing a MyException ")
lift (Exc.throw MyException)
handleCallTest (SayHello "self") reply = do
me <- self px
logInfo (show me ++ " casting to self")
cast px (asServer @TestApi me) (Shout "from me")
void (reply False)
return HandleNextRequest
handleCallTest (SayHello "stop") reply = do
me <- self px
logInfo (show me ++ " stopping me")
void (reply False)
return (StopApiServer Nothing)
handleCallTest (SayHello "xxx") reply = do
me <- self px
logInfo (show me ++ " stopping me with xxx")
void (reply False)
return (StopApiServer (Just "xxx"))
handleCallTest (SayHello "die") reply = do
me <- self px
logInfo (show me ++ " throwing and catching ")
catchRaisedError
px
(\er -> logInfo ("WOW: " ++ show er ++ " - No. This is wrong!"))
(raiseError px "No body loves me... :,(")
void (reply True)
return HandleNextRequest
handleCallTest (SayHello x) reply = do
me <- self px
logInfo (show me ++ " Got Hello: " ++ x)
void (reply (length x > 3))
return HandleNextRequest
handleCallTest Terminate reply = do
me <- self px
logInfo (show me ++ " exiting")
void (reply ())
exitNormally px
handleCallTest (TerminateError msg) reply = do
me <- self px
logInfo (show me ++ " exiting with error: " ++ msg)
void (reply ())
exitWithError px msg
handleTerminateTest msg = do
me <- self px
logInfo (show me ++ " is exiting: " ++ show msg)
maybe (exitNormally px) (exitWithError px) msg