epass 0.1 → 0.1.1
raw patch · 6 files changed
+91/−48 lines, 6 filesdep ~timePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: time
API changes (from Hackage documentation)
- Control.Concurrent.Mailbox: (<!) :: (MailboxClass b) => b m -> m -> IO ()
+ Control.Concurrent.Mailbox: (<!) :: MailboxClass b => b m -> m -> IO ()
- Control.Concurrent.Mailbox: close :: (MailboxClass b) => b m -> IO ()
+ Control.Concurrent.Mailbox: close :: MailboxClass b => b m -> IO ()
- Control.Concurrent.Mailbox: getMessage :: (MailboxClass b) => b m -> IO m
+ Control.Concurrent.Mailbox: getMessage :: MailboxClass b => b m -> IO m
- Control.Concurrent.Mailbox: isEmpty :: (MailboxClass b) => b m -> IO Bool
+ Control.Concurrent.Mailbox: isEmpty :: MailboxClass b => b m -> IO Bool
- Control.Concurrent.Mailbox: putMessage :: (MailboxClass b) => b m -> m -> IO ()
+ Control.Concurrent.Mailbox: putMessage :: MailboxClass b => b m -> m -> IO ()
- Control.Concurrent.Mailbox: receive :: (MailboxClass b) => b m -> [MsgHandler m a] -> IO a
+ Control.Concurrent.Mailbox: receive :: MailboxClass b => b m -> [MsgHandler m a] -> IO a
- Control.Concurrent.Mailbox: receiveNonBlocking :: (MailboxClass b) => b m -> [MsgHandler m a] -> IO a -> IO a
+ Control.Concurrent.Mailbox: receiveNonBlocking :: MailboxClass b => b m -> [MsgHandler m a] -> IO a -> IO a
- Control.Concurrent.Mailbox: receiveTimeout :: (MailboxClass b) => b m -> Int -> [MsgHandler m a] -> IO a -> IO a
+ Control.Concurrent.Mailbox: receiveTimeout :: MailboxClass b => b m -> Int -> [MsgHandler m a] -> IO a -> IO a
- Control.Concurrent.Mailbox: send :: (MailboxClass b) => b m -> m -> IO ()
+ Control.Concurrent.Mailbox: send :: MailboxClass b => b m -> m -> IO ()
- Control.Concurrent.Mailbox: unGetMessage :: (MailboxClass b) => b m -> m -> IO ()
+ Control.Concurrent.Mailbox: unGetMessage :: MailboxClass b => b m -> m -> IO ()
- Control.Concurrent.Mailbox.Wrapper: fromString :: (Wrappable m) => String -> Maybe m
+ Control.Concurrent.Mailbox.Wrapper: fromString :: Wrappable m => String -> Maybe m
- Control.Concurrent.Mailbox.Wrapper: fromStringReadS :: (Wrappable m) => ReadS m
+ Control.Concurrent.Mailbox.Wrapper: fromStringReadS :: Wrappable m => ReadS m
- Control.Concurrent.Mailbox.Wrapper: toString :: (Wrappable m) => m -> String
+ Control.Concurrent.Mailbox.Wrapper: toString :: Wrappable m => m -> String
- Control.Concurrent.Mailbox.Wrapper: wrapReadHandle :: (Wrappable m) => Handle -> ErrorHandler m -> IO (WrapBox m)
+ Control.Concurrent.Mailbox.Wrapper: wrapReadHandle :: Wrappable m => Handle -> ErrorHandler m -> IO (WrapBox m)
- Control.Concurrent.Mailbox.Wrapper: wrapReadHandleWithMailbox :: (Wrappable m) => Handle -> Mailbox m -> ErrorHandler m -> IO (WrapBox m)
+ Control.Concurrent.Mailbox.Wrapper: wrapReadHandleWithMailbox :: Wrappable m => Handle -> Mailbox m -> ErrorHandler m -> IO (WrapBox m)
- Control.Concurrent.Mailbox.Wrapper: wrapWriteHandle :: (Wrappable m) => Handle -> ErrorHandler m -> IO (WrapBox m)
+ Control.Concurrent.Mailbox.Wrapper: wrapWriteHandle :: Wrappable m => Handle -> ErrorHandler m -> IO (WrapBox m)
- Control.Concurrent.Mailbox.Wrapper: wrapWriteHandleWithMailbox :: (Wrappable m) => Handle -> Mailbox m -> ErrorHandler m -> IO (WrapBox m)
+ Control.Concurrent.Mailbox.Wrapper: wrapWriteHandleWithMailbox :: Wrappable m => Handle -> Mailbox m -> ErrorHandler m -> IO (WrapBox m)
Files
- README +1/−1
- demo/Message.hs +1/−5
- demo/TestClient.hs +10/−8
- demo/TestServer.hs +16/−9
- epass.cabal +2/−2
- src/Control/Concurrent/Mailbox.hs +61/−23
README view
@@ -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.
demo/Message.hs view
@@ -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
demo/TestClient.hs view
@@ -15,9 +15,9 @@ hFlush hdl inBox <- wrapReadHandle hdl- (\inBox e -> inBox <! (error $ "Handled: " ++ show e))+ (\ inBox e -> inBox <! (MsgError $ show e)) outBox <- wrapWriteHandle hdl- (\_ e -> inBox <! (error $ "Handled: " ++ show e))+ (\ _ e -> inBox <! (MsgError $ show e)) loop inBox outBox 1 mapM close [inBox, outBox]@@ -29,11 +29,13 @@ outBox <! M n receive inBox- [ \(M 10) -> 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) ]
demo/TestServer.hs view
@@ -13,9 +13,9 @@ (hdl, _, _) <- accept sock inBox <- wrapReadHandle hdl- (\inBox e -> inBox <! (error $ "Handled: " ++ show e))+ (\ inBox e -> inBox <! (MsgError $ show e)) outBox <- wrapWriteHandle hdl- (\_ e -> inBox <! (error $ "Handled: " ++ show e))+ (\ _ e -> inBox <! (MsgError $ show e)) loop inBox outBox mapM close [inBox, outBox]@@ -24,16 +24,23 @@ loop :: MailboxClass mb => 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 <! M (-1)- loop inBox outBox- ] $ receive inBox- [ \ (M (n + 1)) -> handler $ do+ putStrLn $ "Matched " ++ show m ++ " non-blocking."+ outBox <! M (-1)+ loop inBox outBox+ ] $ receiveTimeout inBox 1000+ [ \ (MsgError e) -> handler $+ putStrLn $ "received error: " ++ e+ , \ (m@(M (n + 1))) -> handler $ do+ putStrLn $ "Matched " ++ show m ++ " within timeout." outBox <! M (n * 2) loop inBox outBox , \ m -> handler $ do print m loop inBox outBox- ]+ ] $ do+ putStrLn "Timeout"+ loop inBox outBox
epass.cabal view
@@ -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
src/Control/Concurrent/Mailbox.hs view
@@ -113,22 +113,32 @@ yield -- | An alias for 'send' in the flavor of Erlang's @!@.-(<!) :: MailboxClass b => b m -> m -> IO ()+(<!)+ :: MailboxClass b+ => b m+ -> m+ -> IO () (<!) = send -- Timeout calculations (internal) --------------------------------------------- -timeoutFactor :: Num a => 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