diff --git a/README b/README --- a/README +++ b/README @@ -1,2 +1,2 @@ To get an idea of how to use epass, have a look at the files in demo/ and the -haddock docs. +haddock docs at http://hackage.haskell.org/package/epass. diff --git a/demo/Message.hs b/demo/Message.hs --- a/demo/Message.hs +++ b/demo/Message.hs @@ -1,18 +1,14 @@ module Message ( Message (..) - , Event (..) , Command (..) ) where import Control.Concurrent.Mailbox.Wrapper -data Message = MsgEvent Event +data Message = MsgError String | MsgCommand Command | M Int - deriving (Read, Show) - -data Event = EvKey Char deriving (Read, Show) data Command = CmdQuit diff --git a/demo/TestClient.hs b/demo/TestClient.hs --- a/demo/TestClient.hs +++ b/demo/TestClient.hs @@ -15,9 +15,9 @@ hFlush hdl inBox <- wrapReadHandle hdl - (\inBox e -> inBox inBox inBox inBox handler $ do - putStrLn "received 10" - loop inBox outBox (n + 1) - , \m -> handler $ do - print m - loop inBox outBox (n + 1) + [ \ (MsgError e) -> handler $ + putStrLn $ "received error: " ++ e + , \ (M 10) -> handler $ do + putStrLn "received 10" + loop inBox outBox (n + 1) + , \ m -> handler $ do + print m + loop inBox outBox (n + 1) ] diff --git a/demo/TestServer.hs b/demo/TestServer.hs --- a/demo/TestServer.hs +++ b/demo/TestServer.hs @@ -13,9 +13,9 @@ (hdl, _, _) <- accept sock inBox <- wrapReadHandle hdl - (\inBox e -> inBox inBox inBox inBox mb Message -> mb Message -> IO () loop inBox outBox = do receiveNonBlocking inBox - [ \ (MsgCommand CmdQuit) -> handler $ return () + [ \ (MsgError e) -> handler $ + putStrLn $ "received error: " ++ e + , \ (MsgCommand CmdQuit) -> handler $ return () , \ m -> handler $ do - putStrLn $ "Matched " ++ show m ++ " non-blocking." - outBox handler $ do + putStrLn $ "Matched " ++ show m ++ " non-blocking." + outBox handler $ + putStrLn $ "received error: " ++ e + , \ (m@(M (n + 1))) -> handler $ do + putStrLn $ "Matched " ++ show m ++ " within timeout." outBox handler $ do print m loop inBox outBox - ] + ] $ do + putStrLn "Timeout" + loop inBox outBox diff --git a/epass.cabal b/epass.cabal --- a/epass.cabal +++ b/epass.cabal @@ -1,5 +1,5 @@ Name: epass -Version: 0.1 +Version: 0.1.1 Stability: Alpha Synopsis: Baisc, Erlang-like message passing supporting sockets. Description: This package provides Erlang-like mailboxes for message passing. @@ -30,7 +30,7 @@ Library Build-Depends: base == 4.*, - time == 1.1.* + time == 1.1.* || == 1.2.* Ghc-Options: -Wall diff --git a/src/Control/Concurrent/Mailbox.hs b/src/Control/Concurrent/Mailbox.hs --- a/src/Control/Concurrent/Mailbox.hs +++ b/src/Control/Concurrent/Mailbox.hs @@ -113,22 +113,32 @@ yield -- | An alias for 'send' in the flavor of Erlang's @!@. -( b m -> m -> IO () +( b m + -> m + -> IO () ( a +timeoutFactor + :: Num a + => a timeoutFactor = 1000000 -calcEndTime :: Int -> IO UTCTime +calcEndTime + :: Int + -> IO UTCTime calcEndTime to = do curTime <- getCurrentTime let dt = fromIntegral to / timeoutFactor return $ addUTCTime dt curTime -calcTimeLeft :: UTCTime -> IO Int +calcTimeLeft + :: UTCTime + -> IO Int calcTimeLeft endTime = do curTime <- getCurrentTime return $ round $ (diffUTCTime endTime curTime) * timeoutFactor @@ -150,7 +160,7 @@ => b m -- ^ mailbox to receive on -> [MsgHandler m a] -- ^ message handlers -> IO a -receive _ [] = error "No message handler given! Cannot match." +receive _ [] = error "No message handler given! Cannot match." receive mbox handlers = do a <- matchAll mbox handlers a @@ -165,8 +175,8 @@ -> [MsgHandler m a] -- ^ message handlers -> IO a -- ^ timeout handler -> IO a -receiveTimeout _ _ [] toa = toa -receiveTimeout mbox 0 handlers toa = receiveNonBlocking mbox handlers toa +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 @@ -192,9 +202,17 @@ -- Matching messages (internal) ------------------------------------------------ -matchAll :: MailboxClass b => b m -> [MsgHandler m a] -> IO (IO a) +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 + m <- getMessage mbox ma <- match m hs case ma of @@ -206,7 +224,12 @@ unGetMessage mbox m return r -matchAllTimeout :: MailboxClass b => b m -> UTCTime -> [MsgHandler m a] -> IO (Maybe (IO a)) +matchAllTimeout + :: MailboxClass b + => b m + -> UTCTime + -> [MsgHandler m a] + -> IO (Maybe (IO a)) matchAllTimeout mbox endTime hs = do timeLeft <- calcTimeLeft endTime @@ -219,21 +242,25 @@ Just m -> do matched <- matchTimeout m endTime hs case matched of - Left Nothing -> do + NoMatch -> do r <- matchAllTimeout mbox endTime hs unGetMessage mbox m return r - Left (Just a) -> + (Match a) -> return $ Just a - Right () -> do + Timeout -> do unGetMessage mbox m return Nothing Nothing -> return Nothing -matchCurrent :: MailboxClass b => b m -> [MsgHandler m a] -> IO (Maybe (IO a)) +matchCurrent + :: MailboxClass b + => b m + -> [MsgHandler m a] + -> IO (Maybe (IO a)) matchCurrent mbox hs = do empty <- isEmpty mbox if empty @@ -250,8 +277,11 @@ unGetMessage mbox m return r -match :: m -> [MsgHandler m a] -> IO (Maybe (IO a)) -match _ [] = return Nothing +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 @@ -259,22 +289,28 @@ Just action -> return $ Just action Nothing -> match m hs -matchTimeout :: m -> UTCTime -> [MsgHandler m a] -> IO (Either (Maybe (IO a)) ()) -matchTimeout _ _ [] = return $ Left Nothing +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 $ Right () + 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 $ Left $ Just action + Just (Just action) -> return $ Match action Just Nothing -> matchTimeout m endTime hs - Nothing -> return $ Right () + Nothing -> return $ Timeout -handlePatternMatchFail :: PatternMatchFail -> IO (Maybe (IO a)) +handlePatternMatchFail + :: PatternMatchFail + -> IO (Maybe (IO a)) handlePatternMatchFail _ = return Nothing @@ -299,7 +335,9 @@ data Handler a = Handler (IO a) -- | Generate a handler from an 'IO' action. -handler :: IO a -> Handler a +handler + :: IO a + -> Handler a handler = Handler