tasty-0.7/0000755000000000000000000000000012257063173010720 5ustar0000000000000000tasty-0.7/LICENSE0000644000000000000000000000204312257063173011724 0ustar0000000000000000Copyright (c) 2013 Roman Cheplyaka Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. tasty-0.7/Setup.hs0000644000000000000000000000005612257063173012355 0ustar0000000000000000import Distribution.Simple main = defaultMain tasty-0.7/tasty.cabal0000644000000000000000000000303712257063173013053 0ustar0000000000000000-- Initial tasty.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: tasty version: 0.7 synopsis: Modern and extensible testing framework description: See license: MIT license-file: LICENSE author: Roman Cheplyaka maintainer: roma@ro-che.info -- copyright: category: Testing build-type: Simple -- extra-source-files: cabal-version: >=1.10 Source-repository head type: git location: git://github.com/feuerbach/tasty.git flag colors description: Enable colorful output default: True library exposed-modules: Test.Tasty, Test.Tasty.Options, Test.Tasty.Providers, Test.Tasty.Runners other-modules: Test.Tasty.Parallel, Test.Tasty.Core, Test.Tasty.CoreOptions, Test.Tasty.Patterns, Test.Tasty.Run, Test.Tasty.Ingredients, Test.Tasty.CmdLine, Test.Tasty.Ingredients.ConsoleReporter Test.Tasty.Ingredients.ListTests Test.Tasty.Ingredients.IncludingOptions build-depends: base >= 4.5 && < 5, stm >= 2.3, containers, mtl, tagged >= 0.5, regex-tdfa >= 1.1.8, optparse-applicative >= 0.6, deepseq >= 1.3, either >= 4.0 if flag(colors) build-depends: ansi-terminal >= 0.6.1 cpp-options: -DCOLORS -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing tasty-0.7/Test/0000755000000000000000000000000012257063173011637 5ustar0000000000000000tasty-0.7/Test/Tasty.hs0000644000000000000000000000442512257063173013304 0ustar0000000000000000-- | This module defines the main data types and functions needed to use -- Tasty. module Test.Tasty ( -- * Organizing tests TestName , TestTree , testGroup -- * Running tests , defaultMain , defaultMainWithIngredients , defaultIngredients , 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 -- the tests are run, and destroy or release afterwards. , withResource ) where 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. -- -- At the moment it consists of 'listingTests' and 'consoleTestReporter'. defaultIngredients :: [Ingredient] defaultIngredients = [listingTests, consoleTestReporter] -- | Parse the command line arguments and run the tests defaultMain :: TestTree -> IO () defaultMain = defaultMainWithIngredients defaultIngredients -- | Locally adjust the option value for the given test subtree adjustOption :: IsOption v => (v -> v) -> TestTree -> TestTree adjustOption f = PlusTestOptions $ \opts -> setOption (f $ lookupOption opts) opts -- | Locally set the option value for the given test subtree localOption :: IsOption v => v -> TestTree -> TestTree localOption v = PlusTestOptions (setOption v) -- | Customize the test tree based on the run-time options askOption :: IsOption v => (v -> TestTree) -> TestTree askOption f = AskOptions $ f . lookupOption -- | Acquire the resource to run this test (sub)tree and release it -- afterwards withResource :: IO a -- ^ initialize the resource -> (a -> IO ()) -- ^ free the resource -> (IO a -> TestTree) -- ^ @'IO' a@ is an action which returns the acquired resource. -- Despite it being an 'IO' action, the resource it returns will be -- acquired only once and shared across all the tests in the tree. -> TestTree withResource acq rel = WithResource (ResourceSpec acq rel) tasty-0.7/Test/Tasty/0000755000000000000000000000000012257063173012743 5ustar0000000000000000tasty-0.7/Test/Tasty/CoreOptions.hs0000644000000000000000000000227012257063173015544 0ustar0000000000000000-- | Core options, i.e. the options used by tasty itself {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Test.Tasty.CoreOptions ( NumThreads(..) , coreOptions ) where import Data.Typeable import Data.Proxy import Test.Tasty.Options import Test.Tasty.Patterns -- | Number of parallel threads to use for running tests. -- -- Note that this is /not/ included in 'coreOptions'. -- Instead, it's automatically included in the options for any -- 'TestReporter' ingredient by 'ingredientOptions', because the way test -- reporters are handled already involves parallelism. Other ingredients -- may also choose to include this option. newtype NumThreads = NumThreads { getNumThreads :: Int } deriving (Eq, Ord, Num, Typeable) instance IsOption NumThreads where defaultValue = 1 parseValue = fmap NumThreads . safeRead optionName = return "num-threads" optionHelp = return "Number of threads to use for tests execution" -- | The list of all core options, i.e. the options not specific to any -- provider or ingredient, but to tasty itself. Currently only contains 'TestPattern'. coreOptions :: [OptionDescription] coreOptions = [ Option (Proxy :: Proxy TestPattern) ] tasty-0.7/Test/Tasty/Run.hs0000644000000000000000000001425012257063173014045 0ustar0000000000000000-- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-} module Test.Tasty.Run ( Status(..) , StatusMap , launchTestTree ) 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 import Control.Applicative import Control.Arrow import Test.Tasty.Core import Test.Tasty.Parallel import Test.Tasty.Options import Test.Tasty.CoreOptions -- | Current status of a test data Status = NotStarted -- ^ test has not started running yet | Executing Progress -- ^ test is being run | Exception SomeException -- ^ test threw an exception and was aborted | Done Result -- ^ test finished with a given result -- | Mapping from test numbers (starting from 0) to their status variables. -- -- This is what an ingredient uses to analyse and display progress, and to -- 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 -- it's run *before* we write the status var and signal to other threads -- that we're finished executeTest :: ((Progress -> IO ()) -> IO Result) -- ^ the action to execute the test, which takes a progress callback as -- a parameter -> TVar Status -- ^ variable to write status to -> Seq.Seq Initializer -- ^ initializers (to be executed in this order) -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order) -> IO () 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) -- 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 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 ($ (Seq.empty, Seq.empty)))) $ execWriterT $ getApp $ (foldTestTree trivialFold { foldSingle = runSingleTest , foldResource = addInitAndRelease } opts tree :: AppMonoid (WriterT [(InitFinPair -> IO (), TVar Status)] IO)) where runSingleTest opts _ test = AppMonoid $ do statusVar <- liftIO $ atomically $ newTVar NotStarted let act (inits, fins) = executeTest (run opts test) statusVar inits fins tell [(act, statusVar)] addInitAndRelease (ResourceSpec doInit doRelease) a = AppMonoid . WriterT . fmap ((,) ()) $ do initVar <- newMVar NotCreated tests <- execWriterT $ getApp $ a (getResource initVar) let ntests = length tests finishVar <- newMVar ntests let ini = Initializer doInit initVar fin = Finalizer doRelease initVar finishVar return $ map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests -- | Used to create the IO action which is passed in a WithResource node getResource :: MVar (Resource r) -> IO r getResource var = readMVar var >>= \rState -> case rState of Created r -> return r NotCreated -> throwIO $ UnexpectedState "not created" FailedToCreate {} -> throwIO $ UnexpectedState "failed to create" -- | Start running all the tests in a test tree in parallel. The number of -- threads is determined by the 'NumThreads' option. -- -- Return a map from the test number (starting from 0) to its status -- variable. launchTestTree :: OptionSet -> TestTree -> IO StatusMap launchTestTree opts tree = do testActions <- createTestActions opts tree let NumThreads numTheads = lookupOption opts runInParallel numTheads (fst <$> testActions) return $ IntMap.fromList $ zip [0..] (snd <$> testActions) tasty-0.7/Test/Tasty/Ingredients.hs0000644000000000000000000000774412257063173015566 0ustar0000000000000000module Test.Tasty.Ingredients ( Ingredient(..) , tryIngredients , ingredientOptions , ingredientsOptions ) where import Control.Monad import Data.Proxy import qualified Data.Foldable as F import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Options import Test.Tasty.CoreOptions -- | 'Ingredient's make your test suite tasty. -- -- Ingredients represent different actions that you can perform on your -- test suite. One obvious ingredient that you want to include is -- one that runs tests and reports the progress and results. -- -- Another standard ingredient is one that simply prints the names of all -- tests. -- -- Similar to test providers (see 'IsTest'), every ingredient may specify -- which options it cares about, so that those options are presented to -- the user if the ingredient is included in the test suite. -- -- An ingredient can choose, typically based on the 'OptionSet', whether to -- run. That's what the 'Maybe' is for. The first ingredient that agreed to -- run does its work, and the remaining ingredients are ignored. Thus, the -- order in which you arrange the ingredients may matter. -- -- Usually, the ingredient which runs the tests is unconditional and thus -- should be placed last in the list. Other ingredients usually run only -- if explicitly requested via an option. Their relative order thus doesn't -- matter. -- -- That's all you need to know from an (advanced) user perspective. Read -- on if you want to create a new ingredient. -- -- There are two kinds of ingredients. 'TestReporter', if it agrees to run, -- automatically launches tests execution, and gets the 'StatusMap' which -- it uses to report the progress and results to the user. -- -- 'TestManager' is the second kind of ingredient. It is typically used for -- test management purposes (such as listing the test names), although it -- can also be used for running tests (but, unlike 'TestReporter', it has -- to launch the tests manually). It is therefore more general than -- 'TestReporter'. 'TestReporter' is provided just for convenience. -- -- The function's result should indicate whether all the tests passed. -- -- In the 'TestManager' case, it's up to the ingredient author to decide -- what the result should be. When no tests are run, the result should -- probably be 'True'. Sometimes, even if some tests run and fail, it still -- makes sense to return 'True'. data Ingredient = TestReporter [OptionDescription] (OptionSet -> TestTree -> Maybe (StatusMap -> IO Bool)) | TestManager [OptionDescription] (OptionSet -> TestTree -> Maybe (IO Bool)) -- | Try to run an 'Ingredient'. -- -- If the ingredient refuses to run (usually based on the 'OptionSet'), -- the function returns 'Nothing'. -- -- For a 'TestReporter', this function automatically starts running the -- tests in the background. tryIngredient :: Ingredient -> OptionSet -> TestTree -> Maybe (IO Bool) tryIngredient (TestReporter _ report) opts testTree = do -- Maybe monad reportFn <- report opts testTree return $ reportFn =<< launchTestTree opts testTree tryIngredient (TestManager _ manage) opts testTree = manage opts testTree -- | Run the first 'Ingredient' that agrees to be run. -- -- If no one accepts the task, return 'Nothing'. This is usually a sign of -- misconfiguration. tryIngredients :: [Ingredient] -> OptionSet -> TestTree -> Maybe (IO Bool) tryIngredients ins opts tree = msum $ map (\i -> tryIngredient i opts tree) ins -- | Return the options which are relevant for the given ingredient. -- -- Note that this isn't the same as simply pattern-matching on -- 'Ingredient'. E.g. options for a 'TestReporter' automatically include -- 'NumThreads'. ingredientOptions :: Ingredient -> [OptionDescription] ingredientOptions (TestReporter opts _) = Option (Proxy :: Proxy NumThreads) : opts ingredientOptions (TestManager opts _) = opts -- | Like 'ingredientOption', but folds over multiple ingredients. ingredientsOptions :: [Ingredient] -> [OptionDescription] ingredientsOptions = F.foldMap ingredientOptions tasty-0.7/Test/Tasty/Patterns.hs0000644000000000000000000001263112257063173015102 0ustar0000000000000000-- This code is largely borrowed from test-framework {- Copyright (c) 2008, Maximilian Bolingbroke All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -- | Test patterns -- -- (Most of the code borrowed from the test-framework) {-# LANGUAGE DeriveDataTypeable #-} module Test.Tasty.Patterns ( TestPattern , parseTestPattern , noPattern , testPatternMatches ) where import Test.Tasty.Options import Text.Regex.TDFA import Text.Regex.TDFA.String() import Data.List import Data.Typeable data Token = SlashToken | WildcardToken | DoubleWildcardToken | LiteralToken Char deriving (Eq) tokenize :: String -> [Token] tokenize ('/':rest) = SlashToken : tokenize rest tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest tokenize ('*':rest) = WildcardToken : tokenize rest tokenize (c:rest) = LiteralToken c : tokenize rest tokenize [] = [] data TestPatternMatchMode = TestMatchMode | PathMatchMode -- | A pattern to filter tests. For the syntax description, see -- data TestPattern = TestPattern { tp_categories_only :: Bool, tp_negated :: Bool, tp_match_mode :: TestPatternMatchMode, tp_tokens :: [Token] } | NoPattern deriving Typeable -- | A pattern that matches anything. noPattern :: TestPattern noPattern = NoPattern instance Read TestPattern where readsPrec _ string = [(parseTestPattern string, "")] instance IsOption TestPattern where defaultValue = noPattern parseValue = Just . parseTestPattern optionName = return "pattern" optionHelp = return "Select only tests that match pattern" -- | Parse a pattern parseTestPattern :: String -> TestPattern parseTestPattern string = TestPattern { tp_categories_only = categories_only, tp_negated = negated, tp_match_mode = match_mode, tp_tokens = tokens'' } where tokens = tokenize string (negated, tokens') | (LiteralToken '!'):rest <- tokens = (True, rest) | otherwise = (False, tokens) (categories_only, tokens'') | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix) | otherwise = (False, tokens') match_mode | SlashToken `elem` tokens = PathMatchMode | otherwise = TestMatchMode -- | Test a path (which is the sequence of group titles, possibly followed -- by the test title) against a pattern testPatternMatches :: TestPattern -> [String] -> Bool testPatternMatches NoPattern _ = True testPatternMatches test_pattern path = not_maybe $ any (=~ tokens_regex) things_to_match where not_maybe | tp_negated test_pattern = not | otherwise = id path_to_consider | tp_categories_only test_pattern = dropLast 1 path | otherwise = path tokens_regex = buildTokenRegex (tp_tokens test_pattern) things_to_match = case tp_match_mode test_pattern of -- See if the tokens match any single path component TestMatchMode -> path_to_consider -- See if the tokens match any prefix of the path PathMatchMode -> map pathToString $ inits path_to_consider buildTokenRegex :: [Token] -> String buildTokenRegex [] = [] buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens) where firstTokenToRegex SlashToken = "^" firstTokenToRegex other = tokenToRegex other tokenToRegex SlashToken = "/" tokenToRegex WildcardToken = "[^/]*" tokenToRegex DoubleWildcardToken = "*" tokenToRegex (LiteralToken lit) = regexEscapeChar lit regexEscapeChar :: Char -> String regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c] | otherwise = [c] pathToString :: [String] -> String pathToString path = concat (intersperse "/" path) dropLast :: Int -> [a] -> [a] dropLast n = reverse . drop n . reverse tasty-0.7/Test/Tasty/Parallel.hs0000644000000000000000000000712312257063173015036 0ustar0000000000000000-- | A helper module which takes care of parallelism module Test.Tasty.Parallel (runInParallel) where import Control.Monad import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Foreign.StablePtr -- | Take a list of actions and execute them in parallel, no more than @n@ -- at the same time runInParallel :: Int -- ^ maximum number of parallel threads -> [IO ()] -- ^ list of actions to execute -> IO () -- This implementation tries its best to ensure that exceptions are -- properly propagated to the caller and threads are not left running. -- -- Note that exceptions inside tests are already caught by the test -- actions themselves. Any exceptions that reach this function or its -- threads are by definition unexpected. runInParallel nthreads actions = do callingThread <- myThreadId -- Don't let the main thread be garbage-collected -- Otherwise we may get a "thread blocked indefinitely in an STM -- transaction" exception when a child thread is blocked and GC'd. -- (See e.g. https://github.com/feuerbach/tasty/issues/15) _ <- newStablePtr callingThread -- A variable containing all ThreadIds of forked threads. -- -- These are the threads we'll need to kill if something wrong happens. pidsVar <- atomically $ newTVar [] -- If an unexpected exception has been thrown and we started killing all -- the spawned threads, this flag will be set to False, so that any -- freshly spawned threads will know to terminate, even if their pids -- didn't make it to the "kill list" yet. aliveVar <- atomically $ newTVar True let -- Kill all threads. killAll :: IO () killAll = do pids <- atomically $ do writeTVar aliveVar False readTVar pidsVar -- be sure not to kill myself! me <- myThreadId mapM_ killThread $ filter (/= me) pids cleanup :: Either SomeException () -> IO () cleanup = either (\e -> killAll >> throwTo callingThread e) (const $ return ()) forkCarefully :: IO () -> IO () forkCarefully action = void . flip myForkFinally cleanup $ do -- We cannot check liveness and update the pidsVar in one -- transaction before forking, because we don't know the new pid yet. -- -- So we fork and then check/update. If something has happened in -- the meantime, it's not a big deal — we just cancel. OTOH, if -- we're alive at the time of the transaction, then we add our pid -- and will be killed when something happens. newPid <- myThreadId join . atomically $ do alive <- readTVar aliveVar if alive then do modifyTVar pidsVar (newPid :) return action else return (return ()) capsVar <- atomically $ newTVar nthreads let go a cont = join . atomically $ do caps <- readTVar capsVar if caps > 0 then do writeTVar capsVar $! caps - 1 let release = atomically $ modifyTVar' capsVar (+1) -- Thanks to our exception handling, we won't deadlock even if -- an exception strikes before we 'release'. Everything will be -- killed, so why bother. return $ do forkCarefully (do a; release); cont else retry -- fork here as well, so that we can move to the UI without waiting -- untill all tests have finished forkCarefully $ foldr go (return ()) actions -- Copied from base to stay compatible with GHC 7.4. myForkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId myForkFinally action and_then = mask $ \restore -> forkIO $ try (restore action) >>= and_then tasty-0.7/Test/Tasty/CmdLine.hs0000644000000000000000000000364212257063173014617 0ustar0000000000000000-- | Parsing options supplied on the command line {-# LANGUAGE ScopedTypeVariables #-} module Test.Tasty.CmdLine ( optionParser , suiteOptions , suiteOptionParser , defaultMainWithIngredients ) where import Options.Applicative import Data.Monoid import Data.Proxy import System.Exit import Test.Tasty.Core import Test.Tasty.CoreOptions import Test.Tasty.Ingredients import Test.Tasty.Options -- | Generate a command line parser from a list of option descriptions optionParser :: [OptionDescription] -> Parser OptionSet optionParser = foldr addOption (pure mempty) where addOption :: OptionDescription -> Parser OptionSet -> Parser OptionSet addOption (Option (Proxy :: Proxy v)) p = setOption <$> (optionCLParser :: Parser v) <*> p -- suiteOptions doesn't really belong here (since it's not CmdLine -- specific), but I didn't want to create a new module just for it. -- | All the options relevant for this test suite. This includes the -- options for the test tree and ingredients, and the core options. suiteOptions :: [Ingredient] -> TestTree -> [OptionDescription] suiteOptions ins tree = coreOptions ++ ingredientsOptions ins ++ treeOptions tree -- | The command line parser for the test suite suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet suiteOptionParser ins tree = optionParser $ suiteOptions ins tree -- | Parse the command line arguments and run the tests using the provided -- ingredient list defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO () defaultMainWithIngredients ins testTree = do opts <- execParser $ info (helper <*> suiteOptionParser ins testTree) ( fullDesc <> header "Mmm... tasty test suite" ) case tryIngredients ins opts testTree of Nothing -> putStrLn "This doesn't taste right. Check your ingredients — did you forget a test reporter?" Just act -> do ok <- act if ok then exitSuccess else exitFailure tasty-0.7/Test/Tasty/Options.hs0000644000000000000000000000702712257063173014740 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, ExistentialQuantification, GADTs, OverlappingInstances, FlexibleInstances, UndecidableInstances, TypeOperators #-} -- | Extensible options. They are used for provider-specific settings, -- ingredient-specific settings and core settings (such as the test name pattern). module Test.Tasty.Options ( -- * IsOption class IsOption(..) -- * Option sets and operations , OptionSet , setOption , changeOption , lookupOption , OptionDescription(..) -- * Utilities , safeRead ) where import Data.Typeable import qualified Data.Map as Map import Data.Map (Map) import Data.Tagged import Data.Proxy import Data.Monoid import Options.Applicative import Options.Applicative.Types -- | An option is a data type that inhabits the `IsOption` type class. class Typeable v => IsOption v where -- | The value to use if the option was not supplied explicitly defaultValue :: v -- | Try to parse an option value from a string parseValue :: String -> Maybe v -- | The option name. It is used to form the command line option name, for -- instance. Therefore, it had better not contain spaces or other fancy -- characters. It is recommended to use dashes instead of spaces. optionName :: Tagged v String -- | The option description or help string. This can be an arbitrary -- string. optionHelp :: Tagged v String -- | A command-line option parser. -- -- It has a default implementation in terms of the other methods. -- You may want to override it in some cases (e.g. add a short flag). -- -- Even if you override this, you still should implement all the methods -- above, to allow alternative interfaces. optionCLParser :: Parser v optionCLParser = nullOption ( reader parse <> long name <> value defaultValue <> help helpString ) where name = untag (optionName :: Tagged v String) helpString = untag (optionHelp :: Tagged v String) parse = ReadM . maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right . parseValue data OptionValue = forall v . IsOption v => OptionValue v -- | A set of options. Only one option of each type can be kept. -- -- If some option has not been explicitly set, the default value is used. newtype OptionSet = OptionSet (Map TypeRep OptionValue) -- | Later options override earlier ones instance Monoid OptionSet where mempty = OptionSet mempty OptionSet a `mappend` OptionSet b = OptionSet $ Map.unionWith (flip const) a b -- | Set the option value setOption :: IsOption v => v -> OptionSet -> OptionSet setOption v (OptionSet s) = OptionSet $ Map.insert (typeOf v) (OptionValue v) s -- | Query the option value lookupOption :: forall v . IsOption v => OptionSet -> v lookupOption (OptionSet s) = case Map.lookup (typeOf (undefined :: v)) s of Just (OptionValue x) | Just v <- cast x -> v Just {} -> error "OptionSet: broken invariant (shouldn't happen)" Nothing -> defaultValue -- | Change the option value changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet changeOption f s = setOption (f $ lookupOption s) s -- | The purpose of this data type is to capture the dictionary -- corresponding to a particular option. data OptionDescription where Option :: IsOption v => Proxy v -> OptionDescription -- | Safe read function. Defined here for convenience to use for -- 'parseValue'. safeRead :: Read a => String -> Maybe a safeRead s | [(x, "")] <- reads s = Just x | otherwise = Nothing tasty-0.7/Test/Tasty/Runners.hs0000644000000000000000000000202712257063173014734 0ustar0000000000000000-- | API for test runners module Test.Tasty.Runners ( -- * Working with the test tree TestTree(..) , foldTestTree , TreeFold(..) , trivialFold , AppMonoid(..) , ResourceSpec(..) -- * Ingredients , Ingredient(..) , tryIngredients , ingredientOptions , ingredientsOptions -- * Standard console ingredients -- ** Console test reporter , consoleTestReporter -- ** Tests list , listingTests , ListTests(..) , testsNames -- * Command line handling , optionParser , suiteOptionParser , defaultMainWithIngredients -- * Running tests , Status(..) , Result(..) , Progress(..) , StatusMap , launchTestTree , NumThreads(..) -- * Options , suiteOptions , coreOptions -- ** Patterns , module Test.Tasty.Patterns ) where import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Ingredients import Test.Tasty.CoreOptions import Test.Tasty.Patterns import Test.Tasty.CmdLine import Test.Tasty.Ingredients.ConsoleReporter import Test.Tasty.Ingredients.ListTests tasty-0.7/Test/Tasty/Providers.hs0000644000000000000000000000046112257063173015255 0ustar0000000000000000-- | API for test providers module Test.Tasty.Providers ( IsTest(..) , Result(..) , Progress(..) , TestName , TestTree , singleTest ) where import Test.Tasty.Core -- | Convert a test to a leaf of the 'TestTree' singleTest :: IsTest t => TestName -> t -> TestTree singleTest = SingleTest tasty-0.7/Test/Tasty/Core.hs0000644000000000000000000001545512257063173014201 0ustar0000000000000000-- | Core types and definitions {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, ExistentialQuantification, RankNTypes, DeriveDataTypeable #-} module Test.Tasty.Core where import Control.Applicative import Control.Exception import Test.Tasty.Options import Test.Tasty.Patterns import Data.Foldable import Data.Monoid import Data.Typeable import qualified Data.Map as Map import Data.Tagged import Text.Printf -- | A test result data Result = Result { resultSuccessful :: Bool -- ^ -- 'resultSuccessful' should be 'True' for a passed test and 'False' for -- a failed one. , resultDescription :: String -- ^ -- 'resultDescription' may contain some details about the test. For -- a passed test it's ok to leave it empty. Providers like SmallCheck and -- QuickCheck use it to provide information about how many tests were -- generated. -- -- For a failed test, 'resultDescription' should typically provide more -- information about the failure. } -- | Test progress information. -- -- This may be used by a runner to provide some feedback to the user while -- a long-running test is executing. data Progress = Progress { progressText :: String -- ^ textual information about the test's progress , progressPercent :: Float -- ^ -- 'progressPercent' should be a value between 0 and 1. If it's impossible -- to compute the estimate, use 0. } -- | The interface to be implemented by a test provider. -- -- The type @t@ is the concrete representation of the test which is used by -- the provider. class Typeable t => IsTest t where -- | Run the test run :: OptionSet -- ^ options -> t -- ^ the test to run -> (Progress -> IO ()) -- ^ a callback to report progress -> IO Result -- | The list of options that affect execution of tests of this type testOptions :: Tagged t [OptionDescription] -- | The name of a test or a group of tests type TestName = String -- | 'ResourceSpec' describes how to acquire a resource (the first field) -- and how to release it (the second field). data ResourceSpec a = ResourceSpec (IO a) (a -> IO ()) data ResourceError = NotRunningTests | UnexpectedState String deriving Typeable instance Show ResourceError where show NotRunningTests = "Unhandled resource. Probably a bug in the runner you're using." show (UnexpectedState state) = printf "Unexpected state of the resource (%s). Report as a tasty bug." state instance Exception ResourceError -- | The main data structure defining a test suite. -- -- It consists of individual test cases and properties, organized in named -- groups which form a tree-like hierarchy. -- -- There is no generic way to create a test case. Instead, every test -- provider (tasty-hunit, tasty-smallcheck etc.) provides a function to -- turn a test case into a 'TestTree'. -- -- Groups can be created using 'testGroup'. data TestTree = forall t . IsTest t => SingleTest TestName t -- ^ A single test of some particular type | TestGroup TestName [TestTree] -- ^ Assemble a number of tests into a cohesive group | PlusTestOptions (OptionSet -> OptionSet) TestTree -- ^ Add some options to child tests | forall a . WithResource (ResourceSpec a) (IO a -> TestTree) -- ^ Acquire the resource before the tests in the inner tree start and -- release it after they finish. The tree gets an `IO` action which -- yields the resource, although the resource is shared across all the -- tests. | AskOptions (OptionSet -> TestTree) -- ^ Ask for the options and customize the tests based on them -- | Create a named group of test cases or other groups testGroup :: TestName -> [TestTree] -> TestTree testGroup = TestGroup -- | An algebra for folding a `TestTree`. -- -- Instead of constructing fresh records, build upon `trivialFold` -- instead. This way your code won't break when new nodes/fields are -- indroduced. data TreeFold b = TreeFold { foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b , foldGroup :: TestName -> b -> b , foldResource :: forall a . ResourceSpec a -> (IO a -> b) -> b } -- | 'trivialFold' can serve as the basis for custom folds. Just override -- the fields you need. -- -- Here's what it does: -- -- * single tests are mapped to `mempty` (you probably do want to override that) -- -- * test groups are returned unmodified -- -- * for a resource, an IO action that throws an exception is passed (you -- want to override this for runners/ingredients that execute tests) trivialFold :: Monoid b => TreeFold b trivialFold = TreeFold { foldSingle = \_ _ _ -> mempty , foldGroup = const id , foldResource = \_ f -> f $ throwIO NotRunningTests } -- | Fold a test tree into a single value. -- -- The fold result type should be a monoid. This is used to fold multiple -- results in a test group. In particular, empty groups get folded into 'mempty'. -- -- Apart from pure convenience, this function also does the following -- useful things: -- -- 1. Keeping track of the current options (which may change due to -- `PlusTestOptions` nodes) -- -- 2. Filtering out the tests which do not match the patterns -- -- Thus, it is preferred to an explicit recursive traversal of the tree. -- -- Note: right now, the patterns are looked up only once, and won't be -- affected by the subsequent option changes. This shouldn't be a problem -- in practice; OTOH, this behaviour may be changed later. foldTestTree :: Monoid b => TreeFold b -- ^ the algebra (i.e. how to fold a tree) -> OptionSet -- ^ initial options -> TestTree -- ^ the tree to fold -> b foldTestTree (TreeFold fTest fGroup fResource) opts tree = let pat = lookupOption opts in go pat [] opts tree where go pat path opts tree = case tree of SingleTest name test | testPatternMatches pat (path ++ [name]) -> fTest opts name test | otherwise -> mempty TestGroup name trees -> fGroup name $ foldMap (go pat (path ++ [name]) opts) trees PlusTestOptions f tree -> go pat path (f opts) tree WithResource res tree -> fResource res $ \res -> go pat path opts (tree res) AskOptions f -> go pat path opts (f opts) -- | Useful wrapper for use with foldTestTree newtype AppMonoid f = AppMonoid { getApp :: f () } instance Applicative f => Monoid (AppMonoid f) where mempty = AppMonoid $ pure () AppMonoid f1 `mappend` AppMonoid f2 = AppMonoid $ f1 *> f2 -- | Get the list of options that are relevant for a given test tree treeOptions :: TestTree -> [OptionDescription] treeOptions = Prelude.concat . Map.elems . foldTestTree trivialFold { foldSingle = \_ _ -> getTestOptions } mempty where getTestOptions :: forall t . IsTest t => t -> Map.Map TypeRep [OptionDescription] getTestOptions t = Map.singleton (typeOf t) $ witness testOptions t tasty-0.7/Test/Tasty/Ingredients/0000755000000000000000000000000012257063173015216 5ustar0000000000000000tasty-0.7/Test/Tasty/Ingredients/ConsoleReporter.hs0000644000000000000000000001404012257063173020676 0ustar0000000000000000{-# LANGUAGE TupleSections, CPP, ImplicitParams #-} -- | Console reporter ingredient module Test.Tasty.Ingredients.ConsoleReporter (consoleTestReporter) where import Prelude hiding (fail) import Control.Monad.State hiding (fail) import Control.Concurrent.STM import Control.Exception import Control.DeepSeq import Control.Applicative import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Ingredients import Test.Tasty.Options import Text.Printf import qualified Data.IntMap as IntMap import Data.Maybe import Data.Monoid import System.IO #ifdef COLORS import System.Console.ANSI #endif data RunnerState = RunnerState { ix :: !Int , nestedLevel :: !Int , failures :: !Int } initialState :: RunnerState initialState = RunnerState 0 0 0 type M = StateT RunnerState IO indentSize :: Int indentSize = 2 indent :: Int -> String indent n = replicate (indentSize * n) ' ' -- handle multi-line result descriptions properly formatDesc :: Int -- indent -> String -> String formatDesc n desc = let -- remove all trailing linebreaks chomped = reverse . dropWhile (== '\n') . reverse $ desc multiline = '\n' `elem` chomped -- we add a leading linebreak to the description, to start it on a new -- line and add an indentation paddedDesc = flip concatMap chomped $ \c -> if c == '\n' then c : indent n else [c] in if multiline then paddedDesc else chomped data Maximum a = Maximum a | MinusInfinity instance Ord a => Monoid (Maximum a) where mempty = MinusInfinity Maximum a `mappend` Maximum b = Maximum (a `max` b) MinusInfinity `mappend` a = a a `mappend` MinusInfinity = a -- | Compute the amount of space needed to align "OK"s and "FAIL"s computeAlignment :: OptionSet -> TestTree -> Int computeAlignment opts = fromMonoid . foldTestTree trivialFold { foldSingle = \_ name _ level -> Maximum (length name + level) , foldGroup = \_ m -> m . (+ indentSize) } opts where fromMonoid m = case m 0 of MinusInfinity -> 0 Maximum x -> x -- | A simple console UI consoleTestReporter :: Ingredient -- We fold the test tree using (AppMonoid m, Any) monoid. -- -- The 'Any' part is needed to know whether a group is empty, in which case -- we shouldn't display it. consoleTestReporter = TestReporter [] $ \opts tree -> Just $ \smap -> do isTerm <- hIsTerminalDevice stdout let ?colors = isTerm let alignment = computeAlignment opts tree runSingleTest :: (IsTest t, ?colors :: Bool) => IntMap.IntMap (TVar Status) -> OptionSet -> TestName -> t -> (AppMonoid M, Any) runSingleTest smap _opts name _test = (, Any True) $ AppMonoid $ do st@RunnerState { ix = ix, nestedLevel = level } <- get let statusVar = fromMaybe (error "internal error: index out of bounds") $ IntMap.lookup ix smap -- Print the test name before waiting for the test. This is useful -- for long-running tests. liftIO $ printf "%s%s: %s" (indent level) name (replicate (alignment - indentSize * level - length name) ' ') (rOk, rDesc) <- liftIO $ atomically $ do status <- readTVar statusVar case status of Done r -> return $ (resultSuccessful r, resultDescription r) Exception e -> return (False, "Exception: " ++ show e) _ -> retry rDesc <- liftIO $ formatMessage rDesc liftIO $ if rOk then ok "OK\n" else fail "FAIL\n" when (not $ null rDesc) $ liftIO $ (if rOk then infoOk else infoFail) $ printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc) let ix' = ix+1 updateFailures = if rOk then id else (+1) put $! st { ix = ix', failures = updateFailures (failures st) } runGroup :: TestName -> (AppMonoid M, Any) -> (AppMonoid M, Any) runGroup _ (_, Any False) = mempty runGroup name (AppMonoid act, nonEmpty) = (, nonEmpty) $ AppMonoid $ do st@RunnerState { nestedLevel = level } <- get liftIO $ printf "%s%s\n" (indent level) name put $! st { nestedLevel = level + 1 } act modify $ \st -> st { nestedLevel = level } hSetBuffering stdout NoBuffering -- Do not retain the reference to the tree more than necessary _ <- evaluate alignment st <- flip execStateT initialState $ getApp $ fst $ foldTestTree trivialFold { foldSingle = runSingleTest smap , foldGroup = runGroup } opts tree printf "\n" case failures st of 0 -> do ok $ printf "All %d tests passed\n" (ix st) return True fs -> do fail $ printf "%d out of %d tests failed\n" fs (ix st) return False -- | Printing exceptions or other messages is tricky — in the process we -- can get new exceptions! -- -- See e.g. https://github.com/feuerbach/tasty/issues/25 formatMessage :: String -> IO String formatMessage msg = go 3 msg where -- to avoid infinite recursion, we introduce the recursion limit go :: Int -> String -> IO String go 0 _ = return "exceptions keep throwing other exceptions!" go recLimit msg = do mbStr <- try $ evaluate $ force msg case mbStr of Right str -> return str Left e' -> printf "message threw an exception: %s" <$> go (recLimit-1) (show (e' :: SomeException)) -- (Potentially) colorful output ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO () #ifdef COLORS fail = output BoldIntensity Vivid Red ok = output NormalIntensity Dull Green infoOk = output NormalIntensity Dull White infoFail = output NormalIntensity Dull Red output :: (?colors :: Bool) => ConsoleIntensity -> ColorIntensity -> Color -> String -> IO () output bold intensity color str | ?colors = (do setSGR [ SetColor Foreground intensity color , SetConsoleIntensity bold ] putStr str ) `finally` setSGR [] | otherwise = putStr str #else ok = putStr fail = putStr infoOk = putStr infoFail = putStr #endif tasty-0.7/Test/Tasty/Ingredients/IncludingOptions.hs0000644000000000000000000000056212257063173021045 0ustar0000000000000000module 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) tasty-0.7/Test/Tasty/Ingredients/ListTests.hs0000644000000000000000000000300412257063173017505 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Test.Tasty.Ingredients.ListTests ( ListTests(..) , testsNames , listingTests ) where import Options.Applicative import Data.Typeable import Data.Proxy import Data.Tagged import Test.Tasty.Core import Test.Tasty.Options import Test.Tasty.Ingredients -- | This option, when set to 'True', specifies that we should run in the -- «list tests» mode newtype ListTests = ListTests Bool deriving (Eq, Ord, Typeable) instance IsOption ListTests where defaultValue = ListTests False parseValue = fmap ListTests . safeRead optionName = return "list-tests" optionHelp = return "Do not run the tests; just print their names" optionCLParser = fmap ListTests $ switch ( short 'l' <> long (untag (optionName :: Tagged ListTests String)) <> help (untag (optionHelp :: Tagged ListTests String)) ) -- | Obtain the list of all tests in the suite testsNames :: OptionSet -> TestTree -> [TestName] testsNames {- opts -} {- tree -} = foldTestTree trivialFold { foldSingle = \_opts name _test -> [name] , foldGroup = \groupName names -> map ((groupName ++ "/") ++) names } -- | The ingredient that provides the test listing functionality listingTests :: Ingredient listingTests = TestManager [Option (Proxy :: Proxy ListTests)] $ \opts tree -> case lookupOption opts of ListTests False -> Nothing ListTests True -> Just $ do mapM_ putStrLn $ testsNames opts tree return True