dvdrw/actors
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: introduce Handler type synonym

Browse Source
This commit is contained in:
dvdrw
2026-06-17 16:27:37 +02:00
parent 51cb3a95f5
commit 25a27eda92
4 changed files with 56 additions and 36 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Control/Actor.hs
+26 -17
View File
@@ -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.
--
src/Control/Actor/Core.hs
+20 -9
View File
@@ -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
src/Control/Actor/Network.hs
+7 -7
View File
@@ -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
src/Control/Actor/Supervision.hs
+3 -3
View File
@@ -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) ->