refactor: introduce Handler type synonym

src/Control/Actor.hs

@@ -7,6 +7,8 @@ module Control.Actor
   , module Control.Actor.Network
   , pass
   , continue
+  , maybeContinue
+  , become
   -- Demo
   , pingActor
   , forwardActorWithCell
@@ -31,33 +33,40 @@ import Control.Monad ((<=<))
 import Control.Monad.Reader (MonadIO (..))
 import Unsafe.Coerce (unsafeCoerce)
 
-continue :: r -> Actor u r
+continue :: r -> Actor msg u r
-continue x = (,) (Just x) <$> state
+continue x = (\u -> ActorResult (Just x) u Nothing) <$> state
 
-pass :: Actor u r
+maybeContinue :: Maybe r -> Actor msg u r
-pass = (,) Nothing <$> state
+maybeContinue Nothing = pass
+maybeContinue (Just r) = continue r
+
+pass :: Actor msg u r
+pass = (\u -> ActorResult Nothing u Nothing) <$> state
+
+become :: Handler msg u r -> Actor msg u r
+become fn = (\u -> ActorResult Nothing u (Just fn)) <$> state
 
 -- Demo
 
-pingActor :: String -> Actor () String
+pingActor :: Handler String () String
-pingActor msg = return (Just ("Hello, " <> msg <> "!"), ())
+pingActor msg = continue ("Hello, " <> msg <> "!")
 
-forwardActorWithCell :: TMVar (ActorRef String String) -> String -> Actor () String
+forwardActorWithCell :: TMVar (ActorRef String String) -> Handler String () String
 forwardActorWithCell cell msg = do
   pingRef <- liftIO $ atomically $ readTMVar cell
   reply   <- call msg pingRef
   case reply of
     Nothing -> liftIO $ putStrLn "forwardActorWithCell: received empty reply!"
     Just x  -> liftIO $ putStrLn ("forwardActorWithCell: received reply - " <> x)
-  return (reply, ())
+  maybeContinue reply
 
-repeatActor :: String -> TMVar (ActorRef String String) -> () -> Actor () String
+repeatActor :: String -> TMVar (ActorRef String String) -> Handler () () String
 repeatActor r cell () = do
   ref             <- liftIO $ atomically $ readTMVar cell
   (SomeActorRef self) <- getSelf
   cast r ref
   castIn 1000 () (unsafeCoerce self)
-  return (Nothing, ())
+  pass
 
 system :: IO ()
 system = do
@@ -81,25 +90,25 @@ system = do
 
 -- Network demo
 
-newNodeActor :: NodeAddr -> Actor () NodeId
+newNodeActor :: Handler NodeAddr () NodeId
 newNodeActor = continue <=< liftRuntime . connect Nothing
 
 -- | Actor on node 2: echo — returns whatever it received.
-echoActor :: String -> Actor () String
+echoActor :: Handler String () String
 echoActor = continue
 
 -- | Actor on node 2: printer — side-effects only.
-printerActor :: String -> Actor () ()
+printerActor :: Handler String () ()
 printerActor msg = liftIO (putStrLn $ "  [remote/print] " <> msg) >> pass
 
 -- | Trivial actor used as a stub when we only care about death notifications.
-noopActor :: () -> Actor () ()
+noopActor :: Handler () () ()
-noopActor _ = return (Nothing, ())
+noopActor _ = pass
 
 -- | Captures the received string into a TVar (used as a node-1 receiver actor).
-recvActorFn :: TVar (Maybe String) -> String -> Actor () ()
+recvActorFn :: TVar (Maybe String) -> Handler String () ()
 recvActorFn var msg =
-  liftIO (atomically $ writeTVar var (Just msg)) >> return (Nothing, ())
+  liftIO (atomically $ writeTVar var (Just msg)) >> pass
 
 -- | End-to-end networking demo.
 --

src/Control/Actor/Core.hs

@@ -6,6 +6,8 @@ module Control.Actor.Core
   , state
   , getSelf
   , Actor
+  , ActorResult (..)
+  , Handler
   , liftRuntime
   , notifyOfDeath
   , spawnActor
@@ -44,6 +46,7 @@ import Control.Exception
   , try
   )
 import Control.Monad (forM_, void)
+import Data.Maybe (fromMaybe)
 import Control.Monad.Reader
   ( MonadIO (..)
   , MonadReader (..)
@@ -78,7 +81,15 @@ getSelf = do
     Just ref -> return ref
     Nothing  -> error "getSelf: actor not found in runtime"
 
-type Actor u r = ActorM u (Maybe r, u)
+data ActorResult msg u r = ActorResult
+  { actorReply  :: Maybe r
+  , actorState  :: u
+  , actorBecome :: Maybe (msg -> ActorM u (ActorResult msg u r))
+  }
+
+type Actor msg u r = ActorM u (ActorResult msg u r)
+
+type Handler msg u r = msg -> Actor msg u r
 
 liftRuntime :: RuntimeM a -> ActorM u a
 liftRuntime = ActorM . withReaderT snd . unRuntimeM
@@ -90,7 +101,7 @@ notifyOfDeath rt dm (RemoteTarget _ peerAddr) =
 
 spawnActor ::
   (Binary m, Binary r) =>
-  (m -> Actor u r) ->
+  Handler m u r ->
   (DeathMessage -> ActorM u (SupervisorAction u)) ->
   u ->
   RuntimeM (ActorRef m r)
@@ -104,7 +115,7 @@ spawnActor actorFn deathFn initState = do
       actorState = ActorState actorId links initState
       actorRef   = LocalRef mailbox deathQ actorState
 
-  let loop as = do
+  let loop fn as = do
         event <-
           atomically $
             (Left <$> readTQueue mailbox)
@@ -113,20 +124,20 @@ spawnActor actorFn deathFn initState = do
           Left envelope ->
             case envelope of
               Cast msg -> do
-                (_, u') <- runActorM (actorFn msg) rt as
+                ActorResult _ u' mFn <- runActorM (fn msg) rt as
-                loop as {asEnv = u'}
+                loop (fromMaybe fn mFn) as {asEnv = u'}
               Call msg mv -> do
-                (reply, u') <- runActorM (actorFn msg) rt as
+                ActorResult reply u' mFn <- runActorM (fn msg) rt as
                 putMVar mv reply
-                loop as {asEnv = u'}
+                loop (fromMaybe fn mFn) as {asEnv = u'}
           Right dm -> do
             action <- runActorM (deathFn dm) rt as
             case action of
               Stop       -> return ()
-              Continue u -> loop as {asEnv = u}
+              Continue u -> loop fn as {asEnv = u}
 
   tid <- liftIO $ forkIO $ do
-    result <- try @SomeException (loop actorState)
+    result <- try @SomeException (loop actorFn actorState)
     let reason = case result of
           Right () -> Normal
           Left exc -> case fromException exc of

src/Control/Actor/Network.hs

@@ -14,7 +14,7 @@ module Control.Actor.Network
   ) where
 
 import Control.Actor.Core
-  ( Actor, ActorM, cast', liftRuntime, linkActorTo, spawnActor, state, stopOnDeath )
+  ( Actor, ActorM, ActorResult (..), Handler, cast', liftRuntime, linkActorTo, spawnActor, state, stopOnDeath )
 import Control.Actor.Runtime (Runtime (..), RuntimeM, newRuntime, withRuntime)
 import Control.Actor.Supervision (ChildSpec (..), RestartStrategy (..), childWithRef, supervise')
 import Control.Actor.Transport (ConnHandle (..), Transport (..), createTCPTransport)
@@ -45,11 +45,11 @@ import Data.UUID (UUID)
 
 -- Connection actors
 
-connActorFn :: NetworkMessage -> Actor ConnHandle ()
+connActorFn :: Handler NetworkMessage ConnHandle ()
 connActorFn nm = do
   ch <- state
   liftIO $ chSend ch (encode nm)
-  return (Nothing, ch)
+  return $ ActorResult Nothing ch Nothing
 
 connDeathFn :: NodeAddr -> DeathMessage -> ActorM ConnHandle (SupervisorAction ConnHandle)
 connDeathFn peer _ = do
@@ -60,12 +60,12 @@ connDeathFn peer _ = do
     chClose ch
   return Stop
 
-routerActorFn :: NodeAddr -> ByteString -> Actor () ()
+routerActorFn :: NodeAddr -> Handler ByteString () ()
 routerActorFn senderAddr raw = do
   let nm = decode raw :: NetworkMessage
   valid <- liftRuntime $ validateAndDispatch senderAddr nm
   unless valid $ liftIO $ putStrLn "router: dropping invalid message"
-  return (Nothing, ())
+  return $ ActorResult Nothing () Nothing
 
 -- Connection supervision tree
 
@@ -242,8 +242,8 @@ validateAndDispatch senderAddr nm = case nm of
 
 -- System event handler
 
-sysHandlerFn :: NetworkMessage -> Actor () ()
+sysHandlerFn :: Handler NetworkMessage () ()
-sysHandlerFn _ = return (Nothing, ())
+sysHandlerFn _ = return $ ActorResult Nothing () Nothing
 
 -- Node connection
 

src/Control/Actor/Supervision.hs

@@ -16,7 +16,7 @@ module Control.Actor.Supervision
   , killSlot
   ) where
 
-import Control.Actor.Core (Actor, ActorM, liftRuntime, linkActorTo, spawnActor)
+import Control.Actor.Core (Actor, ActorM, Handler, liftRuntime, linkActorTo, spawnActor)
 import Control.Actor.Runtime (Runtime (..), RuntimeM, withRuntime)
 import Control.Actor.Types
 import Data.Binary (Binary)
@@ -47,7 +47,7 @@ data ChildSpec = forall m r. (Binary m, Binary r) => ChildSpec
 
 child ::
   (Binary m, Binary r) =>
-  (m -> Actor u r) ->
+  Handler m u r ->
   (DeathMessage -> ActorM u (SupervisorAction u)) ->
   u ->
   ChildSpec
@@ -62,7 +62,7 @@ child msgFn deathFn initState =
 
 childWithRef ::
   (Binary m, Binary r) =>
-  (m -> Actor u r) ->
+  Handler m u r ->
   (DeathMessage -> ActorM u (SupervisorAction u)) ->
   u ->
   TMVar (ActorRef m r) ->