Commits

dave4420 committed eae4268

Exceptions in QuickCheck1 properties no longer cause crashes.

Comments (0)

Files changed (2)

f/quickcheck-exception.hs

+prop_throwsException :: Bool
+prop_throwsException = error "shouldn't crash hstest"
+
         when (verbosity /= NoOutput && shouldExplicitlyReportQCResult result) (G.liftIO $ putStr $ reportQCResult nTest result)
         return (countQCResult result)
   where -- `expr` originally copied from Test.QuickCheck, copyright © Koen Claessen <koen@chalmers.se>, licenced under BSD3
-        expr = concat ["let gen = Test.QuickCheck.evaluate (Test.QuickCheck.property ", nTest, ") in ",
+        expr = concat ["let evaluateList xs = do {Control.Exception.evaluate xs;",
+                                                 "case xs of {",
+                                                      "[] -> return xs;",
+                                                      "x : xs' -> Control.Exception.evaluate x >> evaluateList xs' >> return xs",
+                                                 "}} in ",
+                       "let gen = Test.QuickCheck.evaluate (Test.QuickCheck.property ", nTest, ") in ",
                        "let f rnd0 cPassed cMissed stamps",
                              "| cPassed == 100  = \"Passed\"",
                              "| cMissed == 1000 = \"Exhausted\"",
                                                       "Just True  -> f rnd1 (1 + cPassed) cMissed ",
                                                                         "(Test.QuickCheck.stamp result : stamps);",
                                                       "Just False -> unlines (\"Failed\" : Test.QuickCheck.arguments result)} in ",
-                       "f (System.IO.Unsafe.unsafePerformIO System.Random.newStdGen) 0 0 []"]
+                       "let showException e = return $ unlines [\"Failed\", concat [\"Exception: '\",",
+                                                                         "show (e :: Control.Exception.SomeException), \"'\"]] in ",
+                       "let dof = do {gen <- System.Random.newStdGen;",
+                                     "Control.Exception.catch (evaluateList $ f gen 0 0 []) showException} in ",
+                       "System.IO.Unsafe.unsafePerformIO dof"]
         divineTestResult :: String -> QCResult
         divineTestResult "Passed"                       = QCPassed
         divineTestResult "Exhausted"                    = QCExhausted 1000
 test_runsQuickCheck2 = test'runsPropertyTester QuickCheck2 "f/quickcheck-2.hs"
                         (mreplicate 3 (countResultI iPassedProperty) `mappend` mreplicate 2 (countResultI iFailedProperty))
 
+test'exceptionInTestCodeShouldntCauseCrash qc
+      = runGhc defaultFlags {propertyTester = qc} (runModuleTests'' NoOutput qc "f/quickcheck-exception.hs")
+        >>= HU.assertEqual "" (countQCResult $ QCFailed [])
+test_exceptionInTestCodeShouldntCauseCrashForQuickCheck1 = test'exceptionInTestCodeShouldntCauseCrash QuickCheck1
+test_exceptionInTestCodeShouldntCauseCrashForQuickCheck2 = test'exceptionInTestCodeShouldntCauseCrash QuickCheck2
+
 
 getPackagesExposingModule :: String -> G.Ghc [G.PackageConfig]
 getPackagesExposingModule n = fmap (map fst . filter snd . (`G.lookupModuleInAllPackages` G.mkModuleName n)) G.getSessionDynFlags