actors.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}

import Control.Concurrent
import Control.Concurrent.STM

data PID msg = PID
  { pid :: ThreadId,
    mailBox :: TQueue msg
  }

newtype Behavior msg = Behavior ((?self :: PID msg) => msg -> IO (Behavior msg))

spawn :: forall msg. Behavior msg -> IO (PID msg)
spawn beh = mdo
  mailBox <- atomically newTQueue
  let lifecycle (Behavior beh) = do
        msg <- atomically (readTQueue mailBox)
        beh <- beh msg
        lifecycle beh
  pid <- forkIO do
    let ?self = self
    lifecycle beh
    pure ()
  let self = PID {pid, mailBox}
  pure self

(!) :: PID msg -> msg -> IO ()
p ! msg = atomically (writeTQueue (mailBox p) msg)

data Ping = Ping {caller :: PID Pong}

data Pong = Pong {caller :: PID Ping}

mkPing :: Behavior Ping
mkPing = go 0
  where
    go n = Behavior \(Ping caller) -> do
      putStrLn ("Ping! #" <> show n)
      threadDelay 1_000_000
      caller ! Pong ?self
      pure (go (n + 1))

mkPong :: Behavior Pong
mkPong = go 0
  where
    go n = Behavior \(Pong caller) -> do
      putStrLn ("Pong! #" <> show n)
      threadDelay 1_000_000
      caller ! Ping ?self
      pure (go (n + 1))

main = do
  ping <- spawn mkPing
  pong <- spawn mkPong
  ping ! Ping pong
  threadDelay 10_000_000

-- Ping! #0
-- Pong! #0
-- Ping! #1
-- Pong! #1
-- Ping! #2