Now sending an MsgError in case of error.

baldo · Oct 12, 2010 · 58aa748 · 58aa748
1 parent b2f61f9
commit 58aa748
Show file tree

Hide file tree

Showing 3 changed files with 22 additions and 20 deletions.
diff --git a/demo/Message.hs b/demo/Message.hs
@@ -1,20 +1,16 @@
 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
   deriving (Read, Show)
 

diff --git a/demo/TestClient.hs b/demo/TestClient.hs
@@ -15,9 +15,9 @@ main = do
     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 @@ loop inBox outBox n = do
     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)
         ]
 
diff --git a/demo/TestServer.hs b/demo/TestServer.hs
@@ -13,9 +13,9 @@ main = do
     (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,13 +24,17 @@ main = do
 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
+                putStrLn $ "Matched " ++ show m ++ " non-blocking."
+                outBox <! M (-1)
+                loop inBox outBox
         ] $ receiveTimeout inBox 1000
-                [ \ (m@(M (n + 1))) -> handler $ do
+                [ \ (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