From 25a27eda922085549301e77cc57bda4df1de6c3f Mon Sep 17 00:00:00 2001 From: dvdrw Date: Wed, 17 Jun 2026 16:27:37 +0200 Subject: [PATCH] refactor: introduce Handler type synonym --- src/Control/Actor.hs | 43 +++++++++++++++++++------------- src/Control/Actor/Core.hs | 29 ++++++++++++++------- src/Control/Actor/Network.hs | 14 +++++------ src/Control/Actor/Supervision.hs | 6 ++--- 4 files changed, 56 insertions(+), 36 deletions(-) diff --git a/src/Control/Actor.hs b/src/Control/Actor.hs index 30969f8..c3d42e7 100644 --- a/src/Control/Actor.hs +++ b/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 x = (,) (Just x) <$> state +continue :: r -> Actor msg u r +continue x = (\u -> ActorResult (Just x) u Nothing) <$> state -pass :: Actor u r -pass = (,) Nothing <$> state +maybeContinue :: Maybe r -> Actor msg u r +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 msg = return (Just ("Hello, " <> msg <> "!"), ()) +pingActor :: Handler String () String +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 _ = return (Nothing, ()) +noopActor :: Handler () () () +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. -- diff --git a/src/Control/Actor/Core.hs b/src/Control/Actor/Core.hs index 6273396..aed4deb 100644 --- a/src/Control/Actor/Core.hs +++ b/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 - loop as {asEnv = u'} + ActorResult _ u' mFn <- runActorM (fn msg) rt as + 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 diff --git a/src/Control/Actor/Network.hs b/src/Control/Actor/Network.hs index 9b6814e..65ab6ea 100644 --- a/src/Control/Actor/Network.hs +++ b/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 _ = return (Nothing, ()) +sysHandlerFn :: Handler NetworkMessage () () +sysHandlerFn _ = return $ ActorResult Nothing () Nothing -- Node connection diff --git a/src/Control/Actor/Supervision.hs b/src/Control/Actor/Supervision.hs index df58a30..33167a9 100644 --- a/src/Control/Actor/Supervision.hs +++ b/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) ->