Commit 9c41ff02 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Add support for known broken tests.



Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 749fd0cb
......@@ -29,6 +29,11 @@ module Test.Cabal.Monad (
skipIf,
skipUnless,
skipExitCode,
-- * Known broken tests
expectedBroken,
unexpectedSuccess,
expectedBrokenExitCode,
unexpectedSuccessExitCode,
-- whenHasSharedLibraries,
-- * Arguments (TODO: move me)
CommonArgs(..),
......@@ -115,9 +120,25 @@ skipIf b = when b skip
skipUnless :: Bool -> TestM ()
skipUnless b = unless b skip
expectedBroken :: TestM ()
expectedBroken = liftIO $ do
putStrLn "EXPECTED FAIL"
exitWith (ExitFailure expectedBrokenExitCode)
unexpectedSuccess :: TestM ()
unexpectedSuccess = liftIO $ do
putStrLn "UNEXPECTED OK"
exitWith (ExitFailure unexpectedSuccessExitCode)
skipExitCode :: Int
skipExitCode = 64
expectedBrokenExitCode :: Int
expectedBrokenExitCode = 65
unexpectedSuccessExitCode :: Int
unexpectedSuccessExitCode = 66
setupAndCabalTest :: TestM () -> IO ()
setupAndCabalTest m = runTestM $ do
env <- getTestEnv
......
......@@ -42,6 +42,7 @@ import Distribution.Compat.Stack
import Text.Regex.Posix
import Control.Concurrent.Async
import qualified Data.Aeson as JSON
import qualified Data.ByteString.Lazy as BSL
import Control.Monad
......@@ -502,6 +503,22 @@ hasCabalForGhc = do
-- will be picked up by the package db stack of ghc-program
return (programPath ghc_program == programPath runner_ghc_program)
------------------------------------------------------------------------
-- * Broken tests
expectBroken :: Int -> TestM a -> TestM ()
expectBroken ticket m = do
env <- getTestEnv
liftIO . withAsync (runReaderT m env) $ \a -> do
r <- waitCatch a
case r of
Left e -> do
putStrLn $ "This test is known broken, see #" ++ show ticket ++ ":"
print e
runReaderT expectedBroken env
Right _ -> do
runReaderT unexpectedSuccess env
------------------------------------------------------------------------
-- * Miscellaneous
......
......@@ -124,7 +124,8 @@ main = do
-- for each. But for now, just run them earlier to avoid
-- them straggling at the end
work_queue <- newMVar all_tests
failed_tests <- newMVar []
unexpected_fails_var <- newMVar []
unexpected_passes_var <- newMVar []
chan <- newChan
let logAll msg = writeChan chan (ServerLogMsg AllServers msg)
......@@ -160,6 +161,10 @@ main = do
= "OK"
| resultExitCode r == ExitFailure skipExitCode
= "SKIP"
| resultExitCode r == ExitFailure expectedBrokenExitCode
= "KNOWN FAIL"
| resultExitCode r == ExitFailure unexpectedSuccessExitCode
= "UNEXPECTED OK"
| otherwise
= "FAIL"
unless (mainArgHideSuccesses args && status /= "FAIL") $ do
......@@ -172,7 +177,11 @@ main = do
logMeta $ "$ " ++ resultCommand r ++ "\n"
++ resultOutput r ++ "\n"
++ "FAILED " ++ path
modifyMVar_ failed_tests $ \paths -> return (path:paths)
modifyMVar_ unexpected_fails_var $ \paths ->
return (path:paths)
when (status == "UNEXPECTED OK") $
modifyMVar_ unexpected_passes_var $ \paths ->
return (path:paths)
go server
mask $ \restore -> do
......@@ -208,12 +217,16 @@ main = do
-- Propagate the exception
throwIO (e :: SomeException)
failed <- takeMVar failed_tests
logAll $
if not (null failed)
then "FAILED TESTS: " ++ intercalate " " failed
else "OK"
when (not (null failed)) exitFailure
unexpected_fails <- takeMVar unexpected_fails_var
unexpected_passes <- takeMVar unexpected_passes_var
if not (null (unexpected_fails ++ unexpected_passes))
then do
unless (null unexpected_passes) . logAll $
"UNEXPECTED OK: " ++ intercalate " " unexpected_passes
unless (null unexpected_fails) . logAll $
"UNEXPECTED FAIL: " ++ intercalate " " unexpected_fails
exitFailure
else logAll "OK"
findTests :: IO [FilePath]
findTests = getDirectoryContentsRecursive "."
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment