From 894f428a5b2074d8fd6ce16c768583b92016df59 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 18 Nov 2014 18:37:20 +0200
Subject: [PATCH] Better compressor-status termination messages

---
 Handler/Haddock.hs | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs
index 9d764cc..a9ace97 100644
--- a/Handler/Haddock.hs
+++ b/Handler/Haddock.hs
@@ -94,13 +94,19 @@ createCompressor
 createCompressor dirs = do
     baton <- newMVar ()
     status <- newIORef "Compressor is idle"
-    mask_ $ void $ forkIO $ (`finally` writeIORef status "Compressor thread exited") $ forever $ do
+    mask_ $ void $ forkIO $ (finallyE $ \e -> writeIORef status $ "Compressor thread exited: " ++ tshow e) $ forever $ do
         writeIORef status "Waiting for signal to start compressing"
         takeMVar baton
         writeIORef status "Received signal, traversing directories"
         runResourceT $ goDir status (dirRawRoot dirs)
     return (status, void $ tryPutMVar baton ())
   where
+    finallyE f g = mask $ \restore -> do
+        restore g `catch` \e -> do
+            () <- f $ Just (e :: SomeException)
+            () <- throwIO e
+            return ()
+        f Nothing
     goDir status dir = do
         writeIORef status $ "Compressing directory: " ++ fpToText dir
         sourceDirectory dir $$ mapM_C (goFP status)