diff --git a/Test/Tasty.hs b/Test/Tasty.hs --- a/Test/Tasty.hs +++ b/Test/Tasty.hs @@ -10,12 +10,14 @@ , defaultMain , defaultMainWithIngredients , defaultIngredients - -- * Adjusting options + , includingOptions + -- * Adjusting and querying options -- | Normally options are specified on the command line. But you can -- also have different options for different subtrees in the same tree, -- using the functions below. , adjustOption , localOption + , askOption -- * Resources -- | Sometimes several tests need to access the same resource — say, -- a file or a socket. We want to create or grab the resource before @@ -30,6 +32,7 @@ import Test.Tasty.Core import Test.Tasty.Runners import Test.Tasty.Options +import Test.Tasty.Ingredients.IncludingOptions -- | List of the default ingredients. This is what 'defaultMain' uses. -- @@ -49,6 +52,9 @@ -- | Locally set the option value for the given test subtree localOption :: IsOption v => v -> TestTree -> TestTree localOption v = PlusTestOptions (setOption v) + +askOption :: IsOption v => (v -> TestTree) -> TestTree +askOption f = AskOptions $ f . lookupOption -- | Add resource initialization and finalization to the test tree withResource diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs --- a/Test/Tasty/Core.hs +++ b/Test/Tasty/Core.hs @@ -85,6 +85,7 @@ | PlusTestOptions (OptionSet -> OptionSet) TestTree -- ^ Add some options to child tests | WithResource ResourceSpec TestTree + | AskOptions (OptionSet -> TestTree) -- | Create a named group of test cases or other groups testGroup :: TestName -> [TestTree] -> TestTree @@ -130,6 +131,7 @@ fGroup name $ foldMap (go pat (path ++ [name]) opts) trees PlusTestOptions f tree -> go pat path (f opts) tree WithResource res tree -> fResource res (go pat path opts tree) + AskOptions f -> go pat path opts (f opts) -- | Useful wrapper for use with foldTestTree newtype AppMonoid f = AppMonoid { getApp :: f () } diff --git a/Test/Tasty/Ingredients/IncludingOptions.hs b/Test/Tasty/Ingredients/IncludingOptions.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Ingredients/IncludingOptions.hs @@ -0,0 +1,11 @@ +module Test.Tasty.Ingredients.IncludingOptions where + +import Test.Tasty.Ingredients +import Test.Tasty.Options + +-- | This ingredient doesn't do anything apart from registering additional +-- options. +-- +-- The option values can be accessed using 'askOption'. +includingOptions :: [OptionDescription] -> Ingredient +includingOptions opts = TestManager opts (\_ _ -> Nothing) diff --git a/Test/Tasty/Run.hs b/Test/Tasty/Run.hs --- a/Test/Tasty/Run.hs +++ b/Test/Tasty/Run.hs @@ -1,4 +1,5 @@ -- | Running tests +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-} module Test.Tasty.Run ( Status(..) , StatusMap @@ -6,8 +7,12 @@ ) where import qualified Data.IntMap as IntMap +import qualified Data.Sequence as Seq +import qualified Data.Foldable as F import Control.Monad.State import Control.Monad.Writer +import Control.Monad.Reader +import Control.Monad.Trans.Either import Control.Concurrent import Control.Concurrent.STM import Control.Exception @@ -36,6 +41,21 @@ -- detect when tests finish. type StatusMap = IntMap.IntMap (TVar Status) +data Resource r + = NotCreated + | FailedToCreate SomeException + | Created r + +data Initializer + = forall res . Initializer + (IO res) + (MVar (Resource res)) +data Finalizer + = forall res . Finalizer + (res -> IO ()) + (MVar (Resource res)) + (MVar Int) + -- | Start executing a test -- -- Note: we take the finalizer as an argument because it's important that @@ -46,74 +66,101 @@ -- ^ the action to execute the test, which takes a progress callback as -- a parameter -> TVar Status -- ^ variable to write status to - -> IO () -- ^ finalizer + -> Seq.Seq Initializer -- ^ initializers (to be executed in this order) + -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order) -> IO () -executeTest action statusVar fin = do - result <- handleExceptions $ - -- pass our callback (which updates the status variable) to the test - -- action - action yieldProgress +executeTest action statusVar inits fins = + handle (atomically . writeTVar statusVar . Exception) $ do + -- We don't try to protect against async exceptions here. + -- This is because we use interruptible modifyMVar and wouldn't be able + -- to give any guarantees anyway. + -- So all we do is guard actual acquire/test/release actions using 'try'. + -- The only thing we guarantee upon catching an async exception is that + -- we'll write it to the status var, so that the UI won't be waiting + -- infinitely. + resultOrExcn <- runEitherT $ do + F.forM_ inits $ \(Initializer doInit initVar) -> EitherT $ + modifyMVar initVar $ \resStatus -> + case resStatus of + NotCreated -> do + mbRes <- try doInit + case mbRes of + Right res -> return (Created res, Right ()) + Left ex -> return (FailedToCreate ex, Left ex) + Created {} -> return (resStatus, Right ()) + FailedToCreate ex -> return (resStatus, Left ex) - fin `finally` - -- when the test is finished, write its result to the status variable - (atomically $ writeTVar statusVar result) + -- if all initializers ran successfully, actually run the test + EitherT . try $ + -- pass our callback (which updates the status variable) to the test + -- action + action yieldProgress + -- no matter what, try to run each finalizer + -- remember the first exception that occurred + mbExcn <- liftM getFirst . execWriterT . getApp $ + flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) -> + AppMonoid $ do + mbExcn <- + liftIO $ modifyMVar finishVar $ \nUsers -> do + let nUsers' = nUsers - 1 + mbExcn <- + if nUsers' == 0 + then do + resStatus <- readMVar initVar + case resStatus of + Created res -> + either + (\ex -> Just ex) + (\_ -> Nothing) + <$> try (doRelease res) + _ -> return Nothing + else return Nothing + return (nUsers', mbExcn) -- end of modifyMVar + + tell $ First mbExcn + + atomically . writeTVar statusVar $ + case resultOrExcn <* maybe (return ()) Left mbExcn of + Left ex -> Exception ex + Right r -> Done r + where -- the callback yieldProgress progress = atomically $ writeTVar statusVar $ Executing progress - handleExceptions a = do - resultOrException <- try a - case resultOrException of - Left e - | Just async <- fromException e - -> throwIO (async :: AsyncException) -- user interrupt, etc - - | otherwise - -> return $ Exception e - - Right result -> return $ Done result +type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer) -- | Prepare the test tree to be run createTestActions :: OptionSet -> TestTree -> IO [(IO (), TVar Status)] createTestActions opts tree = - liftM (map $ first $ ($ return ())) $ -- no more finalizers will be added + liftM (map (first ($ (Seq.empty, Seq.empty)))) $ execWriterT $ getApp $ - foldTestTree + (foldTestTree runSingleTest (const id) addInitAndRelease opts tree + :: AppMonoid (WriterT [(InitFinPair -> IO (), TVar Status)] IO)) where runSingleTest opts _ test = AppMonoid $ do statusVar <- liftIO $ atomically $ newTVar NotStarted let - act = - executeTest (run opts test) statusVar + act (inits, fins) = + executeTest (run opts test) statusVar inits fins tell [(act, statusVar)] addInitAndRelease (ResourceSpec doInit doRelease) a = AppMonoid . WriterT . fmap ((,) ()) $ do tests <- execWriterT $ getApp a let ntests = length tests - initVar <- newMVar Nothing + initVar <- newMVar NotCreated finishVar <- newMVar ntests let - init = do - modifyMVar initVar $ \mbRes -> - case mbRes of - Nothing -> do - res <- doInit - return (Just res, res) - Just res -> return (mbRes, res) - release x = do - modifyMVar_ finishVar $ \nUsers -> do - let nUsers' = nUsers - 1 - when (nUsers' == 0) $ - doRelease x - return nUsers' - return $ map (first $ \t fin' -> init >>= \r -> t (release r >> fin')) tests + ini = Initializer doInit initVar + fin = Finalizer doRelease initVar finishVar + return $ map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests -- | Start running all the tests in a test tree in parallel. The number of -- threads is determined by the 'NumThreads' option. diff --git a/Test/Tasty/Runners.hs b/Test/Tasty/Runners.hs --- a/Test/Tasty/Runners.hs +++ b/Test/Tasty/Runners.hs @@ -4,6 +4,7 @@ -- * Working with the test tree TestTree(..) , foldTestTree + , AppMonoid(..) , ResourceSpec(..) -- * Ingredients , Ingredient(..) diff --git a/tasty.cabal b/tasty.cabal --- a/tasty.cabal +++ b/tasty.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: tasty -version: 0.5.2.1 +version: 0.6 synopsis: Modern and extensible testing framework description: See license: MIT @@ -39,6 +39,7 @@ Test.Tasty.CmdLine, Test.Tasty.Ingredients.ConsoleReporter Test.Tasty.Ingredients.ListTests + Test.Tasty.Ingredients.IncludingOptions build-depends: base >= 4.5 && < 5, stm >= 2.3, @@ -47,7 +48,8 @@ tagged >= 0.5, regex-posix, optparse-applicative >= 0.6, - deepseq >= 1.3 + deepseq >= 1.3, + either >= 4.0 if flag(colors) build-depends: ansi-terminal >= 0.6.1