Actor.hs

module Actor where

import System.IO
import Control.Concurrent.STM.TChan
import Control.Concurrent
import Control.Monad.STM
import Control.Monad

type Mailbox a = TChan a
data Behaviour a = Behaviour {
  runBehaviour :: Actor a -> a -> IO (Maybe (Behaviour a))
}
data Actor a = Actor { mbox :: Mailbox a, beh :: Behaviour a }

new :: IO (Mailbox a)
new = atomically newTChan

pop :: Mailbox a -> IO a
pop = atomically . readTChan

push :: Mailbox a -> a -> IO ()
push to = atomically . writeTChan to

once :: (Actor a -> a -> IO ()) -> Behaviour a
once f = Behaviour $ \a m -> f a m >> return Nothing

loop :: (Actor a -> a -> IO ()) -> Behaviour a
loop f = Behaviour $ \a m -> f a m >> return (Just (loop f))

createActor :: Behaviour a -> IO (Actor a)
createActor b = liftM (flip Actor b) new

send :: Actor a -> a -> IO ()
send to = push (mbox to)

step :: Actor a -> IO (Maybe (Actor a))
step a = (fmap . fmap) (Actor (mbox a)) $
  pop (mbox a) >>= runBehaviour (beh a) a

run :: Actor a -> IO ()
run a = step a >>= maybe (return ()) run

spawn :: Actor a -> IO ()
spawn a = void $ forkIO (run a)

(<<-) ::  Actor a -> a -> IO ()
(<<-) = send
infixr 4 <<-

(->>) :: a -> Actor a -> IO ()
(->>) = flip send
infixr 4 ->>

-- An example to compute factorial

data Factorial n dest = Factorial Integer (Actor (Value Integer))

data Value n = Value n deriving Show

multiplyActor :: Num n => Actor (Value n) -> n -> IO (Actor (Value n))
multiplyActor dest n = createActor $ once $ multiplyBehaviour dest n

multiplyBehaviour :: Num n => Actor (Value n) -> n -> t -> Value n -> IO ()
multiplyBehaviour dest n _ (Value k) = dest <<- Value (n*k)

resultActor ::  IO (Actor (Value Integer))
resultActor = createActor $ once $ \_ (Value n) -> putStrLn ("Result:" ++ show n)

factorialActor ::  IO (Actor (Factorial n dest))
factorialActor = createActor $ loop factorialBehaviour

factorialBehaviour :: Actor (Factorial n dest) -> Factorial t t1 -> IO ()
factorialBehaviour _ (Factorial 0 r) = r <<- Value 1
factorialBehaviour self (Factorial n r) = do
  m <- multiplyActor r n
  spawn m
  self <<- Factorial (n-1) m

factorial ::  Integer -> IO ()
factorial n = do
  r <- resultActor
  a <- factorialActor
  spawn a
  a <<- Factorial n r
  run r

-- A copy of the example from Erlang's tutorial: http://learnyousomeerlang.com/the-hitchhikers-guide-to-concurrency#thanks-for-all-the-fish
data Dolphin = DoAFlip | Fish

dolphinBehaviour :: Actor Dolphin -> Dolphin -> IO ()
dolphinBehaviour _ d =
  case d of
    DoAFlip -> putStrLn "How about no?"
    Fish -> putStrLn "So long, and thanks for the fish."

dolphinActor :: IO (Actor Dolphin)
dolphinActor = createActor $ loop dolphinBehaviour

displayMenu :: IO String
displayMenu = do
  mapM_ putStrLn ["-- Menu", " flip", " fish", " quit"]
  putStr "Command> "
  hFlush stdout
  getLine

dolphin :: IO ()
dolphin = do
  d <- dolphinActor
  spawn d
  prompt d
  where prompt dol = do
          cmd <- displayMenu
          case cmd of
            "flip" -> dol <<- DoAFlip >> prompt dol
            "fish" -> dol <<- Fish >> prompt dol
            "quit" -> return ()
            _ -> putStrLn ("Unknown command " ++ show cmd) >> prompt dol

main ::  IO ()
{-main = factorial 20-}
main = dolphin