diff --git a/CHANGES.markdown b/CHANGES.markdown deleted file mode 100644 --- a/CHANGES.markdown +++ /dev/null @@ -1,559 +0,0 @@ -## Changes in 2.6.0 - - Allow to focus individual spec items (see #319) - - Do not calculate diff on `--no-diff` (see #332) - - Remove deprecated module Test.Hspec.Core - -## Changes in 2.5.9 - - Extract source locations from RecConError (see #375) - -## Changes in 2.5.8 - - Add `modifyArgs` and `modifyMaxShrinks` to `Test.Hspec.QuickCheck` (see #380) - -## Changes in 2.5.7 - - GHC 8.6.1 related changes - -## Changes in 2.5.6 - - Compatibility with `QuickCheck-2.12` - -## Changes in 2.5.5 - - Use `module[line:column]` instead of `module:line:column` as default label - for `describe`/`it` (fixes #366) - -## Changes in 2.5.4 - - Show how to rerun individual spec items on test failures (see #205) - -## Changes in 2.5.3 - - Treat character escapes like `\NUL` as single tokens on `--diff` (see #351) - - Allow a `/` at the beginning and at the end of an absolute path that is - passed to `--match` or `--skip` - -## Changes in 2.5.2 - - Use module:line:column as default label for describe/it (see #250) - - Warn if user is affected by https://ghc.haskell.org/trac/ghc/ticket/13285 (see #329) - -## Changes in 2.5.1 - - Disable tests for Test.Hspec.Core.Timer (see #352) - -## Changes in 2.5.0 - - Add `sequential` (see #311) - - Add support for `--diff` when `shouldBe` is uesd with - `QuickCheck`-properties - - Add source locations when `shouldBe` is uesd with `QuickCheck` properties - - Print `QuickCheck` labels on success (see #297) - - Retain output of `verbose`, `label`, `collect`, `classify`, etc. for - `QuickCheck` properties (see #257) - - Extract source location from error / undefined (see #316) - - Parse source locations from pattern match failures - - Include source column when formatting source locations - - Colorize whitespaces with background color instead of foreground color with - `--diff` - - Run `Test.Hspec.Core.Formatters.exampleProgress` in `FormatM` instead of - `IO` - - Make sure that progress output is always cleared (fixes #301) - - Add location information to `pending` (not used by any formatter yet) - - Include duration for each spec item in new formatter API (see #315) (not yet exposed) - - Removed deprecated module `Test.Hspec.HUnit`, use - `Test.Hspec.Contrib.HUnit` instead - - Deprecate `--out` - - Remove `BestEffort` source locations - -## Changes in 2.4.8 - - compatibility with GHC 8.4.1-alpha3 - -## Changes in 2.4.7 - - compatibility with `QuickCheck-2.11.3` and up (note that `QuickCheck` - versions `2.11` to `2.11.2` are not fully supported) - -## Changes in 2.4.6 - - compatibility with the upcoming version `4.11.0.0` of `base` - -## Changes in 2.4.5 - - `hspec-discover`: Sort specs using natural sort order - -## Changes in 2.4.4 - - Require quickcheck-io >= 0.2.0 - -## Changes in 2.4.3 - - Read command-line options from environment variable `HSPEC_OPTIONS` - -## Changes in 2.4.2 - - Use `--diff` by default - - Add `--failure-report` (see #266) - -## Changes in 2.4.1 - - Compatibility with HUnit < 1.3 - -## Changes in 2.4.0 - - Read command-line options from config files `~/.hspec` and `.hspec` - - Add support for `--diff` - - Add `xit`, `xspecify`, `xdescribe` and `xcontext` (see #252) - - Add `--rerun-all-on-success` - - Report exceptions in `beforeAll` operations only once - - Add indentation when actual/expected contain newlines (see #263) - - More graceful shutdown on ctrl-c (see #270) - - Run around-hook for Bool and Result (see #252) - - Include `CHANGES.markdown` in package tarball - -Internal changes: - - - Rename `Fail` constructor of `Result`-type to `Failure` - - Add `FailureReason` type - - Add `Test.Hspec.Core.Spec.safeEvaluateExample` - -## Changes in 2.3.2 - - Compatibility with HUnit 1.5 - -## Changes in 2.3.1 - - Fix build for HUnit < 1.4 - -## Changes in 2.3.0 - - Proper support for GHC 8 call stacks - -## Changes in 2.2.4 - - Compatibility with QuickCheck-2.9 - -## Changes in 2.2.3 - - Make sure that `cabal haddock` works for `hspec-discover` - - Forward compatibility for HUnit 1.4 - - Fix tests for GHC 8.0.1-rc1 - -## Changes in 2.2.2 - - Fix compilation for GHC 8.0.1-rc1 - -## Changes in 2.2.1 - - Make sure that Vim's default `errorformat` recognizes exact locations - - GHCJS compatibility - -## Changes in 2.2.0 - - Add source locations to test `Result` - -## Changes in 2.1.10 - - GHC 7.0.* compatibility - -## Changes in 2.1.9 - - Make use of GHC 7.10.2 source locations - - Add `--jobs` - -## Changes in 2.1.8 - - Depend on `hspec-expectations-0.7.0" - -## Changes in 2.1.7 - - Add `beforeAll_` - -## Changes in 2.1.6 - - If there were no previous failures, run all spec items on `--rerun` - -## Changes in 2.1.5 - - Compatibility with QuickCheck-2.8 - -## Changes in 2.1.4 - - Make `hspec-discover` ignore modules with invalid module names, this fixes - issues with `flycheck`'s temporary files - -## Changes in 2.1.3 - - Format source locations like gcc does - -## Changes in 2.1.2 - - Re-export `before_` from `Test.Hspec` - -## Changes in 2.1.1 - - Add `before_` - - Add command-line option `--skip` - -## Changes in 2.1.0 - - Generalize `after_`, `afterAll_` and `around_` - -## Changes in 2.0.2 - - Indent error messages for failed examples (fixes #186) - - Export `defaultParams` from `Test.Hspec.Core.Example` - - Bring back `Test.Hspec.HUnit` and deprecate it to provide a smother upgrade - path - -## Changes in 2.0.1 - - Add missing extra source files to for `hspec-discover` - -## Changes in 2.0.0 - - Split package into `hspec`, `hspec-core` and `hspec-discover` - - Allow hooks (`before`, `around`, etc.) to pass arguments to spec items - - Do not print `-` in front of spec items with `specdoc` formatter - - Move `Test.Hspec.HUnit` to `hspec-contrib` - -## Changes in 1.12.4 - - Add `specGroup` and `specItem` to `Test.Hspec.Core` - - Deprecate `Test.Hspec.Core.it` and `Test.Hspec.Core.describe` - -## Changes in 1.12.3 - - Make `hspec-discover` work with `-XNoImplicitPrelude` - -## Changes in 1.12.2 - - Include `IOErrorType` when printing uncaught `IOException`s (see #204) - -## Changes in 1.12.1 - - Add `--module-name` option to `hspec-discover` (see #168) - -## Changes in 1.12.0 - - Add optional source location to spec items - - Move item requirement text from `SpecItem` constructor to `Item` data type - - Remove `BuildSpecs` constructor from `SpecTree`, having `runIO` this is not - really needed - - Add `mapSpecTree` to `Test.Hspec.Core` - - Add `afterAll` (see #188) - - Do not return `Result` from `hspecWith` and accept command-line options - (the old behavior is still available as `hspecWithResult`) - - Rename `configHandle` to `configOutputFile` - - Omit empty `describe` groups from report - - Do not pass position to `Formatter.exampleGroupStarted` (we can not support - this with the upcomming cleanup actions #188) - - Do not print empty lines before/after spec groups - - Deprecate `Test.Hspec.Formatters.newParagraph` - -## Changes in 1.11.4 - - Make test suite independent from QuickCheck seed (see #187) - -## Changes in 1.11.3 - - Depend on `hspec-expectations-0.6.1` - -## Changes in 1.11.2 - - Add `beforeAll` - -## Changes in 1.11.1 - - Add `specify` as an alias for `it` - -## Changes in 1.11.0 - - Add `BuildSpecs` constructor to internal `SpecTree` data structure. This - allows you to do `IO` while constructing the spec tree. - - Add `runIO` - -## Changes in 1.10.0 - - Do not use exception type to distinguish between synchronous/asynchronous - exceptions (thanks to Michael Snoyman) - - Remove `Example` instance for `Test.HUnit.Test` (#101), use - `Test.Hspec.HUnit.fromHUnitTest` instead. - - Do not reexport `property` from `Test.Hspec.QuickCheck` - - Move `ProgressCallback` out of `Params` - - Add show instance for `Params` - - Move requirement text from `Item` to `SpecItem` constructor - - Remove deprecated modules and functions - -## Changes in 1.9.5 - - Make sure that ctrl-c works properly with GHC 7.8.* and QuickCheck-2.6 - -## Changes in 1.9.4 - - Compatibility with transformers-0.4.0.0 - -## Changes in 1.9.3 - - Make internal Tree data structure more strict (#169) - -## Changes in 1.9.2 - - Print type of exceptions that are raised from QuickCheck properties (#94) - -## Changes in 1.9.1 - - Bring back compatibility with older versions of QuickCheck (#166) - -## Changes in 1.9.0 - - Depend on QuickCheck 2.7 - -## Changes in 1.8.3 - - Do not use color if `TERM=dumb` (see #158) - -## Changes in 1.8.2 - - `hspec-discover` now accepts `--no-main` which results in a top-level spec - being generated instead of a test driver (thanks @DanielG) - - Make sure that `after` is run on failing tests (see #159) - -## Changes in 1.8.1 - - Add `shouldMatchList` - -## Changes in 1.8.0 - - Run `before`/`after`/`around` for each single check of a QuickCheck property - - Add `Test.Hspec.Core.mapSpecItem` - - Add `modifyMaxSuccess`, `modifyMaxDiscardRatio` and `modifyMaxSize` to - `Test.Hspec.QuickCheck` - - Don't fail if callback is not called in `around` - - `hspec-discover`: Remove `--nested` option - - `hspec-discover`: Ignore `Spec.hs`/`Spec.lhs` - -## Changes in 1.7.2 - - Add `after` and `around` - -## Changes in 1.7.1 - - Add `shouldContain` (thanks to Alfredo Di Napoli) - - When printing progress, skip total if it is 0 - - Do not colorize the description/requirement in failure list - -## Changes in 1.7.0 - - Add `--depth` for use with `hspec-smallcheck` - -## Change in 1.6.2 - - Add `before` - - Add `--qc-max-discard` and `--qc-max-size` - -## Changes in 1.6.1 - - Allow to specify the output file with `--out` - -## Changes in 1.6.0 - - Add support for parallelization - - Change license to MIT - - Add MonadIO instance for FormatM - - Add support for custom formatters to hspec-discover - - Add hspecResult - - Rename `--re-run` to `--rerun` + add documentation (#95) - - Remove `configVerbose` - - Use same `--qc-max-success` on `--rerun` (#125) - - Add command-line option `--no-color`, `--color` does not accept arguments - anymore (#130) - -## Changes in 1.5.4 - - Make sure that QuickCheck is never chatty - - Make sure progress for QuickCheck examples is shown - -## Changes in 1.5.3 - - Print "Randomized with seed ..." only once - -## Changes in 1.5.2 - - Add `--seed`, it can be used to specify the seed for QuickCheck properties - - Reuse previous seed on `--re-run` - -## Changes in 1.5.1 - - Depend on quickcheck-io - -## Changes in 1.5.0 - - Allow to use expectations as QuickCheck properties (#80) - - Do not suppress output to `stdout` - - Change type of `pending` to `Expectation`, add `pendingWith` (#121) - - Add the `example` function, it fixes the type of an Expectation (#86) - - Rename `--fast-fail` to `--fail-fast` (for consistency with RSpec) - - Do not clutter Cabal test suite logs with QuickCheck output (#112) - - Skip redundant output from QuickCheck failure messages (#102) - -## Changes in 1.4.5 - - hspec-discover now discovers .lhs files, too - -## Changes in 1.4.4 - - Visually distinguish error message from requirements in the summary (#100) - - Export `formatException` from `Test.Hspec.Formatters` - - Add `--fast-fail` (#82) - - Print a summary on UserInterrupt/ctrl-c (#107) - -## Changes in 1.4.3 - - Add `--dry-run` (#111) - -## Changes in 1.4.2 - - Properly handle ctrl-c while running QuickCheck properties (#93) - - Default to `--color=always` when `--color` is used without argument (#106) - - treat `--qc-max-success` as an alias for `--maximum-generated-tests` - -## Changes in 1.4.1 - - Used CPU time is now only included in the test summary if run with - `--print-cpu-time`. - -## Changes in 1.4.0 - - We now have a manual at http://hspec.github.io/. The sources are in - `doc/`. It's still work in progress. Contributions are very welcome! - - The Haddock documentation now indicates the stability of each exposed - module. `Test.Hspec` is now considered stable. - - `hspec` now supports command-line options - - `--color` can be used to enable/disable colored output - - `--format` can be used to pick a specific formatter - - `--html` can be used to produce an HTML report - - `--maximum-generated-tests` can be used to specify QuickCheck's - `maxSuccess` - - `--match` only runs spec items that match a given string - - `--re-run` only runs spec items that previously failed. This is - undocumented, - experimental and only works within GHCi (use `:reload` / `:main`)! - - Runner functions exported from `Test.Hspec.Runner` new expect a monadic - spec. - - `fromHUnitTest` has been added. It can be used to run existing HUnit test - suites with Hspec. - - The `Example` instance for HUnit `Test`s has been deprecated. - `fromHUnitTest` can be used instead. The primary motivation is, that - `fromHUnitTest` gives more detailed reporting for nested HUnit test suites. - - `Test.Hspec.Monadic` has been deprecated, all functionality is available - through one of `Test.Hspec`, `Test.Hspec.Core` or `Test.Hspec.Runner`. - - More of Hspec's internals are now exposed from `Test.Hspec.Core` - - All runner functions for the core spec type (aka as non-monadic spec) have - been deprecated, use e.g. `Test.Hspec.hspec . fromSpecList` instead. The - motivation is to provide an API that does not expose colliding names. - - Some other stuff from `Test.Hspec.Core` that collides with other parts of - the API has been deprecated. Compatible alternatives are given in each - deprecation message. - - The default formatter now produces less whitespace (#73) + other minor - improvements - - The formatter API has been revamped. - - The exception type is now printed if an example fails due to an exception - (#50) - - The number of pending examples is now printed after each test run (#85) - - `--verbose` has been added (#87) - -## Changes in 1.3.0 - - - `Test.Hspec` now re-exports the monadic API. If you still use the - non-monadic API, you can use `Test.Hspec.Core` as a drop-in replacement. - - - `hspec-expectations`, a set of combinators that allow to express - expectations about the outcome of code examples, is now included with Hspec. - Have a look at the [README of `hspec-expectations`] - (https://github.com/sol/hspec-expectations#readme) - for a short introduction. - - - `hspec-discover`, a mechanism for automatic spec discovery, is now an - official part of Hspec. - Have a look at [`hspec-discover`'s README] - (https://github.com/hspec/hspec/tree/master/hspec-discover#readme) - for a short introduction. - -## Changes in 1.2.0 - - - `hspec` has been removed, and `hspecX` has been renamed to `hspec` (see - [#71](https://github.com/hspec/hspec/issues/71)) - - - `hHspec` now returns a summary of the test run. - - - The time reporting after a test run is not colored anymore. - -## Changes in 1.1.3 - - - `Test.Hspec` warns now about future changes: It will re-export - `Test.Hspec.Monadic` in the future. If you still use the non-monadic API, - you can either use `Test.Hspec.Core` as a drop-in replacement, or migrate your - code to the monadic API. - - The monadic API is more stable and easier to use. Now is a good time to - switch! - - - `Test.Hspec.Core` is now a proper superset of `Test.Hspec` - -## Changes in 1.1.2 - - * All descriptions of nested examples are now included in summary for failing - examples - - * `context` is now an alias for `describe` - -## Changes in 1.1.1 - - * Specs from Test.Hspec.Monadic has been renamed to Spec. For backward - compatibility Specs is still kept as an alias. - -## Changes in 1.1.0 - -### The reason for pending examples is now optional - -With this change, both of the following code snippets work. - -```haskell -it "some behavior" $ - pending -- no reason given -``` - -```haskell -it "some other behavior" $ - pending "some reason" -``` - -### Hspec does not rely on ExistentialQuantification anymore - -### The type used to represent specs is now abstract - -This should give more useful error messages when adapting old specs that use -the non-monadic API for `hspec-1.0`/`hspec-1.1`. - -### Several internal types and functions have been deprecated - -Those are internal functions, and they will be removed/hidden with the next -release. If you use any of those, update your code. If you really need them, -[open a ticket](https://github.com/hspec/hspec/issues) and describe your use -case. - -## Changes in 1.0.0 - -### Hspec now re-uses QuickCheck's property function - -`Test.Hspec.QuickCheck.property` is now simply a re-exports of -`Test.QuickCheck.property`. This has the advantage that you do not get a name -collision if you import both, `Test.Hspec.QuickCheck` and `Test.QuickCheck`. - -### Better support for nested specs - -*NOTE: This is a breaking change to the non-monadic API. The monadic API is -not affected.* - -In some situations parent descriptions for nested specs were not included in -the generated report. Solving this required a change to the data structure -that is used to represent specs (it was not a proper tree, now it is). - -#### Updating specs that use the non-monadic API - -The runner functions (`hspec`, `hspecB` and `hspecX`) now take a list of -descriptions. - -The following works with `hspec-0.9`, but not with `hspec-1.0`. - -```haskell -main = hspecX $ - describe "reverse" [ - it "reverses a list" $ - reverse [1, 2, 3] == [3, 2, 1], - - it "gives the original list, if applied twice" $ property $ - \xs -> reverse (reverse xs) == (xs :: [Int]) - ] - -``` - -For `hspec-1.0`, you need to wrap it into a list. - -```haskell -main = hspecX [ - describe "reverse" [ - it "reverses a list" $ - reverse [1, 2, 3] == [3, 2, 1], - - it "gives the original list, if applied twice" $ property $ - \xs -> reverse (reverse xs) == (xs :: [Int]) - ] - ] -``` - -Specs consisting of several *desribes*, combined with `descriptions`, continue -to work unchanged. But `descriptions` is now a noop, and it will be removed in -a future release. So it is a good idea to drop it. - -The following works with both `hspec-0.9` and `hspec-1.0`. - -```haskell -main = hspecX $ descriptions [ -- descriptions is redundant - describe "Foo" [ - it "has some behavior" True - ] - , describe "Bar" [ - it "has some behavior" True - ] - ] -``` - -But the following is recommended instead. - -```haskell -main = hspecX [ - describe "Foo" [ - it "has some behavior" True - ] - , describe "Bar" [ - it "has some behavior" True - ] - ] -``` - -### A new monadic API for custom Formatters - -For all the details, have a look at the [docs] -(http://hackage.haskell.org/packages/archive/hspec/latest/doc/html/Test-Hspec-Formatters.html). - - -### The total time required to run a spec is now included in the summary - -In addition to the used CPU time, the total time required to run a spec is now -include in the summary. This is useful for specs that do non-CPU-intensive -stuff, or fork subprocesses. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2018 Simon Hengel +Copyright (c) 2011-2021 Simon Hengel Copyright (c) 2011-2012 Trystan Spangler Copyright (c) 2011-2011 Greg Weber diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple -> main = defaultMain diff --git a/hspec-core/src/Test/Hspec/Core/Clock.hs b/hspec-core/src/Test/Hspec/Core/Clock.hs --- a/hspec-core/src/Test/Hspec/Core/Clock.hs +++ b/hspec-core/src/Test/Hspec/Core/Clock.hs @@ -5,11 +5,13 @@ , getMonotonicTime , measure , sleep +, timeout ) where import Text.Printf import System.Clock import Control.Concurrent +import qualified System.Timeout as System newtype Seconds = Seconds Double deriving (Eq, Show, Num, Fractional, PrintfArg) @@ -31,3 +33,6 @@ sleep :: Seconds -> IO () sleep = threadDelay . toMicroseconds + +timeout :: Seconds -> IO a -> IO (Maybe a) +timeout = System.timeout . toMicroseconds diff --git a/hspec-core/src/Test/Hspec/Core/Compat.hs b/hspec-core/src/Test/Hspec/Core/Compat.hs --- a/hspec-core/src/Test/Hspec/Core/Compat.hs +++ b/hspec-core/src/Test/Hspec/Core/Compat.hs @@ -20,6 +20,8 @@ , atomicWriteIORef #endif , interruptible + +, guarded ) where import Control.Applicative @@ -58,6 +60,9 @@ , sequence , sequence_ , sum +#if !MIN_VERSION_base(4,6,0) + , catch +#endif ) import Data.Typeable (Typeable, typeOf, typeRepTyCon) @@ -139,3 +144,6 @@ MaskedInterruptible -> unsafeUnmask act MaskedUninterruptible -> act #endif + +guarded :: Alternative m => (a -> Bool) -> a -> m a +guarded p a = if p a then pure a else empty diff --git a/hspec-core/src/Test/Hspec/Core/Config.hs b/hspec-core/src/Test/Hspec/Core/Config.hs --- a/hspec-core/src/Test/Hspec/Core/Config.hs +++ b/hspec-core/src/Test/Hspec/Core/Config.hs @@ -3,9 +3,12 @@ Config (..) , ColorMode(..) , defaultConfig -, getConfig +, readConfig , configAddFilter , configQuickCheckArgs + +, readFailureReportOnRerun +, applyFailureReport #ifdef TEST , readConfigFiles #endif @@ -21,6 +24,7 @@ import System.Exit import System.FilePath import System.Directory +import System.Environment (getProgName) import qualified Test.QuickCheck as QC import Test.Hspec.Core.Util @@ -36,8 +40,8 @@ configFilterPredicate = Just p1 `filterOr` configFilterPredicate c } -mkConfig :: Maybe FailureReport -> Config -> Config -mkConfig mFailureReport opts = opts { +applyFailureReport :: Maybe FailureReport -> Config -> Config +applyFailureReport mFailureReport opts = opts { configFilterPredicate = matchFilter `filterOr` rerunFilter , configQuickCheckSeed = mSeed , configQuickCheckMaxSuccess = mMaxSuccess @@ -79,8 +83,31 @@ setSeed :: Integer -> QC.Args -> QC.Args setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)} -getConfig :: Config -> String -> [String] -> IO (Maybe FailureReport, Config) -getConfig opts_ prog args = do +-- | +-- `readConfig` parses config options from several sources and constructs a +-- `Config` value. It takes options from: +-- +-- 1. @~/.hspec@ (a config file in the user's home directory) +-- 1. @.hspec@ (a config file in the current working directory) +-- 1. the environment variable @HSPEC_OPTIONS@ +-- 1. the provided list of command-line options (the second argument to @readConfig@) +-- +-- (precedence from low to high) +-- +-- When parsing fails then @readConfig@ writes an error message to `stderr` and +-- exits with `exitFailure`. +-- +-- When @--help@ is provided as a command-line option then @readConfig@ writes +-- a help message to `stdout` and exits with `exitSuccess`. +-- +-- A common way to use @readConfig@ is: +-- +-- @ +-- `System.Environment.getArgs` >>= readConfig `defaultConfig` +-- @ +readConfig :: Config -> [String] -> IO Config +readConfig opts_ args = do + prog <- getProgName configFiles <- do ignore <- ignoreConfigFile opts_ args case ignore of @@ -89,9 +116,12 @@ envVar <- fmap words <$> lookupEnv envVarName case parseOptions opts_ prog configFiles envVar args of Left (err, msg) -> exitWithMessage err msg - Right opts -> do - r <- if configRerun opts then readFailureReport opts else return Nothing - return (r, mkConfig r opts) + Right opts -> return opts + +readFailureReportOnRerun :: Config -> IO (Maybe FailureReport) +readFailureReportOnRerun config + | configRerun config = readFailureReport config + | otherwise = return Nothing readConfigFiles :: IO [ConfigFile] readConfigFiles = do diff --git a/hspec-core/src/Test/Hspec/Core/Config/Options.hs b/hspec-core/src/Test/Hspec/Core/Config/Options.hs --- a/hspec-core/src/Test/Hspec/Core/Config/Options.hs +++ b/hspec-core/src/Test/Hspec/Core/Config/Options.hs @@ -33,8 +33,11 @@ data Config = Config { configIgnoreConfigFile :: Bool , configDryRun :: Bool +, configFocusedOnly :: Bool +, configFailOnFocused :: Bool , configPrintCpuTime :: Bool , configFastFail :: Bool +, configRandomize :: Bool , configFailureReport :: Maybe FilePath , configRerun :: Bool , configRerunAllOnSuccess :: Bool @@ -61,8 +64,11 @@ defaultConfig = Config { configIgnoreConfigFile = False , configDryRun = False +, configFocusedOnly = False +, configFailOnFocused = False , configPrintCpuTime = False , configFastFail = False +, configRandomize = False , configFailureReport = Nothing , configRerun = False , configRerunAllOnSuccess = False @@ -190,12 +196,18 @@ ] runnerOptions :: Monad m => [OptDescr (Result m -> Result m)] -runnerOptions = [ - Option [] ["dry-run"] (NoArg setDryRun) "pretend that everything passed; don't verify anything" - , Option [] ["fail-fast"] (NoArg setFastFail) "abort on first failure" - , Option "r" ["rerun"] (NoArg setRerun) "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" +runnerOptions = concat [ + mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything" + , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items" + , mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items" + , mkFlag "fail-fast" setFastFail "abort on first failure" + , mkFlag "randomize" setRandomize "randomize execution order" + ] ++ [ + Option "r" ["rerun"] (NoArg setRerun) "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" , mkOption [] "failure-report" (Arg "FILE" return setFailureReport) "read/write a failure report for use with --rerun" , Option [] ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess) "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)" + + , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" ] where @@ -211,8 +223,21 @@ setMaxJobs :: Int -> Config -> Config setMaxJobs n c = c {configConcurrentJobs = Just n} - setDryRun = set $ \config -> config {configDryRun = True} - setFastFail = set $ \config -> config {configFastFail = True} + setDryRun :: Bool -> Config -> Config + setDryRun value config = config {configDryRun = value} + + setFocusedOnly :: Bool -> Config -> Config + setFocusedOnly value config = config {configFocusedOnly = value} + + setFailOnFocused :: Bool -> Config -> Config + setFailOnFocused value config = config {configFailOnFocused = value} + + setFastFail :: Bool -> Config -> Config + setFastFail value config = config {configFastFail = value} + + setRandomize :: Bool -> Config -> Config + setRandomize value config = config {configRandomize = value} + setRerun = set $ \config -> config {configRerun = True} setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True} diff --git a/hspec-core/src/Test/Hspec/Core/Example.hs b/hspec-core/src/Test/Hspec/Core/Example.hs --- a/hspec-core/src/Test/Hspec/Core/Example.hs +++ b/hspec-core/src/Test/Hspec/Core/Example.hs @@ -4,6 +4,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} + +-- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Example ( Example (..) , Params (..) @@ -15,6 +17,7 @@ , ResultStatus (..) , Location (..) , FailureReason (..) +, safeEvaluate , safeEvaluateExample ) where @@ -88,13 +91,7 @@ instance Exception ResultStatus safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result -safeEvaluateExample example params around progress = do - r <- safeTry $ forceResult <$> evaluateExample example params around progress - return $ case r of - Left e | Just result <- fromException e -> Result "" result - Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit - Left e -> Result "" $ Failure Nothing $ Error Nothing e - Right result -> result +safeEvaluateExample example params around progress = safeEvaluate $ forceResult <$> evaluateExample example params around progress where forceResult :: Result -> Result forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r @@ -104,6 +101,15 @@ Success -> r Pending _ m -> m `deepseq` r Failure _ m -> m `deepseq` r + +safeEvaluate :: IO Result -> IO Result +safeEvaluate action = do + r <- safeTry $ action + return $ case r of + Left e | Just result <- fromException e -> Result "" result + Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit + Left e -> Result "" $ Failure Nothing $ Error Nothing e + Right result -> result instance Example Result where type Arg Result = () diff --git a/hspec-core/src/Test/Hspec/Core/Example/Location.hs b/hspec-core/src/Test/Hspec/Core/Example/Location.hs --- a/hspec-core/src/Test/Hspec/Core/Example/Location.hs +++ b/hspec-core/src/Test/Hspec/Core/Example/Location.hs @@ -4,6 +4,7 @@ , extractLocation -- for testing +, parseAssertionFailed , parseCallStack , parseLocation , parseSourceSpan @@ -31,6 +32,21 @@ <|> locationFromPatternMatchFail e <|> locationFromRecConError e <|> locationFromIOException e + <|> locationFromNoMethodError e + <|> locationFromAssertionFailed e + +locationFromNoMethodError :: SomeException -> Maybe Location +locationFromNoMethodError e = case fromException e of + Just (NoMethodError s) -> listToMaybe (words s) >>= parseSourceSpan + Nothing -> Nothing + +locationFromAssertionFailed :: SomeException -> Maybe Location +locationFromAssertionFailed e = case fromException e of + Just (AssertionFailed loc) -> parseAssertionFailed loc + Nothing -> Nothing + +parseAssertionFailed :: String -> Maybe Location +parseAssertionFailed loc = parseCallStack loc <|> parseSourceSpan loc locationFromErrorCall :: SomeException -> Maybe Location locationFromErrorCall e = case fromException e of diff --git a/hspec-core/src/Test/Hspec/Core/Format.hs b/hspec-core/src/Test/Hspec/Core/Format.hs --- a/hspec-core/src/Test/Hspec/Core/Format.hs +++ b/hspec-core/src/Test/Hspec/Core/Format.hs @@ -20,12 +20,13 @@ , itemDuration :: Seconds , itemInfo :: String , itemResult :: Result -} +} deriving Show data Result = Success | Pending (Maybe String) | Failure FailureReason + deriving Show data Format m = Format { formatRun :: forall a. m a -> IO a diff --git a/hspec-core/src/Test/Hspec/Core/Formatters.hs b/hspec-core/src/Test/Hspec/Core/Formatters.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters.hs @@ -3,7 +3,7 @@ -- Stability: experimental -- -- This module contains formatters that can be used with --- `Test.Hspec.Runner.hspecWith`. +-- `Test.Hspec.Core.Runner.hspecWith`. module Test.Hspec.Core.Formatters ( -- * Formatters @@ -61,8 +61,11 @@ import Data.Maybe import Test.Hspec.Core.Util +import Test.Hspec.Core.Clock import Test.Hspec.Core.Spec (Location(..)) import Text.Printf +import Control.Monad.IO.Class +import Control.Exception -- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make -- sure, that we only use the public API to implement formatters. @@ -100,8 +103,6 @@ , missingChunk ) -import Test.Hspec.Core.Clock (Seconds(..)) - import Test.Hspec.Core.Formatters.Diff silent :: Formatter @@ -212,28 +213,38 @@ mapM_ indent preface b <- useDiff - let - chunks - | b = diff expected actual - | otherwise = [First expected, Second actual] - withFailColor $ write (indentation ++ "expected: ") - forM_ chunks $ \chunk -> case chunk of - Both a _ -> indented write a - First a -> indented extraChunk a - Second _ -> return () - writeLine "" + let threshold = 2 :: Seconds - withFailColor $ write (indentation ++ " but got: ") - forM_ chunks $ \chunk -> case chunk of - Both a _ -> indented write a - First _ -> return () - Second a -> indented missingChunk a - writeLine "" + mchunks <- liftIO $ if b + then timeout threshold (evaluate $ diff expected actual) + else return Nothing + + case mchunks of + Just chunks -> do + writeDiff chunks extraChunk missingChunk + Nothing -> do + writeDiff [First expected, Second actual] write write where indented output text = case break (== '\n') text of (xs, "") -> output xs (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys + + writeDiff chunks extra missing = do + withFailColor $ write (indentation ++ "expected: ") + forM_ chunks $ \ chunk -> case chunk of + Both a _ -> indented write a + First a -> indented extra a + Second _ -> return () + writeLine "" + + withFailColor $ write (indentation ++ " but got: ") + forM_ chunks $ \ chunk -> case chunk of + Both a _ -> indented write a + First _ -> return () + Second a -> indented missing a + writeLine "" + Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e writeLine "" diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs b/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Formatters.Internal ( FormatM , FormatConfig(..) @@ -9,6 +9,9 @@ , addFailMessage , finally_ , formatterToFormat +#ifdef TEST +, overwriteWith +#endif ) where import Prelude () @@ -94,8 +97,8 @@ } deriving (Eq, Show) data FormatterState = FormatterState { - stateSuccessCount :: Int -, statePendingCount :: Int + stateSuccessCount :: !Int +, statePendingCount :: !Int , stateFailMessages :: [FailureRecord] , stateCpuStartTime :: Maybe Integer , stateStartTime :: Seconds @@ -149,10 +152,18 @@ getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages +overwriteWith :: String -> String -> String +overwriteWith old new + | n == 0 = new + | otherwise = '\r' : new ++ replicate (n - length new) ' ' + where + n = length old + writeTransient :: String -> FormatM () -writeTransient s = do - write ("\r" ++ s) - modify $ \ state -> state {stateTransientOutput = s} +writeTransient new = do + old <- gets stateTransientOutput + write $ old `overwriteWith` new + modify $ \ state -> state {stateTransientOutput = new} h <- getHandle liftIO $ IO.hFlush h diff --git a/hspec-core/src/Test/Hspec/Core/Hooks.hs b/hspec-core/src/Test/Hspec/Core/Hooks.hs --- a/hspec-core/src/Test/Hspec/Core/Hooks.hs +++ b/hspec-core/src/Test/Hspec/Core/Hooks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- | Stability: provisional module Test.Hspec.Core.Hooks ( before @@ -5,6 +6,7 @@ , beforeWith , beforeAll , beforeAll_ +, beforeAllWith , after , after_ , afterAll @@ -12,10 +14,17 @@ , around , around_ , aroundWith +, aroundAll +, aroundAll_ +, aroundAllWith ) where -import Control.Exception (SomeException, finally, throwIO, try) +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Exception (SomeException, finally, throwIO, try, catch) import Control.Concurrent.MVar +import Control.Concurrent.Async import Test.Hspec.Core.Example import Test.Hspec.Core.Tree @@ -45,6 +54,12 @@ mvar <- runIO (newMVar Empty) before_ (memoize mvar action) spec +-- | Run a custom action with an argument before the first spec item. +beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b +beforeAllWith action spec = do + mvar <- runIO (newMVar Empty) + beforeWith (memoize mvar . action) spec + data Memoized a = Empty | Memoized a @@ -91,3 +106,60 @@ modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b modifyAroundAction action item@Item{itemExample = e} = item{ itemExample = \params aroundAction -> e params (aroundAction . action) } + +-- | Wrap an action around the given spec. +aroundAll :: (ActionWith a -> IO ()) -> SpecWith a -> Spec +aroundAll action = aroundAllWith $ \ e () -> action e + +-- | Wrap an action around the given spec. +aroundAll_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a +aroundAll_ action spec = do + allSpecItemsDone <- runIO newEmptyMVar + workerRef <- runIO newEmptyMVar + let + acquire :: IO () + acquire = do + resource <- newEmptyMVar + worker <- async $ do + action $ do + signal resource + waitFor allSpecItemsDone + putMVar workerRef worker + unwrapExceptionsFromLinkedThread $ do + link worker + waitFor resource + release :: IO () + release = signal allSpecItemsDone >> takeMVar workerRef >>= wait + beforeAll_ acquire $ afterAll_ release spec + +-- | Wrap an action around the given spec. Changes the arg type inside. +aroundAllWith :: forall a b. (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b +aroundAllWith action spec = do + allSpecItemsDone <- runIO newEmptyMVar + workerRef <- runIO newEmptyMVar + let + acquire :: b -> IO a + acquire b = do + resource <- newEmptyMVar + worker <- async $ do + flip action b $ \ a -> do + putMVar resource a + waitFor allSpecItemsDone + putMVar workerRef worker + unwrapExceptionsFromLinkedThread $ do + link worker + takeMVar resource + release :: IO () + release = signal allSpecItemsDone >> takeMVar workerRef >>= wait + beforeAllWith acquire $ afterAll_ release spec + +unwrapExceptionsFromLinkedThread :: IO a -> IO a +unwrapExceptionsFromLinkedThread = (`catch` \ (ExceptionInLinkedThread _ e) -> throwIO e) + +type BinarySemaphore = MVar () + +signal :: BinarySemaphore -> IO () +signal = flip putMVar () + +waitFor :: BinarySemaphore -> IO () +waitFor = takeMVar diff --git a/hspec-core/src/Test/Hspec/Core/Runner.hs b/hspec-core/src/Test/Hspec/Core/Runner.hs --- a/hspec-core/src/Test/Hspec/Core/Runner.hs +++ b/hspec-core/src/Test/Hspec/Core/Runner.hs @@ -5,20 +5,30 @@ module Test.Hspec.Core.Runner ( -- * Running a spec hspec -, hspecWith -, hspecResult -, hspecWithResult +, runSpec --- * Types -, Summary (..) +-- * Config , Config (..) , ColorMode (..) , Path , defaultConfig , configAddFilter +, readConfig +-- * Summary +, Summary (..) +, isSuccess +, evaluateSummary + +-- * Legacy +-- | The following primitives are deprecated. Use `runSpec` instead. +, hspecWith +, hspecResult +, hspecWithResult + #ifdef TEST , rerunAll +, specToEvalForest #endif ) where @@ -27,9 +37,12 @@ import Data.Maybe import System.IO -import System.Environment (getProgName, getArgs, withArgs) +import System.Environment (getArgs, withArgs) import System.Exit import qualified Control.Exception as E +import System.Random +import Control.Monad.ST +import Data.STRef import System.Console.ANSI (hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC @@ -41,51 +54,47 @@ import Test.Hspec.Core.Formatters.Internal import Test.Hspec.Core.FailureReport import Test.Hspec.Core.QuickCheckUtil +import Test.Hspec.Core.Shuffle import Test.Hspec.Core.Runner.Eval --- | Filter specs by given predicate. --- --- The predicate takes a list of "describe" labels and a "requirement". -filterSpecs :: Config -> [EvalTree] -> [EvalTree] -filterSpecs c = go [] +applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree] +applyFilterPredicates c = filterForestWithLabels p where - p :: Path -> Bool - p path = (fromMaybe (const True) (configFilterPredicate c) path) && - not (fromMaybe (const False) (configSkipPredicate c) path) - - go :: [String] -> [EvalTree] -> [EvalTree] - go groups = mapMaybe (goSpec groups) + include :: Path -> Bool + include = fromMaybe (const True) (configFilterPredicate c) - goSpecs :: [String] -> [EvalTree] -> ([EvalTree] -> b) -> Maybe b - goSpecs groups specs ctor = case go groups specs of - [] -> Nothing - xs -> Just (ctor xs) + skip :: Path -> Bool + skip = fromMaybe (const False) (configSkipPredicate c) - goSpec :: [String] -> EvalTree -> Maybe (EvalTree) - goSpec groups spec = case spec of - Leaf item -> guard (p (groups, evalItemDescription item)) >> return spec - Node group specs -> goSpecs (groups ++ [group]) specs (Node group) - NodeWithCleanup action specs -> goSpecs groups specs (NodeWithCleanup action) + p :: [String] -> EvalItem -> Bool + p groups item = include path && not (skip path) + where + path = (groups, evalItemDescription item) -applyDryRun :: Config -> [SpecTree ()] -> [SpecTree ()] +applyDryRun :: Config -> [EvalTree] -> [EvalTree] applyDryRun c - | configDryRun c = map (removeCleanup . fmap markSuccess) + | configDryRun c = bimapForest removeCleanup markSuccess | otherwise = id where - markSuccess :: Item () -> Item () - markSuccess item = item {itemExample = safeEvaluateExample (Result "" Success)} + removeCleanup :: IO () -> IO () + removeCleanup _ = return () - removeCleanup :: SpecTree () -> SpecTree () - removeCleanup spec = case spec of - Node x xs -> Node x (map removeCleanup xs) - NodeWithCleanup _ xs -> NodeWithCleanup (\() -> return ()) (map removeCleanup xs) - leaf@(Leaf _) -> leaf + markSuccess :: EvalItem -> EvalItem + markSuccess item = item {evalItemAction = \ _ -> return $ Result "" Success} --- | Run given spec and write a report to `stdout`. +-- | Run a given spec and write a report to `stdout`. -- Exit with `exitFailure` if at least one spec item fails. +-- +-- /Note/: `hspec` handles command-line options and reads config files. This +-- is not always desired. Use `runSpec` if you need more control over these +-- aspects. hspec :: Spec -> IO () -hspec = hspecWith defaultConfig +hspec spec = + getArgs + >>= readConfig defaultConfig + >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec + >>= evaluateSummary -- Add a seed to given config if there is none. That way the same seed is used -- for all properties. This helps with --seed and --rerun. @@ -99,20 +108,25 @@ -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. hspecWith :: Config -> Spec -> IO () -hspecWith conf spec = do - r <- hspecWithResult conf spec - unless (isSuccess r) exitFailure +hspecWith config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary +-- | `True` if the given `Summary` indicates that there were no +-- failures, `False` otherwise. isSuccess :: Summary -> Bool isSuccess summary = summaryFailures summary == 0 +-- | Exit with `exitFailure` if the given `Summary` indicates that there was at +-- least one failure. +evaluateSummary :: Summary -> IO () +evaluateSummary summary = unless (isSuccess summary) exitFailure + -- | Run given spec and returns a summary of the test run. -- -- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecResult :: Spec -> IO Summary -hspecResult = hspecWithResult defaultConfig +hspecResult spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec -- | Run given spec with custom options and returns a summary of the test run. -- @@ -120,11 +134,25 @@ -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary -hspecWithResult config spec = do - prog <- getProgName - args <- getArgs - (oldFailureReport, c_) <- getConfig config prog args - c <- ensureSeed c_ +hspecWithResult config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec + +-- | +-- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in +-- terms of @runSpec@: +-- +-- @ +-- hspec spec = +-- `getArgs` +-- >>= `readConfig` `defaultConfig` +-- >>= `withArgs` [] . runSpec spec +-- >>= `evaluateSummary` +-- @ +runSpec :: Spec -> Config -> IO Summary +runSpec spec c_ = do + oldFailureReport <- readFailureReportOnRerun c_ + + c <- ensureSeed (applyFailureReport oldFailureReport c_) + if configRerunAllOnSuccess c -- With --rerun-all we may run the spec twice. For that reason GHC can not -- optimize away the spec tree. That means that the whole spec tree has to @@ -137,16 +165,40 @@ then rerunAllMode c oldFailureReport else normalMode c where - normalMode c = runSpec c spec + normalMode c = runSpec_ c spec rerunAllMode c oldFailureReport = do - summary <- runSpec c spec + summary <- runSpec_ c spec if rerunAll c oldFailureReport summary - then hspecWithResult config spec + then runSpec spec c_ else return summary -runSpec :: Config -> Spec -> IO Summary -runSpec config spec = do - doNotLeakCommandLineArgumentsToExamples $ withHandle config $ \h -> do +failFocused :: Item a -> Item a +failFocused item = item {itemExample = example} + where + failure = Failure Nothing (Reason "item is focused; failing due to --fail-on-focused") + example + | itemIsFocused item = \ params hook p -> do + Result info status <- itemExample item params hook p + return $ Result info $ case status of + Success -> failure + Pending _ _ -> failure + Failure{} -> status + | otherwise = itemExample item + +failFocusedItems :: Config -> Spec -> Spec +failFocusedItems config spec + | configFailOnFocused config = mapSpecItem_ failFocused spec + | otherwise = spec + +focusSpec :: Config -> Spec -> Spec +focusSpec config spec + | configFocusedOnly config = spec + | otherwise = focus spec + +runSpec_ :: Config -> Spec -> IO Summary +runSpec_ config spec = do + filteredSpec <- specToEvalForest config spec + withHandle config $ \h -> do let formatter = fromMaybe specdoc (configFormatter config) seed = (fromJust . configQuickCheckSeed) config qcArgs = configQuickCheckArgs config @@ -157,11 +209,7 @@ useColor <- doesUseColor h config - let params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) - - filteredSpec <- filterSpecs config . mapMaybe (toEvalTree params) . applyDryRun config <$> runSpecM (focus spec) - - (total, failures) <- withHiddenCursor useColor h $ do + results <- withHiddenCursor useColor h $ do let formatConfig = FormatConfig { formatConfigHandle = h @@ -178,19 +226,35 @@ } runFormatter evalConfig filteredSpec - dumpFailureReport config seed qcArgs failures - return (Summary total (length failures)) + let failures = filter resultItemIsFailure results -toEvalTree :: Params -> SpecTree () -> Maybe EvalTree -toEvalTree params = go + dumpFailureReport config seed qcArgs (map fst failures) + + return Summary { + summaryExamples = length results + , summaryFailures = length failures + } + +specToEvalForest :: Config -> Spec -> IO [EvalTree] +specToEvalForest config spec = do + let + seed = (fromJust . configQuickCheckSeed) config + focusedSpec = focusSpec config (failFocusedItems config spec) + params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) + randomize + | configRandomize config = randomizeForest seed + | otherwise = id + randomize . pruneForest . applyFilterPredicates config . applyDryRun config . toEvalForest params <$> runSpecM focusedSpec + +toEvalForest :: Params -> [SpecTree ()] -> [EvalTree] +toEvalForest params = bimapForest withUnit toEvalItem . filterForest itemIsFocused where - go :: Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem) - go t = case t of - Node s xs -> Just $ Node s (mapMaybe go xs) - NodeWithCleanup c xs -> Just $ NodeWithCleanup (c ()) (mapMaybe go xs) - Leaf (Item requirement loc isParallelizable isFocused e) -> - guard isFocused >> return (Leaf (EvalItem requirement loc (fromMaybe False isParallelizable) (e params $ ($ ())))) + toEvalItem :: Item () -> EvalItem + toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem requirement loc (fromMaybe False isParallelizable) (e params withUnit) + withUnit :: ActionWith () -> IO () + withUnit action = action () + dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO () dumpFailureReport config seed qcArgs xs = do writeFailureReport config FailureReport { @@ -245,3 +309,8 @@ instance Semigroup Summary where (Summary x1 x2) <> (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) #endif + +randomizeForest :: Integer -> [Tree c a] -> [Tree c a] +randomizeForest seed t = runST $ do + ref <- newSTRef (mkStdGen $ fromIntegral seed) + shuffleForest ref t diff --git a/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs b/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs --- a/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs +++ b/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs @@ -14,6 +14,7 @@ , EvalTree , EvalItem(..) , runFormatter +, resultItemIsFailure #ifdef TEST , runSequentially #endif @@ -40,6 +41,7 @@ import qualified Test.Hspec.Core.Format as Format import Test.Hspec.Core.Clock import Test.Hspec.Core.Example.Location +import Test.Hspec.Core.Example (safeEvaluate) -- for compatibility with GHC < 7.10.1 type Monad m = (Functor m, Applicative m, M.Monad m) @@ -53,31 +55,20 @@ data State m = State { stateConfig :: EvalConfig m -, stateSuccessCount :: Int -, statePendingCount :: Int -, stateFailures :: [Path] +, stateResults :: [(Path, Format.Item)] } type EvalM m = StateT (State m) m -increaseSuccessCount :: Monad m => EvalM m () -increaseSuccessCount = modify $ \state -> state {stateSuccessCount = stateSuccessCount state + 1} - -increasePendingCount :: Monad m => EvalM m () -increasePendingCount = modify $ \state -> state {statePendingCount = statePendingCount state + 1} - -addFailure :: Monad m => Path -> EvalM m () -addFailure path = modify $ \state -> state {stateFailures = path : stateFailures state} +addResult :: Monad m => Path -> Format.Item -> EvalM m () +addResult path item = modify $ \ state -> state {stateResults = (path, item) : stateResults state} getFormat :: Monad m => (Format m -> a) -> EvalM m a getFormat format = gets (format . evalConfigFormat . stateConfig) reportItem :: Monad m => Path -> Format.Item -> EvalM m () reportItem path item = do - case Format.itemResult item of - Format.Success {} -> increaseSuccessCount - Format.Pending {} -> increasePendingCount - Format.Failure {} -> addFailure path + addResult path item format <- getFormat formatItem lift (format path item) @@ -113,10 +104,10 @@ type EvalTree = Tree (IO ()) EvalItem runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m) -runEvalM config action = execStateT action (State config 0 0 []) +runEvalM config action = execStateT action (State config []) -- | Evaluate all examples of a given spec and produce a report. -runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO (Int, [Path]) +runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO ([(Path, Format.Item)]) runFormatter config specs = do let start = parallelizeTree (evalConfigConcurrentJobs config) specs @@ -126,10 +117,7 @@ state <- formatRun format $ do runEvalM config $ run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs - let - failures = stateFailures state - total = stateSuccessCount state + statePendingCount state + length failures - return (total, reverse failures) + return (reverse $ stateResults state) where format = evalConfigFormat config @@ -223,8 +211,10 @@ runCleanup :: [String] -> IO () -> EvalM m () runCleanup groups action = do - (dt, r) <- liftIO $ measure $ safeTry action - either (\ e -> reportItem path . failureItem (extractLocation e) dt "" . Error Nothing $ e) return r + r <- liftIO $ measure $ safeEvaluate (action >> return (Result "" Success)) + case r of + (_, Result "" Success) -> return () + _ -> reportResult path Nothing r where path = (groups, "afterAll-hook") @@ -260,9 +250,18 @@ sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m () sequenceActions fastFail = go where + go :: Monad m => [EvalM m ()] -> EvalM m () go [] = return () go (action : actions) = do - () <- action - hasFailures <- (not . null) <$> gets stateFailures + action + hasFailures <- any resultItemIsFailure <$> gets stateResults let stopNow = fastFail && hasFailures unless stopNow (go actions) + +resultItemIsFailure :: (Path, Format.Item) -> Bool +resultItemIsFailure = isFailure . Format.itemResult . snd + where + isFailure r = case r of + Format.Success{} -> False + Format.Pending{} -> False + Format.Failure{} -> True diff --git a/hspec-core/src/Test/Hspec/Core/Shuffle.hs b/hspec-core/src/Test/Hspec/Core/Shuffle.hs new file mode 100644 --- /dev/null +++ b/hspec-core/src/Test/Hspec/Core/Shuffle.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Shuffle ( + shuffleForest +#ifdef TEST +, shuffle +, mkArray +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat +import Test.Hspec.Core.Tree + +import System.Random +import Control.Monad.ST +import Data.STRef +import Data.Array.ST + +shuffleForest :: STRef s StdGen -> [Tree c a] -> ST s [Tree c a] +shuffleForest ref xs = (shuffle ref xs >>= mapM (shuffleTree ref)) + +shuffleTree :: STRef s StdGen -> Tree c a -> ST s (Tree c a) +shuffleTree ref t = case t of + Node d xs -> Node d <$> shuffleForest ref xs + NodeWithCleanup c xs -> NodeWithCleanup c <$> shuffleForest ref xs + Leaf {} -> return t + +shuffle :: STRef s StdGen -> [a] -> ST s [a] +shuffle ref xs = do + arr <- mkArray xs + bounds@(_, n) <- getBounds arr + forM (range bounds) $ \ i -> do + j <- randomIndex (i, n) + vi <- readArray arr i + vj <- readArray arr j + writeArray arr j vi + return vj + where + randomIndex bounds = do + (a, gen) <- randomR bounds <$> readSTRef ref + writeSTRef ref gen + return a + +mkArray :: [a] -> ST s (STArray s Int a) +mkArray xs = newListArray (1, length xs) xs diff --git a/hspec-core/src/Test/Hspec/Core/Spec.hs b/hspec-core/src/Test/Hspec/Core/Spec.hs --- a/hspec-core/src/Test/Hspec/Core/Spec.hs +++ b/hspec-core/src/Test/Hspec/Core/Spec.hs @@ -108,7 +108,7 @@ let ys | any (any itemIsFocused) xs = xs - | otherwise = map (bimapTree id (\ item -> item {itemIsFocused = True})) xs + | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs fromSpecList ys -- | @fit@ is an alias for @fmap focus . it@ diff --git a/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs b/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs --- a/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs +++ b/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs @@ -1,4 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Spec.Monad ( Spec , SpecWith @@ -49,11 +51,11 @@ runIO :: IO r -> SpecM a r runIO = SpecM . liftIO -mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r -mapSpecTree f (SpecM specs) = SpecM (mapWriterT (fmap (second (map f))) specs) +mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r +mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (second f)) specs) mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b -mapSpecItem g f = mapSpecTree (bimapTree g f) +mapSpecItem g f = mapSpecForest (bimapForest g f) mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a mapSpecItem_ = mapSpecItem id diff --git a/hspec-core/src/Test/Hspec/Core/Tree.hs b/hspec-core/src/Test/Hspec/Core/Tree.hs --- a/hspec-core/src/Test/Hspec/Core/Tree.hs +++ b/hspec-core/src/Test/Hspec/Core/Tree.hs @@ -4,8 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} --- | --- Stability: unstable +-- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Tree ( SpecTree , Tree (..) @@ -13,6 +12,13 @@ , specGroup , specItem , bimapTree +, bimapForest +, filterTree +, filterForest +, filterTreeWithLabels +, filterForestWithLabels +, pruneTree +, pruneForest , location ) where @@ -35,6 +41,9 @@ -- over the type of cleanup actions and the type of the actual spec items. type SpecTree a = Tree (ActionWith a) (Item a) +bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d] +bimapForest g f = map (bimapTree g f) + bimapTree :: (a -> b) -> (c -> d) -> Tree a c -> Tree b d bimapTree g f = go where @@ -42,6 +51,38 @@ Node d xs -> Node d (map go xs) NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs) Leaf item -> Leaf (f item) + +filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a) +filterTree = filterTreeWithLabels . const + +filterForest :: (a -> Bool) -> [Tree c a] -> [Tree c a] +filterForest = filterForestWithLabels . const + +filterTreeWithLabels :: ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) +filterTreeWithLabels = filterTree_ [] + +filterForestWithLabels :: ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a] +filterForestWithLabels = filterForest_ [] + +filterForest_ :: [String] -> ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a] +filterForest_ groups = mapMaybe . filterTree_ groups + +filterTree_ :: [String] -> ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) +filterTree_ groups p tree = case tree of + Node group xs -> Just $ Node group $ filterForest_ (groups ++ [group]) p xs + NodeWithCleanup action xs -> Just $ NodeWithCleanup action $ filterForest_ groups p xs + Leaf item -> Leaf <$> guarded (p groups) item + +pruneForest :: [Tree c a] -> [Tree c a] +pruneForest = mapMaybe pruneTree + +pruneTree :: Tree c a -> Maybe (Tree c a) +pruneTree node = case node of + Node group xs -> Node group <$> prune xs + NodeWithCleanup action xs -> NodeWithCleanup action <$> prune xs + Leaf{} -> Just node + where + prune = guarded (not . null) . pruneForest -- | -- @Item@ is used to represent spec items internally. A spec item consists of: diff --git a/hspec-core/src/Test/Hspec/Core/Util.hs b/hspec-core/src/Test/Hspec/Core/Util.hs --- a/hspec-core/src/Test/Hspec/Core/Util.hs +++ b/hspec-core/src/Test/Hspec/Core/Util.hs @@ -63,7 +63,7 @@ else s : go (y, ys) -- | --- A `Path` represents the location of an example within the spec tree. +-- A `Path` describes the location of a spec item within a spec tree. -- -- It consists of a list of group descriptions and a requirement description. type Path = ([String], String) diff --git a/hspec-core/vendor/Control/Concurrent/Async.hs b/hspec-core/vendor/Control/Concurrent/Async.hs --- a/hspec-core/vendor/Control/Concurrent/Async.hs +++ b/hspec-core/vendor/Control/Concurrent/Async.hs @@ -146,7 +146,7 @@ #if __GLASGOW_HASKELL__ < 710 import Data.Typeable #endif -#if MIN_VERSION_base(4,9,0) +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0) import Data.Semigroup (Semigroup((<>))) #endif diff --git a/hspec-meta.cabal b/hspec-meta.cabal --- a/hspec-meta.cabal +++ b/hspec-meta.cabal @@ -1,29 +1,27 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.0. +-- This file has been generated from package.yaml by hpack version 0.34.3. -- -- see: https://github.com/sol/hpack --- --- hash: 09929585045f559b6f4dc8e49667a90bf2260d46c6a0ef0d02b2bdd4d40fb9de -name: hspec-meta -version: 2.6.0 -license: MIT -license-file: LICENSE -copyright: (c) 2011-2018 Simon Hengel, - (c) 2011-2012 Trystan Spangler, - (c) 2011 Greg Weber -maintainer: Simon Hengel -build-type: Simple -category: Testing -stability: experimental -bug-reports: https://github.com/hspec/hspec/issues -homepage: http://hspec.github.io/ -synopsis: A version of Hspec which is used to test Hspec itself -description: A stable version of Hspec which is used to test the - in-development version of Hspec. +name: hspec-meta +version: 2.7.8 +synopsis: A version of Hspec which is used to test Hspec itself +description: A stable version of Hspec which is used to test the + in-development version of Hspec. +category: Testing +stability: experimental +homepage: http://hspec.github.io/ +bug-reports: https://github.com/hspec/hspec/issues +maintainer: Simon Hengel +copyright: (c) 2011-2021 Simon Hengel, + (c) 2011-2012 Trystan Spangler, + (c) 2011 Greg Weber +license: MIT +license-file: LICENSE +build-type: Simple extra-source-files: - CHANGES.markdown + version.yaml source-repository head type: git @@ -57,6 +55,7 @@ Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval + Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec Test.Hspec.Core.Spec.Monad Test.Hspec.Core.Timer @@ -64,15 +63,24 @@ Test.Hspec.Core.Util Control.Concurrent.Async Data.Algorithm.Diff + Test.HUnit + Test.HUnit.Base + Test.HUnit.Lang + Test.HUnit.Terminal + Test.HUnit.Text + Test.Hspec.Expectations + Test.Hspec.Expectations.Contrib + Test.Hspec.Expectations.Matcher Paths_hspec_meta - ghc-options: -Wall hs-source-dirs: src hspec-core/src hspec-core/vendor + vendor/HUnit-1.6.2.0/src/ + vendor/hspec-expectations-0.8.2/src/ + ghc-options: -Wall build-depends: - HUnit - , QuickCheck >=2.10 + QuickCheck >=2.12 , ansi-terminal , array , base ==4.* @@ -81,7 +89,6 @@ , deepseq , directory , filepath - , hspec-expectations ==0.8.2.* , quickcheck-io , random , setenv @@ -92,13 +99,17 @@ executable hspec-meta-discover main-is: hspec-discover.hs + other-modules: + Test.Hspec.Discover.Config + Test.Hspec.Discover.Run + Test.Hspec.Discover.Sort + Paths_hspec_meta hs-source-dirs: hspec-discover/src hspec-discover/driver ghc-options: -Wall build-depends: - HUnit - , QuickCheck >=2.10 + QuickCheck >=2.12 , ansi-terminal , array , base ==4.* @@ -107,16 +118,10 @@ , deepseq , directory , filepath - , hspec-expectations ==0.8.2.* , quickcheck-io , random , setenv , stm >=2.2 , time , transformers >=0.2.2.0 - other-modules: - Test.Hspec.Discover.Config - Test.Hspec.Discover.Run - Test.Hspec.Discover.Sort - Paths_hspec_meta default-language: Haskell2010 diff --git a/src/Test/Hspec.hs b/src/Test/Hspec.hs --- a/src/Test/Hspec.hs +++ b/src/Test/Hspec.hs @@ -56,6 +56,7 @@ , beforeWith , beforeAll , beforeAll_ +, beforeAllWith , after , after_ , afterAll diff --git a/vendor/HUnit-1.6.2.0/src/Test/HUnit.hs b/vendor/HUnit-1.6.2.0/src/Test/HUnit.hs new file mode 100644 --- /dev/null +++ b/vendor/HUnit-1.6.2.0/src/Test/HUnit.hs @@ -0,0 +1,80 @@ +-- | HUnit is a unit testing framework for Haskell, inspired by the JUnit tool +-- for Java. This guide describes how to use HUnit, assuming you are familiar +-- with Haskell, though not necessarily with JUnit. +-- +-- In the Haskell module where your tests will reside, import module +-- @Test.HUnit@: +-- +-- @ +-- import Test.HUnit +-- @ +-- +-- Define test cases as appropriate: +-- +-- @ +-- test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3)) +-- test2 = TestCase (do (x,y) <- partA 3 +-- assertEqual "for the first result of partA," 5 x +-- b <- partB y +-- assertBool ("(partB " ++ show y ++ ") failed") b) +-- @ +-- +-- Name the test cases and group them together: +-- +-- @ +-- tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2] +-- @ +-- +-- Run the tests as a group. At a Haskell interpreter prompt, apply the function +-- @runTestTT@ to the collected tests. (The /TT/ suggests /T/ext orientation +-- with output to the /T/erminal.) +-- +-- @ +-- \> runTestTT tests +-- Cases: 2 Tried: 2 Errors: 0 Failures: 0 +-- \> +-- @ +-- +-- If the tests are proving their worth, you might see: +-- +-- @ +-- \> runTestTT tests +-- ### Failure in: 0:test1 +-- for (foo 3), +-- expected: (1,2) +-- but got: (1,3) +-- Cases: 2 Tried: 2 Errors: 0 Failures: 1 +-- \> +-- @ +-- +-- You can specify tests even more succinctly using operators and overloaded +-- functions that HUnit provides: +-- +-- @ +-- tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3), +-- "test2" ~: do (x, y) <- partA 3 +-- assertEqual "for the first result of partA," 5 x +-- partB y \@? "(partB " ++ show y ++ ") failed" ] +-- @ +-- +-- Assuming the same test failures as before, you would see: +-- +-- @ +-- \> runTestTT tests +-- ### Failure in: 0:test1:(foo 3) +-- expected: (1,2) +-- but got: (1,3) +-- Cases: 2 Tried: 2 Errors: 0 Failures: 1 +-- \> +-- @ + +module Test.HUnit +( + module Test.HUnit.Base, + module Test.HUnit.Text +) +where + +import Test.HUnit.Base +import Test.HUnit.Text + diff --git a/vendor/HUnit-1.6.2.0/src/Test/HUnit/Base.hs b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Base.hs new file mode 100644 --- /dev/null +++ b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Base.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE ConstraintKinds #-} +#define HasCallStack_ HasCallStack => +#else +#define HasCallStack_ +#endif + +-- | Basic definitions for the HUnit library. +-- +-- This module contains what you need to create assertions and test cases and +-- combine them into test suites. +-- +-- This module also provides infrastructure for +-- implementing test controllers (which are used to execute tests). +-- See "Test.HUnit.Text" for a great example of how to implement a test +-- controller. + +module Test.HUnit.Base +( + -- ** Declaring tests + Test(..), + (~=?), (~?=), (~:), (~?), + + -- ** Making assertions + assertFailure, {- from Test.HUnit.Lang: -} + assertBool, assertEqual, assertString, + Assertion, {- from Test.HUnit.Lang: -} + (@=?), (@?=), (@?), + + -- ** Extending the assertion functionality + Assertable(..), ListAssertable(..), + AssertionPredicate, AssertionPredicable(..), + Testable(..), + + -- ** Test execution + -- $testExecutionNote + State(..), Counts(..), + Path, Node(..), + testCasePaths, + testCaseCount, + ReportStart, ReportProblem, + performTest +) where + +import Control.Monad (unless, foldM) +import Data.CallStack + + +-- Assertion Definition +-- ==================== + +import Test.HUnit.Lang + + +-- Conditional Assertion Functions +-- ------------------------------- + +-- | Asserts that the specified condition holds. +assertBool :: HasCallStack_ + String -- ^ The message that is displayed if the assertion fails + -> Bool -- ^ The condition + -> Assertion +assertBool msg b = unless b (assertFailure msg) + +-- | Signals an assertion failure if a non-empty message (i.e., a message +-- other than @\"\"@) is passed. +assertString :: HasCallStack_ + String -- ^ The message that is displayed with the assertion failure + -> Assertion +assertString s = unless (null s) (assertFailure s) + +-- Overloaded `assert` Function +-- ---------------------------- + +-- | Allows the extension of the assertion mechanism. +-- +-- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions, +-- there is a fair amount of flexibility of what can be achieved. As a rule, +-- the resulting @Assertion@ should be the body of a 'TestCase' or part of +-- a @TestCase@; it should not be used to assert multiple, independent +-- conditions. +-- +-- If more complex arrangements of assertions are needed, 'Test's and +-- 'Testable' should be used. +class Assertable t + where assert :: HasCallStack_ t -> Assertion + +instance Assertable () + where assert = return + +instance Assertable Bool + where assert = assertBool "" + +instance (ListAssertable t) => Assertable [t] + where assert = listAssert + +instance (Assertable t) => Assertable (IO t) + where assert = (>>= assert) + +-- | A specialized form of 'Assertable' to handle lists. +class ListAssertable t + where listAssert :: HasCallStack_ [t] -> Assertion + +instance ListAssertable Char + where listAssert = assertString + + +-- Overloaded `assertionPredicate` Function +-- ---------------------------------------- + +-- | The result of an assertion that hasn't been evaluated yet. +-- +-- Most test cases follow the following steps: +-- +-- 1. Do some processing or an action. +-- +-- 2. Assert certain conditions. +-- +-- However, this flow is not always suitable. @AssertionPredicate@ allows for +-- additional steps to be inserted without the initial action to be affected +-- by side effects. Additionally, clean-up can be done before the test case +-- has a chance to end. A potential work flow is: +-- +-- 1. Write data to a file. +-- +-- 2. Read data from a file, evaluate conditions. +-- +-- 3. Clean up the file. +-- +-- 4. Assert that the side effects of the read operation meet certain conditions. +-- +-- 5. Assert that the conditions evaluated in step 2 are met. +type AssertionPredicate = IO Bool + +-- | Used to signify that a data type can be converted to an assertion +-- predicate. +class AssertionPredicable t + where assertionPredicate :: t -> AssertionPredicate + +instance AssertionPredicable Bool + where assertionPredicate = return + +instance (AssertionPredicable t) => AssertionPredicable (IO t) + where assertionPredicate = (>>= assertionPredicate) + + +-- Assertion Construction Operators +-- -------------------------------- + +infix 1 @?, @=?, @?= + +-- | Asserts that the condition obtained from the specified +-- 'AssertionPredicable' holds. +(@?) :: HasCallStack_ AssertionPredicable t + => t -- ^ A value of which the asserted condition is predicated + -> String -- ^ A message that is displayed if the assertion fails + -> Assertion +predi @? msg = assertionPredicate predi >>= assertBool msg + +-- | Asserts that the specified actual value is equal to the expected value +-- (with the expected value on the left-hand side). +(@=?) :: HasCallStack_ (Eq a, Show a) + => a -- ^ The expected value + -> a -- ^ The actual value + -> Assertion +expected @=? actual = assertEqual "" expected actual + +-- | Asserts that the specified actual value is equal to the expected value +-- (with the actual value on the left-hand side). +(@?=) :: HasCallStack_ (Eq a, Show a) + => a -- ^ The actual value + -> a -- ^ The expected value + -> Assertion +actual @?= expected = assertEqual "" expected actual + + + +-- Test Definition +-- =============== + +-- | The basic structure used to create an annotated tree of test cases. +data Test + -- | A single, independent test case composed. + = TestCase Assertion + -- | A set of @Test@s sharing the same level in the hierarchy. + | TestList [Test] + -- | A name or description for a subtree of the @Test@s. + | TestLabel String Test + +instance Show Test where + showsPrec _ (TestCase _) = showString "TestCase _" + showsPrec _ (TestList ts) = showString "TestList " . showList ts + showsPrec p (TestLabel l t) = showString "TestLabel " . showString l + . showChar ' ' . showsPrec p t + +-- Overloaded `test` Function +-- -------------------------- + +-- | Provides a way to convert data into a @Test@ or set of @Test@. +class Testable t + where test :: HasCallStack_ t -> Test + +instance Testable Test + where test = id + +instance (Assertable t) => Testable (IO t) + where test = TestCase . assert + +instance (Testable t) => Testable [t] + where test = TestList . map test + + +-- Test Construction Operators +-- --------------------------- + +infix 1 ~?, ~=?, ~?= +infixr 0 ~: + +-- | Creates a test case resulting from asserting the condition obtained +-- from the specified 'AssertionPredicable'. +(~?) :: HasCallStack_ AssertionPredicable t + => t -- ^ A value of which the asserted condition is predicated + -> String -- ^ A message that is displayed on test failure + -> Test +predi ~? msg = TestCase (predi @? msg) + +-- | Shorthand for a test case that asserts equality (with the expected +-- value on the left-hand side, and the actual value on the right-hand +-- side). +(~=?) :: HasCallStack_ (Eq a, Show a) + => a -- ^ The expected value + -> a -- ^ The actual value + -> Test +expected ~=? actual = TestCase (expected @=? actual) + +-- | Shorthand for a test case that asserts equality (with the actual +-- value on the left-hand side, and the expected value on the right-hand +-- side). +(~?=) :: HasCallStack_ (Eq a, Show a) + => a -- ^ The actual value + -> a -- ^ The expected value + -> Test +actual ~?= expected = TestCase (actual @?= expected) + +-- | Creates a test from the specified 'Testable', with the specified +-- label attached to it. +-- +-- Since 'Test' is @Testable@, this can be used as a shorthand way of attaching +-- a 'TestLabel' to one or more tests. +(~:) :: HasCallStack_ Testable t => String -> t -> Test +label ~: t = TestLabel label (test t) + + + +-- Test Execution +-- ============== + +-- $testExecutionNote +-- Note: the rest of the functionality in this module is intended for +-- implementors of test controllers. If you just want to run your tests cases, +-- simply use a test controller, such as the text-based controller in +-- "Test.HUnit.Text". + +-- | A data structure that hold the results of tests that have been performed +-- up until this point. +data Counts = Counts { cases, tried, errors, failures :: Int } + deriving (Eq, Show, Read) + +-- | Keeps track of the remaining tests and the results of the performed tests. +-- As each test is performed, the path is removed and the counts are +-- updated as appropriate. +data State = State { path :: Path, counts :: Counts } + deriving (Eq, Show, Read) + +-- | Report generator for reporting the start of a test run. +type ReportStart us = State -> us -> IO us + +-- | Report generator for reporting problems that have occurred during +-- a test run. Problems may be errors or assertion failures. +type ReportProblem us = Maybe SrcLoc -> String -> State -> us -> IO us + +-- | Uniquely describes the location of a test within a test hierarchy. +-- Node order is from test case to root. +type Path = [Node] + +-- | Composed into 'Path's. +data Node = ListItem Int | Label String + deriving (Eq, Show, Read) + +-- | Determines the paths for all 'TestCase's in a tree of @Test@s. +testCasePaths :: Test -> [Path] +testCasePaths t0 = tcp t0 [] + where tcp (TestCase _) p = [p] + tcp (TestList ts) p = + concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ] + tcp (TestLabel l t) p = tcp t (Label l : p) + +-- | Counts the number of 'TestCase's in a tree of @Test@s. +testCaseCount :: Test -> Int +testCaseCount (TestCase _) = 1 +testCaseCount (TestList ts) = sum (map testCaseCount ts) +testCaseCount (TestLabel _ t) = testCaseCount t + +-- | Performs a test run with the specified report generators. +-- +-- This handles the actual running of the tests. Most developers will want +-- to use @HUnit.Text.runTestTT@ instead. A developer could use this function +-- to execute tests via another IO system, such as a GUI, or to output the +-- results in a different manner (e.g., upload XML-formatted results to a +-- webservice). +-- +-- Note that the counts in a start report do not include the test case +-- being started, whereas the counts in a problem report do include the +-- test case just finished. The principle is that the counts are sampled +-- only between test case executions. As a result, the number of test +-- case successes always equals the difference of test cases tried and +-- the sum of test case errors and failures. +performTest :: ReportStart us -- ^ report generator for the test run start + -> ReportProblem us -- ^ report generator for errors during the test run + -> ReportProblem us -- ^ report generator for assertion failures during the test run + -> us + -> Test -- ^ the test to be executed + -> IO (Counts, us) +performTest reportStart reportError reportFailure initialUs initialT = do + (ss', us') <- pt initState initialUs initialT + unless (null (path ss')) $ error "performTest: Final path is nonnull" + return (counts ss', us') + where + initState = State{ path = [], counts = initCounts } + initCounts = Counts{ cases = testCaseCount initialT, tried = 0, + errors = 0, failures = 0} + + pt ss us (TestCase a) = do + us' <- reportStart ss us + r <- performTestCase a + case r of + Success -> do + return (ss', us') + Failure loc m -> do + usF <- reportFailure loc m ssF us' + return (ssF, usF) + Error loc m -> do + usE <- reportError loc m ssE us' + return (ssE, usE) + where c@Counts{ tried = n } = counts ss + ss' = ss{ counts = c{ tried = n + 1 } } + ssF = ss{ counts = c{ tried = n + 1, failures = failures c + 1 } } + ssE = ss{ counts = c{ tried = n + 1, errors = errors c + 1 } } + + pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..]) + where f (ss', us') (t, n) = withNode (ListItem n) ss' us' t + + pt ss us (TestLabel label t) = withNode (Label label) ss us t + + withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t + return (ss2{ path = path0 }, us1) + where path0 = path ss0 + ss1 = ss0{ path = node : path0 } diff --git a/vendor/HUnit-1.6.2.0/src/Test/HUnit/Lang.hs b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Lang.hs new file mode 100644 --- /dev/null +++ b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Lang.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} + +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE ConstraintKinds #-} +#define HasCallStack_ HasCallStack => +#else +#define HasCallStack_ +#endif + +module Test.HUnit.Lang ( + Assertion, + assertFailure, + assertEqual, + + Result (..), + performTestCase, +-- * Internals +-- | +-- /Note:/ This is not part of the public API! It is exposed so that you can +-- tinker with the internals of HUnit, but do not expect it to be stable! + HUnitFailure (..), + FailureReason (..), + formatFailureReason +) where + +import Control.DeepSeq +import Control.Exception as E +import Control.Monad +import Data.List +import Data.Typeable +import Data.CallStack + +-- | When an assertion is evaluated, it will output a message if and only if the +-- assertion fails. +-- +-- Test cases are composed of a sequence of one or more assertions. +type Assertion = IO () + +data HUnitFailure = HUnitFailure (Maybe SrcLoc) FailureReason + deriving (Eq, Show, Typeable) + +instance Exception HUnitFailure + +data FailureReason = Reason String | ExpectedButGot (Maybe String) String String + deriving (Eq, Show, Typeable) + +location :: HasCallStack_ Maybe SrcLoc +location = case reverse callStack of + (_, loc) : _ -> Just loc + [] -> Nothing + +-- | Unconditionally signals that a failure has occurred. +assertFailure :: + HasCallStack_ + String -- ^ A message that is displayed with the assertion failure + -> IO a +assertFailure msg = msg `deepseq` E.throwIO (HUnitFailure location $ Reason msg) + +-- | Asserts that the specified actual value is equal to the expected value. +-- The output message will contain the prefix, the expected value, and the +-- actual value. +-- +-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted +-- and only the expected and actual values are output. +assertEqual :: HasCallStack_ (Eq a, Show a) + => String -- ^ The message prefix + -> a -- ^ The expected value + -> a -- ^ The actual value + -> Assertion +assertEqual preface expected actual = + unless (actual == expected) $ do + (prefaceMsg `deepseq` expectedMsg `deepseq` actualMsg `deepseq` E.throwIO (HUnitFailure location $ ExpectedButGot prefaceMsg expectedMsg actualMsg)) + where + prefaceMsg + | null preface = Nothing + | otherwise = Just preface + expectedMsg = show expected + actualMsg = show actual + +formatFailureReason :: FailureReason -> String +formatFailureReason (Reason reason) = reason +formatFailureReason (ExpectedButGot preface expected actual) = intercalate "\n" . maybe id (:) preface $ ["expected: " ++ expected, " but got: " ++ actual] + +data Result = Success | Failure (Maybe SrcLoc) String | Error (Maybe SrcLoc) String + deriving (Eq, Show) + +-- | Performs a single test case. +performTestCase :: Assertion -- ^ an assertion to be made during the test case run + -> IO Result +performTestCase action = + (action >> return Success) + `E.catches` + [E.Handler (\(HUnitFailure loc reason) -> return $ Failure loc (formatFailureReason reason)), + + -- Re-throw AsyncException, otherwise execution will not terminate on + -- SIGINT (ctrl-c). Currently, all AsyncExceptions are being thrown + -- because it's thought that none of them will be encountered during + -- normal HUnit operation. If you encounter an example where this + -- is not the case, please email the maintainer. + E.Handler (\e -> throw (e :: E.AsyncException)), + + E.Handler (\e -> return $ Error Nothing $ show (e :: E.SomeException))] diff --git a/vendor/HUnit-1.6.2.0/src/Test/HUnit/Terminal.hs b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Terminal.hs new file mode 100644 --- /dev/null +++ b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Terminal.hs @@ -0,0 +1,42 @@ +-- | This module handles the complexities of writing information to the +-- terminal, including modifying text in place. + +module Test.HUnit.Terminal ( + terminalAppearance + ) where + +import Data.Char (isPrint) + + +-- | Simplifies the input string by interpreting @\\r@ and @\\b@ characters +-- specially so that the result string has the same final (or /terminal/, +-- pun intended) appearance as would the input string when written to a +-- terminal that overwrites character positions following carriage +-- returns and backspaces. + +terminalAppearance :: String -> String +terminalAppearance str = ta id "" "" str + +-- | The helper function @ta@ takes an accumulating @ShowS@-style function +-- that holds /committed/ lines of text, a (reversed) list of characters +-- on the current line /before/ the cursor, a (normal) list of characters +-- on the current line /after/ the cursor, and the remaining input. + +ta + :: ([Char] -> t) -- ^ An accumulating @ShowS@-style function + -- that holds /committed/ lines of text + -> [Char] -- ^ A (reversed) list of characters + -- on the current line /before/ the cursor + -> [Char] -- ^ A (normal) list of characters + -- on the current line /after/ the cursor + -> [Char] -- ^ The remaining input + -> t +ta f bs as ('\n':cs) = ta (\t -> f (reverse bs ++ as ++ '\n' : t)) "" "" cs +ta f bs as ('\r':cs) = ta f "" (reverse bs ++ as) cs +ta f (b:bs) as ('\b':cs) = ta f bs (b:as) cs +ta _ "" _ ('\b': _) = error "'\\b' at beginning of line" +ta f bs as (c:cs) + | not (isPrint c) = error "invalid nonprinting character" + | null as = ta f (c:bs) "" cs + | otherwise = ta f (c:bs) (tail as) cs +ta f bs as "" = f (reverse bs ++ as) diff --git a/vendor/HUnit-1.6.2.0/src/Test/HUnit/Text.hs b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Text.hs new file mode 100644 --- /dev/null +++ b/vendor/HUnit-1.6.2.0/src/Test/HUnit/Text.hs @@ -0,0 +1,152 @@ +-- | Text-based test controller for running HUnit tests and reporting +-- results as text, usually to a terminal. + +module Test.HUnit.Text +( + PutText(..), + putTextToHandle, putTextToShowS, + runTestText, + showPath, showCounts, + runTestTT, + runTestTTAndExit +) +where + +import Test.HUnit.Base + +import Data.CallStack +import Control.Monad (when) +import System.IO (Handle, stderr, hPutStr, hPutStrLn) +import System.Exit (exitSuccess, exitFailure) + + +-- | As the general text-based test controller ('runTestText') executes a +-- test, it reports each test case start, error, and failure by +-- constructing a string and passing it to the function embodied in a +-- 'PutText'. A report string is known as a \"line\", although it includes +-- no line terminator; the function in a 'PutText' is responsible for +-- terminating lines appropriately. Besides the line, the function +-- receives a flag indicating the intended \"persistence\" of the line: +-- 'True' indicates that the line should be part of the final overall +-- report; 'False' indicates that the line merely indicates progress of +-- the test execution. Each progress line shows the current values of +-- the cumulative test execution counts; a final, persistent line shows +-- the final count values. +-- +-- The 'PutText' function is also passed, and returns, an arbitrary state +-- value (called 'st' here). The initial state value is given in the +-- 'PutText'; the final value is returned by 'runTestText'. + +data PutText st = PutText (String -> Bool -> st -> IO st) st + + +-- | Two reporting schemes are defined here. @putTextToHandle@ writes +-- report lines to a given handle. 'putTextToShowS' accumulates +-- persistent lines for return as a whole by 'runTestText'. +-- +-- @putTextToHandle@ writes persistent lines to the given handle, +-- following each by a newline character. In addition, if the given flag +-- is @True@, it writes progress lines to the handle as well. A progress +-- line is written with no line termination, so that it can be +-- overwritten by the next report line. As overwriting involves writing +-- carriage return and blank characters, its proper effect is usually +-- only obtained on terminal devices. + +putTextToHandle + :: Handle + -> Bool -- ^ Write progress lines to handle? + -> PutText Int +putTextToHandle handle showProgress = PutText put initCnt + where + initCnt = if showProgress then 0 else -1 + put line pers (-1) = do when pers (hPutStrLn handle line); return (-1) + put line True cnt = do hPutStrLn handle (erase cnt ++ line); return 0 + put line False _ = do hPutStr handle ('\r' : line); return (length line) + -- The "erasing" strategy with a single '\r' relies on the fact that the + -- lengths of successive summary lines are monotonically nondecreasing. + erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r" + + +-- | Accumulates persistent lines (dropping progess lines) for return by +-- 'runTestText'. The accumulated lines are represented by a +-- @'ShowS' ('String' -> 'String')@ function whose first argument is the +-- string to be appended to the accumulated report lines. + +putTextToShowS :: PutText ShowS +putTextToShowS = PutText put id + where put line pers f = return (if pers then acc f line else f) + acc f line rest = f (line ++ '\n' : rest) + + +-- | Executes a test, processing each report line according to the given +-- reporting scheme. The reporting scheme's state is threaded through calls +-- to the reporting scheme's function and finally returned, along with final +-- count values. + +runTestText :: PutText st -> Test -> IO (Counts, st) +runTestText (PutText put us0) t = do + (counts', us1) <- performTest reportStart reportError reportFailure us0 t + us2 <- put (showCounts counts') True us1 + return (counts', us2) + where + reportStart ss us = put (showCounts (counts ss)) False us + reportError = reportProblem "Error:" "Error in: " + reportFailure = reportProblem "Failure:" "Failure in: " + reportProblem p0 p1 loc msg ss us = put line True us + where line = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg + kind = if null path' then p0 else p1 + path' = showPath (path ss) + +formatLocation :: Maybe SrcLoc -> String +formatLocation Nothing = "" +formatLocation (Just loc) = srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ "\n" + +-- | Converts test execution counts to a string. + +showCounts :: Counts -> String +showCounts Counts{ cases = cases', tried = tried', + errors = errors', failures = failures' } = + "Cases: " ++ show cases' ++ " Tried: " ++ show tried' ++ + " Errors: " ++ show errors' ++ " Failures: " ++ show failures' + + +-- | Converts a test case path to a string, separating adjacent elements by +-- the colon (\':\'). An element of the path is quoted (as with 'show') when +-- there is potential ambiguity. + +showPath :: Path -> String +showPath [] = "" +showPath nodes = foldl1 f (map showNode nodes) + where f b a = a ++ ":" ++ b + showNode (ListItem n) = show n + showNode (Label label) = safe label (show label) + safe s ss = if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s + + +-- | Provides the \"standard\" text-based test controller. Reporting is made to +-- standard error, and progress reports are included. For possible +-- programmatic use, the final counts are returned. +-- +-- The \"TT\" in the name suggests \"Text-based reporting to the Terminal\". + +runTestTT :: Test -> IO Counts +runTestTT t = do (counts', 0) <- runTestText (putTextToHandle stderr True) t + return counts' + +-- | Convenience wrapper for 'runTestTT'. +-- Simply runs 'runTestTT' and then exits back to the OS, +-- using 'exitSuccess' if there were no errors or failures, +-- or 'exitFailure' if there were. For example: +-- +-- > tests :: Test +-- > tests = ... +-- > +-- > main :: IO () +-- > main = runTestTTAndExit tests + +runTestTTAndExit :: Test -> IO () +runTestTTAndExit tests = do + c <- runTestTT tests + if (errors c == 0) && (failures c == 0) + then exitSuccess + else exitFailure diff --git a/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations.hs b/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations.hs new file mode 100644 --- /dev/null +++ b/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ImplicitParams #-} +-- | +-- Introductory documentation: +module Test.Hspec.Expectations ( + +-- * Setting expectations + Expectation +, expectationFailure +, shouldBe +, shouldSatisfy +, shouldStartWith +, shouldEndWith +, shouldContain +, shouldMatchList +, shouldReturn + +, shouldNotBe +, shouldNotSatisfy +, shouldNotContain +, shouldNotReturn + +-- * Expecting exceptions +, shouldThrow + +-- ** Selecting exceptions +, Selector + +-- ** Predefined type-based selectors +-- | +-- There are predefined selectors for some standard exceptions. Each selector +-- is just @const True@ with an appropriate type. +, anyException +, anyErrorCall +, anyIOException +, anyArithException + +-- ** Combinators for defining value-based selectors +-- | +-- Some exceptions (most prominently `ErrorCall`) have no `Eq` instance. +-- Selecting a specific value would require pattern matching. +-- +-- For such exceptions, combinators that construct selectors are provided. +-- Each combinator corresponds to a constructor; it takes the same arguments, +-- and has the same name (but starting with a lower-case letter). +, errorCall + +-- * Re-exports +, HasCallStack +) where + +import qualified Test.HUnit +import Test.HUnit ((@?=)) +import Control.Exception +import Data.Typeable +import Data.List + +import Control.Monad (unless) + +import Test.Hspec.Expectations.Matcher + +import Data.CallStack (HasCallStack) + +type Expectation = Test.HUnit.Assertion + +expectationFailure :: HasCallStack => String -> Expectation +expectationFailure = Test.HUnit.assertFailure + +expectTrue :: HasCallStack => String -> Bool -> Expectation +expectTrue msg b = unless b (expectationFailure msg) + +infix 1 `shouldBe`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn`, `shouldThrow` +infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn` + +-- | +-- @actual \`shouldBe\` expected@ sets the expectation that @actual@ is equal +-- to @expected@. +shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation +actual `shouldBe` expected = actual @?= expected + +-- | +-- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@. +shouldSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation +v `shouldSatisfy` p = expectTrue ("predicate failed on: " ++ show v) (p v) + +compareWith :: (HasCallStack, Show a) => (a -> a -> Bool) -> String -> a -> a -> Expectation +compareWith comparator errorDesc result expected = expectTrue errorMsg (comparator expected result) + where + errorMsg = show result ++ " " ++ errorDesc ++ " " ++ show expected + +-- | +-- @list \`shouldStartWith\` prefix@ sets the expectation that @list@ starts with @prefix@, +shouldStartWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldStartWith = compareWith isPrefixOf "does not start with" + +-- | +-- @list \`shouldEndWith\` suffix@ sets the expectation that @list@ ends with @suffix@, +shouldEndWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldEndWith = compareWith isSuffixOf "does not end with" + +-- | +-- @list \`shouldContain\` sublist@ sets the expectation that @sublist@ is contained, +-- wholly and intact, anywhere in @list@. +shouldContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +shouldContain = compareWith isInfixOf "does not contain" + +-- | +-- @xs \`shouldMatchList\` ys@ sets the expectation that @xs@ has the same +-- elements that @ys@ has, possibly in another order +shouldMatchList :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +xs `shouldMatchList` ys = maybe (return ()) expectationFailure (matchList xs ys) + +-- | +-- @action \`shouldReturn\` expected@ sets the expectation that @action@ +-- returns @expected@. +shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +action `shouldReturn` expected = action >>= (`shouldBe` expected) + +-- | +-- @actual \`shouldNotBe\` notExpected@ sets the expectation that @actual@ is not +-- equal to @notExpected@ +shouldNotBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation +actual `shouldNotBe` notExpected = expectTrue ("not expected: " ++ show actual) (actual /= notExpected) + +-- | +-- @v \`shouldNotSatisfy\` p@ sets the expectation that @p v@ is @False@. +shouldNotSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation +v `shouldNotSatisfy` p = expectTrue ("predicate succeeded on: " ++ show v) ((not . p) v) + +-- | +-- @list \`shouldNotContain\` sublist@ sets the expectation that @sublist@ is not +-- contained anywhere in @list@. +shouldNotContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation +list `shouldNotContain` sublist = expectTrue errorMsg ((not . isInfixOf sublist) list) + where + errorMsg = show list ++ " does contain " ++ show sublist + +-- | +-- @action \`shouldNotReturn\` notExpected@ sets the expectation that @action@ +-- does not return @notExpected@. +shouldNotReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation +action `shouldNotReturn` notExpected = action >>= (`shouldNotBe` notExpected) + +-- | +-- A @Selector@ is a predicate; it can simultaneously constrain the type and +-- value of an exception. +type Selector a = (a -> Bool) + +-- | +-- @action \`shouldThrow\` selector@ sets the expectation that @action@ throws +-- an exception. The precise nature of the expected exception is described +-- with a 'Selector'. +shouldThrow :: (HasCallStack, Exception e) => IO a -> Selector e -> Expectation +action `shouldThrow` p = do + r <- try action + case r of + Right _ -> + expectationFailure $ + "did not get expected exception: " ++ exceptionType + Left e -> + (`expectTrue` p e) $ + "predicate failed on expected exception: " ++ exceptionType ++ " (" ++ show e ++ ")" + where + -- a string repsentation of the expected exception's type + exceptionType = (show . typeOf . instanceOf) p + where + instanceOf :: Selector a -> a + instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance" + +anyException :: Selector SomeException +anyException = const True + +anyErrorCall :: Selector ErrorCall +anyErrorCall = const True + +errorCall :: String -> Selector ErrorCall +#if MIN_VERSION_base(4,9,0) +errorCall s (ErrorCallWithLocation msg _) = s == msg +#else +errorCall s (ErrorCall msg) = s == msg +#endif + +anyIOException :: Selector IOException +anyIOException = const True + +anyArithException :: Selector ArithException +anyArithException = const True diff --git a/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Contrib.hs b/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Contrib.hs new file mode 100644 --- /dev/null +++ b/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Contrib.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} +-- | +-- Experimental combinators, that may become part of the main distribution, if +-- they turn out to be useful for a wider audience. +module Test.Hspec.Expectations.Contrib ( +-- * Predicates +-- | (useful in combination with `shouldSatisfy`) + isLeft +, isRight +) where + + +#if MIN_VERSION_base(4,7,0) +import Data.Either +#else + +isLeft :: Either a b -> Bool +{-# DEPRECATED isLeft "use Data.Either.Compat.isLeft from package base-compat instead" #-} +isLeft (Left _) = True +isLeft (Right _) = False + +isRight :: Either a b -> Bool +{-# DEPRECATED isRight "use Data.Either.Compat.isRight from package base-compat instead" #-} +isRight (Left _) = False +isRight (Right _) = True +#endif diff --git a/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Matcher.hs b/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Matcher.hs new file mode 100644 --- /dev/null +++ b/vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Matcher.hs @@ -0,0 +1,26 @@ +module Test.Hspec.Expectations.Matcher (matchList) where + +import Prelude hiding (showList) +import Data.List + +matchList :: (Show a, Eq a) => [a] -> [a] -> Maybe String +xs `matchList` ys + | null extra && null missing = Nothing + | otherwise = Just (err "") + where + extra = xs \\ ys + missing = ys \\ xs + + msgAndList msg zs = showString msg . showList zs . showString "\n" + optMsgList msg zs = if null zs then id else msgAndList msg zs + + err :: ShowS + err = + showString "Actual list is not a permutation of expected list!\n" + . msgAndList " expected list contains: " ys + . msgAndList " actual list contains: " xs + . optMsgList " the missing elements are: " missing + . optMsgList " the extra elements are: " extra + +showList :: Show a => [a] -> ShowS +showList xs = showChar '[' . foldr (.) (showChar ']') (intersperse (showString ", ") $ map shows xs) diff --git a/version.yaml b/version.yaml new file mode 100644 --- /dev/null +++ b/version.yaml @@ -0,0 +1,1 @@ +&version 2.7.8