module Test.Framework.Providers.Sandbox (
sandboxTests
, sandboxTest
, sandboxTestGroup
, sandboxTestGroup'
, yieldProgress
) where
import Control.Concurrent
import Control.Exception.Lifted
import Control.Monad hiding (fail)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Error (runErrorT)
import Control.Monad.Trans.State.Strict
import Data.Either
import Prelude hiding (error, fail)
import qualified Prelude (error)
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 Test.Sandbox
import Test.Sandbox.Internals hiding (putOptions)
import Test.Framework.Providers.Sandbox.Internals
sandboxTests :: String
-> Sandbox Test
-> Test
sandboxTests name test = buildTest $ do
options <- interpretArgs =<< getArgs
mvar <- newEmptyMVar :: IO (MVar Int)
return $ mutuallyExclusive $ testGroup name [
buildTestBracketed $
withSystemTempDirectory (name ++ "_") $ \dir -> do
env <- newSandboxState name dir
(result, env') <- (runStateT . runErrorT . runSandbox) (putOptions options >> test) env
let cleanup = (evalStateT . runErrorT . runSandbox) (silently stopAll) env'
>>= either putStrLn return
>> putMVar mvar 0
case result of
Left error -> return (Test name (SandboxTest (Failure error)), cleanup)
Right x -> return (x, cleanup)
, Test "cleaning" (SandboxCleaning mvar) ]
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 <- Sandbox $ do
env <- lift get
(res, env') <- liftIO $ flip (runStateT . runErrorT . runSandbox) env $ test `catches` handlers
lift $ put env'
return res
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 e = stopAll >> throw e
interruptHandler :: AsyncException -> Sandbox a
interruptHandler UserInterrupt = stopAll >> liftIO exitFailure
interruptHandler e = Sandbox . throwError . show $ e
otherHandler :: SomeException -> Sandbox a
otherHandler = Sandbox . 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