tasty-1.2.3/Test/0000755000000000000000000000000013465550677012010 5ustar0000000000000000tasty-1.2.3/Test/Tasty/0000755000000000000000000000000013477217461013106 5ustar0000000000000000tasty-1.2.3/Test/Tasty/Ingredients/0000755000000000000000000000000013477214635015361 5ustar0000000000000000tasty-1.2.3/Test/Tasty/Options/0000755000000000000000000000000013465550677014547 5ustar0000000000000000tasty-1.2.3/Test/Tasty/Patterns/0000755000000000000000000000000013465550677014714 5ustar0000000000000000tasty-1.2.3/Test/Tasty/Runners/0000755000000000000000000000000013465550677014550 5ustar0000000000000000tasty-1.2.3/Test/Tasty.hs0000644000000000000000000001003013465550677013442 0ustar0000000000000000-- | This module defines the main data types and functions needed to use -- Tasty. -- -- To create a test suite, you also need one or more test providers, such -- as -- or -- . -- -- A simple example (using tasty-hunit) is -- -- >import Test.Tasty -- >import Test.Tasty.HUnit -- > -- >main = defaultMain tests -- > -- >tests :: TestTree -- >tests = testGroup "Tests" -- > [ testCase "2+2=4" $ -- > 2+2 @?= 4 -- > , testCase "7 is even" $ -- > assertBool "Oops, 7 is odd" (even 7) -- > ] -- -- Take a look at the : -- it contains a comprehensive list of test providers, a bigger example, -- and a lot of other information. 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 -- * Dependencies , DependencyType(..) , after , after_ ) 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-1.2.3/Test/Tasty/Options.hs0000644000000000000000000001315113465550677015104 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, ExistentialQuantification, GADTs, 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 , safeReadBool ) where import qualified Data.Map as Map import Data.Map (Map) import Data.Char (toLower) import Data.Tagged import Data.Proxy import Data.Typeable import Data.Monoid import Data.Foldable import Prelude hiding (mod) -- Silence FTP import warnings import Options.Applicative #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup) import qualified Data.Semigroup (Semigroup((<>))) #endif -- | 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. Consider using -- 'safeReadBool' for boolean options and 'safeRead' for numeric options. 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 #if MIN_VERSION_base(4,9,0) instance Semigroup OptionSet where (<>) = mappend #endif -- | 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 -- | Parse a 'Bool' case-insensitively safeReadBool :: String -> Maybe Bool safeReadBool s = case (map toLower s) of "true" -> Just True "false" -> Just False _ -> Nothing tasty-1.2.3/Test/Tasty/Providers.hs0000644000000000000000000000144513127364673015423 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-1.2.3/Test/Tasty/Runners.hs0000644000000000000000000000262113465550677015105 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 , parseOptions , optionParser , suiteOptionParser , defaultMainWithIngredients -- * Running tests , Status(..) , Result(..) , Outcome(..) , FailureReason(..) , resultSuccessful , Progress(..) , StatusMap , launchTestTree , NumThreads(..) , DependencyException(..) -- * 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-1.2.3/Test/Tasty/Ingredients.hs0000644000000000000000000001325013465550677015724 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-1.2.3/Test/Tasty/Ingredients/Basic.hs0000644000000000000000000000113313127364673016734 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-1.2.3/Test/Tasty/Ingredients/ConsoleReporter.hs0000644000000000000000000004720513477214635021052 0ustar0000000000000000-- vim:fdm=marker:foldtext=foldtext() {-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts #-} -- | Console reporter ingredient module Test.Tasty.Ingredients.ConsoleReporter ( consoleTestReporter , Quiet(..) , HideSuccesses(..) , AnsiTricks(..) -- * 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(..) , computeStatistics , printStatistics , printStatisticsNoTime -- ** Outputting results , TestOutput(..) , buildTestOutput , foldTestOutput ) where import Prelude hiding (fail) import Control.Monad.State hiding (fail) import Control.Monad.Reader hiding (fail,reader) import Control.Concurrent.STM import Control.Exception 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 #ifdef UNIX import Data.Char.WCWidth (wcwidth) #endif import Data.Maybe import Data.Monoid (Any(..)) import Data.Typeable import Options.Applicative hiding (str, Success, Failure) import System.IO import System.Console.ANSI #if !MIN_VERSION_base(4,8,0) import Data.Proxy import Data.Foldable hiding (concatMap,elem,sequence_) #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup) import qualified Data.Semigroup (Semigroup((<>))) #else import Data.Monoid #endif -------------------------------------------------- -- 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.12 data TestOutput = PrintTest {- test name -} String {- print test name -} (IO ()) {- print test result -} (Result -> IO ()) -- ^ Name of a test, an action that prints the test name, and an action -- that renders the result of the action. | PrintHeading String (IO ()) TestOutput -- ^ Name of a test group, an 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 #if MIN_VERSION_base(4,9,0) instance Semigroup TestOutput where (<>) = mappend #endif 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 - stringWidth name) ' ') hFlush stdout printTestResult result = do rDesc <- formatMessage $ resultDescription result -- use an appropriate printing function let printFn = case resultOutcome result of Success -> ok Failure TestDepFailed -> skipped _ -> 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 name 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 name 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.12 foldTestOutput :: Monoid b => (String -> 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. -> (String -> 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 name 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 name printName readStatusVar printResult go (PrintHeading name printName printBody) = Ap $ foldHeading name 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 toutput smap = getTraversal . fst $ foldTestOutput foldTest foldHeading toutput smap where foldTest _name printName getResult printResult = ( Traversal $ do printName :: IO () r <- getResult printResult r , Any True) foldHeading _name printHeading (printBody, Any nonempty) = ( Traversal $ do when nonempty $ do printHeading :: IO (); getTraversal printBody , Any nonempty ) consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO () consoleOutputHidingSuccesses toutput smap = void . getApp $ foldTestOutput foldTest foldHeading toutput smap where foldTest _name printName getResult printResult = Ap $ do printName :: IO () r <- getResult if resultSuccessful r then do clearThisLine; return $ Any False else do printResult r :: IO (); return $ Any True foldHeading _name printHeading printBody = Ap $ do printHeading :: IO () 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 toutput smap = void . flip evalStateT [] . getApp $ foldTestOutput foldTest foldHeading toutput smap where foldTest _name 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 :: IO () printResult r :: IO () return $ Any True foldHeading _name 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 #if MIN_VERSION_base(4,9,0) instance Semigroup Statistics where (<>) = mappend #endif -- | @computeStatistics@ computes a summary 'Statistics' for -- a given state of the 'StatusMap'. -- Useful in combination with @printStatistics@ computeStatistics :: StatusMap -> IO Statistics computeStatistics = getApp . foldMap (\var -> Ap $ (\r -> Statistics 1 (if resultSuccessful r then 0 else 1)) <$> getResultFromTVar var) reportStatistics :: (?colors :: Bool) => Statistics -> IO () reportStatistics st = case statFailures st of 0 -> ok $ printf "All %d tests passed" (statTotal st) fs -> fail $ printf "%d out of %d tests failed" fs (statTotal st) -- | @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" reportStatistics st case statFailures st of 0 -> ok $ printf " (%.2fs)\n" time _ -> fail $ printf " (%.2fs)\n" time -- | @printStatisticsNoTime@ reports test success/failure statistics -- The @colors@ ImplicitParam controls whether coloured output is used. -- -- @since 0.12 printStatisticsNoTime :: (?colors :: Bool) => Statistics -> IO () printStatisticsNoTime st = reportStatistics st >> printf "\n" -- | 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) , Option (Proxy :: Proxy AnsiTricks) ] $ \opts tree -> Just $ \smap -> do let whenColor = lookupOption opts Quiet quiet = lookupOption opts HideSuccesses hideSuccesses = lookupOption opts NumThreads numThreads = lookupOption opts AnsiTricks ansiTricks = lookupOption opts if quiet then do b <- statusMapResult numThreads smap return $ \_time -> return b else do isTerm <- hSupportsANSI stdout isTermColor <- hSupportsANSIColor stdout (\k -> if isTerm then (do hideCursor; k) `finally` showCursor else k) $ do hSetBuffering stdout LineBuffering let ?colors = useColor whenColor isTermColor let toutput = buildTestOutput opts tree case () of { _ | hideSuccesses && isTerm && ansiTricks -> consoleOutputHidingSuccesses toutput smap | hideSuccesses -> streamOutputHidingSuccesses toutput smap | otherwise -> consoleOutput toutput 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 . safeReadBool 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 . safeReadBool 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 (default: 'auto')" optionCLParser = mkOptionCLParser $ metavar "never|always|auto" -- | By default, when the option @--hide-successes@ is given and the output -- goes to an ANSI-capable terminal, we employ some ANSI terminal tricks to -- display the name of the currently running test and then erase it if it -- succeeds. -- -- These tricks sometimes fail, however—in particular, when the test names -- happen to be longer than the width of the terminal window. See -- -- * -- -- * -- -- When that happens, this option can be used to disable the tricks. In -- that case, the test name will be printed only once the test fails. newtype AnsiTricks = AnsiTricks Bool deriving Typeable instance IsOption AnsiTricks where defaultValue = AnsiTricks True parseValue = fmap AnsiTricks . safeReadBool optionName = return "ansi-tricks" optionHelp = return $ -- Multiline literals don't work because of -XCPP. "Enable various ANSI terminal tricks. " ++ "Can be set to 'true' (default) or 'false'." -- | @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 #if MIN_VERSION_base(4,9,0) instance Ord a => Semigroup (Maximum a) where (<>) = mappend #endif -- | 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 (stringWidth name + level) , foldGroup = \_ m -> m . (+ indentSize) } opts where fromMonoid m = case m 0 of MinusInfinity -> 0 Maximum x -> x -- | Compute the length/width of the string as it would appear in a monospace -- terminal. This takes into account that even in a “mono”space font, not -- all characters actually have the same width, in particular, most CJK -- characters have twice the same as Western characters. -- -- (This only works properly on Unix at the moment; on Windows, the function -- treats every character as width-1 like 'Data.List.length' does.) stringWidth :: String -> Int #ifdef UNIX stringWidth = Prelude.sum . map charWidth where charWidth c = case wcwidth c of -1 -> 1 -- many chars have "undefined" width; default to 1 for these. w -> w #else stringWidth = length #endif -- (Potentially) colorful output ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO () fail = output BoldIntensity Vivid Red ok = output NormalIntensity Dull Green skipped = output NormalIntensity Dull Magenta 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-1.2.3/Test/Tasty/Patterns/Types.hs0000644000000000000000000000140513465550677016354 0ustar0000000000000000module Test.Tasty.Patterns.Types where data Expr = IntLit !Int | NF -- ^ number of fields | Add Expr Expr | Sub Expr Expr | Neg Expr | Not Expr | And Expr Expr | LT Expr Expr | GT Expr Expr | LE Expr Expr | GE Expr Expr | EQ Expr Expr | NE Expr Expr | Or Expr Expr | Concat Expr Expr | Match Expr String | NoMatch Expr String | Field Expr -- ^ nth field of the path, where 1 is the outermost group name and 0 is the whole test name, using @.@ (dot) as a separator | StringLit String | If Expr Expr Expr | ERE String -- ^ an ERE token by itself, like @/foo/@ but not like @$1 ~ /foo/@ | ToUpperFn Expr | ToLowerFn Expr | LengthFn (Maybe Expr) | MatchFn Expr String | SubstrFn Expr Expr (Maybe Expr) deriving (Show, Eq) tasty-1.2.3/Test/Tasty/Patterns/Parser.hs0000644000000000000000000001200113465550677016476 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | See for the -- full awk grammar. module Test.Tasty.Patterns.Parser ( Parser , runParser , ParseResult(..) , expr , parseAwkExpr ) where import Prelude hiding (Ordering(..)) import Text.ParserCombinators.ReadP hiding (many, optional) import Text.ParserCombinators.ReadPrec (readPrec_to_P, minPrec) import Text.Read (readPrec) import Data.Functor import Data.Char import Control.Applicative import Control.Monad import Test.Tasty.Patterns.Types import Test.Tasty.Patterns.Expr type Token = ReadP -- | A separate 'Parser' data type ensures that we don't forget to skip -- spaces. newtype Parser a = Parser (ReadP a) deriving (Functor, Applicative, Alternative, Monad, MonadPlus) #if !MIN_VERSION_base(4,6,0) instance Applicative ReadP where pure = return (<*>) = ap instance Alternative ReadP where empty = mzero (<|>) = mplus #endif data ParseResult a = Success a | Invalid | Ambiguous [a] deriving Show token :: Token a -> Parser a token a = Parser (a <* skipSpaces) sym :: Char -> Parser () sym = void . token . char str :: String -> Parser () str = void . token . string -- | Run a parser runParser :: Parser a -> String -- ^ text to parse -> ParseResult a runParser (Parser p) s = case filter (null . snd) $ readP_to_S (skipSpaces *> p) s of [(a, _)] -> Success a [] -> Invalid as -> Ambiguous (fst <$> as) intP :: Parser Int intP = token $ -- we cannot use the standard Int ReadP parser because it recognizes -- negative numbers, making -1 ambiguous read <$> munch1 isDigit strP :: Parser String strP = token $ readPrec_to_P readPrec minPrec -- this deviates somewhat from the awk string literals, by design -- | An awk ERE token such as @/foo/@. No special characters are recognized -- at the moment, except @\@ as an escape character for @/@ and itself. patP :: Parser String patP = token $ char '/' *> many ch <* char '/' where ch = satisfy (`notElem` "/\\") <|> (char '\\' *> satisfy (`elem` "/\\")) nfP :: Parser () nfP = token $ void $ string "NF" -- | Built-in functions builtin :: Parser Expr builtin = msum [ fn "length" $ LengthFn <$> optional expr -- we don't support length without parentheses at all, -- because that makes length($1) ambiguous -- (we don't require spaces for concatenation) , fn "toupper" $ ToUpperFn <$> expr , fn "tolower" $ ToLowerFn <$> expr , fn "match" $ MatchFn <$> expr <* sym ',' <*> patP , fn "substr" $ SubstrFn <$> expr <* sym ',' <*> expr <*> optional (sym ',' *> expr) ] where fn :: String -> Parser a -> Parser a fn name args = token (string name) *> sym '(' *> args <* sym ')' -- | Atomic expressions expr0 :: Parser Expr expr0 = (sym '(' *> expr <* sym ')') <|> (IntLit <$> intP) <|> (StringLit <$> strP) <|> (ERE <$> patP) <|> (NF <$ nfP) <|> builtin -- | Arguments to unary operators: atomic expressions and field -- expressions expr1 :: Parser Expr expr1 = makeExprParser expr0 [ [ Prefix (Field <$ sym '$') ] ] -- | Whether a parser is unary or non-unary. -- -- This roughly corresponds to the @unary_expr@ and @non_unary_expr@ -- non-terminals in the awk grammar. -- (Why roughly? See 'expr2'.) data Unary = Unary | NonUnary -- | Arithmetic expressions. -- -- Unlike awk, non-unary expressions disallow unary operators everywhere, -- not just in the leading position, to avoid extra complexity in -- 'makeExprParser'. -- -- For example, the expression -- -- >1 3 + -4 -- -- is valid in awk because @3 + -4@ is non-unary, but we disallow it here -- because 'makeExprParser' does not allow us to distinguish it from -- -- >1 -4 + 3 -- -- which is ambiguous. expr2 :: Unary -> Parser Expr expr2 unary = makeExprParser expr1 [ [ Prefix (Not <$ sym '!') ] ++ (case unary of Unary -> [ Prefix (Neg <$ sym '-') ] NonUnary -> [] ) , [ InfixL (Add <$ sym '+') , InfixL (Sub <$ sym '-') ] ] -- | Expressions that may include string concatenation expr3 :: Parser Expr expr3 = concatExpr <|> expr2 Unary where -- The awk spec mandates that concatenation associates to the left. -- But concatenation is associative, so why would we care. concatExpr = Concat <$> nonUnary <*> (nonUnary <|> concatExpr) nonUnary = expr2 NonUnary -- | Everything with lower precedence than concatenation expr4 :: Parser Expr expr4 = makeExprParser expr3 [ [ InfixN (LT <$ sym '<') , InfixN (GT <$ sym '>') , InfixN (LE <$ str "<=") , InfixN (GE <$ str ">=") , InfixN (EQ <$ str "==") , InfixN (NE <$ str "!=") ] , [ Postfix (flip Match <$ sym '~' <*> patP) , Postfix (flip NoMatch <$ str "!~" <*> patP) ] , [ InfixL (And <$ str "&&") ] , [ InfixL (Or <$ str "||") ] , [ TernR ((If <$ sym ':') <$ sym '?') ] ] -- | The awk-like expression parser expr :: Parser Expr expr = expr4 -- | Parse an awk expression parseAwkExpr :: String -> Maybe Expr parseAwkExpr s = case runParser expr s of Success e -> Just e _ -> Nothing tasty-1.2.3/Test/Tasty/Patterns/Eval.hs0000644000000000000000000001041613465550677016141 0ustar0000000000000000{-# LANGUAGE RankNTypes, ViewPatterns #-} module Test.Tasty.Patterns.Eval (Path, eval, withFields, asB) where import Prelude hiding (Ordering(..)) import Control.Monad.Reader import Control.Monad.Error.Class (throwError) -- see #201 import qualified Data.Sequence as Seq import Data.Foldable import Data.List import Data.Maybe import Data.Char import Test.Tasty.Patterns.Types #if !MIN_VERSION_base(4,8,0) import Control.Applicative import Data.Traversable #endif type Path = Seq.Seq String data Value = VN !Int | VS !Bool String -- ^ The 'Bool' is 'True' if the source of the string -- allows it to be numeric | Uninitialized deriving Show type M = ReaderT Path (Either String) asS :: Value -> M String asS v = return $ case v of VN n -> show n VS _ s -> s Uninitialized -> "" -- readMaybe was not in base-4.3 yet parseN :: String -> Maybe Int parseN s = case read s of [(n, "")] -> Just n _ -> Nothing asN :: Value -> M Int asN v = case v of VN n -> return n VS True s -> case parseN s of Just n -> return n Nothing -> throwError $ "Not a number: " ++ show s VS False s -> throwError $ "String is not numeric: " ++ show s Uninitialized -> return 0 isN :: Value -> Bool isN v = case v of VN _ -> True _ -> False isNumeric :: Value -> Bool isNumeric v = case v of VS b s -> b && isJust (parseN s) _ -> True asB :: Value -> M Bool asB v = return $ case v of VN 0 -> False VS _ "" -> False _ -> True fromB :: Bool -> Value fromB = VN . fromEnum -- | Evaluate an awk expression eval :: Expr -> M Value eval e0 = case e0 of IntLit n -> return $ VN n StringLit s -> return $ VS False s NF -> VN . subtract 1 . Seq.length <$> ask Add e1 e2 -> binNumOp (+) e1 e2 Sub e1 e2 -> binNumOp (-) e1 e2 Neg e1 -> VN . negate <$> (asN =<< eval e1) Not e1 -> fromB . not <$> (asB =<< eval e1) And e1 e2 -> binLglOp (&&) e1 e2 Or e1 e2 -> binLglOp (||) e1 e2 LT e1 e2 -> binCmpOp (<) e1 e2 LE e1 e2 -> binCmpOp (<=) e1 e2 GT e1 e2 -> binCmpOp (>) e1 e2 GE e1 e2 -> binCmpOp (>=) e1 e2 EQ e1 e2 -> binCmpOp (==) e1 e2 NE e1 e2 -> binCmpOp (/=) e1 e2 Concat e1 e2 -> VS False <$> ((++) <$> (asS =<< eval e1) <*> (asS =<< eval e2)) If cond e1 e2 -> do condV <- asB =<< eval cond if condV then eval e1 else eval e2 Field e1 -> do n <- asN =<< eval e1 fields <- ask return $ if n > Seq.length fields - 1 then Uninitialized else VS True $ Seq.index fields n ERE pat -> do str <- Seq.index <$> ask <*> pure 0 return . fromB $ match pat str Match e1 pat -> do str <- asS =<< eval e1 return . fromB $ match pat str NoMatch e1 pat -> do str <- asS =<< eval e1 return . fromB . not $ match pat str ToUpperFn e1 -> VS True . map toUpper <$> (asS =<< eval e1) ToLowerFn e1 -> VS True . map toLower <$> (asS =<< eval e1) SubstrFn e1 e2 mb_e3 -> do s <- asS =<< eval e1 m <- asN =<< eval e2 mb_n <- traverse (asN <=< eval) mb_e3 return $ VS True $ maybe id take mb_n . drop (m-1) $ s LengthFn (fromMaybe (Field (IntLit 0)) -> e1) -> VN . length <$> (asS =<< eval e1) MatchFn e1 pat -> do s <- asS =<< eval e1 return . VN . maybe 0 (+1) . findIndex (pat `isPrefixOf`) $ tails s where binNumOp op e1 e2 = VN <$> (op <$> (asN =<< eval e1) <*> (asN =<< eval e2)) binLglOp op e1 e2 = fromB <$> (op <$> (asB =<< eval e1) <*> (asB =<< eval e2)) binCmpOp :: (forall a . Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value binCmpOp op e1 e2 = do v1 <- eval e1 v2 <- eval e2 let compareAsNumbers = isN v1 && isNumeric v2 || isN v2 && isNumeric v1 if compareAsNumbers then fromB <$> (op <$> asN v1 <*> asN v2) else fromB <$> (op <$> asS v1 <*> asS v2) match :: String -- ^ pattern -> String -- ^ string -> Bool match pat str = pat `isInfixOf` str -- | Run the 'M' monad with a given list of fields -- -- The field list should not include @$0@; it's calculated automatically. withFields :: Seq.Seq String -> M a -> Either String a withFields fields a = runReaderT a (whole Seq.<| fields) where whole = intercalate "." $ toList fields tasty-1.2.3/Test/Tasty/Parallel.hs0000644000000000000000000000731713477217461015206 0ustar0000000000000000-- | A helper module which takes care of parallelism {-# LANGUAGE DeriveDataTypeable #-} module Test.Tasty.Parallel (ActionStatus(..), Action(..), runInParallel) where import Control.Monad import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM import Foreign.StablePtr -- | What to do about an 'Action'? data ActionStatus = ActionReady -- ^ the action is ready to be executed | ActionSkip -- ^ the action should be skipped | ActionWait -- ^ not sure what to do yet; wait deriving Eq data Action = Action { actionStatus :: STM ActionStatus , actionRun :: IO () , actionSkip :: STM () } -- | 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 -> [Action] -- ^ list of actions to execute. -- The first action in the pair tells if the second action is ready to run. -> 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) -- FIXME is this still needed? _ <- newStablePtr callingThread actionsVar <- atomically $ newTMVar actions pids <- replicateM nthreads (async $ work actionsVar) return $ do -- Tell worker threads there is no more work after their current task. -- 'cancel' below by itself is not sufficient because if an exception -- is thrown in the middle of a test, the worker thread simply marks -- the test as failed and moves on to their next task. We also need to -- make it clear that there are no further tasks. _ <- atomically $ swapTMVar actionsVar [] -- Cancel all the current tasks, waiting for workers to clean up. -- The waiting part is important (see #249), that's why we use cancel -- instead of killThread. mapM_ cancel pids work :: TMVar [Action] -> IO () work actionsVar = go where go = do join . atomically $ do mb_ready <- findBool =<< takeTMVar actionsVar case mb_ready of Nothing -> do -- Nothing left to do. Put back the TMVar so that other threads -- do not block on an empty TMVar (see #249) and return. putTMVar actionsVar [] return $ return () Just (this, rest) -> do putTMVar actionsVar rest return $ actionRun this >> go -- | Find a ready-to-run item. Filter out the items that will never be -- ready to run. -- -- Return the ready item and the remaining ones. -- -- This action may block if no items are ready to run just yet. -- -- Return 'Nothing' if there are no runnable items left. findBool :: [Action] -> STM (Maybe (Action, [Action])) findBool = go [] where go [] [] = -- nothing to do return Nothing go _ [] = -- nothing ready yet retry go past (this : rest) = do status <- actionStatus this case status of ActionReady -> return $ Just (this, reverse past ++ rest) ActionWait -> go (this : past) rest ActionSkip -> do actionSkip this go past rest tasty-1.2.3/Test/Tasty/Core.hs0000644000000000000000000003326413465550677014350 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 Test.Tasty.Patterns.Types import Data.Foldable import qualified Data.Sequence as Seq 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 | TestDepFailed -- See Note [Skipped tests] -- ^ a dependency of this test failed, so this test was skipped. 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. } deriving Show {- Note [Skipped tests] ~~~~~~~~~~~~~~~~~~~~ There are two potential ways to represent the tests that are skipped because of their failed dependencies: 1. With Outcome = Failure, and FailureReason giving the specifics (TestDepFailed) 2. With a dedicated Outcome = Skipped It seems to me that (1) will lead to fewer bugs (esp. in the extension packages), because most of the time skipped tests should be handled in the same way as failed tests. But sometimes it is not obvious what the right behavior should be. E.g. should --hide-successes show or hide the skipped tests? Perhaps we should hide them, because they aren't really informative. Or perhaps we shouldn't hide them, because we are not sure that they will pass, and hiding them will imply a false sense of security ("there's at most 2 tests failing", whereas in fact there could be much more). So I might change this in the future, but for now treating them as failures seems the easiest yet reasonable approach. -} -- | '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. } deriving Show -- | 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. -- Note: the callback is a no-op at the moment -- and there are no plans to use it; -- feel free to ignore this argument for now. -> 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 -- | These are the two ways in which one test may depend on the others. -- -- This is the same distinction as the -- . -- -- @since 1.2 data DependencyType = AllSucceed -- ^ The current test tree will be executed after its dependencies finish, and only -- if all of the dependencies succeed. | AllFinish -- ^ The current test tree will be executed after its dependencies finish, -- regardless of whether they succeed or not. deriving (Eq, Show) -- | 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 | After DependencyType Expr TestTree -- ^ Only run after all tests that match a given pattern finish -- (and, depending on the 'DependencyType', succeed) -- | Create a named group of test cases or other groups testGroup :: TestName -> [TestTree] -> TestTree testGroup = TestGroup -- | Like 'after', but accepts the pattern as a syntax tree instead -- of a string. Useful for generating a test tree programmatically. -- -- ==== __Examples__ -- -- Only match on the test's own name, ignoring the group names: -- -- @ -- 'after_' 'AllFinish' ('Test.Tasty.Patterns.Types.EQ' ('Field' 'NF') ('StringLit' \"Bar\")) $ -- 'testCase' \"A test that depends on Foo.Bar\" $ ... -- @ -- -- @since 1.2 after_ :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail -> Expr -- ^ the pattern -> TestTree -- ^ the subtree that depends on other tests -> TestTree -- ^ the subtree annotated with dependency information after_ = After -- | The 'after' combinator declares dependencies between tests. -- -- If a 'TestTree' is wrapped in 'after', the tests in this tree will not run -- until certain other tests («dependencies») have finished. These -- dependencies are specified using an AWK pattern (see the «Patterns» section -- in the README). -- -- Moreover, if the 'DependencyType' argument is set to 'AllSucceed' and -- at least one dependency has failed, this test tree will not run at all. -- -- Tasty does not check that the pattern matches any tests (let alone the -- correct set of tests), so it is on you to supply the right pattern. -- -- ==== __Examples__ -- -- The following test will be executed only after all tests that contain -- @Foo@ anywhere in their path finish. -- -- @ -- 'after' 'AllFinish' \"Foo\" $ -- 'testCase' \"A test that depends on Foo.Bar\" $ ... -- @ -- -- Note, however, that our test also happens to contain @Foo@ as part of its name, -- so it also matches the pattern and becomes a dependency of itself. This -- will result in a 'DependencyLoop' exception. To avoid this, either -- change the test name so that it doesn't mention @Foo@ or make the -- pattern more specific. -- -- You can use AWK patterns, for instance, to specify the full path to the dependency. -- -- @ -- 'after' 'AllFinish' \"$0 == \\\"Tests.Foo.Bar\\\"\" $ -- 'testCase' \"A test that depends on Foo.Bar\" $ ... -- @ -- -- Or only specify the dependency's own name, ignoring the group names: -- -- @ -- 'after' 'AllFinish' \"$NF == \\\"Bar\\\"\" $ -- 'testCase' \"A test that depends on Foo.Bar\" $ ... -- @ -- -- @since 1.2 after :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail -> String -- ^ the pattern -> TestTree -- ^ the subtree that depends on other tests -> TestTree -- ^ the subtree annotated with dependency information after deptype s = case parseExpr s of Nothing -> error $ "Could not parse pattern " ++ show s Just e -> after_ deptype e -- | 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 , foldAfter :: DependencyType -> Expr -> 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 , foldAfter = \_ _ b -> b } -- | 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 fAfter) opts0 tree0 = let pat = lookupOption opts0 in go pat mempty opts0 tree0 where go pat path opts tree1 = case tree1 of SingleTest name test | testPatternMatches pat (path Seq.|> name) -> fTest opts name test | otherwise -> mempty TestGroup name trees -> fGroup name $ foldMap (go pat (path Seq.|> name) opts) trees PlusTestOptions f tree -> go pat path (f opts) tree WithResource res0 tree -> fResource res0 $ \res -> go pat path opts (tree res) AskOptions f -> go pat path opts (f opts) After deptype dep tree -> fAfter deptype dep $ go pat path opts tree -- | 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-1.2.3/Test/Tasty/Options/Core.hs0000644000000000000000000000567713465550677016012 0ustar0000000000000000-- | Core options, i.e. the options used by tasty itself {-# LANGUAGE CPP, 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.Fixed import Options.Applicative hiding (str) import GHC.Conc #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif 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' <> metavar "NUMBER") -- | 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' <> metavar "DURATION") 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-1.2.3/Test/Tasty/Options/Env.hs0000644000000000000000000000372613465550677015643 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 :: OptionDescription -> Ap IO OptionSet 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-1.2.3/Test/Tasty/Patterns.hs0000644000000000000000000000276013465550677015255 0ustar0000000000000000-- | Test patterns {-# LANGUAGE CPP, DeriveDataTypeable #-} module Test.Tasty.Patterns ( TestPattern(..) , parseExpr , parseTestPattern , noPattern , Path , exprMatches , testPatternMatches ) where import Test.Tasty.Options import Test.Tasty.Patterns.Types import Test.Tasty.Patterns.Parser import Test.Tasty.Patterns.Eval import Data.Char import Data.Typeable import Options.Applicative hiding (Success) #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif newtype TestPattern = TestPattern (Maybe Expr) deriving (Typeable, Show, Eq) noPattern :: TestPattern noPattern = TestPattern Nothing instance IsOption TestPattern where defaultValue = noPattern parseValue = parseTestPattern optionName = return "pattern" optionHelp = return "Select only tests which satisfy a pattern or awk expression" optionCLParser = mkOptionCLParser (short 'p' <> metavar "PATTERN") parseExpr :: String -> Maybe Expr parseExpr s | all (\c -> isAlphaNum c || c `elem` "._- ") s = Just $ ERE s | otherwise = parseAwkExpr s parseTestPattern :: String -> Maybe TestPattern parseTestPattern s | null s = Just noPattern | otherwise = TestPattern . Just <$> parseExpr s exprMatches :: Expr -> Path -> Bool exprMatches e fields = case withFields fields $ asB =<< eval e of Left msg -> error msg Right b -> b testPatternMatches :: TestPattern -> Path -> Bool testPatternMatches pat fields = case pat of TestPattern Nothing -> True TestPattern (Just e) -> exprMatches e fields tasty-1.2.3/Test/Tasty/Patterns/Expr.hs0000644000000000000000000001430613465550677016172 0ustar0000000000000000-- | -- Copyright : © 2015–2018 Megaparsec contributors -- © 2007 Paolo Martini -- © 1999–2001 Daan Leijen -- -- -- Code adapted from from megaparsec under the BSD license. module Test.Tasty.Patterns.Expr ( Operator (..) , makeExprParser ) where import Control.Monad choice :: MonadPlus m => [m a] -> m a choice = msum option :: MonadPlus m => a -> m a -> m a option x p = p `mplus` return x -- | This data type specifies operators that work on values of type @a@. An -- operator is either binary infix or unary prefix or postfix. A binary -- operator has also an associated associativity. data Operator m a = InfixN (m (a -> a -> a)) -- ^ Non-associative infix | InfixL (m (a -> a -> a)) -- ^ Left-associative infix | InfixR (m (a -> a -> a)) -- ^ Right-associative infix | Prefix (m (a -> a)) -- ^ Prefix | Postfix (m (a -> a)) -- ^ Postfix | TernR (m (m (a -> a -> a -> a))) -- ^ Right-associative ternary. Right-associative means that -- @a ? b : d ? e : f@ parsed as -- @a ? b : (d ? e : f)@ and not as @(a ? b : d) ? e : f@. -- | @'makeExprParser' term table@ builds an expression parser for terms -- @term@ with operators from @table@, taking the associativity and -- precedence specified in the @table@ into account. -- -- @table@ is a list of @[Operator m a]@ lists. The list is ordered in -- descending precedence. All operators in one list have the same precedence -- (but may have different associativity). -- -- Prefix and postfix operators of the same precedence associate to the left -- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@). -- -- Unary operators of the same precedence can only occur once (i.e. @--2@ is -- not allowed if @-@ is prefix negate). If you need to parse several prefix -- or postfix operators in a row, (like C pointers—@**i@) you can use this -- approach: -- -- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp -- -- This is not done by default because in some cases allowing repeating -- prefix or postfix operators is not desirable. -- -- If you want to have an operator that is a prefix of another operator in -- the table, use the following (or similar) wrapper instead of plain -- 'Text.Megaparsec.Char.Lexer.symbol': -- -- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar) -- -- 'makeExprParser' takes care of all the complexity involved in building an -- expression parser. Here is an example of an expression parser that -- handles prefix signs, postfix increment and basic arithmetic: -- -- > expr = makeExprParser term table "expression" -- > -- > term = parens expr <|> integer "term" -- > -- > table = [ [ prefix "-" negate -- > , prefix "+" id ] -- > , [ postfix "++" (+1) ] -- > , [ binary "*" (*) -- > , binary "/" div ] -- > , [ binary "+" (+) -- > , binary "-" (-) ] ] -- > -- > binary name f = InfixL (f <$ symbol name) -- > prefix name f = Prefix (f <$ symbol name) -- > postfix name f = Postfix (f <$ symbol name) makeExprParser :: MonadPlus m => m a -- ^ Term parser -> [[Operator m a]] -- ^ Operator table, see 'Operator' -> m a -- ^ Resulting expression parser makeExprParser = foldl addPrecLevel {-# INLINEABLE makeExprParser #-} -- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@ -- to parser @p@. addPrecLevel :: MonadPlus m => m a -> [Operator m a] -> m a addPrecLevel term ops = term' >>= \x -> choice [ras' x, las' x, nas' x, tern' x, return x] where (ras, las, nas, prefix, postfix, tern) = foldr splitOp ([],[],[],[],[],[]) ops term' = pTerm (choice prefix) term (choice postfix) ras' = pInfixR (choice ras) term' las' = pInfixL (choice las) term' nas' = pInfixN (choice nas) term' tern' = pTernR (choice tern) term' -- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional -- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are -- allowed to fail, in this case 'id' is used. pTerm :: MonadPlus m => m (a -> a) -> m a -> m (a -> a) -> m a pTerm prefix term postfix = do pre <- option id prefix x <- term post <- option id postfix return . post . pre $ x -- | @pInfixN op p x@ parses non-associative infix operator @op@, then term -- with parser @p@, then returns result of the operator application on @x@ -- and the term. pInfixN :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a pInfixN op p x = do f <- op y <- p return $ f x y -- | @pInfixL op p x@ parses left-associative infix operator @op@, then term -- with parser @p@, then returns result of the operator application on @x@ -- and the term. pInfixL :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a pInfixL op p x = do f <- op y <- p let r = f x y pInfixL op p r `mplus` return r -- | @pInfixR op p x@ parses right-associative infix operator @op@, then -- term with parser @p@, then returns result of the operator application on -- @x@ and the term. pInfixR :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a pInfixR op p x = do f <- op y <- p >>= \r -> pInfixR op p r `mplus` return r return $ f x y -- | Parse the first separator of a ternary operator pTernR :: MonadPlus m => m (m (a -> a -> a -> a)) -> m a -> a -> m a pTernR sep1 p x = do sep2 <- sep1 y <- p >>= \r -> pTernR sep1 p r `mplus` return r f <- sep2 z <- p >>= \r -> pTernR sep1 p r `mplus` return r return $ f x y z type Batch m a = ( [m (a -> a -> a)] , [m (a -> a -> a)] , [m (a -> a -> a)] , [m (a -> a)] , [m (a -> a)] , [m (m (a -> a -> a -> a))] ) -- | A helper to separate various operators (binary, unary, and according to -- associativity) and return them in a tuple. splitOp :: Operator m a -> Batch m a -> Batch m a splitOp (InfixR op) (r, l, n, pre, post, tern) = (op:r, l, n, pre, post, tern) splitOp (InfixL op) (r, l, n, pre, post, tern) = (r, op:l, n, pre, post, tern) splitOp (InfixN op) (r, l, n, pre, post, tern) = (r, l, op:n, pre, post, tern) splitOp (Prefix op) (r, l, n, pre, post, tern) = (r, l, n, op:pre, post, tern) splitOp (Postfix op) (r, l, n, pre, post, tern) = (r, l, n, pre, op:post, tern) splitOp (TernR op) (r, l, n, pre, post, tern) = (r, l, n, pre, post, op:tern) tasty-1.2.3/Test/Tasty/Run.hs0000644000000000000000000004006113465550677014215 0ustar0000000000000000-- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, FlexibleContexts, BangPatterns, CPP, DeriveDataTypeable #-} module Test.Tasty.Run ( Status(..) , StatusMap , launchTestTree , DependencyException(..) ) where import qualified Data.IntMap as IntMap import qualified Data.Sequence as Seq import qualified Data.Foldable as F import Data.Maybe import Data.Graph (SCC(..), stronglyConnComp) import Data.Typeable import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader import Control.Concurrent 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 Test.Tasty.Core import Test.Tasty.Parallel import Test.Tasty.Patterns import Test.Tasty.Patterns.Types import Test.Tasty.Options import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers import Test.Tasty.Runners.Utils (timed) -- | 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 deriving Show -- | 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 | BeingDestroyed | Destroyed instance Show (Resource r) where show r = case r of NotCreated -> "NotCreated" BeingCreated -> "BeingCreated" FailedToCreate exn -> "FailedToCreate " ++ show exn Created {} -> "Created" BeingDestroyed -> "BeingDestroyed" Destroyed -> "Destroyed" 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 -- If the resource is destroyed or being destroyed -- while we're starting a test, the test suite is probably -- shutting down. We are about to be killed. -- (In fact we are probably killed already, so these cases are -- unlikely to occur.) -- In any case, the most sensible thing to do is to go to -- sleep, awaiting our fate. Destroyed -> return $ sleepIndefinitely BeingDestroyed -> return $ sleepIndefinitely 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 $ \fin@(Finalizer _ _ 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 destroyResource restore fin 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) -- | Dependencies of a test type Deps = [(DependencyType, Expr)] -- | Traversal type used in 'createTestActions' type Tr = Traversal (WriterT ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer) (ReaderT (Path, Deps) IO)) -- | Exceptions related to dependencies between tests. data DependencyException = DependencyLoop -- ^ Test dependencies form a loop. In other words, test A cannot start -- until test B finishes, and test B cannot start until test -- A finishes. deriving (Typeable) instance Show DependencyException where show DependencyLoop = "Test dependencies form a loop." instance Exception DependencyException -- | Turn a test tree into a list of actions to run tests coupled with -- variables to watch them. createTestActions :: OptionSet -> TestTree -> IO ([(Action, TVar Status)], Seq.Seq Finalizer) createTestActions opts0 tree = do let traversal :: Tr traversal = foldTestTree (trivialFold :: TreeFold Tr) { foldSingle = runSingleTest , foldResource = addInitAndRelease , foldGroup = \name (Traversal a) -> Traversal $ local (first (Seq.|> name)) a , foldAfter = \deptype pat (Traversal a) -> Traversal $ local (second ((deptype, pat) :)) a } opts0 tree (tests, fins) <- unwrap (mempty :: Path) (mempty :: Deps) traversal let mb_tests :: Maybe [(Action, TVar Status)] mb_tests = resolveDeps $ map (\(act, testInfo) -> (act (Seq.empty, Seq.empty), testInfo)) tests case mb_tests of Just tests' -> return (tests', fins) Nothing -> throwIO DependencyLoop where runSingleTest :: IsTest t => OptionSet -> TestName -> t -> Tr runSingleTest opts name test = Traversal $ do statusVar <- liftIO $ atomically $ newTVar NotStarted (parentPath, deps) <- ask let path = parentPath Seq.|> name act (inits, fins) = executeTest (run opts test) statusVar (lookupOption opts) inits fins tell ([(act, (statusVar, path, deps))], mempty) addInitAndRelease :: ResourceSpec a -> (IO a -> Tr) -> Tr addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ \path deps -> do initVar <- atomically $ newTVar NotCreated (tests, fins) <- unwrap path deps $ 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', fins Seq.|> fin) wrap :: (Path -> Deps -> IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)) -> Tr wrap = Traversal . WriterT . fmap ((,) ()) . ReaderT . uncurry unwrap :: Path -> Deps -> Tr -> IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer) unwrap path deps = flip runReaderT (path, deps) . execWriterT . getTraversal -- | Take care of the dependencies. -- -- Return 'Nothing' if there is a dependency cycle. resolveDeps :: [(IO (), (TVar Status, Path, Deps))] -> Maybe [(Action, TVar Status)] resolveDeps tests = checkCycles $ do (run_test, (statusVar, path0, deps)) <- tests let -- Note: Duplicate dependencies may arise if the same test name matches -- multiple patterns. It's not clear that removing them is worth the -- trouble; might consider this in the future. deps' :: [(DependencyType, TVar Status, Path)] deps' = do (deptype, depexpr) <- deps (_, (statusVar1, path, _)) <- tests guard $ exprMatches depexpr path return (deptype, statusVar1, path) getStatus :: STM ActionStatus getStatus = foldr (\(deptype, statusvar, _) k -> do status <- readTVar statusvar case status of Done result | deptype == AllFinish || resultSuccessful result -> k | otherwise -> return ActionSkip _ -> return ActionWait ) (return ActionReady) deps' let dep_paths = map (\(_, _, path) -> path) deps' action = Action { actionStatus = getStatus , actionRun = run_test , actionSkip = writeTVar statusVar $ Done $ Result -- See Note [Skipped tests] { resultOutcome = Failure TestDepFailed , resultDescription = "" , resultShortDescription = "SKIP" , resultTime = 0 } } return ((action, statusVar), (path0, dep_paths)) checkCycles :: Ord b => [(a, (b, [b]))] -> Maybe [a] checkCycles tests = do let result = fst <$> tests graph = [ ((), v, vs) | (v, vs) <- snd <$> tests ] sccs = stronglyConnComp graph not_cyclic = all (\scc -> case scc of AcyclicSCC{} -> True CyclicSCC{} -> False) sccs guard not_cyclic return result -- | 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 -- | Run a resource finalizer. -- -- This function is called from two different places: -- -- 1. A test thread, which is the last one to use the resource. -- 2. The main thread, if an exception (e.g. Ctrl-C) is received. -- -- Therefore, it is possible that this function is called multiple -- times concurrently on the same finalizer. -- -- This function should be run with async exceptions masked, -- and the restore function should be passed as an argument. destroyResource :: (forall a . IO a -> IO a) -> Finalizer -> IO (Maybe SomeException) destroyResource restore (Finalizer doRelease stateVar _) = join . atomically $ do rState <- readTVar stateVar case rState of Created res -> do writeTVar stateVar BeingDestroyed return $ (either Just (const Nothing) <$> try (restore $ doRelease res)) <* atomically (writeTVar stateVar Destroyed) BeingCreated -> retry -- If the resource is being destroyed, wait until it is destroyed. -- This is so that we don't start destroying the next resource out of -- order. BeingDestroyed -> retry NotCreated -> do -- prevent the resource from being created by a competing thread writeTVar stateVar Destroyed return $ return Nothing FailedToCreate {} -> return $ return Nothing Destroyed -> return $ return Nothing -- | Start running the tests (in background, in parallel) and pass control -- to the callback. -- -- Once the callback returns, stop running the tests. -- -- 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 k0 = do (testActions, fins) <- createTestActions opts tree let NumThreads numTheads = lookupOption opts (t,k1) <- timed $ do abortTests <- runInParallel numTheads (fst <$> testActions) (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions) k0 smap) `finallyRestore` \restore -> do -- Tell all running tests to wrap up. abortTests -- Destroy all allocated resources in the case they didn't get -- destroyed by their tests. (See #75.) F.mapM_ (destroyResource restore) fins -- Wait until all resources are destroyed. (Specifically, those -- that were being destroyed by their tests, not those that were -- destroyed by destroyResource above.) restore $ waitForResources fins k1 t where alive :: Resource r -> Bool alive r = case r of NotCreated -> False BeingCreated -> True FailedToCreate {} -> False Created {} -> True BeingDestroyed -> True Destroyed -> False waitForResources fins = atomically $ F.forM_ fins $ \(Finalizer _ rvar _) -> do res <- readTVar rvar check $ not $ alive res unexpectedState :: String -> Resource r -> SomeException unexpectedState where_ r = toException $ UnexpectedState where_ (show r) sleepIndefinitely :: IO () sleepIndefinitely = forever $ threadDelay (10^(7::Int)) -- | Like 'finally' (which also masks its finalizers), but pass the restore -- action to the finalizer. finallyRestore :: IO a -- ^ computation to run first -> ((forall c . IO c -> IO c) -> IO b) -- ^ computation to run afterward (even if an exception was raised) -> IO a -- ^ returns the value from the first computation a `finallyRestore` sequel = mask $ \restore -> do r <- restore a `onException` sequel restore _ <- sequel restore return r tasty-1.2.3/Test/Tasty/Runners/Reducers.hs0000644000000000000000000000537413465550677016671 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 Control.Applicative import Prelude -- Silence AMP import warnings #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup) import qualified Data.Semigroup (Semigroup((<>))) #else import Data.Monoid #endif -- | 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 #if MIN_VERSION_base(4,9,0) instance Applicative f => Semigroup (Traversal f) where (<>) = mappend #endif -- | Monoid generated by @'liftA2' ('<>')@ -- -- Starting from GHC 8.6, a similar type is available from "Data.Monoid". -- This type is nevertheless kept for compatibility. 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 #if MIN_VERSION_base(4,9,0) instance (Applicative f, Monoid a) => Semigroup (Ap f a) where (<>) = mappend #endif tasty-1.2.3/Test/Tasty/Runners/Utils.hs0000644000000000000000000000777713465550677016226 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | Note: this module is re-exported as a whole from "Test.Tasty.Runners" module Test.Tasty.Runners.Utils where import Control.Exception import Control.Applicative #ifndef VERSION_clock import Data.Time.Clock.POSIX (getPOSIXTime) #endif import Data.Typeable (Typeable) import Prelude -- Silence AMP import warnings import Text.Printf import Foreign.C (CInt) #ifdef VERSION_clock import qualified System.Clock as Clock #endif import Test.Tasty.Core (Time) -- 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 System.Posix.Signals import System.Mem.Weak (deRefWeak) #endif -- | 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 = go 3 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 $ forceElements msg case mbStr of Right () -> return msg Left e' -> printf "message threw an exception: %s" <$> go (recLimit-1) (show (e' :: SomeException)) -- https://ro-che.info/articles/2015-05-28-force-list forceElements :: [a] -> () forceElements = foldr seq () -- from https://ro-che.info/articles/2014-07-30-bracket -- | Install signal handlers so that e.g. the cursor is restored if the test -- suite is killed by SIGTERM. Upon a signal, a 'SignalException' will be -- thrown to the thread that has executed this action. -- -- This function is called automatically from the @defaultMain*@ family of -- functions. You only need to call it explicitly if you call -- 'tryIngredients' yourself. -- -- This function does nothing on non-UNIX systems or when compiled with GHC -- older than 7.6. 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) #else return () #endif -- | This exception is thrown when the program receives a signal, assuming -- 'installSignalHandlers' was called. -- -- The 'CInt' field contains the signal number, as in -- 'System.Posix.Signals.Signal'. We don't use that type synonym, however, -- because it's not available on non-UNIXes. newtype SignalException = SignalException CInt deriving (Show, Typeable) instance Exception SignalException -- | 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) #ifdef VERSION_clock -- | 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 $ #if MIN_VERSION_clock(0,7,1) Clock.toNanoSecs t #else Clock.timeSpecAsNanoSecs t #endif return $ ns / 10 ^ (9 :: Int) #else -- | Get system time getTime :: IO Time getTime = realToFrac <$> getPOSIXTime #endif tasty-1.2.3/Test/Tasty/CmdLine.hs0000644000000000000000000000474313465550677014773 0ustar0000000000000000-- | Parsing options supplied on the command line module Test.Tasty.CmdLine ( optionParser , suiteOptions , suiteOptionParser , parseOptions , 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 #if !MIN_VERSION_base(4,9,0) import Data.Monoid #endif import Test.Tasty.Core import Test.Tasty.Runners.Utils 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 and environment options passed to tasty. -- -- Useful if you need to get the options before 'defaultMain' is called. -- -- Once within the test tree, 'askOption' should be used instead. -- -- The arguments to this function should be the same as for -- 'defaultMainWithIngredients'. If you don't use any custom ingredients, -- pass 'defaultIngredients'. parseOptions :: [Ingredient] -> TestTree -> IO OptionSet parseOptions ins tree = do cmdlineOpts <- execParser $ info (helper <*> suiteOptionParser ins tree) ( fullDesc <> header "Mmm... tasty test suite" ) envOpts <- suiteEnvOptions ins tree return $ envOpts <> cmdlineOpts -- | 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 opts <- parseOptions ins testTree 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 tasty-1.2.3/Test/Tasty/Ingredients/ListTests.hs0000644000000000000000000000262613465550677017667 0ustar0000000000000000-- | Ingredient for listing test names {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Test.Tasty.Ingredients.ListTests ( ListTests(..) , testsNames , listingTests ) where import Data.Proxy import Data.Typeable 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 . safeReadBool 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-1.2.3/Test/Tasty/Ingredients/IncludingOptions.hs0000644000000000000000000000064713127364673021214 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-1.2.3/LICENSE0000644000000000000000000000204312457221174012060 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-1.2.3/Setup.hs0000644000000000000000000000005612457221174012511 0ustar0000000000000000import Distribution.Simple main = defaultMain tasty-1.2.3/tasty.cabal0000644000000000000000000000472513477254352013223 0ustar0000000000000000-- Initial tasty.cabal generated by cabal init. For further documentation, -- see http://haskell.org/cabal/users-guide/ name: tasty version: 1.2.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 flag clock description: Depend on the clock package for more accurate time measurement default: True 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 -- for testing only Test.Tasty.Patterns.Types Test.Tasty.Patterns.Parser Test.Tasty.Patterns.Eval other-modules: Test.Tasty.Parallel, Test.Tasty.Core, Test.Tasty.Options.Core, Test.Tasty.Options.Env, Test.Tasty.Patterns, Test.Tasty.Patterns.Expr, 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 >= 2.1.3.1, tagged >= 0.5, optparse-applicative >= 0.14, unbounded-delays >= 0.1, async >= 2.0, ansi-terminal >= 0.9 if flag(clock) build-depends: clock >= 0.4.4.0 else build-depends: time >= 1.4 if impl(ghc < 7.6) -- for GHC.Generics build-depends: ghc-prim if !os(windows) && !impl(ghcjs) build-depends: unix, wcwidth cpp-options: -D__UNIX__ -- hs-source-dirs: default-language: Haskell2010 default-extensions: CPP, ScopedTypeVariables, DeriveDataTypeable ghc-options: -Wall tasty-1.2.3/CHANGELOG.md0000644000000000000000000002473713477254410012704 0ustar0000000000000000Changes ======= Version 1.2.3 ------------- * Expose `computeStatistics` from `Test.Tasty.Ingredients.ConsoleReporter`. * Ensure that `finally` and `bracket` work as expected inside tests when the test suite is interrupted by Ctrl-C. Version 1.2.2 ------------- * Expose timed and getTime * Add parseOptions * Allow to disable ANSI tricks with --ansi-tricks=false Version 1.2.1 ------------- * Document and expose installSignalHandlers * Enable colors in Emacs and other almost-ANSI-capable terminals Version 1.2 ----------- Make it possible to declare dependencies between tests (see the README for details) Version 1.1.0.4 --------------- Make tasty work with GHCJS Version 1.1.0.3 --------------- Fix compatibility with GHC 8.6 Version 1.1.0.2 --------------- Fix a bug where some (mostly Asian) characters would break alignment in the terminal output Version 1.1.0.1 --------------- Fix a bug where `-l` was still using `/` instead of `.` as a field separator Version 1.1 ----------- **NOTE**: This major release contains some breaking changes to the semantics of patterns. In the original pattern design I didn't notice the conflict between using `/` as a field separator and as the AWK syntax for pattern matching `/.../`. The new patterns have been around for a relatively short time (5 months), so hopefully the breakage won't be too big. I'm sorry about any problems caused by the change. See for the discussion. * The field separator in patterns is changed from slash (`/`) to period (`.`), and `.` is now allowed in raw patterns. The field separator is used to join the group names and the test name when comparing to a pattern such as `-p foo` or `-p /foo/`. If you used -p 'foo/bar' or -p '/foo\/bar/' before, now you should use -p 'foo.bar' or -p '/foo.bar/' if you meant "test/group `bar` inside group `foo`, or -p '/foo\/bar/' if you meant "test/group containing `foo/bar` in the name". The need for escaping the slash inside the `/.../` pattern was precisely the motivation for this change. * Raw patterns (ones that are not AWK expressions) may no longer contain slashes (`/`). So -p 'foo/bar' is no longer allowed, and -p '/foo/' is now parsed as an AWK expression `/foo/`, whereas before it was treated as a raw pattern and converted to `/\/foo\//`. The reason for this change is that `/foo/` is a valid AWK expression and should be parsed as such. * Raw patterns may now contain hyphens, so e.g. `-p type-checking` now works. In theory this makes some valid AWK expressions (such as `NF-2`) not to be parsed as such, but they are either unlikely to be useful or could also be expressed in other ways (`NF!=2`). * Several new exports, mostly for testing/debugging patterns: * `TestPattern` now has a `Show` instance; `TestPattern` and `Expr` now have `Eq` instances. * The constructors of `TestPattern` are now exported. * `parseAwkExpr` is introduced and can be used in ghci to see how an AWK expression is parsed. (For parsing test patterns, which include raw patterns in addition to AWK expression, use `parseTestPattern`.) Version 1.0.1.1 --------------- Fix a bug where a test suite that uses resources would hang if interrupted Version 1.0.1 ------------- * Add a `safeReadBool` function, for case-insensitive parsing of boolean options * Convert all tasty's own options to case-insensitive Version 1.0.0.1 --------------- Adjust lower bounds for the dependencies (mtl and optparse-applicative) Version 1.0 ----------- * New pattern language (see the README and/or the [blog post][awk]) * Make the `clock` dependency optional [awk]: https://ro-che.info/articles/2018-01-08-tasty-new-patterns Version 0.12.0.1 ---------------- Fix compatibility with GHC 8.4 Version 0.12 ------------ Backward compat breaking revision of `Test.Tasty.Ingredients.ConsoleReporter` that exposes the name of tests/groups. 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-1.2.3/README.md0000644000000000000000000006340513477214635012352 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 To find out what's new, read the **[change log][]**. [change log]: https://github.com/feuerbach/tasty/blob/master/core/CHANGELOG.md ## 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]: https://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](https://hackage.haskell.org/package/tasty-hunit) — for unit tests (based on [HUnit](https://hackage.haskell.org/package/HUnit)) * [tasty-golden][] — for golden tests, which are unit tests whose results are kept in files * [tasty-smallcheck](https://hackage.haskell.org/package/tasty-smallcheck) — exhaustive property-based testing (based on [smallcheck](https://hackage.haskell.org/package/smallcheck)) * [tasty-quickcheck](https://hackage.haskell.org/package/tasty-quickcheck) — for randomized property-based testing (based on [QuickCheck](http://hackage.haskell.org/package/QuickCheck)) * [tasty-hedgehog](https://github.com/qfpl/tasty-hedgehog) — for randomized property-based testing (based on [Hedgehog](https://hackage.haskell.org/package/hedgehog)) * [tasty-hspec](https://hackage.haskell.org/package/tasty-hspec) — for [Hspec](https://hspec.github.io/) tests * [tasty-leancheck](https://hackage.haskell.org/package/tasty-leancheck) — for enumerative property-based testing (based on [LeanCheck](https://hackage.haskell.org/package/leancheck)) * [tasty-program](https://hackage.haskell.org/package/tasty-program) — run external program and test whether it terminates successfully * [tasty-wai](https://hackage.haskell.org/package/tasty-wai) - for testing [wai](https://hackage.haskell.org/wai) endpoints. [tasty-golden]: https://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](https://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](https://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](https://hackage.haskell.org/package/tasty-html) adds the possibility to write the test results as a HTML file * [tasty-stats](https://hackage.haskell.org/package/tasty-stats) adds the possibility to collect statistics of the test suite in a CSV file. ### Other packages * [tasty-th](https://hackage.haskell.org/package/tasty-th) automatically discovers tests based on the function names and generate the boilerplate code for you * [tasty-hunit-adapter](https://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 PATTERN] [-t|--timeout DURATION] [-l|--list-tests] [-j|--num-threads NUMBER] [-q|--quiet] [--hide-successes] [--color never|always|auto] [--quickcheck-tests NUMBER] [--quickcheck-replay SEED] [--quickcheck-show-replay] [--quickcheck-max-size NUMBER] [--quickcheck-max-ratio NUMBER] [--quickcheck-verbose] [--smallcheck-depth NUMBER] Available options: -h,--help Show this help text -p,--pattern PATTERN Select only tests which satisfy a pattern or awk expression -t,--timeout DURATION 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 NUMBER 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 never|always|auto When to use colored output (default: 'auto') --quickcheck-tests NUMBER Number of test cases for QuickCheck to generate --quickcheck-replay SEED Random seed to use for replaying a previous test run (use same --quickcheck-max-size) --quickcheck-show-replay Show a replay token for replaying tests --quickcheck-max-size NUMBER Size of the biggest test cases quickcheck generates --quickcheck-max-ratio NUMBER Maximum number of discared tests per successful test before giving up --quickcheck-verbose Show the generated test cases --smallcheck-depth NUMBER 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`. Note on boolean options: by convention, boolean ("on/off") options are specified using a switch on the command line, for example `--quickcheck-show-replay` instead of `--quickcheck-show-replay=true`. However, when passed via the environment, the option value needs to be `True` or `False` (case-insensitive), e.g. `TASTY_QUICKCHECK_SHOW_REPLAY=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 `-p/--pattern` option. Tasty patterns are very powerful, but if you just want to quickly run tests containing `foo` somewhere in their name or in the name of an enclosing test group, you can just pass `-p foo`. If you need more power, or if that didn't work as expected, read on. A pattern is an [awk expression][awk]. When the expression is evaluated, the field `$1` is set to the outermost test group name, `$2` is set to the next test group name, and so on up to `$NF`, which is set to the test's own name. The field `$0` is set to all other fields concatenated using `.` as a separator. [awk]: https://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html#tag_20_06_13_02 As an example, consider a test inside two test groups: ``` testGroup "One" [ testGroup "Two" [ testCase "Three" _ ] ] ``` When a pattern is evaluated for the above test case, the available fields and variables are: $0 = "One.Two.Three" $1 = "One" $2 = "Two" $3 = "Three" NF = 3 Here are some examples of awk expressions accepted as patterns: * `$2 == "Two"` — select the subgroup `Two` * `$2 == "Two" && $3 == "Three"` — select the test or subgroup named `Three` in the subgroup named `Two` * `$2 == "Two" || $2 == "Twenty-two"` — select two subgroups * `$0 !~ /skip/` or `! /skip/` — select tests whose full names (including group names) do not contain the word `skip` * `$NF !~ /skip/` — select tests whose own names (but not group names) do not contain the word `skip` * `$(NF-1) ~ /QuickCheck/` — select tests whose immediate parent group name contains `QuickCheck` As an extension to the awk expression language, if a pattern `pat` contains only letters, digits, and characters from the set `._ -` (period, underscore, space, hyphen), it is treated like `/pat/` (and therefore matched against `$0`). This is so that we can use `-p foo` as a shortcut for `-p /foo/`. The only deviation from awk that you will likely notice is that Tasty does not implement regular expression matching. Instead, `$1 ~ /foo/` means that the string `foo` occurs somewhere in `$1`, case-sensitively. We want to avoid a heavy dependency of `regex-tdfa` or similar libraries; however, if there is demand, regular expression support could be added under a cabal flag. The following operators are supported (in the order of decreasing precedence):

Syntax

Name

Type of Result

Associativity

(expr)

Grouping

Type of expr

N/A

$expr

Field reference

String

N/A

!expr

-expr

Logical not

Unary minus

Numeric

Numeric

N/A

N/A

expr + expr

expr - expr

Addition

Subtraction

Numeric

Numeric

Left

Left

expr expr

String concatenation

String

Right

expr < expr

expr <= expr

expr != expr

expr == expr

expr > expr

expr >= expr

Less than

Less than or equal to

Not equal to

Equal to

Greater than

Greater than or equal to

Numeric

Numeric

Numeric

Numeric

Numeric

Numeric

None

None

None

None

None

None

expr ~ pat

expr !~ pat

(pat must be a literal, not an expression, e.g. /foo/)

Substring match

No substring match

Numeric

Numeric

None

None

expr && expr

Logical AND

Numeric

Left

expr || expr

Logical OR

Numeric

Left

expr1 ? expr2 : expr3

Conditional expression

Type of selected
expr2 or expr3

Right
The following built-in functions are supported: ``` substr(s, m[, n]) ``` Return the at most `n`-character substring of `s` that begins at position `m`, numbering from 1. If `n` is omitted, or if `n` specifies more characters than are left in the string, the length of the substring will be limited by the length of the string `s`. ``` tolower(s) ``` Convert the string `s` to lower case. ``` toupper(s) ``` Convert the string `s` to upper case. ``` match(s, pat) ``` Return the position, in characters, numbering from 1, in string `s` where the pattern `pat` occurs, or zero if it does not occur at all. `pat` must be a literal, not an expression, e.g. `/foo/`. ``` length([s]) ``` Return the length, in characters, of its argument taken as a string, or of the whole record, `$0`, if there is no argument. ### 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). ## Dependencies Tasty executes tests in parallel to make them finish faster. If this parallelism is not desirable, you can declare *dependencies* between tests, so that one test will not start until certain other tests finish. Dependencies are declared using the `after` combinator: * `after AllFinish "pattern" my_tests` will execute the test tree `my_tests` only after all tests that match the pattern finish. * `after AllSucceed "pattern" my_tests` will execute the test tree `my_tests` only after all tests that match the pattern finish **and** only if they all succeed. If at least one dependency fails, then `my_tests` will be skipped. The relevant types are: ``` haskell after :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail -> String -- ^ the pattern -> TestTree -- ^ the subtree that depends on other tests -> TestTree -- ^ the subtree annotated with dependency information data DependencyType = AllSucceed | AllFinish ``` The pattern follows the same AWK-like syntax and semantics as described in [Patterns](#patterns). There is also a variant named `after_` that accepts the AST of the pattern instead of a textual representation. Let's consider some typical examples. (A note about terminology: here by "resource" I mean anything stateful and external to the test: it could be a file, a database record, or even a value stored in an `IORef` that's shared among tests. The resource may or may not be managed by `withResource`.) 1. Two tests, Test A and Test B, access the same shared resource and cannot be run concurrently. To achieve this, make Test A a dependency of Test B: ``` haskell testGroup "Tests accessing the same resource" [ testCase "Test A" $ ... , after AllFinish "Test A" $ testCase "Test B" $ ... ] ``` 1. Test A creates a resource and Test B uses that resource. Like above, we make Test A a dependency of Test B, except now we don't want to run Test B if Test A failed because the resource may not have been set up properly. So we use `AllSucceed` instead of `AllFinish` ``` haskell testGroup "Tests creating and using a resource" [ testCase "Test A" $ ... , after AllSucceed "Test A" $ testCase "Test B" $ ... ] ``` Here are some caveats to keep in mind regarding dependencies in Tasty: 1. If Test B depends on Test A, remember that either of the may be filtered out using the `--pattern` option. Collecting the dependency info happens *after* filtering. Therefore, if Test A is filtered out, Test B will run unconditionally, and if Test B is filtered out, it simply won't run. 1. Tasty does not currently check whether the pattern in a dependency matches anything at all, so make sure your patterns are correct and do not contain typos. Fortunately, misspecified dependencies usually lead to test failures and so can be detected that way. 1. Dependencies shouldn't form a cycle, otherwise Tasty with fail with the message "Test dependencies form a loop." A common cause of this is a test matching its own dependency pattern. 1. Using dependencies may introduce quadratic complexity. Specifically, resolving dependencies is *O(number_of_tests × number_of_dependencies)*, since each pattern has to be matched against each test name. As a guideline, if you have up to 1000 tests, the overhead will be negligible, but if you have thousands of tests or more, then you probably shouldn't have more than a few dependencies. Additionally, it is recommended that the dependencies follow the natural order of tests, i.e. that the later tests in the test tree depend on the earlier ones and not vice versa. If the execution order mandated by the dependencies is sufficiently different from the natural order of tests in the test tree, searching for the next test to execute may also have an overhead quadratic in the number of tests. ## FAQ 1. **Q**: When my tests write to stdout/stderr, the output is garbled. Why is that and what do I do? **A**: It is not recommended that you print anything to the console when using the console test reporter (which is the default one). See [#103](https://github.com/feuerbach/tasty/issues/103) for the discussion. Some ideas on how to work around this: * Use [testCaseSteps](https://hackage.haskell.org/package/tasty-hunit/docs/Test-Tasty-HUnit.html#v:testCaseSteps) (for tasty-hunit only). * Use a test reporter that does not print to the console (like tasty-ant-xml). * Write your output to files instead. 2. **Q**: Why doesn't the `--hide-successes` option work properly? The test headings show up and/or the output appears garbled. **A**: This can happen sometimes when the terminal is narrower than the output. A workaround is to disable ANSI tricks: pass `--ansi-tricks=false` on the command line or set `TASTY_ANSI_TRICKS=false` in the environment. See [issue #152](https://github.com/feuerbach/tasty/issues/152). ## 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](https://yannesposito.com/Scratch/en/blog/Holy-Haskell-Starter/) * [First time testing, also with FP Complete](https://levischuck.com/posts/2013-11-13-first-testing-and-fpcomplete.html) (tasty has been added to stackage since then) * [24 Days of Hackage: tasty](https://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html) * [Resources in Tasty](https://ro-che.info/articles/2013-12-10-tasty-resources) * [Custom options in Tasty][custom-options-article] * [Resources in Tasty (update)](https://ro-che.info/articles/2013-12-29-tasty-resources-2) * [Announcing tasty-rerun](https://ocharles.org.uk/blog/posts/2014-01-20-announcing-tasty-rerun.html) * [Code testing in Haskell revisited (with Tasty)](https://lambda.jstolarek.com/2014/01/code-testing-in-haskell-revisited-with-tasty/) * [New patterns in tasty][awk-patterns-article] * [Screencast: Dynamic Test Suites in Haskell using Hspec and Tasty](https://www.youtube.com/watch?v=PGsDvgmZF7A) * [Automatically generated directories for tasty tests][tasty-directories] [custom-options-article]: https://ro-che.info/articles/2013-12-20-tasty-custom-options.html [awk-patterns-article]: https://ro-che.info/articles/2018-01-08-tasty-new-patterns [tasty-directories]: https://nmattia.com/posts/2018-04-30-tasty-test-names.html 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.