Eliminate a corner case of losing exception messages

Author: ndmitchell

CHANGES.txt

@@ -1,5 +1,6 @@
 Changelog for Shake (* = breaking change)
 
+    Eliminate a corner case of losing exception messages
     Make FSATrace available as a result type
     Commands which have AutoDeps aren't also linted
     #278, add StdoutTrim - like Stdout, but with trim applied

src/Development/Shake/Internal/Core/Monad.hs

@@ -69,12 +69,14 @@ type Capture a = (a -> IO ()) -> IO ()
 runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)
 runRAW ro rw m k = do
     rw <- newIORef rw
-    handler <- newIORef undefined
+    handler <- newIORef throwIO
     writeIORef handler $ \e -> do
         -- make sure we never call the error continuation twice
         writeIORef handler throwIO
         k $ Left e
-    goRAW handler ro rw m (k . Right)
+    -- If the continuation itself throws an error we need to make sure we
+    -- don't end up running it twice (once with its result, once with its own exception)
+    goRAW handler ro rw m (\v -> do writeIORef handler throwIO; k $ Right v)
         `catch_` \e -> ($ e) =<< readIORef handler
 
 goRAW :: forall ro rw a . IORef (SomeException -> IO ()) -> ro -> IORef rw -> RAW ro rw a -> Capture a

src/Test/Monad.hs

@@ -89,3 +89,11 @@ main = testSimple $ do
                 k $ Left $ toException Overflow
             flip catchRAW (const $ liftIO $ modifyIORef ref ('y':)) $ throwRAW $ toException Overflow
     (===) "xyxyy" =<< readIORef ref
+
+    -- what if we throw an exception inside the continuation of run
+    ref <- newIORef 0
+    res <- try $ runRAW 1 "test" (return 1) $ \_ -> do
+        modifyIORef ref (+1)
+        throwIO Overflow
+    res === Left Overflow
+    (=== 1) =<< readIORef ref