diff --git a/Test/Tasty/ExpectedFailure.hs b/Test/Tasty/ExpectedFailure.hs --- a/Test/Tasty/ExpectedFailure.hs +++ b/Test/Tasty/ExpectedFailure.hs @@ -1,35 +1,111 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, LambdaCase #-} module Test.Tasty.ExpectedFailure (expectFail, expectFailBecause, ignoreTest, ignoreTestBecause, wrapTest) where import Test.Tasty.Options import Test.Tasty.Runners import Test.Tasty.Providers +#if MIN_VERSION_tasty(1,3,1) +import Test.Tasty.Providers.ConsoleFormat ( ResultDetailsPrinter(..) ) +#endif +import Test.Tasty ( Timeout(..), askOption, localOption ) import Data.Typeable import Data.Tagged import Data.Maybe import Data.Monoid +import Control.Exception ( displayException, evaluate, try, SomeException ) +import Control.Concurrent.Timeout ( timeout ) -data WrappedTest t = WrappedTest (IO Result -> IO Result) t + +data WrappedTest t = WrappedTest Timeout (IO Result -> IO Result) t deriving Typeable instance forall t. IsTest t => IsTest (WrappedTest t) where - run opts (WrappedTest wrap t) prog = wrap (run opts t prog) + run opts (WrappedTest tmout wrap t) prog = + -- Re-implement timeouts and exception handling *inside* the + -- wrapper. The primary location for timeout and exception + -- handling is in `executeTest` in the Tasty module's + -- Test.Tasty.Run implementation, but that handling is above the + -- level of this wrapper which therefore cannot absorb timeouts + -- and exceptions as *expected* failures. + let (pre,post) = case tmout of + NoTimeout -> (fmap Just, fromJust) + Timeout t s -> (timeout t, fromMaybe (timeoutResult t s)) + timeoutResult t s = + Result { resultOutcome = Failure $ TestTimedOut t + , resultDescription = "Timed out after " <> s + , resultShortDescription = "TIMEOUT" + , resultTime = fromIntegral t +#if MIN_VERSION_tasty(1,3,1) + , resultDetailsPrinter = ResultDetailsPrinter . const . const $ return () +#endif + } + exceptionResult e = + Result { resultOutcome = Failure $ TestThrewException e + , resultDescription = "Exception: " ++ displayException e + , resultShortDescription = "FAIL" + , resultTime = 0 +#if MIN_VERSION_tasty(1,3,1) + , resultDetailsPrinter = ResultDetailsPrinter . const . const $ return () +#endif + } + forceList = foldr seq () + in wrap $ try (pre (run opts t prog + -- Ensure exceptions trying to show the + -- failure result are caught as "expected" + -- (see Issue #24 and note below) + >>= \r -> evaluate (forceList (resultDescription r) `seq` + forceList (resultShortDescription r) `seq` + resultOutcome r `seq` + r))) + >>= \case + Right r -> return (post r) + Left (e :: SomeException) -> return $ exceptionResult e testOptions = retag (testOptions :: Tagged t [OptionDescription]) + -- Note regarding post-run evaluate above: + -- + -- The normal behavior of tasty-expected-failure is to run the + -- test, show the failure result, but then note that the failure + -- is expected and not count that against a test failure. If the + -- test unexpectedly succeeds, a message to that effect is + -- printed, but there is no resultDescription display of the test + -- inputs. + -- + -- As of Tasty 1.4, the core tasty code was enhanced to fix issue + -- #280 in tasty: essentially the test result report is forced. + -- However, when used with tests expected to fail that also throw + -- exceptions when attempting to show the result, the forcing in + -- Tasty 1.4 causes an exception to be thrown after the + -- tasty-expected-failure protections but still within the realm + -- where tasty would count it as a failure. The fix here attempts + -- to `show` the failing value here in tasty-expected-failure; if + -- an exception occurs during that `show` then code here will + -- report it (somewhat incorrectly) via the exceptionResult above, + -- where tasty's subsequent forcing of the text of that + -- exceptionResult no longer causes an exception *there*. Since + -- the value is only shown if there was already a failure, the + -- reason is misleading but the outcome is consistent with the + -- intent of tasty-expected-failure handling. + + -- | 'wrapTest' allows you to modify the behaviour of the tests, e.g. by -- modifying the result or not running the test at all. It is used to implement -- 'expectFail' and 'ignoreTest'. wrapTest :: (IO Result -> IO Result) -> TestTree -> TestTree wrapTest wrap = go where - go (SingleTest n t) = SingleTest n (WrappedTest wrap t) + go (SingleTest n t) = + askOption $ \(old_timeout :: Timeout) -> + localOption NoTimeout $ -- disable Tasty's timeout; handled here instead + SingleTest n (WrappedTest old_timeout wrap t) go (TestGroup name tests) = TestGroup name (map go tests) go (PlusTestOptions plus tree) = PlusTestOptions plus (go tree) go (WithResource spec gentree) = WithResource spec (go . gentree) go (AskOptions f) = AskOptions (go . f) --- | Marks all tests in the give test as expected failures: The tests will +-- | Marks all tests in the given test suite as expected failures: The tests will -- still be run, but if they succeed, it is reported as a test suite failure, -- and conversely a the failure of the test is ignored. -- @@ -56,13 +132,13 @@ change r | resultSuccessful r = r { resultOutcome = Failure TestFailed - , resultDescription = resultDescription r <> "(unexpected success" <> comment <> ")" - , resultShortDescription = "PASS (unexpected" <> comment <> ")" + , resultDescription = resultDescription r <> " (unexpected success" <> comment <> ")" + , resultShortDescription = resultShortDescription r <> " (unexpected" <> comment <> ")" } | otherwise = r { resultOutcome = Success - , resultDescription = resultDescription r <> "(expected failure)" - , resultShortDescription = "FAIL (expected" <> comment <> ")" + , resultDescription = resultDescription r <> " (expected failure)" + , resultShortDescription = resultShortDescription r <> " (expected" <> comment <> ")" } "" `append` s = s t `append` s | last t == '\n' = t ++ s ++ "\n" @@ -92,6 +168,6 @@ ignoreTest' :: Maybe String -> TestTree -> TestTree ignoreTest' reason = wrapTest $ const $ return $ - (testPassed "") { - resultShortDescription = "IGNORED" <> maybe "" (mappend ": ") reason + (testPassed $ fromMaybe "" reason) { + resultShortDescription = "IGNORED" } diff --git a/tasty-expected-failure.cabal b/tasty-expected-failure.cabal --- a/tasty-expected-failure.cabal +++ b/tasty-expected-failure.cabal @@ -1,5 +1,5 @@ name: tasty-expected-failure -version: 0.11.1.2 +version: 0.12.3 synopsis: Mark tasty tests as failure expected description: With the function 'Test.Tasty.ExpectedFailure.expectFail' in the provided module @@ -27,17 +27,42 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10 -tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 library exposed-modules: Test.Tasty.ExpectedFailure build-depends: - base >= 4.5 && <4.14, + base >= 4.9 && <5, tagged >= 0.7 && < 0.9, - tasty >= 0.11 + tasty >= 0.11, + unbounded-delays < 0.2 default-language: Haskell2010 source-repository head type: git location: git://github.com/nomeata/tasty-expected-failure + + +test-suite expected-fail-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: TestExpectedFails.hs + build-depends: base, + tasty, + tasty-hunit, + tasty-golden, + tasty-expected-failure + + +test-suite expected-fail-hh-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + main-is: TestExpectedFailsHH.hs + build-depends: base, + hedgehog, + tasty, + tasty-hedgehog, + tasty-expected-failure diff --git a/tests/TestExpectedFails.hs b/tests/TestExpectedFails.hs new file mode 100644 --- /dev/null +++ b/tests/TestExpectedFails.hs @@ -0,0 +1,50 @@ +import Control.Concurrent (threadDelay) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.Golden +import Test.Tasty.HUnit + +-- n.b. running via `cabal v2-test` outputs plaintext, but running via +-- `cabal v2-run test:expected-fail-tests` will generate colorized +-- output. It's adviseable to visually inspect this output to ensure +-- that "PASS (unexpected)" is rendered in Red and "FAIL (expected)" +-- is rendered in Green. + +main = defaultMain $ + localOption (mkTimeout 1000000) $ -- 1s + testGroup "Expected Failures" $ + [ testCase "clearly good" $ 1 + 1 @=? 2 + , expectFail $ testCase "clearly bad" $ 1 + 1 @=? 3 + + -- n.b. uncomment this to observe the results of a test that was + -- , expectFail $ testCase "also good" $ 1 + 2 @=? 3 + + , expectFail $ expectFail $ testCase "two wrongs make a right" $ 1 + 1 @=? 2 + + , expectFail $ testCase "throws failure" $ fail "bad" + , expectFail $ testCase "throws error" $ error "also bad" + + , expectFail $ testCase "takes too long" $ threadDelay 2000000 + + , expectFail $ goldenVsString "hello" "hello.out" $ return $ error "not golden" + + -- Issue 24 + , expectFail $ testCase "this is expected to fail" + (mrtOne (someFunc "Hello, world!") @?= "") + + , expectFail $ testCase "this is also expected to fail" + (someFunc "Hello, world!" @?= MyResultType { mrtOne = "", mrtTwo = "" }) + ] + + +data MyResultType = MyResultType { mrtOne :: String + , mrtTwo :: String + } + deriving (Eq, Show) + +someFunc :: String -> MyResultType +someFunc fp = MyResultType + { + mrtOne = fp + , mrtTwo = undefined + } diff --git a/tests/TestExpectedFailsHH.hs b/tests/TestExpectedFailsHH.hs new file mode 100644 --- /dev/null +++ b/tests/TestExpectedFailsHH.hs @@ -0,0 +1,40 @@ +import Control.Concurrent ( threadDelay ) +import Control.Monad.IO.Class ( liftIO ) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.Hedgehog + +-- n.b. running via `cabal v2-test` outputs plaintext, but running via +-- `cabal v2-run test:expected-fail-tests` will generate colorized +-- output. It's adviseable to visually inspect this output to ensure +-- that "PASS (unexpected)" is rendered in Red and "FAIL (expected)" +-- is rendered in Green. + +main = defaultMain $ + localOption (mkTimeout 1000000) $ -- 1s + testGroup "Expected Hedgehog Failures" $ + [ testProperty "good" $ property $ success + , expectFail $ testProperty "rarely good" $ property $ do + xs <- forAll $ Gen.list (Range.linear 0 10) Gen.alpha + reverse xs === xs + + -- n.b. uncomment this to observe the results of a test that was + -- expected to fail but actually passes. + -- , expectFail $ testProperty "surprisingly good" $ property $ success + + , expectFail $ testProperty "giving up" $ property $ discard + + , expectFail $ expectFail $ testProperty "the failure of a failure is my good" $ + property $ success + + , expectFail $ testProperty "throws failure" $ + property $ fail "bad" + + , expectFail $ testProperty "too slow" $ + property $ do + liftIO $ threadDelay 2000000 + success + ]