Catch exceptions in callbacks

sol · Apr 26, 2011 · b8570ad · b8570ad
1 parent 3294864
commit b8570ad
Show file tree

Hide file tree

Showing 2 changed files with 13 additions and 3 deletions.
diff --git a/Test/QuickCheck/Test.hs b/Test/QuickCheck/Test.hs
@@ -367,11 +367,21 @@ localMinFound st res =
 
 callbackPostTest :: State -> P.Result -> IO ()
 callbackPostTest st res =
-  sequence_ [ f st res | PostTest _ f <- callbacks res ]
+  sequence_ [ safely st (f st res) | PostTest _ f <- callbacks res ]
 
 callbackPostFinalFailure :: State -> P.Result -> IO ()
 callbackPostFinalFailure st res =
-  sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ]
+  sequence_ [ safely st (f st res) | PostFinalFailure _ f <- callbacks res ]
+
+safely :: State -> IO () -> IO ()
+safely st x = do
+  r <- tryEvaluateIO x
+  case r of
+    Left e ->
+      putLine (terminal st)
+        ("*** Exception in callback: " ++ show e)
+    Right x ->
+      return x
 
 --------------------------------------------------------------------------
 -- the end.
diff --git a/examples/Weird.hs b/examples/Weird.hs
@@ -8,7 +8,7 @@ import Test.QuickCheck
 import Test.QuickCheck.Property
 import Test.QuickCheck.Function
 
-prop = callback (PostTest (\_ _ -> putStrLn "\n\n\napa\n\n\n")) f
+prop = callback (PostTest Counterexample (\_ _ -> putStrLn "\n\n\napa\n\n\n")) f
   where f :: Int -> Bool
         f _ = undefined