tasty 0.5.2.1 → 0.6
raw patch · 6 files changed
+111/−42 lines, 6 filesdep +either
Dependencies added: either
Files
- Test/Tasty.hs +7/−1
- Test/Tasty/Core.hs +2/−0
- Test/Tasty/Ingredients/IncludingOptions.hs +11/−0
- Test/Tasty/Run.hs +86/−39
- Test/Tasty/Runners.hs +1/−0
- tasty.cabal +4/−2
Test/Tasty.hs view
@@ -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
Test/Tasty/Core.hs view
@@ -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 () }
+ Test/Tasty/Ingredients/IncludingOptions.hs view
@@ -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)
Test/Tasty/Run.hs view
@@ -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.
Test/Tasty/Runners.hs view
@@ -4,6 +4,7 @@ -- * Working with the test tree TestTree(..) , foldTestTree+ , AppMonoid(..) , ResourceSpec(..) -- * Ingredients , Ingredient(..)
tasty.cabal view
@@ -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 <http://documentup.com/feuerbach/tasty> 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