diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..8d3e641 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,295 @@ +Changes +======= + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..136a074 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..6a2ccb5 --- /dev/null +++ b/README.md @@ -0,0 +1,419 @@ +# 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]: http://hackage.haskell.org/package/tasty + +In order to create a test suite, you also need to install one or more «providers» (see +below). + +### Providers + +The following providers exist: + +* [tasty-hunit](http://hackage.haskell.org/package/tasty-hunit) — for unit tests + (based on [HUnit](http://hackage.haskell.org/package/HUnit)) +* [tasty-golden][] — for golden + tests, which are unit tests whose results are kept in files +* [tasty-smallcheck](http://hackage.haskell.org/package/tasty-smallcheck) — + exhaustive property-based testing + (based on [smallcheck](http://hackage.haskell.org/package/smallcheck)) +* [tasty-quickcheck](http://hackage.haskell.org/package/tasty-quickcheck) — for randomized + property-based testing (based on [QuickCheck](http://hackage.haskell.org/package/QuickCheck)) +* [tasty-hedgehog](https://github.com/qfpl/tasty-hedgehog) — for randomized + property-based testing (based on [Hedgehog](http://hackage.haskell.org/package/hedgehog)) +* [tasty-hspec](http://hackage.haskell.org/package/tasty-hspec) — for + [Hspec](http://hspec.github.io/) tests +* [tasty-program](http://hackage.haskell.org/package/tasty-program) — run + external program and test whether it terminates successfully + +[tasty-golden]: http://hackage.haskell.org/package/tasty-golden + +It's easy to create custom providers using the API from `Test.Tasty.Providers`. + +### Ingredients + +Ingredients represent different actions that you can perform on your test suite. +One obvious ingredient that you want to include is one that runs tests and +reports the progress and results. + +Another standard ingredient is one that simply prints the names of all tests. + +It is possible to write custom ingredients using the API from `Test.Tasty.Runners`. + +Some ingredients that can enhance your test suite are: + +* [tasty-ant-xml](http://hackage.haskell.org/package/tasty-ant-xml) adds a + possibility to write the test results in a machine-readable XML format, which + is understood by various CI systems and IDEs +* [tasty-rerun](http://hackage.haskell.org/package/tasty-rerun) adds support for + minimal test reruns by recording previous test runs and using this information + to filter the test tree. For example, you can use this ingredient to only run + failed tests, or only run tests that threw an exception. +* [tasty-html](http://hackage.haskell.org/package/tasty-html) adds the + possibility to write the test results as a HTML file +* [tasty-stats](http://hackage.haskell.org/package/tasty-stats) adds the + possibility to collect statistics of the test suite in a CSV file. + +### Other packages + +* [tasty-th](http://hackage.haskell.org/package/tasty-th) automatically +discovers tests based on the function names and generate the boilerplate code for +you +* [tasty-hunit-adapter](http://hackage.haskell.org/package/tasty-hunit-adapter) + converts existing HUnit test suites into tasty test suites +* [tasty-discover](https://github.com/lwm/tasty-discover) automatically discovers +your tests. +* [tasty-expected-failure](https://github.com/nomeata/tasty-expected-failure) provides +test markers for when you expect failures or wish to ignore tests. + + +## Options + +Options allow one to customize the run-time behavior of the test suite, such +as: + +* mode of operation (run tests, list tests, run tests quietly etc.) +* which tests are run (see «Patterns» below) +* parameters of individual providers (like depth of search for SmallCheck) + +### Setting options + +There are two main ways to set options: + +#### Runtime + +When using the standard console runner, the options can be passed on the +command line or via environment variables. To see the available options, run +your test suite with the `--help` flag. The output will look something like this +(depending on which ingredients and providers the test suite uses): + +``` +% ./test --help +Mmm... tasty test suite + +Usage: test [-p|--pattern ARG] [-t|--timeout ARG] [-l|--list-tests] + [-j|--num-threads ARG] [-q|--quiet] [--hide-successes] [--color ARG] + [--quickcheck-tests ARG] [--quickcheck-replay ARG] + [--quickcheck-show-replay ARG] [--quickcheck-max-size ARG] + [--quickcheck-max-ratio ARG] [--quickcheck-verbose] + [--smallcheck-depth ARG] + +Available options: + -h,--help Show this help text + -p,--pattern ARG Select only tests that match pattern + -t,--timeout ARG Timeout for individual tests (suffixes: ms,s,m,h; + default: s) + -l,--list-tests Do not run the tests; just print their names + -j,--num-threads ARG Number of threads to use for tests execution + -q,--quiet Do not produce any output; indicate success only by + the exit code + --hide-successes Do not print tests that passed successfully + --color ARG When to use colored output. Options are 'never', + 'always' and 'auto' (default: 'auto') + --quickcheck-tests ARG Number of test cases for QuickCheck to generate + --quickcheck-replay ARG Replay token to use for replaying a previous test run + --quickcheck-show-replay ARG + Show a replay token for replaying tests + --quickcheck-max-size ARG + Size of the biggest test cases quickcheck generates + --quickcheck-max-ratio ARG + Maximum number of discared tests per successful test + before giving up + --quickcheck-verbose Show the generated test cases + --smallcheck-depth ARG Depth to use for smallcheck tests +``` + +Every option can be passed via environment. To obtain the environment variable +name from the option name, replace hyphens `-` with underscores `_`, capitalize +all letters, and prepend `TASTY_`. For example, the environment equivalent of +`--smallcheck-depth` is `TASTY_SMALLCHECK_DEPTH`. To turn on a switch (such as +`TASTY_HIDE_SUCCESSES`), set the variable to `True`. + +If you're using a non-console runner, please refer to its documentation to find +out how to configure options during the run time. + +#### Compile-time + +You can also specify options in the test suite itself, using +`localOption`. It can be applied not only to the whole test tree, but also to +individual tests or subgroups, so that different tests can be run with +different options. + +It is possible to combine run-time and compile-time options, too, by using +`adjustOption`. For example, make the overall testing depth configurable +during the run time, but increase or decrease it slightly for individual +tests. + +This method currently doesn't work for ingredient options, such as `--quiet` or +`--num-threads`. You can set them by setting the corresponding environment +variable before calling `defaultMain`: + + + +```haskell +import Test.Tasty +import System.Environment + +main = do + setEnv "TASTY_NUM_THREADS" "1" + defaultMain _ +``` + +### Patterns + +It is possible to restrict the set of executed tests using the `--pattern` +option. The syntax of patterns is the same as for test-framework, namely: + +- An optional prefixed bang `!` negates the pattern. +- If the pattern ends with a slash, it is removed for the purpose of + the following description, but it would only find a match with a + test group. In other words, `foo/` will match a group called `foo` + and any tests underneath it, but will not match a regular test + `foo`. +- If the pattern does not contain a slash `/`, the framework checks + for a match against any single component of the path. +- Otherwise, the pattern is treated as a glob, where: + - The wildcard `*` matches anything within a single path component + (i.e. `foo` but not `foo/bar`). + - Two wildcards `**` matches anything (i.e. `foo` and `foo/bar`). + - Anything else matches exactly that text in the path (i.e. `foo` + would only match a component of the test path called `foo` (or a + substring of that form). + +For example, `group/*1` matches `group/test1` but not +`group/subgroup/test1`, whereas both examples would be matched by +`group/**1`. A leading slash matches the beginning of the test path; for +example, `/test*` matches `test1` but not `group/test1`. + +### Running tests in parallel + +In order to run tests in parallel, you have to do the following: + +* Compile (or, more precisely, *link*) your test program with the `-threaded` + flag; +* Launch the program with `+RTS -N -RTS`. + +### Timeout + +To apply timeout to individual tests, use the `--timeout` (or `-t`) command-line +option, or set the option in your test suite using the `mkTimeout` function. + +Timeouts can be fractional, and can be optionally followed by a suffix `ms` +(milliseconds), `s` (seconds), `m` (minutes), or `h` (hours). When there's no +suffix, seconds are assumed. + +Example: + + ./test --timeout=0.5m + +sets a 30 seconds timeout for each individual test. + +### Options controlling console output + +The following options control behavior of the standard console interface: + +
+
-q,--quiet
+
+ Run the tests but don't output anything. The result is indicated only by the + exit code, which is 1 if at least one test has failed, and 0 if all tests + have passed. Execution stops when the first failure is detected, so not all + tests are necessarily run. + This may be useful for various batch systems, such as commit hooks. +
+
--hide-successes
+
Report only the tests that has failed. Especially useful when the +number of tests is large.
+
-l,--list-tests
+
Don't run the tests; only list their names, in the format accepted by +--pattern.
+
--color
+
Whether to produce colorful output. Accepted values: never, +always, auto. auto means that colors will +only be enabled when output goes to a terminal and is the default value.
+
+ +### Custom options + +It is possible to add custom options, too. + +To do that, + +1. Define a datatype to represent the option, and make it an instance of + `IsOption` +2. Register the options with the `includingOptions` ingredient +3. To query the option value, use `askOption`. + +See the [Custom options in Tasty][custom-options-article] article for some examples. + +## Project organization and integration with Cabal + +There may be several ways to organize your project. What follows is not +Tasty's requirements but my recommendations. + +### Tests for a library + +Place your test suite sources in a dedicated subdirectory (called `tests` +here) instead of putting them among the main library sources. + +The directory structure will be as follows: + + my-project/ + my-project.cabal + src/ + ... + tests/ + test.hs + Mod1.hs + Mod2.hs + ... + +`test.hs` is where your `main` function is defined. The tests may be +contained in `test.hs` or spread across multiple modules (`Mod1.hs`, `Mod2.hs`, +...) which are then imported by `test.hs`. + +Add the following section to the cabal file (`my-project.cabal`): + + test-suite test + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: + test.hs + build-depends: + base >= 4 && < 5 + , tasty >= 0.7 -- insert the current version here + , my-project -- depend on the library we're testing + , ... + +### Tests for a program + +All the above applies, except you can't depend on the library if there's no +library. You have two options: + +* Re-organize the project into a library and a program, so that both the + program and the test suite depend on this new library. The library can be + declared in the same cabal file. +* Add your program sources directory to the `Hs-source-dirs`. Note that this + will lead to double compilation (once for the program and once for the test + suite). + +## FAQ + +1. How do I make some tests execute after others? + + Currently, your only option is to make all tests execute sequentially by + setting the number of tasty threads to 1 ([example](#num_threads_example)). + See [#48](https://github.com/feuerbach/tasty/issues/48) for the discussion. + +## Press + +Blog posts and other publications related to tasty. If you wrote or just found +something not mentioned here, send a pull request! + +* [Holy Haskell Project Starter](http://yannesposito.com/Scratch/en/blog/Holy-Haskell-Starter/) +* [First time testing, also with FP Complete](http://levischuck.com/posts/2013-11-13-first-testing-and-fpcomplete.html) + (tasty has been added to stackage since then) +* [24 Days of Hackage: tasty](http://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html) +* [Resources in Tasty](http://ro-che.info/articles/2013-12-10-tasty-resources.html) +* [Custom options in Tasty][custom-options-article] +* [Resources in Tasty (update)](http://ro-che.info/articles/2013-12-29-tasty-resources-2.html) +* [Announcing tasty-rerun](http://ocharles.org.uk/blog/posts/2014-01-20-announcing-tasty-rerun.html) +* [Code testing in Haskell revisited (with Tasty)](http://lambda.jstolarek.com/2014/01/code-testing-in-haskell-revisited-with-tasty/) + +[custom-options-article]: http://ro-che.info/articles/2013-12-20-tasty-custom-options.html + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/Tasty.hs b/Test/Tasty.hs new file mode 100644 index 0000000..c3a48b8 --- /dev/null +++ b/Test/Tasty.hs @@ -0,0 +1,97 @@ +-- | This module defines the main data types and functions needed to use +-- Tasty. +module Test.Tasty + ( + -- * Organizing tests + TestName + , TestTree + , testGroup + -- * Running tests + , defaultMain + , defaultMainWithIngredients + , defaultIngredients + , includingOptions + -- * Adjusting and querying options + -- | Normally options are specified on the command line. But you can + -- also have different options for different subtrees in the same tree, + -- using the functions below. + -- + -- Note that /ingredient options/ (number of threads, hide successes + -- etc.) set in this way will not have any effect. This is for modifying + -- per-test options, such as timeout, number of generated tests etc. + , adjustOption + , localOption + , askOption + -- ** Standard options + , Timeout(..) + , mkTimeout + -- * Resources + -- | Sometimes several tests need to access the same resource — say, + -- a file or a socket. We want to create or grab the resource before + -- the tests are run, and destroy or release afterwards. + , withResource + ) + where + +import Test.Tasty.Core +import Test.Tasty.Runners +import Test.Tasty.Options +import Test.Tasty.Options.Core +import Test.Tasty.Ingredients.Basic + +-- | List of the default ingredients. This is what 'defaultMain' uses. +-- +-- At the moment it consists of 'listingTests' and 'consoleTestReporter'. +defaultIngredients :: [Ingredient] +defaultIngredients = [listingTests, consoleTestReporter] + +-- | Parse the command line arguments and run the tests. +-- +-- When the tests finish, this function calls 'exitWith' with the exit code +-- that indicates whether any tests have failed. Most external systems +-- (stack, cabal, travis-ci, jenkins etc.) rely on the exit code to detect +-- whether the tests pass. If you want to do something else after +-- `defaultMain` returns, you need to catch the exception and then re-throw +-- it. Example: +-- +-- >import Test.Tasty +-- >import Test.Tasty.HUnit +-- >import System.Exit +-- >import Control.Exception +-- > +-- >test = testCase "Test 1" (2 @?= 3) +-- > +-- >main = defaultMain test +-- > `catch` (\e -> do +-- > if e == ExitSuccess +-- > then putStrLn "Yea" +-- > else putStrLn "Nay" +-- > throwIO e) + +defaultMain :: TestTree -> IO () +defaultMain = defaultMainWithIngredients defaultIngredients + +-- | Locally adjust the option value for the given test subtree +adjustOption :: IsOption v => (v -> v) -> TestTree -> TestTree +adjustOption f = PlusTestOptions $ \opts -> + setOption (f $ lookupOption opts) opts + +-- | Locally set the option value for the given test subtree +localOption :: IsOption v => v -> TestTree -> TestTree +localOption v = PlusTestOptions (setOption v) + +-- | Customize the test tree based on the run-time options +askOption :: IsOption v => (v -> TestTree) -> TestTree +askOption f = AskOptions $ f . lookupOption + +-- | Acquire the resource to run this test (sub)tree and release it +-- afterwards +withResource + :: IO a -- ^ initialize the resource + -> (a -> IO ()) -- ^ free the resource + -> (IO a -> TestTree) + -- ^ @'IO' a@ is an action which returns the acquired resource. + -- Despite it being an 'IO' action, the resource it returns will be + -- acquired only once and shared across all the tests in the tree. + -> TestTree +withResource acq rel = WithResource (ResourceSpec acq rel) diff --git a/Test/Tasty/CmdLine.hs b/Test/Tasty/CmdLine.hs new file mode 100644 index 0000000..fffe9a3 --- /dev/null +++ b/Test/Tasty/CmdLine.hs @@ -0,0 +1,102 @@ +-- | Parsing options supplied on the command line +{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-} +module Test.Tasty.CmdLine + ( optionParser + , suiteOptions + , suiteOptionParser + , defaultMainWithIngredients + ) where + +import Options.Applicative +import Data.Monoid +import Data.Proxy +import Data.Foldable (foldMap) +import Prelude -- Silence AMP and FTP import warnings +import System.Exit +import System.IO + +-- We install handlers only on UNIX (obviously) and on GHC >= 7.6. +-- GHC 7.4 lacks mkWeakThreadId (see #181), and this is not important +-- enough to look for an alternative implementation, so we just disable it +-- there. +#define INSTALL_HANDLERS defined UNIX && MIN_VERSION_base(4,6,0) + +#if INSTALL_HANDLERS +import Control.Concurrent (mkWeakThreadId, myThreadId) +import Control.Exception (Exception(..), throwTo) +import Control.Monad (forM_) +import Data.Typeable (Typeable) +import System.Posix.Signals +import System.Mem.Weak (deRefWeak) +#endif + +import Test.Tasty.Core +import Test.Tasty.Ingredients +import Test.Tasty.Options +import Test.Tasty.Options.Env +import Test.Tasty.Runners.Reducers + + +-- | Generate a command line parser from a list of option descriptions +optionParser :: [OptionDescription] -> Parser OptionSet +optionParser = getApp . foldMap toSet where + toSet :: OptionDescription -> Ap Parser OptionSet + toSet (Option (Proxy :: Proxy v)) = Ap $ + (singleOption <$> (optionCLParser :: Parser v)) <|> pure mempty + +-- | The command line parser for the test suite +suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet +suiteOptionParser ins tree = optionParser $ suiteOptions ins tree + +-- | Parse the command line arguments and run the tests using the provided +-- ingredient list. +-- +-- When the tests finish, this function calls 'exitWith' with the exit code +-- that indicates whether any tests have failed. See 'defaultMain' for +-- details. +defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO () +defaultMainWithIngredients ins testTree = do + installSignalHandlers + cmdlineOpts <- execParser $ + info (helper <*> suiteOptionParser ins testTree) + ( fullDesc <> + header "Mmm... tasty test suite" + ) + + envOpts <- suiteEnvOptions ins testTree + + let opts = envOpts <> cmdlineOpts + + case tryIngredients ins opts testTree of + Nothing -> do + hPutStrLn stderr + "No ingredients agreed to run. Something is wrong either with your ingredient set or the options." + exitFailure + Just act -> do + ok <- act + if ok then exitSuccess else exitFailure + +-- from https://ro-che.info/articles/2014-07-30-bracket +-- Install a signal handler so that e.g. the cursor is restored if the test +-- suite is killed by SIGTERM. +installSignalHandlers :: IO () +installSignalHandlers = do +#if INSTALL_HANDLERS + main_thread_id <- myThreadId + weak_tid <- mkWeakThreadId main_thread_id + forM_ [ sigABRT, sigBUS, sigFPE, sigHUP, sigILL, sigQUIT, sigSEGV, + sigSYS, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ ] $ \sig -> + installHandler sig (Catch $ send_exception weak_tid sig) Nothing + where + send_exception weak_tid sig = do + m <- deRefWeak weak_tid + case m of + Nothing -> return () + Just tid -> throwTo tid (toException $ SignalException sig) + +newtype SignalException = SignalException Signal + deriving (Show, Typeable) +instance Exception SignalException +#else + return () +#endif diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs new file mode 100644 index 0000000..20836db --- /dev/null +++ b/Test/Tasty/Core.hs @@ -0,0 +1,259 @@ +-- | Core types and definitions +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, + ExistentialQuantification, RankNTypes, DeriveDataTypeable, + DeriveGeneric #-} +module Test.Tasty.Core where + +import Control.Exception +import Test.Tasty.Options +import Test.Tasty.Patterns +import Data.Foldable +import Data.Monoid +import Data.Typeable +import qualified Data.Map as Map +import Data.Tagged +import GHC.Generics +import Prelude -- Silence AMP and FTP import warnings +import Text.Printf + +-- | If a test failed, 'FailureReason' describes why +data FailureReason + = TestFailed + -- ^ test provider indicated failure of the code to test, either because + -- the tested code returned wrong results, or raised an exception + | TestThrewException SomeException + -- ^ the test code itself raised an exception. Typical cases include missing + -- example input or output files. + -- + -- Usually, providers do not have to implement this, as their 'run' method + -- may simply raise an exception. + | TestTimedOut Integer + -- ^ test didn't complete in allotted time + deriving Show + +-- | Outcome of a test run +-- +-- Note: this is isomorphic to @'Maybe' 'FailureReason'@. You can use the +-- @generic-maybe@ package to exploit that. +data Outcome + = Success -- ^ test succeeded + | Failure FailureReason -- ^ test failed because of the 'FailureReason' + deriving (Show, Generic) + +-- | Time in seconds. Used to measure how long the tests took to run. +type Time = Double + +-- | A test result +data Result = Result + { resultOutcome :: Outcome + -- ^ Did the test fail? If so, why? + , resultDescription :: String + -- ^ + -- 'resultDescription' may contain some details about the test. For + -- a passed test it's ok to leave it empty. Providers like SmallCheck and + -- QuickCheck use it to provide information about how many tests were + -- generated. + -- + -- For a failed test, 'resultDescription' should typically provide more + -- information about the failure. + , resultShortDescription :: String + -- ^ The short description printed in the test run summary, usually @OK@ or + -- @FAIL@. + , resultTime :: Time + -- ^ How long it took to run the test, in seconds. + } + +-- | 'True' for a passed test, 'False' for a failed one. +resultSuccessful :: Result -> Bool +resultSuccessful r = + case resultOutcome r of + Success -> True + Failure {} -> False + +-- | Shortcut for creating a 'Result' that indicates exception +exceptionResult :: SomeException -> Result +exceptionResult e = Result + { resultOutcome = Failure $ TestThrewException e + , resultDescription = "Exception: " ++ show e + , resultShortDescription = "FAIL" + , resultTime = 0 + } + +-- | Test progress information. +-- +-- This may be used by a runner to provide some feedback to the user while +-- a long-running test is executing. +data Progress = Progress + { progressText :: String + -- ^ textual information about the test's progress + , progressPercent :: Float + -- ^ + -- 'progressPercent' should be a value between 0 and 1. If it's impossible + -- to compute the estimate, use 0. + } + +-- | The interface to be implemented by a test provider. +-- +-- The type @t@ is the concrete representation of the test which is used by +-- the provider. +class Typeable t => IsTest t where + -- | Run the test + -- + -- This method should cleanly catch any exceptions in the code to test, and + -- return them as part of the 'Result', see 'FailureReason' for an + -- explanation. It is ok for 'run' to raise an exception if there is a + -- problem with the test suite code itself (for example, if a file that + -- should contain example data or expected output is not found). + run + :: OptionSet -- ^ options + -> t -- ^ the test to run + -> (Progress -> IO ()) -- ^ a callback to report progress + -> IO Result + + -- | The list of options that affect execution of tests of this type + testOptions :: Tagged t [OptionDescription] + +-- | The name of a test or a group of tests +type TestName = String + +-- | 'ResourceSpec' describes how to acquire a resource (the first field) +-- and how to release it (the second field). +data ResourceSpec a = ResourceSpec (IO a) (a -> IO ()) + +-- | A resources-related exception +data ResourceError + = NotRunningTests + | UnexpectedState String String + | UseOutsideOfTest + deriving Typeable + +instance Show ResourceError where + show NotRunningTests = + "Unhandled resource. Probably a bug in the runner you're using." + show (UnexpectedState where_ what) = + printf "Unexpected state of the resource (%s) in %s. Report as a tasty bug." + what where_ + show UseOutsideOfTest = + "It looks like you're attempting to use a resource outside of its test. Don't do that!" + +instance Exception ResourceError + +-- | The main data structure defining a test suite. +-- +-- It consists of individual test cases and properties, organized in named +-- groups which form a tree-like hierarchy. +-- +-- There is no generic way to create a test case. Instead, every test +-- provider (tasty-hunit, tasty-smallcheck etc.) provides a function to +-- turn a test case into a 'TestTree'. +-- +-- Groups can be created using 'testGroup'. +data TestTree + = forall t . IsTest t => SingleTest TestName t + -- ^ A single test of some particular type + | TestGroup TestName [TestTree] + -- ^ Assemble a number of tests into a cohesive group + | PlusTestOptions (OptionSet -> OptionSet) TestTree + -- ^ Add some options to child tests + | forall a . WithResource (ResourceSpec a) (IO a -> TestTree) + -- ^ Acquire the resource before the tests in the inner tree start and + -- release it after they finish. The tree gets an `IO` action which + -- yields the resource, although the resource is shared across all the + -- tests. + | AskOptions (OptionSet -> TestTree) + -- ^ Ask for the options and customize the tests based on them + +-- | Create a named group of test cases or other groups +testGroup :: TestName -> [TestTree] -> TestTree +testGroup = TestGroup + +-- | An algebra for folding a `TestTree`. +-- +-- Instead of constructing fresh records, build upon `trivialFold` +-- instead. This way your code won't break when new nodes/fields are +-- indroduced. +data TreeFold b = TreeFold + { foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b + , foldGroup :: TestName -> b -> b + , foldResource :: forall a . ResourceSpec a -> (IO a -> b) -> b + } + +-- | 'trivialFold' can serve as the basis for custom folds. Just override +-- the fields you need. +-- +-- Here's what it does: +-- +-- * single tests are mapped to `mempty` (you probably do want to override that) +-- +-- * test groups are returned unmodified +-- +-- * for a resource, an IO action that throws an exception is passed (you +-- want to override this for runners/ingredients that execute tests) +trivialFold :: Monoid b => TreeFold b +trivialFold = TreeFold + { foldSingle = \_ _ _ -> mempty + , foldGroup = const id + , foldResource = \_ f -> f $ throwIO NotRunningTests + } + +-- | Fold a test tree into a single value. +-- +-- The fold result type should be a monoid. This is used to fold multiple +-- results in a test group. In particular, empty groups get folded into 'mempty'. +-- +-- Apart from pure convenience, this function also does the following +-- useful things: +-- +-- 1. Keeping track of the current options (which may change due to +-- `PlusTestOptions` nodes) +-- +-- 2. Filtering out the tests which do not match the patterns +-- +-- Thus, it is preferred to an explicit recursive traversal of the tree. +-- +-- Note: right now, the patterns are looked up only once, and won't be +-- affected by the subsequent option changes. This shouldn't be a problem +-- in practice; OTOH, this behaviour may be changed later. +foldTestTree + :: Monoid b + => TreeFold b + -- ^ the algebra (i.e. how to fold a tree) + -> OptionSet + -- ^ initial options + -> TestTree + -- ^ the tree to fold + -> b +foldTestTree (TreeFold fTest fGroup fResource) opts0 tree0 = + let pat = lookupOption opts0 + in go pat [] opts0 tree0 + where + go pat path opts tree1 = + case tree1 of + SingleTest name test + | testPatternMatches pat (path ++ [name]) + -> fTest opts name test + | otherwise -> mempty + TestGroup name trees -> + fGroup name $ foldMap (go pat (path ++ [name]) opts) trees + PlusTestOptions f tree -> go pat path (f opts) tree + WithResource res0 tree -> fResource res0 $ \res -> go pat path opts (tree res) + AskOptions f -> go pat path opts (f opts) + +-- | Get the list of options that are relevant for a given test tree +treeOptions :: TestTree -> [OptionDescription] +treeOptions = + + Prelude.concat . + Map.elems . + + foldTestTree + trivialFold { foldSingle = \_ _ -> getTestOptions } + mempty + + where + getTestOptions + :: forall t . IsTest t + => t -> Map.Map TypeRep [OptionDescription] + getTestOptions t = + Map.singleton (typeOf t) $ + witness testOptions t diff --git a/Test/Tasty/Ingredients.hs b/Test/Tasty/Ingredients.hs new file mode 100644 index 0000000..10c586a --- /dev/null +++ b/Test/Tasty/Ingredients.hs @@ -0,0 +1,141 @@ +-- | 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" diff --git a/Test/Tasty/Ingredients/Basic.hs b/Test/Tasty/Ingredients/Basic.hs new file mode 100644 index 0000000..05a4d07 --- /dev/null +++ b/Test/Tasty/Ingredients/Basic.hs @@ -0,0 +1,23 @@ +-- | 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 diff --git a/Test/Tasty/Ingredients/ConsoleReporter.hs b/Test/Tasty/Ingredients/ConsoleReporter.hs new file mode 100644 index 0000000..f8c1c19 --- /dev/null +++ b/Test/Tasty/Ingredients/ConsoleReporter.hs @@ -0,0 +1,584 @@ +-- vim:fdm=marker:foldtext=foldtext() +{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts #-} +-- | Console reporter ingredient +module Test.Tasty.Ingredients.ConsoleReporter + ( consoleTestReporter + , Quiet(..) + , HideSuccesses(..) + -- * Internals + -- | The following functions and datatypes are internals that are exposed to + -- simplify the task of rolling your own custom console reporter UI. + + -- ** Output colouring + , UseColor(..) + , useColor + -- ** Test failure statistics + , Statistics(..) + , printStatistics + , 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 +import Data.Maybe +import Data.Monoid +import Data.Typeable +import Options.Applicative hiding (str) +import System.IO +import System.Console.ANSI +#if !MIN_VERSION_base(4,8,0) +import Data.Proxy +import Data.Tagged +import Data.Foldable hiding (concatMap,elem,sequence_) +import Control.Applicative +#endif +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup) +import qualified Data.Semigroup (Semigroup((<>))) +#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 - length name) ' ') + hFlush stdout + + printTestResult result = do + rDesc <- formatMessage $ resultDescription result + + -- use an appropriate printing function + let + printFn = + if resultSuccessful result + then ok + else fail + time = resultTime result + printFn (resultShortDescription result) + -- print time only if it's significant + when (time >= 0.01) $ + printFn (printf " (%.2fs)" time) + printFn "\n" + + when (not $ null rDesc) $ + (if resultSuccessful result then infoOk else infoFail) $ + printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc) + + return $ PrintTest 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 :: 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) + ] $ + \opts tree -> Just $ \smap -> do + + let + whenColor = lookupOption opts + Quiet quiet = lookupOption opts + HideSuccesses hideSuccesses = lookupOption opts + NumThreads numThreads = lookupOption opts + + if quiet + then do + b <- statusMapResult numThreads smap + return $ \_time -> return b + else + + do + isTerm <- hSupportsANSI stdout + + (\k -> if isTerm + then (do hideCursor; k) `finally` showCursor + else k) $ do + + hSetBuffering stdout LineBuffering + + let + ?colors = useColor whenColor isTerm + + let + toutput = buildTestOutput opts tree + + case () of { _ + | hideSuccesses && isTerm -> + consoleOutputHidingSuccesses toutput smap + | hideSuccesses && not isTerm -> + 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 . safeRead + optionName = return "quiet" + optionHelp = return "Do not produce any output; indicate success only by the exit code" + optionCLParser = mkFlagCLParser (short 'q') (Quiet True) + +-- | Report only failed tests +newtype HideSuccesses = HideSuccesses Bool + deriving (Eq, Ord, Typeable) +instance IsOption HideSuccesses where + defaultValue = HideSuccesses False + parseValue = fmap HideSuccesses . safeRead + optionName = return "hide-successes" + optionHelp = return "Do not print tests that passed successfully" + optionCLParser = mkFlagCLParser mempty (HideSuccesses True) + +-- | When to use color on the output +-- +-- @since 0.11.3 +data UseColor + = Never + | Always + | Auto -- ^ Only if stdout is an ANSI color supporting terminal + deriving (Eq, Ord, Typeable) + +-- | Control color output +instance IsOption UseColor where + defaultValue = Auto + parseValue = parseUseColor + optionName = return "color" + optionHelp = return "When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')" + +-- | @useColor when isTerm@ decides if colors should be used, +-- where @isTerm@ indicates whether @stdout@ is a terminal device. +-- +-- @since 0.11.3 +useColor :: UseColor -> Bool -> Bool +useColor when_ isTerm = + case when_ of + Never -> False + Always -> True + Auto -> isTerm + +parseUseColor :: String -> Maybe UseColor +parseUseColor s = + case map toLower s of + "never" -> return Never + "always" -> return Always + "auto" -> return Auto + _ -> Nothing + +-- }}} + +-------------------------------------------------- +-- Various utilities +-------------------------------------------------- +-- {{{ +getResultFromTVar :: TVar Status -> IO Result +getResultFromTVar var = + atomically $ do + status <- readTVar var + case status of + Done r -> return r + _ -> retry + +-- }}} + +-------------------------------------------------- +-- Formatting +-------------------------------------------------- +-- {{{ + +indentSize :: Int +indentSize = 2 + +indent :: Int -> String +indent n = replicate (indentSize * n) ' ' + +-- handle multi-line result descriptions properly +formatDesc + :: Int -- indent + -> String + -> String +formatDesc n desc = + let + -- remove all trailing linebreaks + chomped = reverse . dropWhile (== '\n') . reverse $ desc + + multiline = '\n' `elem` chomped + + -- we add a leading linebreak to the description, to start it on a new + -- line and add an indentation + paddedDesc = flip concatMap chomped $ \c -> + if c == '\n' + then c : indent n + else [c] + in + if multiline + then paddedDesc + else chomped + +data Maximum a + = Maximum a + | MinusInfinity + +instance Ord a => Monoid (Maximum a) where + mempty = MinusInfinity + + Maximum a `mappend` Maximum b = Maximum (a `max` b) + MinusInfinity `mappend` a = a + a `mappend` MinusInfinity = a +#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 (length name + level) + , foldGroup = \_ m -> m . (+ indentSize) + } + opts + where + fromMonoid m = + case m 0 of + MinusInfinity -> 0 + Maximum x -> x + +-- (Potentially) colorful output +ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO () +fail = output BoldIntensity Vivid Red +ok = output NormalIntensity Dull Green +infoOk = output NormalIntensity Dull White +infoFail = output NormalIntensity Dull Red + +output + :: (?colors :: Bool) + => ConsoleIntensity + -> ColorIntensity + -> Color + -> String + -> IO () +output bold intensity color str + | ?colors = + (do + setSGR + [ SetColor Foreground intensity color + , SetConsoleIntensity bold + ] + putStr str + ) `finally` setSGR [] + | otherwise = putStr str + +-- }}} diff --git a/Test/Tasty/Ingredients/IncludingOptions.hs b/Test/Tasty/Ingredients/IncludingOptions.hs new file mode 100644 index 0000000..f0ded2d --- /dev/null +++ b/Test/Tasty/Ingredients/IncludingOptions.hs @@ -0,0 +1,12 @@ +-- | 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) diff --git a/Test/Tasty/Ingredients/ListTests.hs b/Test/Tasty/Ingredients/ListTests.hs new file mode 100644 index 0000000..6266947 --- /dev/null +++ b/Test/Tasty/Ingredients/ListTests.hs @@ -0,0 +1,48 @@ +-- | 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 +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +import Test.Tasty.Core +import Test.Tasty.Options +import Test.Tasty.Ingredients + +-- | This option, when set to 'True', specifies that we should run in the +-- «list tests» mode +newtype ListTests = ListTests Bool + deriving (Eq, Ord, Typeable) +instance IsOption ListTests where + defaultValue = ListTests False + parseValue = fmap ListTests . safeRead + optionName = return "list-tests" + optionHelp = return "Do not run the tests; just print their names" + optionCLParser = mkFlagCLParser (short 'l') (ListTests True) + +-- | Obtain the list of all tests in the suite +testsNames :: OptionSet -> TestTree -> [TestName] +testsNames {- opts -} {- tree -} = + foldTestTree + trivialFold + { foldSingle = \_opts name _test -> [name] + , foldGroup = \groupName names -> map ((groupName ++ "/") ++) names + } + +-- | The ingredient that provides the test listing functionality +listingTests :: Ingredient +listingTests = TestManager [Option (Proxy :: Proxy ListTests)] $ + \opts tree -> + case lookupOption opts of + ListTests False -> Nothing + ListTests True -> Just $ do + mapM_ putStrLn $ testsNames opts tree + return True diff --git a/Test/Tasty/Options.hs b/Test/Tasty/Options.hs new file mode 100644 index 0000000..7c977d4 --- /dev/null +++ b/Test/Tasty/Options.hs @@ -0,0 +1,157 @@ +{-# 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 + ) where + +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Tagged +import Data.Proxy +import Data.Typeable +import Data.Monoid +import Data.Foldable +import Prelude 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 + 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 diff --git a/Test/Tasty/Options/Core.hs b/Test/Tasty/Options/Core.hs new file mode 100644 index 0000000..048f2c1 --- /dev/null +++ b/Test/Tasty/Options/Core.hs @@ -0,0 +1,96 @@ +-- | 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 +#if !MIN_VERSION_base(4,8,0) +import Data.Tagged +import Data.Monoid +#endif +import Data.Fixed +import Options.Applicative hiding (str) +import GHC.Conc + +import Test.Tasty.Options +import Test.Tasty.Patterns + +-- | Number of parallel threads to use for running tests. +-- +-- Note that this is /not/ included in 'coreOptions'. +-- Instead, it's automatically included in the options for any +-- 'TestReporter' ingredient by 'ingredientOptions', because the way test +-- reporters are handled already involves parallelism. Other ingredients +-- may also choose to include this option. +newtype NumThreads = NumThreads { getNumThreads :: Int } + deriving (Eq, Ord, Num, Typeable) +instance IsOption NumThreads where + defaultValue = NumThreads numCapabilities + parseValue = mfilter onlyPositive . fmap NumThreads . safeRead + optionName = return "num-threads" + optionHelp = return "Number of threads to use for tests execution" + optionCLParser = mkOptionCLParser (short 'j') + +-- | Filtering function to prevent non-positive number of threads +onlyPositive :: NumThreads -> Bool +onlyPositive (NumThreads x) = x > 0 + +-- | Timeout to be applied to individual tests +data Timeout + = Timeout Integer String + -- ^ 'String' is the original representation of the timeout (such as + -- @\"0.5m\"@), so that we can print it back. 'Integer' is the number of + -- microseconds. + | NoTimeout + deriving (Show, Typeable) + +instance IsOption Timeout where + defaultValue = NoTimeout + parseValue str = + Timeout + <$> parseTimeout str + <*> pure str + optionName = return "timeout" + optionHelp = return "Timeout for individual tests (suffixes: ms,s,m,h; default: s)" + optionCLParser = mkOptionCLParser (short 't') + +parseTimeout :: String -> Maybe Integer +parseTimeout str = + -- it sucks that there's no more direct way to convert to a number of + -- microseconds + (round :: Micro -> Integer) . (* 10^6) <$> + case reads str of + [(n, suffix)] -> + case suffix of + "ms" -> Just (n / 10^3) + "" -> Just n + "s" -> Just n + "m" -> Just (n * 60) + "h" -> Just (n * 60^2) + _ -> Nothing + _ -> Nothing + +-- | A shortcut for creating 'Timeout' values +mkTimeout + :: Integer -- ^ microseconds + -> Timeout +mkTimeout n = + Timeout n $ + showFixed True (fromInteger n / (10^6) :: Micro) ++ "s" + +-- | The list of all core options, i.e. the options not specific to any +-- provider or ingredient, but to tasty itself. Currently contains +-- 'TestPattern' and 'Timeout'. +coreOptions :: [OptionDescription] +coreOptions = + [ Option (Proxy :: Proxy TestPattern) + , Option (Proxy :: Proxy Timeout) + ] diff --git a/Test/Tasty/Options/Env.hs b/Test/Tasty/Options/Env.hs new file mode 100644 index 0000000..1cedc71 --- /dev/null +++ b/Test/Tasty/Options/Env.hs @@ -0,0 +1,63 @@ +-- | Get options from the environment +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +module Test.Tasty.Options.Env (getEnvOptions, suiteEnvOptions) where + +import Test.Tasty.Options +import Test.Tasty.Core +import Test.Tasty.Ingredients +import Test.Tasty.Runners.Reducers + +import System.Environment +import Data.Foldable +import Data.Tagged +import Data.Proxy +import Data.Char +import Data.Typeable +import Control.Exception +import Control.Applicative +import Prelude -- Silence AMP and FTP import warnings +import Text.Printf + +data EnvOptionException + = BadOption + String -- option name + String -- variable name + String -- value + deriving (Typeable) + +instance Show EnvOptionException where + show (BadOption optName varName value) = + printf + "Bad environment variable %s='%s' (parsed as option %s)" + varName value optName + +instance Exception EnvOptionException + +-- | Search the environment for given options +getEnvOptions :: [OptionDescription] -> IO OptionSet +getEnvOptions = getApp . foldMap lookupOpt + where + lookupOpt (Option (px :: Proxy v)) = do + let + name = proxy optionName px + envName = ("TASTY_" ++) . flip map name $ \c -> + if c == '-' + then '_' + else toUpper c + mbValueStr <- Ap $ myLookupEnv envName + flip foldMap mbValueStr $ \valueStr -> + let + mbValue :: Maybe v + mbValue = parseValue valueStr + + err = throwIO $ BadOption name envName valueStr + + in Ap $ maybe err (return . singleOption) mbValue + +-- | Search the environment for all options relevant for this suite +suiteEnvOptions :: [Ingredient] -> TestTree -> IO OptionSet +suiteEnvOptions ins tree = getEnvOptions $ suiteOptions ins tree + +-- note: switch to lookupEnv once we no longer support 7.4 +myLookupEnv :: String -> IO (Maybe String) +myLookupEnv name = either (const Nothing) Just <$> (try (getEnv name) :: IO (Either IOException String)) diff --git a/Test/Tasty/Parallel.hs b/Test/Tasty/Parallel.hs new file mode 100644 index 0000000..90dff58 --- /dev/null +++ b/Test/Tasty/Parallel.hs @@ -0,0 +1,144 @@ +-- | A helper module which takes care of parallelism +{-# LANGUAGE DeriveDataTypeable #-} +module Test.Tasty.Parallel (runInParallel) where + +import Control.Monad +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Foreign.StablePtr +import Data.Typeable +import GHC.Conc (labelThread) + +data Interrupt = Interrupt + deriving Typeable +instance Show Interrupt where + show Interrupt = "interrupted" +instance Exception Interrupt + +data ParThreadKilled = ParThreadKilled SomeException + deriving Typeable +instance Show ParThreadKilled where + show (ParThreadKilled exn) = + "tasty: one of the test running threads was killed by: " ++ + show exn +instance Exception ParThreadKilled + +shutdown :: ThreadId -> IO () +shutdown = flip throwTo Interrupt + +-- | Take a list of actions and execute them in parallel, no more than @n@ +-- at the same time. +-- +-- The action itself is asynchronous, ie. it returns immediately and does +-- the work in new threads. It returns an action which aborts tests and +-- cleans up. +runInParallel + :: Int -- ^ maximum number of parallel threads + -> [IO ()] -- ^ list of actions to execute + -> IO (IO ()) +-- This implementation tries its best to ensure that exceptions are +-- properly propagated to the caller and threads are not left running. +-- +-- Note that exceptions inside tests are already caught by the test +-- actions themselves. Any exceptions that reach this function or its +-- threads are by definition unexpected. +runInParallel nthreads actions = do + callingThread <- myThreadId + + -- Don't let the main thread be garbage-collected + -- Otherwise we may get a "thread blocked indefinitely in an STM + -- transaction" exception when a child thread is blocked and GC'd. + -- (See e.g. https://github.com/feuerbach/tasty/issues/15) + _ <- newStablePtr callingThread + + -- A variable containing all ThreadIds of forked threads. + -- + -- These are the threads we'll need to kill if something wrong happens. + pidsVar <- atomically $ newTVar [] + + -- If an unexpected exception has been thrown and we started killing all + -- the spawned threads, this flag will be set to False, so that any + -- freshly spawned threads will know to terminate, even if their pids + -- didn't make it to the "kill list" yet. + aliveVar <- atomically $ newTVar True + + let + -- Kill all threads. + shutdownAll :: IO () + shutdownAll = do + pids <- atomically $ do + writeTVar aliveVar False + readTVar pidsVar + + -- be sure not to kill myself! + me <- myThreadId + mapM_ shutdown $ filter (/= me) pids + + cleanup :: Either SomeException () -> IO () + cleanup Right {} = return () + cleanup (Left exn) + | Just Interrupt <- fromException exn + -- I'm being shut down either by a fellow thread (which caught an + -- exception), or by the main thread which decided to stop running + -- tests. In any case, just end silently. + = return () + | otherwise = do + -- Wow, I caught an exception (most probably an async one, + -- although it doesn't really matter). Shut down all other + -- threads, and re-throw my exception to the calling thread. + shutdownAll + throwTo callingThread $ ParThreadKilled exn + + forkCarefully :: IO () -> IO ThreadId + forkCarefully action = flip myForkFinally cleanup $ do + -- We cannot check liveness and update the pidsVar in one + -- transaction before forking, because we don't know the new pid yet. + -- + -- So we fork and then check/update. If something has happened in + -- the meantime, it's not a big deal — we just cancel. OTOH, if + -- we're alive at the time of the transaction, then we add our pid + -- and will be killed when something happens. + newPid <- myThreadId + + join . atomically $ do + alive <- readTVar aliveVar + if alive + then do + modifyTVar pidsVar (newPid :) + return action + else + return (return ()) + + capsVar <- atomically $ newTVar nthreads + + let + go a cont = join . atomically $ do + caps <- readTVar capsVar + if caps > 0 + then do + writeTVar capsVar $! caps - 1 + let + release = atomically $ modifyTVar' capsVar (+1) + + -- Thanks to our exception handling, we won't deadlock even if + -- an exception strikes before we 'release'. Everything will be + -- killed, so why bother. + return $ do + pid <- forkCarefully (do a :: IO (); release) + labelThread pid "tasty_test_thread" + cont + + else retry + + -- fork here as well, so that we can move to the UI without waiting + -- untill all tests have finished + pid <- forkCarefully $ foldr go (return ()) actions + labelThread pid "tasty_thread_manager" + return shutdownAll + +-- Copied from base to stay compatible with GHC 7.4. +myForkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId +myForkFinally action and_then = + mask $ \restore -> + forkIO $ try (restore action) >>= and_then diff --git a/Test/Tasty/Patterns.hs b/Test/Tasty/Patterns.hs new file mode 100644 index 0000000..ade1285 --- /dev/null +++ b/Test/Tasty/Patterns.hs @@ -0,0 +1,163 @@ +-- This code is largely borrowed from test-framework +{- +Copyright (c) 2008, Maximilian Bolingbroke +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +-- | Test patterns +-- +-- (Most of the code borrowed from the test-framework) + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module Test.Tasty.Patterns + ( TestPattern + , parseTestPattern + , noPattern + , testPatternMatches + ) where + +import Test.Tasty.Options + +import Text.Regex.TDFA +import Text.Regex.TDFA.String() + +import Data.List +import Data.Typeable +#if !MIN_VERSION_base(4,8,0) +import Data.Tagged +import Data.Monoid +#endif + +import Options.Applicative + +data Token = SlashToken + | WildcardToken + | DoubleWildcardToken + | LiteralToken Char + deriving (Eq, Show) + +tokenize :: String -> [Token] +tokenize ('/':rest) = SlashToken : tokenize rest +tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest +tokenize ('*':rest) = WildcardToken : tokenize rest +tokenize (c:rest) = LiteralToken c : tokenize rest +tokenize [] = [] + + +data TestPatternMatchMode = TestMatchMode + | PathMatchMode + deriving Show + +-- | A pattern to filter tests. For the syntax description, see +-- the README. +data TestPattern = TestPattern { + tp_categories_only :: Bool, + tp_negated :: Bool, + tp_match_mode :: TestPatternMatchMode, + tp_tokens :: [Token] + } | NoPattern + deriving (Typeable, Show) + +-- | A pattern that matches anything. +noPattern :: TestPattern +noPattern = NoPattern + +instance Read TestPattern where + readsPrec _ string = [(parseTestPattern string, "")] + +instance IsOption TestPattern where + defaultValue = noPattern + parseValue = Just . parseTestPattern + optionName = return "pattern" + optionHelp = return "Select only tests that match pattern" + optionCLParser = mkOptionCLParser (short 'p') + +-- | Parse a pattern +parseTestPattern :: String -> TestPattern +parseTestPattern string = TestPattern { + tp_categories_only = categories_only, + tp_negated = negated, + tp_match_mode = match_mode, + tp_tokens = tokens'' + } + where + tokens = tokenize string + (negated, tokens') + | (LiteralToken '!'):rest <- tokens = (True, rest) + | otherwise = (False, tokens) + (categories_only, tokens'') + | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix) + | otherwise = (False, tokens') + match_mode + | SlashToken `elem` tokens = PathMatchMode + | otherwise = TestMatchMode + + +-- | Test a path (which is the sequence of group titles, possibly followed +-- by the test title) against a pattern +testPatternMatches :: TestPattern -> [String] -> Bool +testPatternMatches test_pattern = + -- It is important that GHC assigns arity 1 to this function, + -- so that compilation of the regex is shared among the invocations. + -- See #175. + case test_pattern of + NoPattern -> const True + TestPattern {} -> \path -> + let + path_to_consider | tp_categories_only test_pattern = dropLast 1 path + | otherwise = path + things_to_match = case tp_match_mode test_pattern of + -- See if the tokens match any single path component + TestMatchMode -> path_to_consider + -- See if the tokens match any prefix of the path + PathMatchMode -> map pathToString $ inits path_to_consider + in not_maybe . any (match tokens_regex) $ things_to_match + where + not_maybe | tp_negated test_pattern = not + | otherwise = id + tokens_regex :: Regex + tokens_regex = makeRegex $ buildTokenRegex (tp_tokens test_pattern) + + +buildTokenRegex :: [Token] -> String +buildTokenRegex [] = [] +buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens) + where + firstTokenToRegex SlashToken = "^" + firstTokenToRegex other = tokenToRegex other + + tokenToRegex SlashToken = "/" + tokenToRegex WildcardToken = "[^/]*" + tokenToRegex DoubleWildcardToken = ".*" + tokenToRegex (LiteralToken lit) = regexEscapeChar lit + +regexEscapeChar :: Char -> String +regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c] + | otherwise = [c] + +pathToString :: [String] -> String +pathToString path = concat (intersperse "/" path) + +dropLast :: Int -> [a] -> [a] +dropLast n = reverse . drop n . reverse diff --git a/Test/Tasty/Providers.hs b/Test/Tasty/Providers.hs new file mode 100644 index 0000000..9979413 --- /dev/null +++ b/Test/Tasty/Providers.hs @@ -0,0 +1,40 @@ +-- | 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 + } diff --git a/Test/Tasty/Run.hs b/Test/Tasty/Run.hs new file mode 100644 index 0000000..fac665c --- /dev/null +++ b/Test/Tasty/Run.hs @@ -0,0 +1,313 @@ +-- | Running tests +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, + FlexibleContexts, BangPatterns #-} +module Test.Tasty.Run + ( Status(..) + , StatusMap + , launchTestTree + ) where + +import qualified Data.IntMap as IntMap +import qualified Data.Sequence as Seq +import qualified Data.Foldable as F +import Data.Maybe +import Control.Monad.State +import Control.Monad.Writer +import Control.Monad.Reader +import Control.Concurrent.STM +import Control.Concurrent.Timeout (timeout) +import Control.Concurrent.Async +import Control.Exception as E +import Control.Applicative +import Control.Arrow +import GHC.Conc (labelThread) +import Prelude -- Silence AMP and FTP import warnings +import qualified System.Clock as Clock + +import Test.Tasty.Core +import Test.Tasty.Parallel +import Test.Tasty.Options +import Test.Tasty.Options.Core +import Test.Tasty.Runners.Reducers + +-- | Current status of a test +data Status + = NotStarted + -- ^ test has not started running yet + | Executing Progress + -- ^ test is being run + | Done Result + -- ^ test finished with a given result + +-- | Mapping from test numbers (starting from 0) to their status variables. +-- +-- This is what an ingredient uses to analyse and display progress, and to +-- detect when tests finish. +type StatusMap = IntMap.IntMap (TVar Status) + +data Resource r + = NotCreated + | BeingCreated + | FailedToCreate SomeException + | Created r + | Destroyed + +instance Show (Resource r) where + show r = case r of + NotCreated -> "NotCreated" + BeingCreated -> "BeingCreated" + FailedToCreate exn -> "FailedToCreate " ++ show exn + Created {} -> "Created" + Destroyed -> "Destroyed" + +data ResourceVar = forall r . ResourceVar (TVar (Resource r)) + +data Initializer + = forall res . Initializer + (IO res) + (TVar (Resource res)) +data Finalizer + = forall res . Finalizer + (res -> IO ()) + (TVar (Resource res)) + (TVar Int) + +-- | Execute a test taking care of resources +executeTest + :: ((Progress -> IO ()) -> IO Result) + -- ^ the action to execute the test, which takes a progress callback as + -- a parameter + -> TVar Status -- ^ variable to write status to + -> Timeout -- ^ optional timeout to apply + -> Seq.Seq Initializer -- ^ initializers (to be executed in this order) + -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order) + -> IO () +executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do + resultOrExn <- try $ restore $ do + -- N.B. this can (re-)throw an exception. It's okay. By design, the + -- actual test will not be run, then. We still run all the + -- finalizers. + -- + -- There's no point to transform these exceptions to something like + -- EitherT, because an async exception (cancellation) can strike + -- anyway. + initResources + + -- If all initializers ran successfully, actually run the test. + -- We run it in a separate thread, so that the test's exception + -- handler doesn't interfere with our timeout. + withAsync (action yieldProgress) $ \asy -> do + labelThread (asyncThreadId asy) "tasty_test_execution_thread" + timed $ applyTimeout timeoutOpt $ wait asy + + -- no matter what, try to run each finalizer + mbExn <- destroyResources restore + + atomically . writeTVar statusVar $ Done $ + case resultOrExn <* maybe (Right ()) Left mbExn of + Left ex -> exceptionResult ex + Right (t,r) -> r { resultTime = t } + + where + initResources :: IO () + initResources = + F.forM_ inits $ \(Initializer doInit initVar) -> do + join $ atomically $ do + resStatus <- readTVar initVar + case resStatus of + NotCreated -> do + -- signal to others that we're taking care of the resource + -- initialization + writeTVar initVar BeingCreated + return $ + (do + res <- doInit + atomically $ writeTVar initVar $ Created res + ) `E.catch` \exn -> do + atomically $ writeTVar initVar $ FailedToCreate exn + throwIO exn + BeingCreated -> retry + Created {} -> return $ return () + FailedToCreate exn -> return $ throwIO exn + _ -> return $ throwIO $ + unexpectedState "initResources" resStatus + + applyTimeout :: Timeout -> IO Result -> IO Result + applyTimeout NoTimeout a = a + applyTimeout (Timeout t tstr) a = do + let + timeoutResult = + Result + { resultOutcome = Failure $ TestTimedOut t + , resultDescription = + "Timed out after " ++ tstr + , resultShortDescription = "TIMEOUT" + , resultTime = fromIntegral t + } + fromMaybe timeoutResult <$> timeout t a + + -- destroyResources should not be interrupted by an exception + -- Here's how we ensure this: + -- + -- * the finalizer is wrapped in 'try' + -- * async exceptions are masked by the caller + -- * we don't use any interruptible operations here (outside of 'try') + destroyResources :: (forall a . IO a -> IO a) -> IO (Maybe SomeException) + destroyResources restore = do + -- remember the first exception that occurred + liftM getFirst . execWriterT . getTraversal $ + flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) -> + Traversal $ do + iAmLast <- liftIO $ atomically $ do + nUsers <- readTVar finishVar + let nUsers' = nUsers - 1 + writeTVar finishVar nUsers' + return $ nUsers' == 0 + + mbExcn <- liftIO $ + if iAmLast + then join $ atomically $ do + resStatus <- readTVar initVar + case resStatus of + Created res -> do + -- Don't worry about double destroy — only one thread + -- receives iAmLast + return $ + (either Just (const Nothing) + <$> try (restore $ doRelease res)) + <* atomically (writeTVar initVar Destroyed) + FailedToCreate {} -> return $ return Nothing + _ -> return $ return $ Just $ + unexpectedState "destroyResources" resStatus + else return Nothing + + tell $ First mbExcn + + -- The callback + -- Since this is not used yet anyway, disable for now. + -- I'm not sure whether we should get rid of this altogether. For most + -- providers this is either difficult to implement or doesn't make + -- sense at all. + -- See also https://github.com/feuerbach/tasty/issues/33 + yieldProgress _ = return () + +type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer) + +-- | Turn a test tree into a list of actions to run tests coupled with +-- variables to watch them +createTestActions :: OptionSet -> TestTree -> IO ([(IO (), TVar Status)], [ResourceVar]) +createTestActions opts0 tree = do + let + traversal :: + Traversal (WriterT ([(InitFinPair -> IO (), TVar Status)], [ResourceVar]) IO) + traversal = + foldTestTree + trivialFold + { foldSingle = runSingleTest + , foldResource = addInitAndRelease + } + opts0 tree + (tests, rvars) <- unwrap traversal + let tests' = map (first ($ (Seq.empty, Seq.empty))) tests + return (tests', rvars) + + where + runSingleTest opts _ test = Traversal $ do + statusVar <- liftIO $ atomically $ newTVar NotStarted + let + act (inits, fins) = + executeTest (run opts test) statusVar (lookupOption opts) inits fins + tell ([(act, statusVar)], mempty) + addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ do + initVar <- atomically $ newTVar NotCreated + (tests, rvars) <- unwrap $ a (getResource initVar) + let ntests = length tests + finishVar <- atomically $ newTVar ntests + let + ini = Initializer doInit initVar + fin = Finalizer doRelease initVar finishVar + tests' = map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests + return (tests', ResourceVar initVar : rvars) + wrap = Traversal . WriterT . fmap ((,) ()) + unwrap = execWriterT . getTraversal + +-- | Used to create the IO action which is passed in a WithResource node +getResource :: TVar (Resource r) -> IO r +getResource var = + atomically $ do + rState <- readTVar var + case rState of + Created r -> return r + Destroyed -> throwSTM UseOutsideOfTest + _ -> throwSTM $ unexpectedState "getResource" rState + +-- | Start running all the tests in a test tree in parallel, without +-- blocking the current thread. The number of test running threads is +-- determined by the 'NumThreads' option. +launchTestTree + :: OptionSet + -> TestTree + -> (StatusMap -> IO (Time -> IO a)) + -- ^ A callback. First, it receives the 'StatusMap' through which it + -- can observe the execution of tests in real time. Typically (but not + -- necessarily), it waits until all the tests are finished. + -- + -- After this callback returns, the test-running threads (if any) are + -- terminated and all resources acquired by tests are released. + -- + -- The callback must return another callback (of type @'Time' -> 'IO' + -- a@) which additionally can report and/or record the total time + -- taken by the test suite. This time includes the time taken to run + -- all resource initializers and finalizers, which is why it is more + -- accurate than what could be measured from inside the first callback. + -> IO a +launchTestTree opts tree k0 = do + (testActions, rvars) <- 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) + `finally` do + abortTests + waitForResources rvars + k1 t + where + alive :: Resource r -> Bool + alive r = case r of + NotCreated -> False + BeingCreated -> True + FailedToCreate {} -> False + Created {} -> True + Destroyed -> False + + waitForResources rvars = atomically $ + forM_ rvars $ \(ResourceVar rvar) -> do + res <- readTVar rvar + check $ not $ alive res + +unexpectedState :: String -> Resource r -> SomeException +unexpectedState where_ r = toException $ UnexpectedState where_ (show r) + +-- | Measure the time taken by an 'IO' action to run +timed :: IO a -> IO (Time, a) +timed t = do + start <- getTime + !r <- t + end <- getTime + return (end-start, r) + +-- | Get monotonic time +-- +-- Warning: This is not the system time, but a monotonically increasing time +-- that facilitates reliable measurement of time differences. +getTime :: IO Time +getTime = do + t <- Clock.getTime Clock.Monotonic + let ns = realToFrac $ +#if MIN_VERSION_clock(0,7,1) + Clock.toNanoSecs t +#else + Clock.timeSpecAsNanoSecs t +#endif + return $ ns / 10 ^ (9 :: Int) diff --git a/Test/Tasty/Runners.hs b/Test/Tasty/Runners.hs new file mode 100644 index 0000000..4060231 --- /dev/null +++ b/Test/Tasty/Runners.hs @@ -0,0 +1,60 @@ +-- | API for test runners +module Test.Tasty.Runners + ( + -- * Working with the test tree + TestTree(..) + , foldTestTree + , TreeFold(..) + , trivialFold + , ResourceSpec(..) + , module Test.Tasty.Runners.Reducers + -- * Ingredients + , Ingredient(..) + , Time + , tryIngredients + , ingredientOptions + , ingredientsOptions + -- * Standard console ingredients + -- | NOTE: the exports in this section are deprecated and will be + -- removed in the future. Please import "Test.Tasty.Ingredients.Basic" + -- if you need them. + + -- ** Console test reporter + , consoleTestReporter + -- ** Tests list + , listingTests + , ListTests(..) + , testsNames + -- * Command line handling + , optionParser + , suiteOptionParser + , defaultMainWithIngredients + -- * Running tests + , Status(..) + , Result(..) + , Outcome(..) + , FailureReason(..) + , resultSuccessful + , Progress(..) + , StatusMap + , launchTestTree + , NumThreads(..) + -- * Options + , suiteOptions + , coreOptions + -- ** Patterns + , module Test.Tasty.Patterns + -- * Utilities + , module Test.Tasty.Runners.Utils + ) + where + +import Test.Tasty.Core +import Test.Tasty.Run +import Test.Tasty.Ingredients +import Test.Tasty.Options.Core +import Test.Tasty.Patterns +import Test.Tasty.CmdLine +import Test.Tasty.Ingredients.Basic +import Test.Tasty.Runners.Reducers +import Test.Tasty.Runners.Utils diff --git a/Test/Tasty/Runners/Reducers.hs b/Test/Tasty/Runners/Reducers.hs new file mode 100644 index 0000000..8616887 --- /dev/null +++ b/Test/Tasty/Runners/Reducers.hs @@ -0,0 +1,71 @@ +-- | Monoidal wrappers for applicative functors. Useful to define tree +-- folds. + +-- These are the same as in the 'reducers' package. We do not use +-- 'reducers' to avoid its dependencies. + +{- License for the 'reducers' package +Copyright 2008-2011 Edward Kmett + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Test.Tasty.Runners.Reducers where + +import Data.Monoid +import Control.Applicative +import Prelude -- Silence AMP import warnings +#if MIN_VERSION_base(4,9,0) +import Data.Semigroup (Semigroup) +import qualified Data.Semigroup (Semigroup((<>))) +#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' ('<>')@ +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 diff --git a/Test/Tasty/Runners/Utils.hs b/Test/Tasty/Runners/Utils.hs new file mode 100644 index 0000000..ef04187 --- /dev/null +++ b/Test/Tasty/Runners/Utils.hs @@ -0,0 +1,27 @@ +-- | Note: this module is re-exported as a whole from "Test.Tasty.Runners" +module Test.Tasty.Runners.Utils where + +import Control.Exception +import Control.DeepSeq +import Control.Applicative +import Prelude -- Silence AMP import warnings +import Text.Printf + +-- | Catch possible exceptions that may arise when evaluating a string. +-- For normal (total) strings, this is a no-op. +-- +-- This function should be used to display messages generated by the test +-- suite (such as test result descriptions). +-- +-- See e.g. +formatMessage :: String -> IO String +formatMessage = 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 $ force msg + case mbStr of + Right str -> return str + Left e' -> printf "message threw an exception: %s" <$> go (recLimit-1) (show (e' :: SomeException)) diff --git a/tasty.cabal b/tasty.cabal new file mode 100644 index 0000000..a49ac3c --- /dev/null +++ b/tasty.cabal @@ -0,0 +1,74 @@ +-- Initial tasty.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: tasty +version: 0.12.0.1 +synopsis: Modern and extensible testing framework +description: Tasty is a modern testing framework for Haskell. + It lets you combine your unit tests, golden + tests, QuickCheck/SmallCheck properties, and any + other types of tests into a single test suite. +license: MIT +license-file: LICENSE +author: Roman Cheplyaka +maintainer: Roman Cheplyaka +homepage: https://github.com/feuerbach/tasty +bug-reports: https://github.com/feuerbach/tasty/issues +-- copyright: +category: Testing +build-type: Simple +extra-source-files: CHANGELOG.md, README.md +cabal-version: >=1.10 + +Source-repository head + type: git + location: git://github.com/feuerbach/tasty.git + subdir: core + +library + exposed-modules: + Test.Tasty, + Test.Tasty.Options, + Test.Tasty.Providers, + Test.Tasty.Runners + Test.Tasty.Ingredients, + Test.Tasty.Ingredients.Basic + Test.Tasty.Ingredients.ConsoleReporter + other-modules: + Test.Tasty.Parallel, + Test.Tasty.Core, + Test.Tasty.Options.Core, + Test.Tasty.Options.Env, + Test.Tasty.Patterns, + Test.Tasty.Run, + Test.Tasty.Runners.Reducers, + Test.Tasty.Runners.Utils, + Test.Tasty.CmdLine, + Test.Tasty.Ingredients.ListTests + Test.Tasty.Ingredients.IncludingOptions + build-depends: + base >= 4.5 && < 5, + stm >= 2.3, + containers, + mtl, + tagged >= 0.5, + regex-tdfa >= 1.1.8.2, + optparse-applicative >= 0.11, + deepseq >= 1.3, + unbounded-delays >= 0.1, + async >= 2.0, + ansi-terminal >= 0.6.2, + clock >= 0.4.4.0 + + if impl(ghc < 7.6) + -- for GHC.Generics + build-depends: ghc-prim + + if !os(windows) + build-depends: unix + cpp-options: -DUNIX + + -- hs-source-dirs: + default-language: Haskell2010 + default-extensions: CPP + ghc-options: -Wall