test-framework: Catch exceptions also in sequential runner

1 files changed, 21 insertions, 11 deletions

diff --git a/test-framework/Test/Framework.hs b/test-framework/Test/Framework.hs
index b7d0dc2..5ca0f38 100644
--- a/test-framework/Test/Framework.hs
+++ b/test-framework/Test/Framework.hs
@@ -305,8 +305,7 @@ runTreePar topmparregion revidxlist revpath toptree@Resource{} topoutvar = runRe
       submitOrRunIn mparregion idxlist Nothing $ \makeRegion -> do
         setConsoleRegion makeRegion ('|' : path ++ " [R] making...")
 
-        evalue <- try make
-        case evalue of
+        try make >>= \case
           Left (err :: SomeException) -> do
             finishConsoleRegion makeRegion $
               ansiRed ++ "Exception building resource at " ++ path ++ ":" ++ ansiReset ++ "\n" ++ show err
@@ -320,8 +319,7 @@ runTreePar topmparregion revidxlist revpath toptree@Resource{} topoutvar = runRe
               poolSubmit ?pool idxlist Nothing $ do
                 cleanupRegion <- openConsoleRegion Linear
                 setConsoleRegion cleanupRegion ('|' : path ++ " [R] cleanup...")
-                eres <- try (cleanup value)
-                case eres of
+                try (cleanup value) >>= \case
                   Left (err :: SomeException) -> do
                     finishConsoleRegion cleanupRegion $
                       ansiRed ++ "Exception cleaning up resource at " ++ path ++ ":" ++ ansiReset ++ "\n" ++ show err
@@ -381,18 +379,30 @@ runTreeSeq indent revpath (Group opts name trees) = do
                  ansiGreen ++ "OK" ++ ansiReset ++
                  prettyDuration False (realToFrac (diffUTCTime endtm starttm))
       return (mempty { seqresNumLines = 1 })
-    else return (res <> (mempty { seqresNumLines = 1 }))
-runTreeSeq indent path (Resource _ make cleanup fun) = do
+    else return (res <> mempty { seqresNumLines = 1 })
+runTreeSeq indent revpath (Resource _ make cleanup fun) = do
+  let path = intercalate "/" (reverse revpath)
   outputted <- newIORef False
   let ?testCtx = TestCtx (\str -> do
                    atomicModifyIORef' outputted (\_ -> (True, ()))
-                   putStrLn (ansiYellow ++ "## Warning for " ++ (intercalate "/" (reverse path)) ++
+                   putStrLn (ansiYellow ++ "## Warning for " ++ path ++
                              ":" ++ ansiReset ++ "\n" ++ str))
-  value <- make
-  res <- runTreeSeq indent path (fun value)
-  cleanup value
+  res <- try make >>= \case
+    Left (err :: SomeException) -> do
+      putStrLn $ ansiRed ++ "Exception building resource at " ++ path ++ ":" ++ ansiReset
+      print err
+      return (mempty { seqresAllSuccess = All False })
+    Right value -> do
+      res <- runTreeSeq indent revpath (fun value)
+      try (cleanup value) >>= \case
+        Left (err :: SomeException) -> do
+          putStrLn $ ansiRed ++ "Exception cleaning up resource at " ++ path ++ ":" ++ ansiReset
+          print err
+          return (res { seqresAllSuccess = All False })
+        Right () -> return res
+
   warnings <- readIORef outputted
-  return (res <> (mempty { seqresHaveWarnings = Any warnings }))
+  return (res <> mempty { seqresHaveWarnings = Any warnings })
 runTreeSeq indent path (HP name prop) = do
   let thislen = 2*indent + length name
   let prefix = replicate (2*indent) ' ' ++ name ++ ": " ++ replicate (?maxlen - thislen) ' '