Fixed breakage on GHC 6.10.1

[Lucu.git] / Network / HTTP / Lucu / ResponseWriter.hs

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 52f6cf3476e1613c3e99c07805b1b467d33ccf85..3ab4bda714fc37295a3f2992e854e4179518e722 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -22,29 +22,27 @@ import           System.IO
 
 
 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
-responseWriter cnf h tQueue readerTID
-    = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
-      catch awaitSomethingToWrite $ \ exc ->
-      case exc of
-        IOException _               -> return ()
-        AsyncException ThreadKilled -> return ()
-        BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
-        _                           -> print exc
+responseWriter !cnf !h !tQueue !readerTID
+    = awaitSomethingToWrite
+      `catches`
+      [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
+      , Handler  ( \ ThreadKilled        -> return () )
+      , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
+      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+      ]
     where
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
           = {-# SCC "awaitSomethingToWrite" #-}
             do action
                    <- atomically $!
-                      do -- キューが空でなくなるまで待つ
-                         queue <- readTVar tQueue
-                         when (S.null queue)
-                              retry
-
+                      -- キューが空でなくなるまで待つ
+                      do queue <- readTVar tQueue
                          -- GettingBody 状態にあり、Continue が期待され
                          -- てゐて、それがまだ送信前なのであれば、
                          -- Continue を送信する。
                          case S.viewr queue of
+                           EmptyR   -> retry
                            _ :> itr -> do state <- readItr itr itrState id
 
                                           if state == GettingBody then
@@ -163,6 +161,7 @@ responseWriter cnf h tQueue readerTID
                             do queue <- readTVar tQueue
 
                                case S.viewr queue of
+                                 EmptyR         -> return () -- this should never happen
                                  remaining :> _ -> writeTVar tQueue remaining
 
                                readItr itr itrWillClose id