diff --git a/Test/Tasty/ExpectedFailure.hs b/Test/Tasty/ExpectedFailure.hs --- a/Test/Tasty/ExpectedFailure.hs +++ b/Test/Tasty/ExpectedFailure.hs @@ -1,19 +1,58 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +{-# 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 +import Test.Tasty ( Timeout(..) ) import Data.Typeable import Data.Tagged import Data.Maybe import Data.Monoid +import Control.Exception ( displayException, try, SomeException ) +import Control.Concurrent.Timeout ( timeout ) + data WrappedTest t = WrappedTest (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 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 lookupOption opts of + NoTimeout -> (fmap Just, fromJust) + Timeout t s -> (timeout (faster t), fromMaybe (timeoutResult t s)) + -- 'faster' has to shorten the user-specified timeout by a + -- small amount because the main Timeout option is + -- separately passed to `executeTest` and that one will + -- usually fire first if both have the same timeout. This + -- is a really kludgy hack, but the assumption is that most + -- test timeouts have low resolution, so making the timeout + -- slightly faster isn't significant in the overall sense. + -- If it is, the test writer will hopefully find this + -- comment, increase their timeout specification + -- accordingly, and not curse us too heavily. + faster t = t - 2000 -- must specify a timeout period that will *fire* faster than the original + timeoutResult t s = + Result { resultOutcome = Failure $ TestTimedOut t + , resultDescription = "Timed out after " <> s + , resultShortDescription = "TIMEOUT" + , resultTime = fromIntegral t + } + exceptionResult e = + Result { resultOutcome = Failure $ TestThrewException e + , resultDescription = "Exception: " ++ displayException e + , resultShortDescription = "FAIL" + , resultTime = 0 + } + in wrap $ try (pre $ run opts t prog) >>= \case + Right r -> return (post r) + Left (e :: SomeException) -> return $ exceptionResult e testOptions = retag (testOptions :: Tagged t [OptionDescription]) -- | 'wrapTest' allows you to modify the behaviour of the tests, e.g. by @@ -56,13 +95,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" 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 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,30 @@ +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" + ] 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 + ]