tasty-0.11.3/Test/0000755000000000000000000000000013144010616012041 5ustar0000000000000000tasty-0.11.3/Test/Tasty/0000755000000000000000000000000013144257207013156 5ustar0000000000000000tasty-0.11.3/Test/Tasty/Ingredients/0000755000000000000000000000000013171665425015436 5ustar0000000000000000tasty-0.11.3/Test/Tasty/Options/0000755000000000000000000000000013142023031014571 5ustar0000000000000000tasty-0.11.3/Test/Tasty/Runners/0000755000000000000000000000000013142023031014572 5ustar0000000000000000tasty-0.11.3/Test/Tasty.hs0000644000000000000000000000637013127364673013527 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. -- -- Note that /ingredient options/ (number of threads, hide successes -- etc.) set in this way will not have any effect. This is for modifying -- per-test options, such as timeout, number of generated tests etc. , adjustOption , localOption , askOption -- ** Standard options , Timeout(..) , mkTimeout -- * 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.Options.Core import Test.Tasty.Ingredients.Basic -- | 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. -- -- When the tests finish, this function calls 'exitWith' with the exit code -- that indicates whether any tests have failed. Most external systems -- (stack, cabal, travis-ci, jenkins etc.) rely on the exit code to detect -- whether the tests pass. If you want to do something else after -- `defaultMain` returns, you need to catch the exception and then re-throw -- it. Example: -- -- >import Test.Tasty -- >import Test.Tasty.HUnit -- >import System.Exit -- >import Control.Exception -- > -- >test = testCase "Test 1" (2 @?= 3) -- > -- >main = defaultMain test -- > `catch` (\e -> do -- > if e == ExitSuccess -- > then putStrLn "Yea" -- > else putStrLn "Nay" -- > throwIO e) 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.11.3/Test/Tasty/Options.hs0000644000000000000000000001214313127364673015155 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 , singleOption , OptionDescription(..) -- * Utilities , flagCLParser , mkFlagCLParser , mkOptionCLParser , safeRead ) where import qualified Data.Map as Map import Data.Map (Map) import Data.Tagged import Data.Proxy import Data.Typeable import Data.Monoid import Data.Foldable import Prelude -- Silence FTP import warnings import Options.Applicative -- | 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) and -- 'flagCLParser', 'mkFlagCLParser' and 'mkOptionCLParser' might come in -- handy. -- -- Even if you override this, you still should implement all the methods -- above, to allow alternative interfaces. -- -- Do not supply a default value here for this parser! -- This is because if no value was provided on the command line we may -- lookup the option e.g. in the environment. But if the parser always -- succeeds, we have no way to tell whether the user really provided the -- option on the command line. -- (If we don't specify a default, the option becomes mandatory. -- So, when we build the complete parser for OptionSet, we turn a -- failing parser into an always-succeeding one that may return an empty -- OptionSet.) optionCLParser :: Parser v optionCLParser = mkOptionCLParser mempty 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 -- | Create a singleton 'OptionSet' singleOption :: IsOption v => v -> OptionSet singleOption v = setOption v mempty -- | 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 -- | Command-line parser to use with flags flagCLParser :: forall v . IsOption v => Maybe Char -- ^ optional short flag -> v -- ^ non-default value (when the flag is supplied) -> Parser v flagCLParser mbShort = mkFlagCLParser (foldMap short mbShort) -- | Command-line flag parser that takes additional option modifiers. mkFlagCLParser :: forall v . IsOption v => Mod FlagFields v -- ^ option modifier -> v -- ^ non-default value (when the flag is supplied) -> Parser v mkFlagCLParser mod v = flag' v ( long (untag (optionName :: Tagged v String)) <> help (untag (optionHelp :: Tagged v String)) <> mod ) -- | Command-line option parser that takes additional option modifiers. mkOptionCLParser :: forall v . IsOption v => Mod OptionFields v -> Parser v mkOptionCLParser mod = option parse ( long name <> help (untag (optionHelp :: Tagged v String)) <> mod ) where name = untag (optionName :: Tagged v String) parse = str >>= maybe (readerError $ "Could not parse " ++ name) pure <$> parseValue -- | 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.11.3/Test/Tasty/Providers.hs0000644000000000000000000000144513127364673015502 0ustar0000000000000000-- | API for test providers module Test.Tasty.Providers ( IsTest(..) , testPassed , testFailed , 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 -- | 'Result' of a passed test testPassed :: String -- ^ description (may be empty) -> Result testPassed desc = Result { resultOutcome = Success , resultDescription = desc , resultShortDescription = "OK" , resultTime = 0 } -- | 'Result' of a failed test testFailed :: String -- ^ description -> Result testFailed desc = Result { resultOutcome = Failure TestFailed , resultDescription = desc , resultShortDescription = "FAIL" , resultTime = 0 } tasty-0.11.3/Test/Tasty/Runners.hs0000644000000000000000000000254413127364673015162 0ustar0000000000000000-- | API for test runners module Test.Tasty.Runners ( -- * Working with the test tree TestTree(..) , foldTestTree , TreeFold(..) , trivialFold , ResourceSpec(..) , module Test.Tasty.Runners.Reducers -- * Ingredients , Ingredient(..) , Time , tryIngredients , ingredientOptions , ingredientsOptions -- * Standard console ingredients -- | NOTE: the exports in this section are deprecated and will be -- removed in the future. Please import "Test.Tasty.Ingredients.Basic" -- if you need them. -- ** Console test reporter , consoleTestReporter -- ** Tests list , listingTests , ListTests(..) , testsNames -- * Command line handling , optionParser , suiteOptionParser , defaultMainWithIngredients -- * Running tests , Status(..) , Result(..) , Outcome(..) , FailureReason(..) , resultSuccessful , Progress(..) , StatusMap , launchTestTree , NumThreads(..) -- * Options , suiteOptions , coreOptions -- ** Patterns , module Test.Tasty.Patterns -- * Utilities , module Test.Tasty.Runners.Utils ) where import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Ingredients import Test.Tasty.Options.Core import Test.Tasty.Patterns import Test.Tasty.CmdLine import Test.Tasty.Ingredients.Basic import Test.Tasty.Runners.Reducers import Test.Tasty.Runners.Utils tasty-0.11.3/Test/Tasty/Ingredients.hs0000644000000000000000000001325013127364673015775 0ustar0000000000000000-- | This module contains the core definitions related to ingredients. -- -- Ingredients themselves are provided by other modules (usually under -- the @Test.Tasty.Ingredients.*@ hierarchy). module Test.Tasty.Ingredients ( Ingredient(..) , tryIngredients , ingredientOptions , ingredientsOptions , suiteOptions , composeReporters ) 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.Options.Core import Control.Concurrent.Async (concurrently) -- | '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. -- -- The first kind is 'TestReporter'. If the ingredient that agrees to run -- is a 'TestReporter', then tasty will automatically launch the tests and -- pass a 'StatusMap' to the ingredient. All the ingredient needs to do -- then is to process the test results and probably report them to the user -- in some way (hence the name). -- -- '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 if it wants them to be run). 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 (Time -> IO Bool))) -- ^ For the explanation on how the callback works, see the -- documentation for 'launchTestTree'. | 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 $ launchTestTree opts testTree $ \smap -> reportFn smap 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 -- | 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 -- | Compose two 'TestReporter' ingredients which are then executed -- in parallel. This can be useful if you want to have two reporters -- active at the same time, e.g., one which prints to the console and -- one which writes the test results to a file. -- -- Be aware that it is not possible to use 'composeReporters' with a 'TestManager', -- it only works for 'TestReporter' ingredients. composeReporters :: Ingredient -> Ingredient -> Ingredient composeReporters (TestReporter o1 f1) (TestReporter o2 f2) = TestReporter (o1 ++ o2) $ \o t -> case (f1 o t, f2 o t) of (g, Nothing) -> g (Nothing, g) -> g (Just g1, Just g2) -> Just $ \s -> do (h1, h2) <- concurrently (g1 s) (g2 s) return $ \x -> fmap (uncurry (&&)) $ concurrently (h1 x) (h2 x) composeReporters _ _ = error "Only TestReporters can be composed" tasty-0.11.3/Test/Tasty/Ingredients/Basic.hs0000644000000000000000000000113313127364673017013 0ustar0000000000000000-- | This module exports the basic ingredients defined in the 'tasty' -- packages. -- -- Note that if @defaultIngredients@ from "Test.Tasty" suits your needs, -- use that instead of importing this module. module Test.Tasty.Ingredients.Basic ( -- ** Console test reporter consoleTestReporter , Quiet(..) , HideSuccesses(..) -- ** Listing tests , listingTests , ListTests(..) , testsNames -- ** Adding options , includingOptions ) where import Test.Tasty.Ingredients.ConsoleReporter import Test.Tasty.Ingredients.ListTests import Test.Tasty.Ingredients.IncludingOptions tasty-0.11.3/Test/Tasty/Ingredients/ConsoleReporter.hs0000644000000000000000000004050713171665425021125 0ustar0000000000000000-- vim:fdm=marker:foldtext=foldtext() {-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts #-} -- | Console reporter ingredient module Test.Tasty.Ingredients.ConsoleReporter ( consoleTestReporter , Quiet(..) , HideSuccesses(..) -- * Internals -- | The following functions and datatypes are internals that are exposed to -- simplify the task of rolling your own custom console reporter UI. -- ** Output colouring , UseColor(..) , useColor -- ** Test failure statistics , Statistics(..) , printStatistics -- ** Outputting results , TestOutput(..) , buildTestOutput , foldTestOutput ) where import Control.Monad.State hiding (fail) import Control.Monad.Reader hiding (fail,reader) import Control.Concurrent.STM import Control.Exception import Control.Applicative import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Ingredients import Test.Tasty.Options import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers import Test.Tasty.Runners.Utils import Text.Printf import qualified Data.IntMap as IntMap import Data.Char import Data.Maybe import Data.Monoid import Data.Proxy import Data.Tagged import Data.Typeable import Data.Foldable hiding (concatMap,elem,sequence_) import Options.Applicative import Prelude hiding (fail) -- Silence AMP and FTP import warnings import System.IO import System.Console.ANSI -------------------------------------------------- -- TestOutput base definitions -------------------------------------------------- -- {{{ -- | 'TestOutput' is an intermediary between output formatting and output -- printing. It lets us have several different printing modes (normal; print -- failures only; quiet). -- -- @since 0.11.3 data TestOutput = PrintTest {- print test name -} (IO ()) {- print test result -} (Result -> IO ()) -- ^ Action that prints the test name and an action that renders the -- result of the action. | PrintHeading (IO ()) TestOutput -- ^ Action that prints the heading of a test group and the 'TestOutput' -- for that test group. | Skip -- ^ Inactive test (e.g. not matching the current pattern) | Seq TestOutput TestOutput -- ^ Two sets of 'TestOuput' on the same level -- The monoid laws should hold observationally w.r.t. the semantics defined -- in this module instance Monoid TestOutput where mempty = Skip mappend = Seq type Level = Int -- | Build the 'TestOutput' for a 'TestTree' and 'OptionSet'. The @colors@ -- ImplicitParam controls whether the output is colored. -- -- @since 0.11.3 buildTestOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput buildTestOutput opts tree = let -- Do not retain the reference to the tree more than necessary !alignment = computeAlignment opts tree runSingleTest :: (IsTest t, ?colors :: Bool) => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput runSingleTest _opts name _test = Ap $ do level <- ask let printTestName = do printf "%s%s: %s" (indent level) name (replicate (alignment - indentSize * level - length name) ' ') hFlush stdout printTestResult result = do rDesc <- formatMessage $ resultDescription result -- use an appropriate printing function let printFn = if resultSuccessful result then ok else fail time = resultTime result printFn (resultShortDescription result) -- print time only if it's significant when (time >= 0.01) $ printFn (printf " (%.2fs)" time) printFn "\n" when (not $ null rDesc) $ (if resultSuccessful result then infoOk else infoFail) $ printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc) return $ PrintTest printTestName printTestResult runGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput runGroup name grp = Ap $ do level <- ask let printHeading = printf "%s%s\n" (indent level) name printBody = runReader (getApp grp) (level + 1) return $ PrintHeading printHeading printBody in flip runReader 0 $ getApp $ foldTestTree trivialFold { foldSingle = runSingleTest , foldGroup = runGroup } opts tree -- | Fold function for the 'TestOutput' tree into a 'Monoid'. -- -- @since 0.11.3 foldTestOutput :: Monoid b => (IO () -> IO Result -> (Result -> IO ()) -> b) -- ^ Eliminator for test cases. The @IO ()@ prints the testname. The -- @IO Result@ blocks until the test is finished, returning it's 'Result'. -- The @Result -> IO ()@ function prints the formatted output. -> (IO () -> b -> b) -- ^ Eliminator for test groups. The @IO ()@ prints the test group's name. -- The @b@ is the result of folding the test group. -> TestOutput -- ^ The @TestOutput@ being rendered. -> StatusMap -- ^ The @StatusMap@ received by the 'TestReporter' -> b foldTestOutput foldTest foldHeading outputTree smap = flip evalState 0 $ getApp $ go outputTree where go (PrintTest printName printResult) = Ap $ do ix <- get put $! ix + 1 let statusVar = fromMaybe (error "internal error: index out of bounds") $ IntMap.lookup ix smap readStatusVar = getResultFromTVar statusVar return $ foldTest printName readStatusVar printResult go (PrintHeading printName printBody) = Ap $ foldHeading printName <$> getApp (go printBody) go (Seq a b) = mappend (go a) (go b) go Skip = mempty -- }}} -------------------------------------------------- -- TestOutput modes -------------------------------------------------- -- {{{ consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO () consoleOutput output smap = getTraversal . fst $ foldTestOutput foldTest foldHeading output smap where foldTest printName getResult printResult = ( Traversal $ do printName r <- getResult printResult r , Any True) foldHeading printHeading (printBody, Any nonempty) = ( Traversal $ do when nonempty $ do printHeading; getTraversal printBody , Any nonempty ) consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO () consoleOutputHidingSuccesses output smap = void . getApp $ foldTestOutput foldTest foldHeading output smap where foldTest printName getResult printResult = Ap $ do printName r <- getResult if resultSuccessful r then do clearThisLine; return $ Any False else do printResult r; return $ Any True foldHeading printHeading printBody = Ap $ do printHeading Any failed <- getApp printBody unless failed clearAboveLine return $ Any failed clearAboveLine = do cursorUpLine 1; clearThisLine clearThisLine = do clearLine; setCursorColumn 0 streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO () streamOutputHidingSuccesses output smap = void . flip evalStateT [] . getApp $ foldTestOutput foldTest foldHeading output smap where foldTest printName getResult printResult = Ap $ do r <- liftIO $ getResult if resultSuccessful r then return $ Any False else do stack <- get put [] liftIO $ do sequence_ $ reverse stack printName printResult r return $ Any True foldHeading printHeading printBody = Ap $ do modify (printHeading :) Any failed <- getApp printBody unless failed $ modify $ \stack -> case stack of _:rest -> rest [] -> [] -- shouldn't happen anyway return $ Any failed -- }}} -------------------------------------------------- -- Statistics -------------------------------------------------- -- {{{ -- | Track the number of tests that were run and failures of a 'TestTree' or -- sub-tree. -- -- @since 0.11.3 data Statistics = Statistics { statTotal :: !Int -- ^ Number of active tests (e.g., that match the -- pattern specified on the commandline), inactive tests -- are not counted. , statFailures :: !Int -- ^ Number of active tests that failed. } instance Monoid Statistics where Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2) mempty = Statistics 0 0 computeStatistics :: StatusMap -> IO Statistics computeStatistics = getApp . foldMap (\var -> Ap $ (\r -> Statistics 1 (if resultSuccessful r then 0 else 1)) <$> getResultFromTVar var) -- | @printStatistics@ reports test success/failure statistics and time it took -- to run. The 'Time' results is intended to be filled in by the 'TestReporter' -- callback. The @colors@ ImplicitParam controls whether coloured output is -- used. -- -- @since 0.11.3 printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO () printStatistics st time = do printf "\n" case statFailures st of 0 -> do ok $ printf "All %d tests passed (%.2fs)\n" (statTotal st) time fs -> do fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) time -- | Wait until -- -- * all tests have finished successfully, and return 'True', or -- -- * at least one test has failed, and return 'False' statusMapResult :: Int -- ^ lookahead -> StatusMap -> IO Bool statusMapResult lookahead0 smap | IntMap.null smap = return True | otherwise = join . atomically $ IntMap.foldrWithKey f finish smap mempty lookahead0 where f :: Int -> TVar Status -> (IntMap.IntMap () -> Int -> STM (IO Bool)) -> (IntMap.IntMap () -> Int -> STM (IO Bool)) -- ok_tests is a set of tests that completed successfully -- lookahead is the number of unfinished tests that we are allowed to -- look at f key tvar k ok_tests lookahead | lookahead <= 0 = -- We looked at too many unfinished tests. next_iter ok_tests | otherwise = do this_status <- readTVar tvar case this_status of Done r -> if resultSuccessful r then k (IntMap.insert key () ok_tests) lookahead else return $ return False _ -> k ok_tests (lookahead-1) -- next_iter is called when we end the current iteration, -- either because we reached the end of the test tree -- or because we exhausted the lookahead next_iter :: IntMap.IntMap () -> STM (IO Bool) next_iter ok_tests = -- If we made no progress at all, wait until at least some tests -- complete. -- Otherwise, reduce the set of tests we are looking at. if IntMap.null ok_tests then retry else return $ statusMapResult lookahead0 (IntMap.difference smap ok_tests) finish :: IntMap.IntMap () -> Int -> STM (IO Bool) finish ok_tests _ = next_iter ok_tests -- }}} -------------------------------------------------- -- Console test reporter -------------------------------------------------- -- {{{ -- | A simple console UI consoleTestReporter :: Ingredient consoleTestReporter = TestReporter [ Option (Proxy :: Proxy Quiet) , Option (Proxy :: Proxy HideSuccesses) , Option (Proxy :: Proxy UseColor) ] $ \opts tree -> Just $ \smap -> do let whenColor = lookupOption opts Quiet quiet = lookupOption opts HideSuccesses hideSuccesses = lookupOption opts NumThreads numThreads = lookupOption opts if quiet then do b <- statusMapResult numThreads smap return $ \_time -> return b else do isTerm <- hSupportsANSI stdout (\k -> if isTerm then (do hideCursor; k) `finally` showCursor else k) $ do hSetBuffering stdout LineBuffering let ?colors = useColor whenColor isTerm let output = buildTestOutput opts tree case () of { _ | hideSuccesses && isTerm -> consoleOutputHidingSuccesses output smap | hideSuccesses && not isTerm -> streamOutputHidingSuccesses output smap | otherwise -> consoleOutput output smap } return $ \time -> do stats <- computeStatistics smap printStatistics stats time return $ statFailures stats == 0 -- | Do not print test results (see README for details) newtype Quiet = Quiet Bool deriving (Eq, Ord, Typeable) instance IsOption Quiet where defaultValue = Quiet False parseValue = fmap Quiet . safeRead optionName = return "quiet" optionHelp = return "Do not produce any output; indicate success only by the exit code" optionCLParser = mkFlagCLParser (short 'q') (Quiet True) -- | Report only failed tests newtype HideSuccesses = HideSuccesses Bool deriving (Eq, Ord, Typeable) instance IsOption HideSuccesses where defaultValue = HideSuccesses False parseValue = fmap HideSuccesses . safeRead optionName = return "hide-successes" optionHelp = return "Do not print tests that passed successfully" optionCLParser = mkFlagCLParser mempty (HideSuccesses True) -- | When to use color on the output -- -- @since 0.11.3 data UseColor = Never | Always | Auto -- ^ Only if stdout is an ANSI color supporting terminal deriving (Eq, Ord, Typeable) -- | Control color output instance IsOption UseColor where defaultValue = Auto parseValue = parseUseColor optionName = return "color" optionHelp = return "When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')" -- | @useColor when isTerm@ decides if colors should be used, -- where @isTerm@ indicates whether @stdout@ is a terminal device. -- -- @since 0.11.3 useColor :: UseColor -> Bool -> Bool useColor when isTerm = case when of Never -> False Always -> True Auto -> isTerm parseUseColor :: String -> Maybe UseColor parseUseColor s = case map toLower s of "never" -> return Never "always" -> return Always "auto" -> return Auto _ -> Nothing -- }}} -------------------------------------------------- -- Various utilities -------------------------------------------------- -- {{{ getResultFromTVar :: TVar Status -> IO Result getResultFromTVar var = atomically $ do status <- readTVar var case status of Done r -> return r _ -> retry -- }}} -------------------------------------------------- -- Formatting -------------------------------------------------- -- {{{ 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 -- (Potentially) colorful output ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO () 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 -- }}} tasty-0.11.3/Test/Tasty/Parallel.hs0000644000000000000000000001171213127364673015257 0ustar0000000000000000-- | A helper module which takes care of parallelism {-# LANGUAGE DeriveDataTypeable #-} module Test.Tasty.Parallel (runInParallel) where import Control.Monad import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Foreign.StablePtr import Data.Typeable import GHC.Conc (labelThread) data Interrupt = Interrupt deriving Typeable instance Show Interrupt where show Interrupt = "interrupted" instance Exception Interrupt data ParThreadKilled = ParThreadKilled SomeException deriving Typeable instance Show ParThreadKilled where show (ParThreadKilled exn) = "tasty: one of the test running threads was killed by: " ++ show exn instance Exception ParThreadKilled shutdown :: ThreadId -> IO () shutdown = flip throwTo Interrupt -- | Take a list of actions and execute them in parallel, no more than @n@ -- at the same time. -- -- The action itself is asynchronous, ie. it returns immediately and does -- the work in new threads. It returns an action which aborts tests and -- cleans up. runInParallel :: Int -- ^ maximum number of parallel threads -> [IO ()] -- ^ list of actions to execute -> IO (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. shutdownAll :: IO () shutdownAll = do pids <- atomically $ do writeTVar aliveVar False readTVar pidsVar -- be sure not to kill myself! me <- myThreadId mapM_ shutdown $ filter (/= me) pids cleanup :: Either SomeException () -> IO () cleanup Right {} = return () cleanup (Left exn) | Just Interrupt <- fromException exn -- I'm being shut down either by a fellow thread (which caught an -- exception), or by the main thread which decided to stop running -- tests. In any case, just end silently. = return () | otherwise = do -- Wow, I caught an exception (most probably an async one, -- although it doesn't really matter). Shut down all other -- threads, and re-throw my exception to the calling thread. shutdownAll throwTo callingThread $ ParThreadKilled exn forkCarefully :: IO () -> IO ThreadId forkCarefully action = 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 pid <- forkCarefully (do a; release) labelThread pid "tasty_test_thread" cont else retry -- fork here as well, so that we can move to the UI without waiting -- untill all tests have finished pid <- forkCarefully $ foldr go (return ()) actions labelThread pid "tasty_thread_manager" return shutdownAll -- 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.11.3/Test/Tasty/Core.hs0000644000000000000000000002140213127364673014410 0ustar0000000000000000-- | Core types and definitions {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, ExistentialQuantification, RankNTypes, DeriveDataTypeable, DeriveGeneric #-} module Test.Tasty.Core where 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 GHC.Generics import Prelude -- Silence AMP and FTP import warnings import Text.Printf -- | If a test failed, 'FailureReason' describes why data FailureReason = TestFailed -- ^ test provider indicated failure of the code to test, either because -- the tested code returned wrong results, or raised an exception | TestThrewException SomeException -- ^ the test code itself raised an exception. Typical cases include missing -- example input or output files. -- -- Usually, providers do not have to implement this, as their 'run' method -- may simply raise an exception. | TestTimedOut Integer -- ^ test didn't complete in allotted time deriving Show -- | Outcome of a test run -- -- Note: this is isomorphic to @'Maybe' 'FailureReason'@. You can use the -- @generic-maybe@ package to exploit that. data Outcome = Success -- ^ test succeeded | Failure FailureReason -- ^ test failed because of the 'FailureReason' deriving (Show, Generic) -- | Time in seconds. Used to measure how long the tests took to run. type Time = Double -- | A test result data Result = Result { resultOutcome :: Outcome -- ^ Did the test fail? If so, why? , 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. , resultShortDescription :: String -- ^ The short description printed in the test run summary, usually @OK@ or -- @FAIL@. , resultTime :: Time -- ^ How long it took to run the test, in seconds. } -- | 'True' for a passed test, 'False' for a failed one. resultSuccessful :: Result -> Bool resultSuccessful r = case resultOutcome r of Success -> True Failure {} -> False -- | Shortcut for creating a 'Result' that indicates exception exceptionResult :: SomeException -> Result exceptionResult e = Result { resultOutcome = Failure $ TestThrewException e , resultDescription = "Exception: " ++ show e , resultShortDescription = "FAIL" , resultTime = 0 } -- | 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 -- -- This method should cleanly catch any exceptions in the code to test, and -- return them as part of the 'Result', see 'FailureReason' for an -- explanation. It is ok for 'run' to raise an exception if there is a -- problem with the test suite code itself (for example, if a file that -- should contain example data or expected output is not found). 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 ()) -- | A resources-related exception data ResourceError = NotRunningTests | UnexpectedState String String | UseOutsideOfTest deriving Typeable instance Show ResourceError where show NotRunningTests = "Unhandled resource. Probably a bug in the runner you're using." show (UnexpectedState where_ what) = printf "Unexpected state of the resource (%s) in %s. Report as a tasty bug." what where_ show UseOutsideOfTest = "It looks like you're attempting to use a resource outside of its test. Don't do that!" 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) -- | 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.11.3/Test/Tasty/Options/Core.hs0000644000000000000000000000564013127364673016051 0ustar0000000000000000-- | Core options, i.e. the options used by tasty itself {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- for (^) module Test.Tasty.Options.Core ( NumThreads(..) , Timeout(..) , mkTimeout , coreOptions ) where import Control.Monad (mfilter) import Data.Proxy import Data.Typeable import Data.Tagged import Data.Fixed import Data.Monoid import Options.Applicative import GHC.Conc import Prelude -- Silence FTP import warnings 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 = NumThreads numCapabilities parseValue = mfilter onlyPositive . fmap NumThreads . safeRead optionName = return "num-threads" optionHelp = return "Number of threads to use for tests execution" optionCLParser = mkOptionCLParser (short 'j') -- | Filtering function to prevent non-positive number of threads onlyPositive :: NumThreads -> Bool onlyPositive (NumThreads x) = x > 0 -- | Timeout to be applied to individual tests data Timeout = Timeout Integer String -- ^ 'String' is the original representation of the timeout (such as -- @\"0.5m\"@), so that we can print it back. 'Integer' is the number of -- microseconds. | NoTimeout deriving (Show, Typeable) instance IsOption Timeout where defaultValue = NoTimeout parseValue str = Timeout <$> parseTimeout str <*> pure str optionName = return "timeout" optionHelp = return "Timeout for individual tests (suffixes: ms,s,m,h; default: s)" optionCLParser = mkOptionCLParser (short 't') parseTimeout :: String -> Maybe Integer parseTimeout str = -- it sucks that there's no more direct way to convert to a number of -- microseconds (round :: Micro -> Integer) . (* 10^6) <$> case reads str of [(n, suffix)] -> case suffix of "ms" -> Just (n / 10^3) "" -> Just n "s" -> Just n "m" -> Just (n * 60) "h" -> Just (n * 60^2) _ -> Nothing _ -> Nothing -- | A shortcut for creating 'Timeout' values mkTimeout :: Integer -- ^ microseconds -> Timeout mkTimeout n = Timeout n $ showFixed True (fromInteger n / (10^6) :: Micro) ++ "s" -- | The list of all core options, i.e. the options not specific to any -- provider or ingredient, but to tasty itself. Currently contains -- 'TestPattern' and 'Timeout'. coreOptions :: [OptionDescription] coreOptions = [ Option (Proxy :: Proxy TestPattern) , Option (Proxy :: Proxy Timeout) ] tasty-0.11.3/Test/Tasty/Options/Env.hs0000644000000000000000000000364013127364673015707 0ustar0000000000000000-- | Get options from the environment {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} module Test.Tasty.Options.Env (getEnvOptions, suiteEnvOptions) where import Test.Tasty.Options import Test.Tasty.Core import Test.Tasty.Ingredients import Test.Tasty.Runners.Reducers import System.Environment import Data.Foldable import Data.Tagged import Data.Proxy import Data.Char import Data.Typeable import Control.Exception import Control.Applicative import Prelude -- Silence AMP and FTP import warnings import Text.Printf data EnvOptionException = BadOption String -- option name String -- variable name String -- value deriving (Typeable) instance Show EnvOptionException where show (BadOption optName varName value) = printf "Bad environment variable %s='%s' (parsed as option %s)" varName value optName instance Exception EnvOptionException -- | Search the environment for given options getEnvOptions :: [OptionDescription] -> IO OptionSet getEnvOptions = getApp . foldMap lookupOpt where lookupOpt (Option (px :: Proxy v)) = do let name = proxy optionName px envName = ("TASTY_" ++) . flip map name $ \c -> if c == '-' then '_' else toUpper c mbValueStr <- Ap $ myLookupEnv envName flip foldMap mbValueStr $ \valueStr -> let mbValue :: Maybe v mbValue = parseValue valueStr err = throwIO $ BadOption name envName valueStr in Ap $ maybe err (return . singleOption) mbValue -- | Search the environment for all options relevant for this suite suiteEnvOptions :: [Ingredient] -> TestTree -> IO OptionSet suiteEnvOptions ins tree = getEnvOptions $ suiteOptions ins tree -- note: switch to lookupEnv once we no longer support 7.4 myLookupEnv :: String -> IO (Maybe String) myLookupEnv name = either (const Nothing) Just <$> (try (getEnv name) :: IO (Either IOException String)) tasty-0.11.3/Test/Tasty/Patterns.hs0000644000000000000000000001344413133325627015320 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 import Data.Tagged import Options.Applicative import Data.Monoid data Token = SlashToken | WildcardToken | DoubleWildcardToken | LiteralToken Char deriving (Eq, Show) 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 deriving Show -- | A pattern to filter tests. For the syntax description, see -- the README. data TestPattern = TestPattern { tp_categories_only :: Bool, tp_negated :: Bool, tp_match_mode :: TestPatternMatchMode, tp_tokens :: [Token] } | NoPattern deriving (Typeable, Show) -- | 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" optionCLParser = mkOptionCLParser (short 'p') -- | 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 test_pattern = -- It is important that GHC assigns arity 1 to this function, -- so that compilation of the regex is shared among the invocations. -- See #175. case test_pattern of NoPattern -> const True TestPattern {} -> \path -> let path_to_consider | tp_categories_only test_pattern = dropLast 1 path | otherwise = path 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 in not_maybe . any (match tokens_regex) $ things_to_match where not_maybe | tp_negated test_pattern = not | otherwise = id tokens_regex :: Regex tokens_regex = makeRegex $ buildTokenRegex (tp_tokens test_pattern) 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.11.3/Test/Tasty/Run.hs0000644000000000000000000002526113127364673014273 0ustar0000000000000000-- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, FlexibleContexts, BangPatterns #-} 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 Data.Maybe import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader import Control.Concurrent.STM import Control.Concurrent.Timeout (timeout) import Control.Concurrent.Async import Control.Exception as E import Control.Applicative import Control.Arrow import GHC.Conc (labelThread) import Prelude -- Silence AMP and FTP import warnings import qualified System.Clock as Clock import Test.Tasty.Core import Test.Tasty.Parallel import Test.Tasty.Options import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers -- | Current status of a test data Status = NotStarted -- ^ test has not started running yet | Executing Progress -- ^ test is being run | 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 | BeingCreated | FailedToCreate SomeException | Created r | Destroyed instance Show (Resource r) where show r = case r of NotCreated -> "NotCreated" BeingCreated -> "BeingCreated" FailedToCreate exn -> "FailedToCreate " ++ show exn Created {} -> "Created" Destroyed -> "Destroyed" data ResourceVar = forall r . ResourceVar (TVar (Resource r)) data Initializer = forall res . Initializer (IO res) (TVar (Resource res)) data Finalizer = forall res . Finalizer (res -> IO ()) (TVar (Resource res)) (TVar Int) -- | Execute a test taking care of resources 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 -> Timeout -- ^ optional timeout to apply -> Seq.Seq Initializer -- ^ initializers (to be executed in this order) -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order) -> IO () executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do resultOrExn <- try $ restore $ do -- N.B. this can (re-)throw an exception. It's okay. By design, the -- actual test will not be run, then. We still run all the -- finalizers. -- -- There's no point to transform these exceptions to something like -- EitherT, because an async exception (cancellation) can strike -- anyway. initResources -- If all initializers ran successfully, actually run the test. -- We run it in a separate thread, so that the test's exception -- handler doesn't interfere with our timeout. withAsync (action yieldProgress) $ \asy -> do labelThread (asyncThreadId asy) "tasty_test_execution_thread" timed $ applyTimeout timeoutOpt $ wait asy -- no matter what, try to run each finalizer mbExn <- destroyResources restore atomically . writeTVar statusVar $ Done $ case resultOrExn <* maybe (Right ()) Left mbExn of Left ex -> exceptionResult ex Right (t,r) -> r { resultTime = t } where initResources :: IO () initResources = F.forM_ inits $ \(Initializer doInit initVar) -> do join $ atomically $ do resStatus <- readTVar initVar case resStatus of NotCreated -> do -- signal to others that we're taking care of the resource -- initialization writeTVar initVar BeingCreated return $ (do res <- doInit atomically $ writeTVar initVar $ Created res ) `E.catch` \exn -> do atomically $ writeTVar initVar $ FailedToCreate exn throwIO exn BeingCreated -> retry Created {} -> return $ return () FailedToCreate exn -> return $ throwIO exn _ -> return $ throwIO $ unexpectedState "initResources" resStatus applyTimeout :: Timeout -> IO Result -> IO Result applyTimeout NoTimeout a = a applyTimeout (Timeout t tstr) a = do let timeoutResult = Result { resultOutcome = Failure $ TestTimedOut t , resultDescription = "Timed out after " ++ tstr , resultShortDescription = "TIMEOUT" , resultTime = fromIntegral t } fromMaybe timeoutResult <$> timeout t a -- destroyResources should not be interrupted by an exception -- Here's how we ensure this: -- -- * the finalizer is wrapped in 'try' -- * async exceptions are masked by the caller -- * we don't use any interruptible operations here (outside of 'try') destroyResources :: (forall a . IO a -> IO a) -> IO (Maybe SomeException) destroyResources restore = do -- remember the first exception that occurred liftM getFirst . execWriterT . getTraversal $ flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) -> Traversal $ do iAmLast <- liftIO $ atomically $ do nUsers <- readTVar finishVar let nUsers' = nUsers - 1 writeTVar finishVar nUsers' return $ nUsers' == 0 mbExcn <- liftIO $ if iAmLast then join $ atomically $ do resStatus <- readTVar initVar case resStatus of Created res -> do -- Don't worry about double destroy — only one thread -- receives iAmLast return $ (either Just (const Nothing) <$> try (restore $ doRelease res)) <* atomically (writeTVar initVar Destroyed) FailedToCreate {} -> return $ return Nothing _ -> return $ return $ Just $ unexpectedState "destroyResources" resStatus else return Nothing tell $ First mbExcn -- The callback -- Since this is not used yet anyway, disable for now. -- I'm not sure whether we should get rid of this altogether. For most -- providers this is either difficult to implement or doesn't make -- sense at all. -- See also https://github.com/feuerbach/tasty/issues/33 yieldProgress _ = return () type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer) -- | Turn a test tree into a list of actions to run tests coupled with -- variables to watch them createTestActions :: OptionSet -> TestTree -> IO ([(IO (), TVar Status)], [ResourceVar]) createTestActions opts tree = do let traversal :: Traversal (WriterT ([(InitFinPair -> IO (), TVar Status)], [ResourceVar]) IO) traversal = foldTestTree trivialFold { foldSingle = runSingleTest , foldResource = addInitAndRelease } opts tree (tests, rvars) <- unwrap traversal let tests' = map (first ($ (Seq.empty, Seq.empty))) tests return (tests', rvars) where runSingleTest opts _ test = Traversal $ do statusVar <- liftIO $ atomically $ newTVar NotStarted let act (inits, fins) = executeTest (run opts test) statusVar (lookupOption opts) inits fins tell ([(act, statusVar)], mempty) addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ do initVar <- atomically $ newTVar NotCreated (tests, rvars) <- unwrap $ a (getResource initVar) let ntests = length tests finishVar <- atomically $ newTVar ntests let ini = Initializer doInit initVar fin = Finalizer doRelease initVar finishVar tests' = map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests return (tests', ResourceVar initVar : rvars) wrap = Traversal . WriterT . fmap ((,) ()) unwrap = execWriterT . getTraversal -- | Used to create the IO action which is passed in a WithResource node getResource :: TVar (Resource r) -> IO r getResource var = atomically $ do rState <- readTVar var case rState of Created r -> return r Destroyed -> throwSTM UseOutsideOfTest _ -> throwSTM $ unexpectedState "getResource" rState -- | Start running all the tests in a test tree in parallel, without -- blocking the current thread. The number of test running threads is -- determined by the 'NumThreads' option. launchTestTree :: OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -- ^ A callback. First, it receives the 'StatusMap' through which it -- can observe the execution of tests in real time. Typically (but not -- necessarily), it waits until all the tests are finished. -- -- After this callback returns, the test-running threads (if any) are -- terminated and all resources acquired by tests are released. -- -- The callback must return another callback (of type @'Time' -> 'IO' -- a@) which additionally can report and/or record the total time -- taken by the test suite. This time includes the time taken to run -- all resource initializers and finalizers, which is why it is more -- accurate than what could be measured from inside the first callback. -> IO a launchTestTree opts tree k = do (testActions, rvars) <- createTestActions opts tree let NumThreads numTheads = lookupOption opts (t,k) <- timed $ do abortTests <- runInParallel numTheads (fst <$> testActions) (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions) k smap) `finally` do abortTests waitForResources rvars k t where alive :: Resource r -> Bool alive r = case r of NotCreated -> False BeingCreated -> True FailedToCreate {} -> False Created {} -> True Destroyed -> False waitForResources rvars = atomically $ forM_ rvars $ \(ResourceVar rvar) -> do res <- readTVar rvar check $ not $ alive res unexpectedState :: String -> Resource r -> SomeException unexpectedState where_ r = toException $ UnexpectedState where_ (show r) -- | Measure the time taken by an 'IO' action to run timed :: IO a -> IO (Time, a) timed t = do start <- getTime !r <- t end <- getTime return (end-start, r) -- | Get monotonic time -- -- Warning: This is not the system time, but a monotonically increasing time -- that facilitates reliable measurement of time differences. getTime :: IO Time getTime = do t <- Clock.getTime Clock.Monotonic let ns = realToFrac $ Clock.timeSpecAsNanoSecs t return $ ns / 10 ^ (9 :: Int) tasty-0.11.3/Test/Tasty/Runners/Reducers.hs0000644000000000000000000000443613142007130016713 0ustar0000000000000000-- | Monoidal wrappers for applicative functors. Useful to define tree -- folds. -- These are the same as in the 'reducers' package. We do not use -- 'reducers' to avoid its dependencies. {- License for the 'reducers' package Copyright 2008-2011 Edward Kmett All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. -} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Tasty.Runners.Reducers where import Data.Monoid import Control.Applicative import Prelude -- Silence AMP import warnings -- | Monoid generated by '*>' newtype Traversal f = Traversal { getTraversal :: f () } instance Applicative f => Monoid (Traversal f) where mempty = Traversal $ pure () Traversal f1 `mappend` Traversal f2 = Traversal $ f1 *> f2 -- | Monoid generated by @'liftA2' ('<>')@ newtype Ap f a = Ap { getApp :: f a } deriving (Functor, Applicative, Monad) instance (Applicative f, Monoid a) => Monoid (Ap f a) where mempty = pure mempty mappend = liftA2 mappend tasty-0.11.3/Test/Tasty/Runners/Utils.hs0000644000000000000000000000201713127364673016255 0ustar0000000000000000-- | Note: this module is re-exported as a whole from "Test.Tasty.Runners" module Test.Tasty.Runners.Utils where import Control.Exception import Control.DeepSeq import Control.Applicative import Prelude -- Silence AMP import warnings import Text.Printf -- | Catch possible exceptions that may arise when evaluating a string. -- For normal (total) strings, this is a no-op. -- -- This function should be used to display messages generated by the test -- suite (such as test result descriptions). -- -- See e.g. 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)) tasty-0.11.3/Test/Tasty/CmdLine.hs0000644000000000000000000000650313144257207015031 0ustar0000000000000000-- | Parsing options supplied on the command line {-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-} module Test.Tasty.CmdLine ( optionParser , suiteOptions , suiteOptionParser , defaultMainWithIngredients ) where import Options.Applicative import Data.Monoid import Data.Proxy import Data.Foldable (foldMap) import Prelude -- Silence AMP and FTP import warnings import System.Exit import System.IO -- We install handlers only on UNIX (obviously) and on GHC >= 7.6. -- GHC 7.4 lacks mkWeakThreadId (see #181), and this is not important -- enough to look for an alternative implementation, so we just disable it -- there. #define INSTALL_HANDLERS defined UNIX && MIN_VERSION_base(4,6,0) #if INSTALL_HANDLERS import Control.Concurrent (mkWeakThreadId, myThreadId) import Control.Exception (Exception(..), throwTo) import Control.Monad (forM_) import Data.Typeable (Typeable) import System.Posix.Signals import System.Mem.Weak (deRefWeak) #endif import Test.Tasty.Core import Test.Tasty.Ingredients import Test.Tasty.Options import Test.Tasty.Options.Env import Test.Tasty.Runners.Reducers -- | Generate a command line parser from a list of option descriptions optionParser :: [OptionDescription] -> Parser OptionSet optionParser = getApp . foldMap toSet where toSet :: OptionDescription -> Ap Parser OptionSet toSet (Option (Proxy :: Proxy v)) = Ap $ (singleOption <$> (optionCLParser :: Parser v)) <|> pure mempty -- | 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. -- -- When the tests finish, this function calls 'exitWith' with the exit code -- that indicates whether any tests have failed. See 'defaultMain' for -- details. defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO () defaultMainWithIngredients ins testTree = do installSignalHandlers cmdlineOpts <- execParser $ info (helper <*> suiteOptionParser ins testTree) ( fullDesc <> header "Mmm... tasty test suite" ) envOpts <- suiteEnvOptions ins testTree let opts = envOpts <> cmdlineOpts case tryIngredients ins opts testTree of Nothing -> do hPutStrLn stderr "No ingredients agreed to run. Something is wrong either with your ingredient set or the options." exitFailure Just act -> do ok <- act if ok then exitSuccess else exitFailure -- from https://ro-che.info/articles/2014-07-30-bracket -- Install a signal handler so that e.g. the cursor is restored if the test -- suite is killed by SIGTERM. installSignalHandlers :: IO () installSignalHandlers = do #if INSTALL_HANDLERS main_thread_id <- myThreadId weak_tid <- mkWeakThreadId main_thread_id forM_ [ sigABRT, sigBUS, sigFPE, sigHUP, sigILL, sigQUIT, sigSEGV, sigSYS, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ ] $ \sig -> installHandler sig (Catch $ send_exception weak_tid sig) Nothing where send_exception weak_tid sig = do m <- deRefWeak weak_tid case m of Nothing -> return () Just tid -> throwTo tid (toException $ SignalException sig) newtype SignalException = SignalException Signal deriving (Show, Typeable) instance Exception SignalException #else return () #endif tasty-0.11.3/Test/Tasty/Ingredients/ListTests.hs0000644000000000000000000000264013127364673017734 0ustar0000000000000000-- | Ingredient for listing test names {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Test.Tasty.Ingredients.ListTests ( ListTests(..) , testsNames , listingTests ) where import Data.Proxy import Data.Typeable import Data.Monoid import Options.Applicative 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 = mkFlagCLParser (short 'l') (ListTests True) -- | 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 tasty-0.11.3/Test/Tasty/Ingredients/IncludingOptions.hs0000644000000000000000000000064713127364673021273 0ustar0000000000000000-- | Ingredient for registering user-defined options 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) tasty-0.11.3/LICENSE0000644000000000000000000000204312457221174012137 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.11.3/Setup.hs0000644000000000000000000000005612457221174012570 0ustar0000000000000000import Distribution.Simple main = defaultMain tasty-0.11.3/tasty.cabal0000644000000000000000000000416513171665425013276 0ustar0000000000000000-- Initial tasty.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: tasty version: 0.11.3 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden tests, QuickCheck/SmallCheck properties, and any other types of tests into a single test suite. license: MIT license-file: LICENSE author: Roman Cheplyaka maintainer: Roman Cheplyaka homepage: https://github.com/feuerbach/tasty bug-reports: https://github.com/feuerbach/tasty/issues -- copyright: category: Testing build-type: Simple extra-source-files: CHANGELOG.md, README.md cabal-version: >=1.10 Source-repository head type: git location: git://github.com/feuerbach/tasty.git subdir: core library exposed-modules: Test.Tasty, Test.Tasty.Options, Test.Tasty.Providers, Test.Tasty.Runners Test.Tasty.Ingredients, Test.Tasty.Ingredients.Basic Test.Tasty.Ingredients.ConsoleReporter other-modules: Test.Tasty.Parallel, Test.Tasty.Core, Test.Tasty.Options.Core, Test.Tasty.Options.Env, Test.Tasty.Patterns, Test.Tasty.Run, Test.Tasty.Runners.Reducers, Test.Tasty.Runners.Utils, Test.Tasty.CmdLine, 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.2, optparse-applicative >= 0.11, deepseq >= 1.3, unbounded-delays >= 0.1, async >= 2.0, ansi-terminal >= 0.6.2, clock >= 0.4.4.0 if impl(ghc < 7.6) -- for GHC.Generics build-depends: ghc-prim if !os(windows) build-depends: unix cpp-options: -DUNIX -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing tasty-0.11.3/CHANGELOG.md0000644000000000000000000001504613171726221012747 0ustar0000000000000000Changes ======= Version 0.11.3 -------------- Expose and document several of the internals of `Test.Tasty.Ingredients.ConsoleReporter`. Version 0.11.2.5 ---------------- Fix compatibility with GHC 7.4 Version 0.11.2.4 ---------------- 1. Make the `--quiet` mode more efficient on a large number of tests 2. Fix a bug where a cursor would disappear if the test suite was terminated by a signal other than SIGINT. Version 0.11.2.3 ---------------- Make filtering tests (`-p`) work faster Version 0.11.2.2 ---------------- Fix a critical bug in the quiet mode (`-q`/`--quiet`): the exit status could be wrong or the test suite could hang. Version 0.11.2.1 ---------------- Fix compatibility with the latest `unbounded-delays` Version 0.11.2 -------------- Add `composeReporters`, a function to run multiple reporter ingredients Version 0.11.1 -------------- Introduce `mkOptionCLParser` and `mkFlagCLParser` Version 0.11.0.4 ---------------- Fix compatibility with `optparse-applicative-0.13` Version 0.11.0.3 ---------------- Switch from `regex-tdfa-rc` to `regex-tdfa`, which got a new maintainer. Version 0.11.0.2 ---------------- Clarify `IsTest`’s specification with regard to exceptions Version 0.11.0.1 ---------------- Use monotonic clock when measuring durations. Version 0.11 ------------ New field `resultShortDescription` of `Result` Version 0.10.1.2 ---------------- * Improve the docs * Fix compatibility with GHC HEAD Version 0.10.1.1 ---------------- * Prevent parsing non-positive number of threads via program options (#104) * Buffer output to avoid slowdowns when printing test results (#101) * Default to using the maximum number of available cores for test execution Version 0.10.1 -------------- Export `Test.Tasty.Runners.formatMessage` Version 0.10.0.4 ---------------- Don't output ANSI codes for the Emacs terminal emulator Version 0.10.0.3 ---------------- Better handle the situation when there are no ingredients to run Version 0.10.0.2 ---------------- Split the changelog into per-project changelogs Version 0.10.0.1 ---------------- Update to optparse-applicative 0.11 Version 0.10 ------------ * Add the `--color` option * Timings * Introduce the `Time` type synonym * Change the types of `launchTestTree` and `TestReporter` to accept the total run time * `consoleTestReporter` now displays the timings Version 0.9.0.1 --------------- Upgrade to optparse-applicative-0.10. Version 0.8.1.3 --------------- Be careful not to export the `Show (a -> b)` instance, see Version 0.8.1.2 --------------- Hide cursor when running tests Version 0.8.1.1 --------------- Fix for GHC 7.9 Version 0.8.0.4 --------------- Remove the old 'colors' flag description from the cabal file Version 0.8.0.2 --------------- Make ansi-terminal an unconditional dependency Version 0.8 ----------- * `Test.Tasty.Ingredients` is now exposed * `Test.Tasty.Ingredients.Basic` is added, which exports the ingredients defined in the `tasty` package. These exports should now be used instead of ones exported from `Test.Tasty.Runners` * The `Result` type is now structured a bit differently. Providers now should use `testPassed` and `testFailed` functions instead of constructing `Result`s directly. * Add «quiet mode» (see README) * Add «hide successes» mode (see README) * Add short command-line options: `-j` for `--num-threads`, `-p` for `--pattern` * Add timeout support * `AppMonoid` is renamed to `Traversal` for consistency with the 'reducers' package. Another similar wrapper, `Ap`, is introduced. * Fix a resources bug (resources were not released if the test suite was interrupted) * The type of `launchTestTree` is changed. It now takes a continuation as an argument. This is necessary to fix the bug mentioned above. * Add `flagCLParser` to be used as the `optionCLParser` implementation for boolean options. * Add the ability to pass options via environment Version 0.7 ----------- * Use `regex-tdfa` instead of `regex-posix` (which is a native implementation, and as such is more portable) * `foldTestTree` now takes the algebra in the form of a record rather than multiple arguments, to minimize breakage when new nodes are added or existing ones change * `withResource` now passes the IO action to get the resource to the inner test tree Version 0.6 ----------- * Better handling of exceptions that arise during resource creation or disposal * Expose the `AppMonoid` wrapper * Add `askOption` and `inludingOptions` Version 0.5.2.1 --------------- Depend on ansi-terminal >= 0.6.1. This fixes some issues with colors on Windows. Version 0.5.2 ------------- * Export `Result` and `Progress` from `Test.Tasty.Runners` * Make it clear that only GHC 7.4+ is supported Version 0.5.1 ------------- Export `ResourceSpec` from `Test.Tasty.Runners` Version 0.5 ----------- Add a capability to acquire and release resources. See the «Resources» section in the `Test.Tasty` docs. For the end users, the API is backwards-compatible. Test runners may have to be adjusted — there is a new constructor of `TestTree` and a new argument of `foldTestTree`. Version 0.4.2 ------------- Add `defaultIngredients` Version 0.4.1.1 --------------- Print the failure description in red Version 0.4.0.1 --------------- Fix a bug ([#25](https://github.com/feuerbach/tasty/issues/25)) Version 0.4 ----------- The big change in this release is introduction of ingredients, which is a replacement for runners. But unless you have a custom runner, this is unlikely to affect you much. The `Ingredient` data type has replaced the `Runner` type. The following functions have been renamed and possibly changed their types: * `defaultMainWithRunner` → `defaultMainWithIngredients` * `treeOptionParser` → `suiteOptionParser` * `getTreeOptions` → `treeOptions` * `runUI` → `consoleTestReporter` Added in this release: * `suiteOptions` * `optionParser` * functions operating on ingredients * `testsNames` * the `listingTests` ingredient and its option, `ListTests` `NumThreads` is no longer a core option, but is automatically included in the test reporting ingredients (see its haddock). Version 0.3.1 ------------- * Proper reporting of (some) non-terminating tests (#15) * Upgrade to optparse-applicative 0.6 Version 0.3 ----------- * Restrict dependency versions * Fix a bug where non-terminating test would lead to a deadlock (#15) Version 0.2 ----------- * Add an `execRunner` function * Make `Runner` return `IO Bool` Version 0.1.1 ------------- Set lower bound on optparse-applicative dependency version tasty-0.11.3/README.md0000644000000000000000000004133313127364673012425 0ustar0000000000000000# Tasty **Tasty** is a modern testing framework for Haskell. It lets you combine your unit tests, golden tests, QuickCheck/SmallCheck properties, and any other types of tests into a single test suite. Features: * Run tests in parallel but report results in a deterministic order * Filter the tests to be run using patterns specified on the command line * Hierarchical, colored display of test results * Reporting of test statistics * Acquire and release resources (sockets, temporary files etc.) that can be shared among several tests * Extensibility: add your own test providers and ingredients (runners) above and beyond those provided [![Build Status](https://travis-ci.org/feuerbach/tasty.png?branch=master)](https://travis-ci.org/feuerbach/tasty) To find out what's new, read the **[change log][]**. [change log]: https://github.com/feuerbach/tasty/blob/master/core/CHANGELOG.md Ask any tasty-related questions on the **[mailing list][]** or IRC channel **#tasty** at FreeNode ([logs & stats][ircbrowse]). [mailing list]: https://groups.google.com/forum/#!forum/haskell-tasty [ircbrowse]: http://ircbrowse.net/tasty ## Example Here's how your `test.hs` might look like: ```haskell import Test.Tasty import Test.Tasty.SmallCheck as SC import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit import Data.List import Data.Ord main = defaultMain tests tests :: TestTree tests = testGroup "Tests" [properties, unitTests] properties :: TestTree properties = testGroup "Properties" [scProps, qcProps] scProps = testGroup "(checked by SmallCheck)" [ SC.testProperty "sort == sort . reverse" $ \list -> sort (list :: [Int]) == sort (reverse list) , SC.testProperty "Fermat's little theorem" $ \x -> ((x :: Integer)^7 - x) `mod` 7 == 0 -- the following property does not hold , SC.testProperty "Fermat's last theorem" $ \x y z n -> (n :: Integer) >= 3 SC.==> x^n + y^n /= (z^n :: Integer) ] qcProps = testGroup "(checked by QuickCheck)" [ QC.testProperty "sort == sort . reverse" $ \list -> sort (list :: [Int]) == sort (reverse list) , QC.testProperty "Fermat's little theorem" $ \x -> ((x :: Integer)^7 - x) `mod` 7 == 0 -- the following property does not hold , QC.testProperty "Fermat's last theorem" $ \x y z n -> (n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer) ] unitTests = testGroup "Unit tests" [ testCase "List comparison (different length)" $ [1, 2, 3] `compare` [1,2] @?= GT -- the following test does not hold , testCase "List comparison (same length)" $ [1, 2, 3] `compare` [1,2,2] @?= LT ] ``` And here is the output of the above program: ![](https://raw.github.com/feuerbach/tasty/master/screenshot.png) (Note that whether QuickCheck finds a counterexample to the third property is determined by chance.) ## Packages [tasty][] is the core package. It contains basic definitions and APIs and a console runner. [tasty]: http://hackage.haskell.org/package/tasty In order to create a test suite, you also need to install one or more «providers» (see below). ### Providers The following providers exist: * [tasty-hunit](http://hackage.haskell.org/package/tasty-hunit) — for unit tests (based on [HUnit](http://hackage.haskell.org/package/HUnit)) * [tasty-golden][] — for golden tests, which are unit tests whose results are kept in files * [tasty-smallcheck](http://hackage.haskell.org/package/tasty-smallcheck) — exhaustive property-based testing (based on [smallcheck](http://hackage.haskell.org/package/smallcheck)) * [tasty-quickcheck](http://hackage.haskell.org/package/tasty-quickcheck) — for randomized property-based testing (based on [QuickCheck](http://hackage.haskell.org/package/QuickCheck)) * [tasty-hspec](http://hackage.haskell.org/package/tasty-hspec) — for [Hspec](http://hspec.github.io/) tests * [tasty-program](http://hackage.haskell.org/package/tasty-program) — run external program and test whether it terminates successfully [tasty-golden]: http://hackage.haskell.org/package/tasty-golden It's easy to create custom providers using the API from `Test.Tasty.Providers`. ### Ingredients 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. It is possible to write custom ingredients using the API from `Test.Tasty.Runners`. Some ingredients that can enhance your test suite are: * [tasty-ant-xml](http://hackage.haskell.org/package/tasty-ant-xml) adds a possibility to write the test results in a machine-readable XML format, which is understood by various CI systems and IDEs * [tasty-rerun](http://hackage.haskell.org/package/tasty-rerun) adds support for minimal test reruns by recording previous test runs and using this information to filter the test tree. For example, you can use this ingredient to only run failed tests, or only run tests that threw an exception. * [tasty-html](http://hackage.haskell.org/package/tasty-html) adds the possibility to write the test results as a HTML file * [tasty-stats](http://hackage.haskell.org/package/tasty-stats) adds the possibility to collect statistics of the test suite in a CSV file. ### Other packages * [tasty-th](http://hackage.haskell.org/package/tasty-th) automatically discovers tests based on the function names and generate the boilerplate code for you * [tasty-hunit-adapter](http://hackage.haskell.org/package/tasty-hunit-adapter) converts existing HUnit test suites into tasty test suites * [tasty-discover](https://github.com/lwm/tasty-discover) automatically discovers your tests. * [tasty-expected-failure](https://github.com/nomeata/tasty-expected-failure) provides test markers for when you expect failures or wish to ignore tests. ## Options Options allow one to customize the run-time behavior of the test suite, such as: * mode of operation (run tests, list tests, run tests quietly etc.) * which tests are run (see «Patterns» below) * parameters of individual providers (like depth of search for SmallCheck) ### Setting options There are two main ways to set options: #### Runtime When using the standard console runner, the options can be passed on the command line or via environment variables. To see the available options, run your test suite with the `--help` flag. The output will look something like this (depending on which ingredients and providers the test suite uses): ``` % ./test --help Mmm... tasty test suite Usage: test [-p|--pattern ARG] [-t|--timeout ARG] [-l|--list-tests] [-j|--num-threads ARG] [-q|--quiet] [--hide-successes] [--color ARG] [--quickcheck-tests ARG] [--quickcheck-replay ARG] [--quickcheck-show-replay ARG] [--quickcheck-max-size ARG] [--quickcheck-max-ratio ARG] [--quickcheck-verbose] [--smallcheck-depth ARG] Available options: -h,--help Show this help text -p,--pattern ARG Select only tests that match pattern -t,--timeout ARG Timeout for individual tests (suffixes: ms,s,m,h; default: s) -l,--list-tests Do not run the tests; just print their names -j,--num-threads ARG Number of threads to use for tests execution -q,--quiet Do not produce any output; indicate success only by the exit code --hide-successes Do not print tests that passed successfully --color ARG When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto') --quickcheck-tests ARG Number of test cases for QuickCheck to generate --quickcheck-replay ARG Replay token to use for replaying a previous test run --quickcheck-show-replay ARG Show a replay token for replaying tests --quickcheck-max-size ARG Size of the biggest test cases quickcheck generates --quickcheck-max-ratio ARG Maximum number of discared tests per successful test before giving up --quickcheck-verbose Show the generated test cases --smallcheck-depth ARG Depth to use for smallcheck tests ``` Every option can be passed via environment. To obtain the environment variable name from the option name, replace hyphens `-` with underscores `_`, capitalize all letters, and prepend `TASTY_`. For example, the environment equivalent of `--smallcheck-depth` is `TASTY_SMALLCHECK_DEPTH`. To turn on a switch (such as `TASTY_HIDE_SUCCESSES`), set the variable to `True`. If you're using a non-console runner, please refer to its documentation to find out how to configure options during the run time. #### Compile-time You can also specify options in the test suite itself, using `localOption`. It can be applied not only to the whole test tree, but also to individual tests or subgroups, so that different tests can be run with different options. It is possible to combine run-time and compile-time options, too, by using `adjustOption`. For example, make the overall testing depth configurable during the run time, but increase or decrease it slightly for individual tests. This method currently doesn't work for ingredient options, such as `--quiet` or `--num-threads`. You can set them by setting the corresponding environment variable before calling `defaultMain`: ```haskell import Test.Tasty import System.Environment main = do setEnv "TASTY_NUM_THREADS" "1" defaultMain _ ``` ### Patterns It is possible to restrict the set of executed tests using the `--pattern` option. The syntax of patterns is the same as for test-framework, namely: - An optional prefixed bang `!` negates the pattern. - If the pattern ends with a slash, it is removed for the purpose of the following description, but it would only find a match with a test group. In other words, `foo/` will match a group called `foo` and any tests underneath it, but will not match a regular test `foo`. - If the pattern does not contain a slash `/`, the framework checks for a match against any single component of the path. - Otherwise, the pattern is treated as a glob, where: - The wildcard `*` matches anything within a single path component (i.e. `foo` but not `foo/bar`). - Two wildcards `**` matches anything (i.e. `foo` and `foo/bar`). - Anything else matches exactly that text in the path (i.e. `foo` would only match a component of the test path called `foo` (or a substring of that form). For example, `group/*1` matches `group/test1` but not `group/subgroup/test1`, whereas both examples would be matched by `group/**1`. A leading slash matches the beginning of the test path; for example, `/test*` matches `test1` but not `group/test1`. ### Running tests in parallel In order to run tests in parallel, you have to do the following: * Compile (or, more precisely, *link*) your test program with the `-threaded` flag; * Launch the program with `+RTS -N -RTS`. ### Timeout To apply timeout to individual tests, use the `--timeout` (or `-t`) command-line option, or set the option in your test suite using the `mkTimeout` function. Timeouts can be fractional, and can be optionally followed by a suffix `ms` (milliseconds), `s` (seconds), `m` (minutes), or `h` (hours). When there's no suffix, seconds are assumed. Example: ./test --timeout=0.5m sets a 30 seconds timeout for each individual test. ### Options controlling console output The following options control behavior of the standard console interface:
-q,--quiet
Run the tests but don't output anything. The result is indicated only by the exit code, which is 1 if at least one test has failed, and 0 if all tests have passed. Execution stops when the first failure is detected, so not all tests are necessarily run. This may be useful for various batch systems, such as commit hooks.
--hide-successes
Report only the tests that has failed. Especially useful when the number of tests is large.
-l,--list-tests
Don't run the tests; only list their names, in the format accepted by --pattern.
--color
Whether to produce colorful output. Accepted values: never, always, auto. auto means that colors will only be enabled when output goes to a terminal and is the default value.
### Custom options It is possible to add custom options, too. To do that, 1. Define a datatype to represent the option, and make it an instance of `IsOption` 2. Register the options with the `includingOptions` ingredient 3. To query the option value, use `askOption`. See the [Custom options in Tasty][custom-options-article] article for some examples. ## Project organization and integration with Cabal There may be several ways to organize your project. What follows is not Tasty's requirements but my recommendations. ### Tests for a library Place your test suite sources in a dedicated subdirectory (called `tests` here) instead of putting them among the main library sources. The directory structure will be as follows: my-project/ my-project.cabal src/ ... tests/ test.hs Mod1.hs Mod2.hs ... `test.hs` is where your `main` function is defined. The tests may be contained in `test.hs` or spread across multiple modules (`Mod1.hs`, `Mod2.hs`, ...) which are then imported by `test.hs`. Add the following section to the cabal file (`my-project.cabal`): test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: test.hs build-depends: base >= 4 && < 5 , tasty >= 0.7 -- insert the current version here , my-project -- depend on the library we're testing , ... ### Tests for a program All the above applies, except you can't depend on the library if there's no library. You have two options: * Re-organize the project into a library and a program, so that both the program and the test suite depend on this new library. The library can be declared in the same cabal file. * Add your program sources directory to the `Hs-source-dirs`. Note that this will lead to double compilation (once for the program and once for the test suite). ## FAQ 1. How do I make some tests execute after others? Currently, your only option is to make all tests execute sequentially by setting the number of tasty threads to 1 ([example](#num_threads_example)). See [#48](https://github.com/feuerbach/tasty/issues/48) for the discussion. ## Press Blog posts and other publications related to tasty. If you wrote or just found something not mentioned here, send a pull request! * [Holy Haskell Project Starter](http://yannesposito.com/Scratch/en/blog/Holy-Haskell-Starter/) * [First time testing, also with FP Complete](http://levischuck.com/posts/2013-11-13-first-testing-and-fpcomplete.html) (tasty has been added to stackage since then) * [24 Days of Hackage: tasty](http://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html) * [Resources in Tasty](http://ro-che.info/articles/2013-12-10-tasty-resources.html) * [Custom options in Tasty][custom-options-article] * [Resources in Tasty (update)](http://ro-che.info/articles/2013-12-29-tasty-resources-2.html) * [Announcing tasty-rerun](http://ocharles.org.uk/blog/posts/2014-01-20-announcing-tasty-rerun.html) * [Code testing in Haskell revisited (with Tasty)](http://lambda.jstolarek.com/2014/01/code-testing-in-haskell-revisited-with-tasty/) [custom-options-article]: http://ro-che.info/articles/2013-12-20-tasty-custom-options.html ## Background Tasty is heavily influenced by [test-framework][]. The problems with test-framework are: * Poor code style (some lines of the code wouldn't even fit in a twitter message!) * Poor architecture — e.g. relying on laziness for IO and control flow. The whole story with `:~>` and `ImprovingIO` is really obscure. * Non-extensible options. For example, when I integrated SmallCheck with test-framework (in the form of the `test-framework-smallcheck` package), I still had to submit patches to the main package to make SmallCheck depth customizable by the user. * The project is effectively unmaintained. So I decided to recreate everything that I liked in test-framework from scratch in this package. [test-framework]: http://batterseapower.github.io/test-framework/ Maintainers ----------- [Roman Cheplyaka](https://github.com/feuerbach) is the primary maintainer. [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please get in touch with him if the primary maintainer cannot be reached.