module Test.Framework.Providers.Sandbox (
sandboxTests
, sandboxTest
, sandboxTestGroup
, sandboxTestGroup'
, yieldProgress
, withRetry
) where
import Control.Exception.Lifted
import Control.Monad hiding (fail)
import Control.Monad.Reader (ask)
import System.Console.ANSI
import System.Environment
import System.Exit
import System.IO
import System.IO.Temp
import Test.Framework
import Test.Framework.Providers.API (Test (..))
import Data.Typeable
import Test.Sandbox
import Test.Sandbox.Internals hiding (putOptions)
import Test.Framework.Providers.Sandbox.Internals
sandboxTests :: String
-> [Sandbox Test]
-> Test
sandboxTests name tests = testGroup name [
buildTest $ do
options <- interpretArgs =<< getArgs
if isExcluded options name then return $ Test name (SandboxTest Skipped)
else withSystemTempDirectory (name ++ "_") $ \dir -> do
env <- newSandboxState name dir
result <- runSandbox (putOptions options >> sandboxTestGroup name tests `finally` stopAll) env
case result of
Left error' -> return $ Test name (SandboxTest (Failure error'))
Right x -> return x
]
sandboxTestGroup :: String
-> [Sandbox Test]
-> Sandbox Test
sandboxTestGroup name tests = withTest name $ do
liftIO $ putStrLn ""
liftM (testGroup name) (sequence tests)
sandboxTestGroup' :: String
-> Sandbox Bool
-> [Sandbox Test]
-> Sandbox Test
sandboxTestGroup' name condition tests = do
result <- condition
if result then
sandboxTestGroup name tests
else return $ Test (name ++ " (disabled)") (SandboxTest Skipped)
sandboxTest :: String
-> Sandbox ()
-> Sandbox Test
sandboxTest name test = withTest name $ do
res <- do
ref <- ask
liftIO $ flip runSandbox ref $ test `catches` handlers
liftIO $ printTestResult res
case res of
Left error' -> return $ Test name (SandboxTest (Failure error'))
Right _ -> return $ Test name (SandboxTest Passed)
where handlers = [ Handler exitHandler
, Handler interruptHandler
, Handler otherHandler ]
exitHandler :: ExitCode -> Sandbox a
exitHandler = throw
interruptHandler :: AsyncException -> Sandbox a
interruptHandler UserInterrupt = liftIO exitFailure
interruptHandler e = throwError $ show e
otherHandler :: SomeException -> Sandbox a
otherHandler = throwError . show
yieldProgress :: String
-> Sandbox ()
yieldProgress p = do
pl <- getVariable prettyPrintVariable []
unless (null pl) $ liftIO $ putStr " / "
_ <- setVariable prettyPrintVariable (p : pl)
liftIO $ putStrColor Dull Blue p >> hFlush stdout
class SandboxRetry a where
withRetry :: Int -> Sandbox a -> Sandbox a
instance SandboxRetry Test where
withRetry num action =
if num <= 1
then action
else do
res <- action
if isPassed res
then return res
else withRetry (num 1) action
isPassed :: Test -> Bool
isPassed test =
case test of
(Test _ res') ->
case cast res' of
(Just (SandboxTest Passed)) -> True
_ -> False
(TestGroup _ tests) -> and $ map isPassed tests
_ -> error "withRetry does not support this test-type."
instance SandboxRetry () where
withRetry num action =
if num <= 1
then action
else action `catchError` (\_ -> withRetry (num 1) action)