module Control.Concurrent.Mailbox
(
MailboxClass (..)
, Mailbox
, newMailbox
, send
, (<!)
, receive
, receiveNonBlocking
, receiveTimeout
, MsgHandler
, Handler
, handler
, (.>)
, (<|>)
)
where
import Prelude hiding (catch)
import Control.Concurrent (yield)
import Control.Concurrent.STM
import Control.Exception hiding (Handler)
import Data.Time
import System.Timeout
class MailboxClass b where
getMessage
:: b m
-> IO m
unGetMessage
:: b m
-> m
-> IO ()
putMessage
:: b m
-> m
-> IO ()
isEmpty
:: b m
-> IO Bool
close
:: b m
-> IO ()
newtype Mailbox m = MBox (TChan m)
newMailbox :: IO (Mailbox m)
newMailbox = fmap MBox newTChanIO
instance MailboxClass Mailbox where
getMessage (MBox chan) = atomically $ readTChan chan
unGetMessage (MBox chan) msg = atomically $ unGetTChan chan msg
putMessage (MBox chan) msg = atomically $ writeTChan chan msg
isEmpty (MBox chan) = atomically $ isEmptyTChan chan
close _ = return ()
send
:: MailboxClass b
=> b m
-> m
-> IO ()
send mbox msg = do
putMessage mbox msg
yield
(<!)
:: MailboxClass b
=> b m
-> m
-> IO ()
(<!) = send
timeoutFactor
:: Num a
=> a
timeoutFactor = 1000000
calcEndTime
:: Int
-> IO UTCTime
calcEndTime to = do
curTime <- getCurrentTime
let dt = fromIntegral to / timeoutFactor
return $ addUTCTime dt curTime
calcTimeLeft
:: UTCTime
-> IO Int
calcTimeLeft endTime = do
curTime <- getCurrentTime
return $ round $ (diffUTCTime endTime curTime) * timeoutFactor
receive
:: MailboxClass b
=> b m
-> [MsgHandler m a]
-> IO a
receive _ [] = error "No message handler given! Cannot match."
receive mbox handlers = do
a <- matchAll mbox handlers
a
receiveTimeout
:: MailboxClass b
=> b m
-> Int
-> [MsgHandler m a]
-> IO a
-> IO a
receiveTimeout _ _ [] toa = toa
receiveTimeout mbox 0 handlers toa = receiveNonBlocking mbox handlers toa
receiveTimeout mbox to handlers toa = do
endTime <- calcEndTime to
ma <- matchAllTimeout mbox endTime handlers
case ma of
Just a -> a
Nothing -> toa
receiveNonBlocking
:: MailboxClass b
=> b m
-> [MsgHandler m a]
-> IO a
-> IO a
receiveNonBlocking mbox handlers na = do
ma <- matchCurrent mbox handlers
case ma of
Just a -> a
Nothing -> na
data TimeoutResult a = Match (IO a)
| NoMatch
| Timeout
matchAll
:: MailboxClass b
=> b m
-> [MsgHandler m a]
-> IO (IO a)
matchAll mbox hs = do
m <- getMessage mbox
ma <- match m hs
case ma of
Just a ->
return a
Nothing -> do
r <- matchAll mbox hs
unGetMessage mbox m
return r
matchAllTimeout
:: MailboxClass b
=> b m
-> UTCTime
-> [MsgHandler m a]
-> IO (Maybe (IO a))
matchAllTimeout mbox endTime hs = do
timeLeft <- calcTimeLeft endTime
if timeLeft <= 0
then return Nothing
else do
mm <- timeout timeLeft $ getMessage mbox
case mm of
Just m -> do
matched <- matchTimeout m endTime hs
case matched of
NoMatch -> do
r <- matchAllTimeout mbox endTime hs
unGetMessage mbox m
return r
(Match a) ->
return $ Just a
Timeout -> do
unGetMessage mbox m
return Nothing
Nothing ->
return Nothing
matchCurrent
:: MailboxClass b
=> b m
-> [MsgHandler m a]
-> IO (Maybe (IO a))
matchCurrent mbox hs = do
empty <- isEmpty mbox
if empty
then return Nothing
else do
m <- getMessage mbox
ma <- match m hs
case ma of
Just a ->
return $ Just a
Nothing -> do
r <- matchCurrent mbox hs
unGetMessage mbox m
return r
match
:: m
-> [MsgHandler m a]
-> IO (Maybe (IO a))
match _ [] = return Nothing
match m (h : hs) = do
ma <- catch (case h m of (Handler a) -> return $ Just a)
handlePatternMatchFail
case ma of
Just action -> return $ Just action
Nothing -> match m hs
matchTimeout
:: m
-> UTCTime
-> [MsgHandler m a]
-> IO (TimeoutResult a)
matchTimeout _ _ [] = return NoMatch
matchTimeout m endTime (h : hs) = do
timeLeft <- calcTimeLeft endTime
if timeLeft <= 0
then return Timeout
else do
ma <- timeout timeLeft $
catch (case h m of (Handler a) -> return $ Just a)
handlePatternMatchFail
case ma of
Just (Just action) -> return $ Match action
Just Nothing -> matchTimeout m endTime hs
Nothing -> return $ Timeout
handlePatternMatchFail
:: PatternMatchFail
-> IO (Maybe (IO a))
handlePatternMatchFail _ = return Nothing
type MsgHandler m a = m -> Handler a
data Handler a = Handler (IO a)
handler
:: IO a
-> Handler a
handler = Handler
(.>)
:: MsgHandler m a
-> (a -> b)
-> MsgHandler m b
(h .> f) m =
let Handler a = h m
in handler $ a >>= return . f
(<|>)
:: [MsgHandler m a]
-> [MsgHandler m b]
-> [MsgHandler m (Either a b)]
has <|> hbs = (map (.> Left) has) ++ (map (.> Right) hbs)