extensible-effects-concurrent-0.16.0: examples/example-1/Main.hs

-- | 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

mainProcessSpawnsAChildAndReturns :: HasCallStack => Eff (InterruptableProcess q) ()
mainProcessSpawnsAChildAndReturns = void (spawn (void receiveAnyMessage))

example:: ( HasCallStack, HasLogging IO q) => Eff (InterruptableProcess q) ()
example = do
  me <- self
  logInfo ("I am " ++ show me)
  server <- testServerLoop
  logInfo ("Started server " ++ show server)
  let go = do
        lift (putStr "Enter something: ")
        x <- lift getLine
        case x of
          ('K' : rest) -> do
            callRegistered (TerminateError rest)
            go
          ('S' : _) -> do
            callRegistered Terminate
            go
          ('C' : _) -> do
            castRegistered (Shout x)
            go
          ('R' : rest) -> do
            replicateM_ (read rest) (castRegistered (Shout x))
            go
          ('q' : _) -> logInfo "Done."
          _         -> do
            res <- callRegistered (SayHello x)
            logInfo ("Result: " ++ show res)
            go
  registerServer server go

testServerLoop
  :: forall q
   . ( HasCallStack
     , HasLogging IO q
     )
  => Eff (InterruptableProcess q) (Server TestApi)
testServerLoop = spawnApiServer
  (handleCastTest <> handleCalls handleCallTest) handleTerminateTest
 where
  handleCastTest = handleCasts $ \(Shout x) -> do
    me <- self
    logInfo (show me ++ " Shouting: " ++ x)
    return AwaitNext
  handleCallTest :: Api TestApi ('Synchronous r) -> (Eff (InterruptableProcess q) (Maybe r, CallbackResult) -> xxx) -> xxx
  handleCallTest (SayHello "e1") k = k $ do
    me <- self
    logInfo (show me ++ " raising an error")
    interrupt (ProcessError "No body loves me... :,(")
  handleCallTest (SayHello "e2") k = k $ do
    me <- self
    logInfo (show me ++ " throwing a MyException ")
    void (lift (Exc.throw MyException))
    pure (Nothing, AwaitNext)
  handleCallTest (SayHello "self") k = k $ do
    me <- self
    logInfo (show me ++ " casting to self")
    cast (asServer @TestApi me) (Shout "from me")
    return (Just False, AwaitNext)
  handleCallTest (SayHello "stop") k = k $ do
    me <- self
    logInfo (show me ++ " stopping me")
    return (Just False, StopServer (ProcessError "test error"))
  handleCallTest (SayHello x) k = k $ do
    me <- self
    logInfo (show me ++ " Got Hello: " ++ x)
    return (Just (length x > 3), AwaitNext)
  handleCallTest Terminate k = k $ do
    me <- self
    logInfo (show me ++ " exiting")
    pure (Just (), StopServer ProcessFinished)
  handleCallTest (TerminateError msg) k = k $ do
    me <- self
    logInfo (show me ++ " exiting with error: " ++ msg)
    pure (Just (), StopServer (ProcessError msg))
  handleTerminateTest = InterruptCallback $ \msg -> do
    me <- self
    logInfo (show me ++ " is exiting: " ++ show msg)
    logProcessExit msg
    pure (StopServer msg)