diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 861538692aab842a1b9cc4aba3042f5d8afca333..3dd1c747d3248536de16417943c2c62a0b8f81ff 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.hs @@ -45,12 +45,14 @@ module Test.Cabal.Monad ( testActualFile, -- * Skipping tests skip, + skipIO, skipIf, + skipIfIO, skipUnless, + skipUnlessIO, -- * Known broken tests expectedBroken, unexpectedSuccess, - -- whenHasSharedLibraries, -- * Arguments (TODO: move me) CommonArgs(..), renderCommonArgs, @@ -176,23 +178,32 @@ testArgParser = TestArgs <*> argument str ( metavar "FILE") <*> commonArgParser -skip :: String -> TestM () -skip reason = liftIO $ do +skipIO :: String -> IO () +skipIO reason = do putStrLn ("SKIP " ++ reason) E.throwIO (TestCodeSkip reason) +skip :: String -> TestM () +skip = liftIO . skipIO + +skipIfIO :: String -> Bool -> IO () +skipIfIO reason b = when b (skipIO reason) + skipIf :: String -> Bool -> TestM () skipIf reason b = when b (skip reason) +skipUnlessIO :: String -> Bool -> IO () +skipUnlessIO reason b = unless b (skipIO reason) + skipUnless :: String -> Bool -> TestM () skipUnless reason b = unless b (skip reason) -expectedBroken :: TestM () -expectedBroken = liftIO $ do +expectedBroken :: Int -> TestM a +expectedBroken t = liftIO $ do putStrLn "EXPECTED FAIL" - E.throwIO TestCodeKnownFail + E.throwIO (TestCodeKnownFail t) -unexpectedSuccess :: TestM () +unexpectedSuccess :: TestM a unexpectedSuccess = liftIO $ do putStrLn "UNEXPECTED OK" E.throwIO TestCodeUnexpectedOk diff --git a/cabal-testsuite/src/Test/Cabal/TestCode.hs b/cabal-testsuite/src/Test/Cabal/TestCode.hs index e29c9ea6b45701e828424040a4182fdaf2404f86..4d0762bdae5b867f2b328bcb81451ade45227615 100644 --- a/cabal-testsuite/src/Test/Cabal/TestCode.hs +++ b/cabal-testsuite/src/Test/Cabal/TestCode.hs @@ -19,7 +19,7 @@ import Data.Typeable (Typeable) data TestCode = TestCodeOk | TestCodeSkip String - | TestCodeKnownFail + | TestCodeKnownFail Int | TestCodeUnexpectedOk | TestCodeFail deriving (Eq, Show, Read, Typeable) @@ -31,11 +31,11 @@ instance Exception TestCode #endif displayTestCode :: TestCode -> String -displayTestCode TestCodeOk = "OK" -displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg -displayTestCode TestCodeKnownFail = "OK (known failure)" -displayTestCode TestCodeUnexpectedOk = "FAIL (unexpected success)" -displayTestCode TestCodeFail = "FAIL" +displayTestCode TestCodeOk = "OK" +displayTestCode (TestCodeSkip msg) = "SKIP " ++ msg +displayTestCode (TestCodeKnownFail t) = "OK (known failure, see #" <> show t <> ")" +displayTestCode TestCodeUnexpectedOk = "FAIL (unexpected success)" +displayTestCode TestCodeFail = "FAIL" isTestCodeSkip :: TestCode -> Bool isTestCodeSkip (TestCodeSkip _) = True