actor-0.1: PingPong.hs

{-# LANGUAGE MultiParamTypeClasses, PatternSignatures, TypeSynonymInstances, FlexibleInstances  #-}

module PingPong where

-- standard ping-pong actor example

import IO
import Monad
import Data.IORef
import Control.Concurrent


import Actor.ActorBase
import Actor.ActorSyntax
import Actor.ActorCompiler
import Actor.ActorLinearSearch




-- boilerplate

data Msg 
     = Ping | Pong | Stop deriving (Eq,Show)


valHashOp_Msg = HashOp {numberOfTables = 3,
                        hashMsg = \ msg -> case msg of
                                             Ping -> 1
                                             Pong -> 2
                                             Stop -> 3 }


instance EMatch Msg where
  match tags m1 m2 = return (m1 == m2, tags)


-- auxilliary

loop c = do { c; loop c}

ifonly b c = if b then c
             else return ()


--wait = 2
wait = 10000

pingAct count pong self =
  do { pingsLeft <- newIORef (count -1)
     ; let pong_pid = actorToPID pong
     ; send pong_pid Ping
     ; loop
       ( receive self
         [ [Pong] .->. ( do { v <- readIORef pingsLeft
                            ; ifonly (v `mod`  wait == 0) (putStrLn "ping:Pong")
                            ; if v > 0
                               then do {send pong_pid Ping; writeIORef pingsLeft (v-1) }
                               else do {putStrLn "ping:Stop" ; send pong_pid Stop }
                          }
                      )
         ]
       )
     }          

pongAct pong exit self =
  do { pongCount <- newIORef 0
     ; let pong_pid = actorToPID pong
     ; loop
       ( receive self
         [ [Ping] .->. ( do { v <- readIORef pongCount
                            ; ifonly (v `mod` wait == 0) (putStrLn ("pong:Ping " ++ (show v)))
                            ; send pong_pid Pong
                            ; writeIORef pongCount (v+1)
                            }
                        ) 
         ,
           [Stop] .->. ( do { putStrLn "pong: Stop"
                            ; putMVar exit ()         -- EXIT
                            }
                        )
         ]
       )
     }          


main :: IO ()
main = do { (ping :: Act Msg) <- createActor valHashOp_Msg
          ; (pong :: Act Msg) <- createActor valHashOp_Msg
          ; exit <- newEmptyMVar
          ; runActor ping (pingAct 1000000 pong)
          ; runActor pong (pongAct ping exit)
          ; readMVar exit -- blocks till we hit exit
          ; kill (actorToPID ping) ; kill (actorToPID pong)
          }