diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,28 @@ +## Version 1.0 (2019-05-13) +- Add histograms to labels / coverage ([#289][289], [@jacobstanley][jacobstanley]) +- Improved shrinking of lists ([#276][276], [@jacobstanley][jacobstanley] / [@edsko][edsko]) +- Simplify `MonadGen`, this breaks the use of `StateT` on the outside of a `GenT` for the time being, it still works fine on the inside though and you can use `distributeT` to run it ([#276][276], [@jacobstanley][jacobstanley]) +- Change `Applicative` `GenT` to use zipping ([#272][272], [@jacobstanley][jacobstanley] / [@edsko][edsko]) +- Rename `Tree` -> `TreeT`, `Node` -> `NodeT` ([#272][272], [@jacobstanley][jacobstanley]) +- `diff` function which takes any `a -> a -> Bool` comparison function ([#196][196], [@chessai][chessai] / [@jacobstanley][jacobstanley]) +- Labelling of test runs via `label`, `collect` ([#262][262], [@ruhatch][ruhatch] / [@jacobstanley][jacobstanley]) +- Classification of test runs via `cover`, `classify` ([#253][253], [@felixmulder][felixmulder] / [@jacobstanley][jacobstanley]) +- Define proper `Applicative` instances for `NodeT`, `TreeT` and `GenT` ([#173][173][@sjakobi][sjakobi] +- `MonadFail` instance for `PropertyT` ([#267][267], [@geigerzaehler][geigerzaehler]) +- `MonadResource` instance for `PropertyT` ([#268][268], [@geigerzaehler][geigerzaehler]) +- Example for the `tripping` function ([#258][258], [@HuwCampbell][HuwCampbell]) +- Improve documentation for state machine testing ([#252][252], [@endgame][endgame]) +- `runTests` function for running tests from a top level executable, this was later renamed to `defaultMain` as is the de facto convention ([#168][168], [@erikd][erikd]) +- Show output variables when parallel state machine testing fails to linearise ([#235][235], [@HuwCampbell][HuwCampbell]) +- Note about `enumBounded` danger ([#202][202], [@thumphries][thumphries]) +- Expose `discoverPrefix` to find prefixed properties ([#229][229], [@ruhatch][ruhatch]) +- Remove use of `unix` package and replace with `lookupEnv` ([#226][226], [@puffnfresh][puffnfresh]) + ## Version 0.6.1 (2018-09-22) -- Set stdout/stderr encoding to UTF-8 on Windows ([#218][218], [@moodmosaic][moodmosaic]) +- Fix UTF-8 related rendering bugs on Windows ([#218][218], [@moodmosaic][moodmosaic]) +- Verify that our SplitMix/Seed avoids pathological γ-values ([#207][207], [@moodmosaic][moodmosaic]) +- Avoid weak gamma values in Hedgehog.Internal.Seed ([#198][198], [@moodmosaic][moodmosaic]) ## Version 0.6 (2018-05-14) @@ -28,29 +50,29 @@ ## Version 0.5 (2017-07-16) -- Parallel state machine testing, allows detection of commands which are not-atomic ([#98][98], [@jystic][jystic]) -- Easier to use variables for state machine testing ([#94][94], [@jystic][jystic]) -- `MonadGen` class allows the use of transformers like `ReaderT` and `StateT` on the outside of generators ([#99][99], [@jystic][jystic]) -- Better error messages for tests which throw exceptions ([#95][95], [@jystic][jystic]) -- Separated test input generation and assertions in to `PropertyT` and `TestT` respectively, this allows `TestT` to have a `MonadBaseControl` instance ([#96][96], [@jystic][jystic]) +- Parallel state machine testing, allows detection of commands which are not-atomic ([#98][98], [@jacobstanley][jacobstanley]) +- Easier to use variables for state machine testing ([#94][94], [@jacobstanley][jacobstanley]) +- `MonadGen` class allows the use of transformers like `ReaderT` and `StateT` on the outside of generators ([#99][99], [@jacobstanley][jacobstanley]) +- Better error messages for tests which throw exceptions ([#95][95], [@jacobstanley][jacobstanley]) +- Separated test input generation and assertions in to `PropertyT` and `TestT` respectively, this allows `TestT` to have a `MonadBaseControl` instance ([#96][96], [@jacobstanley][jacobstanley]) - This document grew links to the pull requests which introduced various changes ([#93][93], [@moodmosaic][moodmosaic]) ## Version 0.4.1 (2017-06-28) -- Fixed runtime type error that could occur when shrinking state machine commands ([#91][91], [@jystic][jystic]) +- Fixed runtime type error that could occur when shrinking state machine commands ([#91][91], [@jacobstanley][jacobstanley]) ## Version 0.4 (2017-06-28) -- Abstract state machine testing, check out Tim Humphries' great [blog post](http://teh.id.au/posts/2017/07/15/state-machine-testing) or the [process registry example](https://github.com/hedgehogqa/haskell-hedgehog/blob/master/hedgehog-example/test/Test/Example/Registry.hs) to see how it works ([#89][89], [@jystic][jystic]) -- `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests ([#89][89], [@jystic][jystic]) +- Abstract state machine testing, check out Tim Humphries' great [blog post](http://teh.id.au/posts/2017/07/15/state-machine-testing) or the [process registry example](https://github.com/hedgehogqa/haskell-hedgehog/blob/master/hedgehog-example/test/Test/Example/Registry.hs) to see how it works ([#89][89], [@jacobstanley][jacobstanley]) +- `liftCatch`, `liftCatchIO`, `withCatch` functions for isolating exceptions during tests ([#89][89], [@jacobstanley][jacobstanley]) ## Version 0.3 (2017-06-11) - Exponential range combinators ([#43][43], [@chris-martin][chris-martin]) - Roundtrip example, check out the [blog post](http://teh.id.au/posts/2017/06/07/round-trip-property/) ([#85][85], [@thumphries][thumphries]) -- `tripping` now displays intermediate value ([#85][85], [@jystic][jystic]) -- `distribute` function for pulling a transformer out to the top level ([#83][83], [@jystic][jystic]) -- `withExceptT` function for executing tests with an inner `ExceptT` (e.g. `Test (ExceptT x m) a`) ([#83][83], [@jystic][jystic]) +- `tripping` now displays intermediate value ([#85][85], [@jacobstanley][jacobstanley]) +- `distribute` function for pulling a transformer out to the top level ([#83][83], [@jacobstanley][jacobstanley]) +- `withExceptT` function for executing tests with an inner `ExceptT` (e.g. `Test (ExceptT x m) a`) ([#83][83], [@jacobstanley][jacobstanley]) ## Version 0.2.2 (2017-05-16) @@ -61,24 +83,24 @@ ## Version 0.2.1 (2017-05-09) -- Added `ascii`, `latin1`, `unicode` character generators ([#73][73], [@jystic][jystic]) +- Added `ascii`, `latin1`, `unicode` character generators ([#73][73], [@jacobstanley][jacobstanley]) ## Version 0.2 (2017-05-06) -- Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0` ([@jystic][jystic]) -- Concurrent test runner does not display tests until they are executing ([@jystic][jystic]) -- Test runner now outputs a summary of how many successful / failed tests were run ([@jystic][jystic]) -- `checkSequential` and `checkParallel` now allow for tests to be run without Template Haskell ([@jystic][jystic]) -- Auto-discovery of properties is now available via `discover` instead of being baked in ([@jystic][jystic]) -- `annotate` allows source code to be annotated inline with extra information ([@jystic][jystic]) -- `forAllWith` can be used to generate values without a `Show` instance ([@jystic][jystic]) -- Removed uses of `Typeable` to allow for generating types which cannot implement it ([@jystic][jystic]) +- Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0` ([@jacobstanley][jacobstanley]) +- Concurrent test runner does not display tests until they are executing ([@jacobstanley][jacobstanley]) +- Test runner now outputs a summary of how many successful / failed tests were run ([@jacobstanley][jacobstanley]) +- `checkSequential` and `checkParallel` now allow for tests to be run without Template Haskell ([@jacobstanley][jacobstanley]) +- Auto-discovery of properties is now available via `discover` instead of being baked in ([@jacobstanley][jacobstanley]) +- `annotate` allows source code to be annotated inline with extra information ([@jacobstanley][jacobstanley]) +- `forAllWith` can be used to generate values without a `Show` instance ([@jacobstanley][jacobstanley]) +- Removed uses of `Typeable` to allow for generating types which cannot implement it ([@jacobstanley][jacobstanley]) [Dieharder]: https://webhome.phy.duke.edu/~rgb/General/dieharder.php -[jystic]: - https://github.com/jystic +[jacobstanley]: + https://github.com/jacobstanley [chris-martin]: https://github.com/chris-martin [thumphries]: @@ -105,11 +127,59 @@ https://github.com/dredozubov [fisx]: https://github.com/fisx +[puffnfresh]: + https://github.com/puffnfresh +[ruhatch]: + https://github.com/ruhatch +[HuwCampbell]: + https://github.com/HuwCampbell +[endgame]: + https://github.com/endgame +[geigerzaehler]: + https://github.com/geigerzaehler +[sjakobi]: + https://github.com/sjakobi +[felixmulder]: + https://github.com/felixmulder +[edsko]: + https://github.com/edsko +[289]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/289 +[276]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/276 +[272]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/272 +[268]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/268 +[262]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/262 +[258]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/258 +[253]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/253 +[252]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/252 +[235]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/235 +[229]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/229 +[226]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/226 +[218]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/218 +[207]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/207 +[202]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/202 +[198]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/198 [185]: https://github.com/hedgehogqa/haskell-hedgehog/pull/185 [184]: https://github.com/hedgehogqa/haskell-hedgehog/pull/184 +[168]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/168 [162]: https://github.com/hedgehogqa/haskell-hedgehog/pull/162 [157]: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,14 +1,24 @@ -hedgehog [![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] -======== + -> Hedgehog will eat all your bugs. +
- + -[Hedgehog](http://hedgehog.qa/) is a modern property-based testing -system, in the spirit of QuickCheck. Hedgehog uses integrated shrinking, -so shrinks obey the invariants of generated values by construction. +# Release with confidence. +[![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] [![AppVeyor][appveyor-shield]][appveyor] + +
+ +[Hedgehog](http://hedgehog.qa/) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine. + +Generate hundreds of test cases automatically, exposing even the most insidious of corner cases. Failures are automatically simplified, giving developers coherent, intelligible error messages. + ## Features - Integrated shrinking, shrinks obey invariants by construction. @@ -28,6 +38,7 @@ qualified. You also need to enable Template Haskell so the Hedgehog test runner can find your properties. + ```hs {-# LANGUAGE TemplateHaskell #-} @@ -76,11 +87,18 @@ ``` +
+
+ + [hackage]: http://hackage.haskell.org/package/hedgehog - [hackage-shield]: https://img.shields.io/badge/hackage-v0.5-blue.svg + [hackage-shield]: https://img.shields.io/badge/hackage-v1.0-blue.svg [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master + + [appveyor]: https://ci.appveyor.com/project/hedgehogqa/haskell-hedgehog + [appveyor-shield]: https://ci.appveyor.com/api/projects/status/o4rlstbc80sum3on/branch/master?svg=true [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html diff --git a/hedgehog.cabal b/hedgehog.cabal --- a/hedgehog.cabal +++ b/hedgehog.cabal @@ -1,4 +1,4 @@ -version: 0.6.1 +version: 1.0 name: hedgehog @@ -11,14 +11,17 @@ bug-reports: https://github.com/hedgehogqa/haskell-hedgehog/issues synopsis: - Hedgehog will eat all your bugs. + Release with confidence. description: - Hedgehog is a modern property-based testing system, in the spirit of - QuickCheck. Hedgehog uses integrated shrinking, so shrinks obey the - invariants of generated values by construction. + automatically generates a comprehensive array + of test cases, exercising your software in ways human testers would never + imagine. . - To get started quickly, see the examples: - + Generate hundreds of test cases automatically, exposing even the + most insidious of corner cases. Failures are automatically simplified, giving + developers coherent, intelligible error messages. + . + To get started quickly, see the . category: Testing license: @@ -30,15 +33,10 @@ build-type: Simple tested-with: - GHC == 7.10.2 - , GHC == 7.10.3 - , GHC == 8.0.1 - , GHC == 8.0.2 - , GHC == 8.2.1 + GHC == 8.0.2 , GHC == 8.2.2 - , GHC == 8.4.1 - , GHC == 8.4.2 - , GHC == 8.4.3 + , GHC == 8.4.4 + , GHC == 8.6.4 extra-source-files: README.md CHANGELOG.md @@ -49,45 +47,46 @@ library build-depends: - base >= 3 && < 5 - , ansi-terminal >= 0.6 && < 0.9 + -- GHC 8.0.1 / base-4.9.0.0 (May 2016) + base >= 4.9 && < 5 + , ansi-terminal >= 0.6 && < 0.10 , async >= 2.0 && < 2.3 , bytestring >= 0.10 && < 0.11 , concurrent-output >= 1.7 && < 1.11 , containers >= 0.4 && < 0.7 , directory >= 1.2 && < 1.4 , exceptions >= 0.7 && < 0.11 + , fail >= 4.9 && < 5 , lifted-async >= 0.7 && < 0.11 , mmorph >= 1.0 && < 1.2 , monad-control >= 1.0 && < 1.1 , mtl >= 2.1 && < 2.3 - , pretty-show >= 1.6 && < 1.8 + , pretty-show >= 1.6 && < 1.10 , primitive >= 0.6 && < 0.7 , random >= 1.1 && < 1.2 , resourcet >= 1.1 && < 1.3 , semigroups >= 0.16 && < 0.19 - , stm >= 2.4 && < 2.5 - , template-haskell >= 2.10 && < 2.14 + , stm >= 2.4 && < 2.6 + , template-haskell >= 2.10 && < 2.15 , text >= 1.1 && < 1.3 - , th-lift >= 0.7 && < 0.8 , time >= 1.4 && < 1.10 - , transformers >= 0.4 && < 0.6 - , transformers-base >= 0.4 && < 0.5 + , transformers >= 0.5 && < 0.6 + , transformers-base >= 0.4.5.1 && < 0.5 , wl-pprint-annotated >= 0.0 && < 0.2 - if !os(windows) - build-depends: - unix >= 2.6 && < 2.8 - ghc-options: -Wall + if impl(ghc >= 8.0) + ghc-options: -Wnoncanonical-monad-instances + hs-source-dirs: src exposed-modules: Hedgehog Hedgehog.Gen + Hedgehog.Main Hedgehog.Range Hedgehog.Internal.Config @@ -126,14 +125,19 @@ test other-modules: + Test.Hedgehog.Applicative + Test.Hedgehog.Filter Test.Hedgehog.Seed Test.Hedgehog.Text + Test.Hedgehog.Zip build-depends: hedgehog , base >= 3 && < 5 , containers >= 0.4 && < 0.7 - , pretty-show >= 1.6 && < 1.8 + , mmorph >= 1.0 && < 1.2 + , mtl >= 2.1 && < 2.3 + , pretty-show >= 1.6 && < 1.10 , semigroups >= 0.16 && < 0.19 , text >= 1.1 && < 1.3 , transformers >= 0.3 && < 0.6 diff --git a/src/Hedgehog.hs b/src/Hedgehog.hs --- a/src/Hedgehog.hs +++ b/src/Hedgehog.hs @@ -62,6 +62,7 @@ , recheck , discover + , discoverPrefix , checkParallel , checkSequential @@ -97,6 +98,7 @@ , success , failure , assert + , diff , (===) , (/==) , tripping @@ -107,6 +109,12 @@ , evalEither , evalExceptT + -- * Coverage + , classify + , cover + , label + , collect + -- * State Machine Tests , Command(..) , Callback(..) @@ -125,7 +133,7 @@ , Opaque(..) -- * Transformers - , distribute + , distributeT -- * Functors , HTraversable(..) @@ -142,12 +150,13 @@ import Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1) -import Hedgehog.Internal.Distributive (Distributive(..)) +import Hedgehog.Internal.Distributive (distributeT) import Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..)) import Hedgehog.Internal.HTraversable (HTraversable(..)) import Hedgehog.Internal.Opaque (Opaque(..)) import Hedgehog.Internal.Property (annotate, annotateShow) -import Hedgehog.Internal.Property (assert, (===), (/==)) +import Hedgehog.Internal.Property (assert, diff, (===), (/==)) +import Hedgehog.Internal.Property (classify, cover) import Hedgehog.Internal.Property (discard, failure, success) import Hedgehog.Internal.Property (DiscardLimit, withDiscards) import Hedgehog.Internal.Property (eval, evalM, evalIO) @@ -161,12 +170,14 @@ import Hedgehog.Internal.Property (ShrinkRetries, withRetries) import Hedgehog.Internal.Property (Test, TestT, property, test) import Hedgehog.Internal.Property (TestLimit, withTests) +import Hedgehog.Internal.Property (collect, label) import Hedgehog.Internal.Range (Range, Size(..)) import Hedgehog.Internal.Runner (check, recheck, checkSequential, checkParallel) + import Hedgehog.Internal.Seed (Seed(..)) import Hedgehog.Internal.State (Command(..), Callback(..)) import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) import Hedgehog.Internal.State (executeSequential, executeParallel) import Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque) -import Hedgehog.Internal.TH (discover) +import Hedgehog.Internal.TH (discover, discoverPrefix) import Hedgehog.Internal.Tripping (tripping) diff --git a/src/Hedgehog/Gen.hs b/src/Hedgehog/Gen.hs --- a/src/Hedgehog/Gen.hs +++ b/src/Hedgehog/Gen.hs @@ -1,9 +1,6 @@ module Hedgehog.Gen ( - -- * Combinators - lift - -- ** Shrinking - , shrink + shrink , prune -- ** Size diff --git a/src/Hedgehog/Internal/Config.hs b/src/Hedgehog/Internal/Config.hs --- a/src/Hedgehog/Internal/Config.hs +++ b/src/Hedgehog/Internal/Config.hs @@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -25,16 +25,12 @@ import qualified GHC.Conc as Conc -import Language.Haskell.TH.Lift (deriveLift) +import Language.Haskell.TH.Syntax (Lift) import System.Console.ANSI (hSupportsANSI) import System.Environment (lookupEnv) import System.IO (stdout) -#if !mingw32_HOST_OS -import System.Posix.User (getEffectiveUserName) -#endif - import Text.Read (readMaybe) @@ -45,7 +41,7 @@ -- ^ Disable ANSI colors in report output. | EnableColor -- ^ Enable ANSI colors in report output. - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Lift) -- | How verbose should the report output be. -- @@ -54,22 +50,18 @@ -- ^ Only display the summary of the test run. | Normal -- ^ Display each property as it is running, as well as the summary. - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Lift) -- | The number of workers to use when running properties in parallel. -- newtype WorkerCount = WorkerCount Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) detectMark :: MonadIO m => m Bool detectMark = do -#if mingw32_HOST_OS - pure False -#else - user <- liftIO getEffectiveUserName - pure $ user == "mth" -#endif + user <- liftIO $ lookupEnv "USER" + pure $ user == Just "mth" lookupBool :: MonadIO m => String -> m (Maybe Bool) lookupBool key = @@ -163,10 +155,3 @@ detectWorkers Just x -> pure x - ------------------------------------------------------------------------- --- FIXME Replace with DeriveLift when we drop 7.10 support. - -$(deriveLift ''UseColor) -$(deriveLift ''Verbosity) -$(deriveLift ''WorkerCount) diff --git a/src/Hedgehog/Internal/Discovery.hs b/src/Hedgehog/Internal/Discovery.hs --- a/src/Hedgehog/Internal/Discovery.hs +++ b/src/Hedgehog/Internal/Discovery.hs @@ -33,9 +33,9 @@ propertySource :: Pos String } deriving (Eq, Ord, Show) -readProperties :: MonadIO m => FilePath -> m (Map PropertyName PropertySource) -readProperties path = - findProperties path <$> liftIO (readFile path) +readProperties :: MonadIO m => String -> FilePath -> m (Map PropertyName PropertySource) +readProperties prefix path = + findProperties prefix path <$> liftIO (readFile path) readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String)) readDeclaration path line = do @@ -59,11 +59,11 @@ x : _ -> Just x -findProperties :: FilePath -> String -> Map PropertyName PropertySource -findProperties path = +findProperties :: String -> FilePath -> String -> Map PropertyName PropertySource +findProperties prefix path = Map.map PropertySource . Map.mapKeysMonotonic PropertyName . - Map.filterWithKey (\k _ -> isProperty k) . + Map.filterWithKey (\k _ -> List.isPrefixOf prefix k) . findDeclarations path findDeclarations :: FilePath -> String -> Map String (Pos String) @@ -71,10 +71,6 @@ declarations . classified . positioned path - -isProperty :: String -> Bool -isProperty = - List.isPrefixOf "prop_" ------------------------------------------------------------------------ -- Declaration Identification diff --git a/src/Hedgehog/Internal/Distributive.hs b/src/Hedgehog/Internal/Distributive.hs --- a/src/Hedgehog/Internal/Distributive.hs +++ b/src/Hedgehog/Internal/Distributive.hs @@ -1,54 +1,284 @@ {-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} module Hedgehog.Internal.Distributive ( - Distributive(..) + MonadTransDistributive(..) + , MonadTransJuggle(..) ) where import Control.Monad (join) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Control (MonadTransControl(..)) +import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) +import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..)) +import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) import Control.Monad.Trans.Reader (ReaderT(..)) -import Control.Monad.Trans.Writer (WriterT(..)) +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict +import Data.Proxy (Proxy(..)) +import Data.Bifunctor (Bifunctor(..)) + import GHC.Exts (Constraint) +-- NOTE: Replace use of Proxy with TypeApplications when we drop 7.10 support. -class Distributive g where +------------------------------------------------------------------------ +-- * MonadTransDistributive + +class MonadTransDistributive g where type Transformer (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) (m :: * -> *) :: Constraint type Transformer f g m = ( - Monad m - , Monad (f m) - , Monad (g m) - , Monad (f (g m)) - , MonadTrans f - , MFunctor f - ) + Monad m + , Monad (f m) + , Monad (g m) + , Monad (f (g m)) + , MonadTrans f + , MFunctor f + ) -- | Distribute one monad transformer over another. -- - distribute :: Transformer f g m => g (f m) a -> f (g m) a + distributeT :: Transformer f g m => g (f m) a -> f (g m) a -instance Distributive MaybeT where - distribute x = - lift . MaybeT . pure =<< hoist lift (runMaybeT x) +instance MonadTransDistributive IdentityT where + distributeT m = + lift . IdentityT . pure =<< hoist lift (runIdentityT m) -instance Distributive (ExceptT x) where - distribute x = - lift . ExceptT . pure =<< hoist lift (runExceptT x) +instance MonadTransDistributive MaybeT where + distributeT m = + lift . MaybeT . pure =<< hoist lift (runMaybeT m) -instance Monoid w => Distributive (WriterT w) where - distribute x = - lift . WriterT . pure =<< hoist lift (runWriterT x) +instance MonadTransDistributive (ExceptT x) where + distributeT m = + lift . ExceptT . pure =<< hoist lift (runExceptT m) -instance Distributive (ReaderT r) where - distribute x = +instance MonadTransDistributive (ReaderT r) where + distributeT m = join . lift . ReaderT $ \r -> - pure . hoist lift $ runReaderT x r + pure . hoist lift $ runReaderT m r + +instance Monoid w => MonadTransDistributive (Lazy.WriterT w) where + distributeT m = + lift . Lazy.WriterT . pure =<< hoist lift (Lazy.runWriterT m) + +instance Monoid w => MonadTransDistributive (Strict.WriterT w) where + distributeT m = do + lift . Strict.WriterT . pure =<< hoist lift (Strict.runWriterT m) + +instance MonadTransDistributive (Lazy.StateT s) where + type Transformer f (Lazy.StateT s) m = ( + Monad m + , Monad (f m) + , Monad (Lazy.StateT s m) + , Monad (f (Lazy.StateT s m)) + , MonadTrans f + , MonadTransControl f + , MonadTransJuggle f + , MFunctor f + ) + + distributeT :: forall f m a. + Transformer f (Lazy.StateT s) m + => Lazy.StateT s (f m) a + -> f (Lazy.StateT s m) a + distributeT m = + join $ liftWith $ \run -> + let + restoreStateT :: s -> StT f (a, s) -> (f (Lazy.StateT s m) a, s) + restoreStateT s = do + first (restoreT . pure) . juggleState @f @a Proxy Proxy s + in + Lazy.StateT $ \s -> do + fmap (restoreStateT s) . run $ Lazy.runStateT m s + +instance MonadTransDistributive (Strict.StateT s) where + type Transformer f (Strict.StateT s) m = ( + Monad m + , Monad (f m) + , Monad (Strict.StateT s m) + , Monad (f (Strict.StateT s m)) + , MonadTrans f + , MonadTransControl f + , MonadTransJuggle f + , MFunctor f + ) + + distributeT :: forall f m a. + Transformer f (Strict.StateT s) m + => Strict.StateT s (f m) a + -> f (Strict.StateT s m) a + distributeT m = + join $ liftWith $ \run -> + let + restoreStateT :: s -> StT f (a, s) -> (f (Strict.StateT s m) a, s) + restoreStateT s = do + first (restoreT . pure) . juggleState @f @a Proxy Proxy s + in + Strict.StateT $ \s -> do + fmap (restoreStateT s) . run $ Strict.runStateT m s + +instance Monoid w => MonadTransDistributive (Lazy.RWST r w s) where + type Transformer f (Lazy.RWST r w s) m = ( + Monad m + , Monad (f m) + , Monad (Lazy.RWST r w s m) + , Monad (f (Lazy.RWST r w s m)) + , MonadTrans f + , MonadTransControl f + , MonadTransJuggle f + , MFunctor f + ) + + distributeT :: forall f m a. + Transformer f (Lazy.RWST r w s) m + => Lazy.RWST r w s (f m) a + -> f (Lazy.RWST r w s m) a + distributeT m = + join $ liftWith $ \run -> + let + restoreRWST :: s -> StT f (a, s, w) -> (f (Lazy.RWST r w s m) a, s, w) + restoreRWST s = do + first3 (restoreT . pure) . juggleRWS @f @w @a Proxy Proxy Proxy s + in + Lazy.RWST $ \r s -> do + fmap (restoreRWST s) . run $ Lazy.runRWST m r s + +instance Monoid w => MonadTransDistributive (Strict.RWST r w s) where + type Transformer f (Strict.RWST r w s) m = ( + Monad m + , Monad (f m) + , Monad (Strict.RWST r w s m) + , Monad (f (Strict.RWST r w s m)) + , MonadTrans f + , MonadTransControl f + , MonadTransJuggle f + , MFunctor f + ) + + distributeT :: forall f m a. + Transformer f (Strict.RWST r w s) m + => Strict.RWST r w s (f m) a + -> f (Strict.RWST r w s m) a + distributeT m = + join $ liftWith $ \run -> + let + restoreRWST :: s -> StT f (a, s, w) -> (f (Strict.RWST r w s m) a, s, w) + restoreRWST s = do + first3 (restoreT . pure) . juggleRWS @f @w @a Proxy Proxy Proxy s + in + Strict.RWST $ \r s -> do + fmap (restoreRWST s) . run $ Strict.runRWST m r s + +------------------------------------------------------------------------ +-- * MonadTransJuggle + +first3 :: (a -> b) -> (a, s, w) -> (b, s, w) +first3 f (a, s, w) = + (f a, s, w) + +unpack3 :: (a, s, w) -> (a, (s, w)) +unpack3 (a, s, w) = + (a, (s, w)) + +juggleRWS :: forall t w a s. + (MonadTransJuggle t, Monoid w) + => Proxy t + -> Proxy w + -> Proxy a + -> s + -> StT t (a, s, w) + -> (StT t a, s, w) +juggleRWS _ _ _ s0 st0 = + let + (st, (s, w)) = + juggleState @t @a Proxy Proxy (s0, mempty) $ + mapStT @t @(a, s, w) Proxy Proxy unpack3 st0 + in + (st, s, w) + +class MonadTransControl t => MonadTransJuggle (t :: (* -> *) -> * -> *) where + mapStT :: Proxy t -> Proxy a -> (a -> b) -> StT t a -> StT t b + juggleState :: Proxy t -> Proxy a -> s -> StT t (a, s) -> (StT t a, s) + +instance MonadTransJuggle MaybeT where + mapStT _ _ = + fmap + + juggleState _ _ s0 = \case + Nothing -> + (Nothing, s0) + Just (x, s) -> + (Just x, s) + +instance MonadTransJuggle (ExceptT x) where + mapStT _ _ = + fmap + + juggleState _ _ s0 = \case + Left x -> + (Left x, s0) + Right (x, s) -> + (Right x, s) + +instance MonadTransJuggle (ReaderT r) where + mapStT _ _ = + id + + juggleState _ _ _ (x, s) = + (x, s) + +instance Monoid w => MonadTransJuggle (Lazy.WriterT w) where + mapStT _ _ = + first + + juggleState _ _ _ ((x, s), w) = + ((x, w), s) + +instance Monoid w => MonadTransJuggle (Strict.WriterT w) where + mapStT _ _ = + first + + juggleState _ _ _ ((x, s), w) = + ((x, w), s) + +instance MonadTransJuggle (Lazy.StateT s) where + mapStT _ _ = + first + + juggleState _ _ _ ((x, s0), s1) = + ((x, s1), s0) + +instance MonadTransJuggle (Strict.StateT s) where + mapStT _ _ = + first + + juggleState _ _ _ ((x, s0), s1) = + ((x, s1), s0) + +instance Monoid w => MonadTransJuggle (Lazy.RWST r w s) where + mapStT _ _ = + first3 + + juggleState _ _ _ ((x, s0), s1, w) = + ((x, s1, w), s0) + +instance Monoid w => MonadTransJuggle (Strict.RWST r w s) where + mapStT _ _ = + first3 + + juggleState _ _ _ ((x, s0), s1, w) = + ((x, s1, w), s0) diff --git a/src/Hedgehog/Internal/Gen.hs b/src/Hedgehog/Internal/Gen.hs --- a/src/Hedgehog/Internal/Gen.hs +++ b/src/Hedgehog/Internal/Gen.hs @@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -23,7 +24,7 @@ , MonadGen(..) -- * Combinators - , lift + , generalize -- ** Shrinking , shrink @@ -94,7 +95,9 @@ , discard , ensure , filter + , filterT , just + , justT -- ** Collections , maybe @@ -123,16 +126,24 @@ , printTree , printWith , printTreeWith + , renderTree -- * Internal -- $internal -- ** Transfomer , runGenT + , evalGen + , evalGenT , mapGenT , generate - , liftTree + , toTree + , toTreeMaybeT + , fromTree + , fromTreeT + , fromTreeMaybeT , runDiscardEffect + , runDiscardEffectT -- ** Size , golden @@ -148,37 +159,33 @@ , Vec(..) , Nat(..) , subtermMVec - - -- ** Sampling - , renderNodes ) where import Control.Applicative (Alternative(..),liftA2) -import Control.Monad (MonadPlus(..), filterM, replicateM, ap, join) +import Control.Monad (MonadPlus(..), filterM, replicateM, join) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Fail (MonadFail (..)) +import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Morph (MFunctor(..), MMonad(..), generalize) +import Control.Monad.Morph (MFunctor(..), MMonad(..)) +import qualified Control.Monad.Morph as Morph import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans) -import qualified Control.Monad.Trans.Class as Trans -import Control.Monad.Trans.Except (ExceptT(..), mapExceptT) -import Control.Monad.Trans.Identity (IdentityT(..), mapIdentityT) -import Control.Monad.Trans.Maybe (MaybeT(..), mapMaybeT) -import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import qualified Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT(..), mapReaderT) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Identity (IdentityT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Resource (MonadResource(..)) -import qualified Control.Monad.Trans.State.Lazy as Lazy -import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Zip (MonadZip(..)) -import Data.Bifunctor (first, second) +import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Char as Char @@ -200,11 +207,11 @@ import qualified Data.Text.Encoding as Text import Data.Word (Word8, Word16, Word32, Word64) -import Hedgehog.Internal.Distributive (Distributive(..)) +import Hedgehog.Internal.Distributive (MonadTransDistributive(..)) import Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed import qualified Hedgehog.Internal.Shrink as Shrink -import Hedgehog.Internal.Tree (Tree(..), Node(..)) +import Hedgehog.Internal.Tree (Tree, TreeT(..), NodeT(..)) import qualified Hedgehog.Internal.Tree as Tree import Hedgehog.Range (Size, Range) import qualified Hedgehog.Range as Range @@ -224,18 +231,35 @@ -- newtype GenT m a = GenT { - unGen :: Size -> Seed -> Tree (MaybeT m) a + unGenT :: Size -> Seed -> TreeT (MaybeT m) a } -- | Runs a generator, producing its shrink tree. -- -runGenT :: Size -> Seed -> GenT m a -> Tree (MaybeT m) a +runGenT :: Size -> Seed -> GenT m a -> TreeT (MaybeT m) a runGenT size seed (GenT m) = m size seed +-- | Run a generator, producing its shrink tree. +-- +-- 'Nothing' means discarded, 'Just' means we have a value. +-- +evalGen :: Size -> Seed -> Gen a -> Maybe (Tree a) +evalGen size seed = + fmap (fmap Maybe.fromJust) . + Tree.filter Maybe.isJust . + evalGenT size seed + +-- | Runs a generator, producing its shrink tree. +-- +evalGenT :: Monad m => Size -> Seed -> GenT m a -> TreeT m (Maybe a) +evalGenT size seed = + runDiscardEffectT . + runGenT size seed + -- | Map over a generator's shrink tree. -- -mapGenT :: (Tree (MaybeT m) a -> Tree (MaybeT n) b) -> GenT m a -> GenT n b +mapGenT :: (TreeT (MaybeT m) a -> TreeT (MaybeT n) b) -> GenT m a -> GenT n b mapGenT f gen = GenT $ \size seed -> f (runGenT size seed gen) @@ -243,308 +267,217 @@ -- | Lift a predefined shrink tree in to a generator, ignoring the seed and the -- size. -- -liftTree :: Tree (MaybeT m) a -> GenT m a -liftTree x = - GenT (\_ _ -> x) +fromTree :: MonadGen m => Tree a -> m a +fromTree = + fromTreeT . + hoist (Morph.generalize) --- | Run the discard effects through the tree and reify them as 'Maybe' values --- at the nodes. 'Nothing' means discarded, 'Just' means we have a value. +-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the +-- size. -- -runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a) +fromTreeT :: MonadGen m => TreeT (GenBase m) a -> m a +fromTreeT x = + fromTreeMaybeT $ + hoist (MaybeT . fmap Just) x + +-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the +-- size. +-- +fromTreeMaybeT :: MonadGen m => TreeT (MaybeT (GenBase m)) a -> m a +fromTreeMaybeT x = + fromGenT . GenT $ \_ _ -> + x + +-- | Observe a generator's shrink tree. +-- +toTree :: forall m a. (MonadGen m, GenBase m ~ Identity) => m a -> m (Tree a) +toTree = + withGenT $ mapGenT (Maybe.maybe empty pure . runDiscardEffect) + +-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the +-- size. +-- +toTreeMaybeT :: MonadGen m => m a -> m (TreeT (MaybeT (GenBase m)) a) +toTreeMaybeT = + withGenT $ mapGenT pure + +-- | Lazily run the discard effects through the tree and reify it a +-- @Maybe (Tree a)@. +-- +-- 'Nothing' means discarded, 'Just' means we have a value. +-- +-- Discards in the child nodes of the tree are simply removed. +-- +runDiscardEffect :: TreeT (MaybeT Identity) a -> Maybe (Tree a) runDiscardEffect = - runMaybeT . distribute + fmap (fmap Maybe.fromJust) . + Tree.filter Maybe.isJust . + runDiscardEffectT +-- | Run the discard effects through the tree and reify them as 'Maybe' values +-- at the nodes. +-- +-- 'Nothing' means discarded, 'Just' means we have a value. +-- +runDiscardEffectT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a) +runDiscardEffectT = + runMaybeT . + distributeT + +-- | Lift a @Gen / GenT Identity@ in to a @Monad m => GenT m@ +-- +generalize :: Monad m => Gen a -> GenT m a +generalize = + hoist Morph.generalize + ------------------------------------------------------------------------ -- MonadGen -- | Class of monads which can generate input data for tests. -- --- /The functions on this class can, and should, be used without their @Gen@/ --- /suffix by importing "Hedgehog.Gen" qualified./ --- -class Monad m => MonadGen m where - -- | See @Gen.@'Hedgehog.Gen.lift' - -- - liftGen :: Gen a -> m a - - -- | See @Gen.@'Hedgehog.Gen.shrink' - -- - shrinkGen :: (a -> [a]) -> m a -> m a +class (Monad m, Monad (GenBase m)) => MonadGen m where + type GenBase m :: (* -> *) - -- | See @Gen.@'Hedgehog.Gen.prune' + -- | Extract a 'GenT' from a 'MonadGen'. -- - pruneGen :: m a -> m a + toGenT :: m a -> GenT (GenBase m) a - -- | See @Gen.@'Hedgehog.Gen.scale' + -- | Lift a 'GenT' in to a 'MonadGen'. -- - scaleGen :: (Size -> Size) -> m a -> m a + fromGenT :: GenT (GenBase m) a -> m a - -- | See @Gen.@'Hedgehog.Gen.freeze' - -- - freezeGen :: m a -> m (a, m a) +-- | Transform a 'MonadGen' as a 'GenT'. +-- +withGenT :: (MonadGen m, MonadGen n) => (GenT (GenBase m) a -> GenT (GenBase n) b) -> m a -> n b +withGenT f = + fromGenT . f . toGenT instance Monad m => MonadGen (GenT m) where - liftGen gen = - hoist generalize gen - - shrinkGen = - mapGenT . Tree.expand - - pruneGen = - mapGenT Tree.prune + -- | The type of the transformer stack's base 'Monad'. + -- + type GenBase (GenT m) = + m - scaleGen f gen = - GenT $ \size0 seed -> - let - size = - f size0 - in - if size < 0 then - error "Hedgehog.Gen.scale: negative size" - else - runGenT size seed gen + -- | Convert a 'MonadGen' to a 'GenT'. + -- + toGenT = + id - freezeGen gen = - GenT $ \size seed -> do - mx <- Trans.lift . Trans.lift . runMaybeT . runTree $ runGenT size seed gen - case mx of - Nothing -> - mzero - Just (Node x xs) -> - pure (x, liftTree . Tree.fromNode $ Node x xs) + -- | Convert a 'GenT' to a 'MonadGen'. + -- + fromGenT = + id instance MonadGen m => MonadGen (IdentityT m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - mapIdentityT (shrink f) - - pruneGen = - hoist prune - - scaleGen f = - hoist (scale f) - - freezeGen = - mapIdentityT $ - fmap (second Trans.lift) . freeze - -shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a] -shrinkMaybe f = \case - Nothing -> - pure Nothing - Just x -> - fmap Just (f x) - -shrinkEither :: (a -> [a]) -> Either x a -> [Either x a] -shrinkEither f = \case - Left x -> - pure $ Left x - Right x -> - fmap Right (f x) + type GenBase (IdentityT m) = + IdentityT (GenBase m) -shrink2 :: (a -> [a]) -> (a, b) -> [(a, b)] -shrink2 f (x, y) = - fmap (, y) (f x) + toGenT = + distributeT . hoist toGenT -shrink3 :: (a -> [a]) -> (a, b, c) -> [(a, b, c)] -shrink3 f (x, y, z) = - fmap (, y, z) (f x) + fromGenT = + hoist fromGenT . distributeT instance MonadGen m => MonadGen (MaybeT m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - mapMaybeT $ - shrink (shrinkMaybe f) - - pruneGen = - hoist prune + type GenBase (MaybeT m) = + MaybeT (GenBase m) - scaleGen f = - hoist (scale f) + toGenT = + distributeT . hoist toGenT - freezeGen = - mapMaybeT $ \m0 -> do - (mx, m) <- freeze m0 - pure $ fmap (, MaybeT m) mx + fromGenT = + hoist fromGenT . distributeT instance MonadGen m => MonadGen (ExceptT x m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - mapExceptT $ - shrink (shrinkEither f) - - pruneGen = - hoist prune + type GenBase (ExceptT x m) = + ExceptT x (GenBase m) - scaleGen f = - hoist (scale f) + toGenT = + distributeT . hoist toGenT - freezeGen = - mapExceptT $ \m0 -> do - (mx, m) <- freeze m0 - pure $ fmap (, ExceptT m) mx + fromGenT = + hoist fromGenT . distributeT instance MonadGen m => MonadGen (ReaderT r m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - mapReaderT (shrink f) - - pruneGen = - hoist prune - - scaleGen f = - hoist (scale f) - - freezeGen = - mapReaderT $ - fmap (second Trans.lift) . freeze - -instance MonadGen m => MonadGen (Lazy.StateT s m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - Lazy.mapStateT $ - shrink (shrink2 f) - - pruneGen = - hoist prune - - scaleGen f = - hoist (scale f) - - freezeGen m0 = - Lazy.StateT $ \s0 -> do - ((x, s), m) <- freeze (Lazy.runStateT m0 s0) - pure ((x, Lazy.StateT (const m)), s) - -instance MonadGen m => MonadGen (Strict.StateT s m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - Strict.mapStateT $ - shrink (shrink2 f) - - pruneGen = - hoist prune + type GenBase (ReaderT r m) = + ReaderT r (GenBase m) - scaleGen f = - hoist (scale f) + toGenT = + distributeT . hoist toGenT - freezeGen m0 = - Strict.StateT $ \s0 -> do - ((x, s), m) <- freeze (Strict.runStateT m0 s0) - pure ((x, Strict.StateT (const m)), s) + fromGenT = + hoist fromGenT . distributeT instance (MonadGen m, Monoid w) => MonadGen (Lazy.WriterT w m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - Lazy.mapWriterT $ - shrink (shrink2 f) - - pruneGen = - hoist prune + type GenBase (Lazy.WriterT w m) = + Lazy.WriterT w (GenBase m) - scaleGen f = - hoist (scale f) + toGenT = + distributeT . hoist toGenT - freezeGen m0 = - Lazy.WriterT $ do - ((x, w), m) <- freeze (Lazy.runWriterT m0) - pure ((x, Lazy.WriterT m), w) + fromGenT = + hoist fromGenT . distributeT instance (MonadGen m, Monoid w) => MonadGen (Strict.WriterT w m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - Strict.mapWriterT $ - shrink (shrink2 f) - - pruneGen = - hoist prune - - scaleGen f = - hoist (scale f) - - freezeGen m0 = - Strict.WriterT $ do - ((x, w), m) <- freeze (Strict.runWriterT m0) - pure ((x, Strict.WriterT m), w) - -instance (MonadGen m, Monoid w) => MonadGen (Lazy.RWST r w s m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - Lazy.mapRWST $ - shrink (shrink3 f) - - pruneGen = - hoist prune - - scaleGen f = - hoist (scale f) - - freezeGen m0 = - Lazy.RWST $ \r s0 -> do - ((x, s, w), m) <- freeze (Lazy.runRWST m0 r s0) - pure ((x, Lazy.RWST (\_ _ -> m)), s, w) - -instance (MonadGen m, Monoid w) => MonadGen (Strict.RWST r w s m) where - liftGen = - Trans.lift . liftGen - - shrinkGen f = - Strict.mapRWST $ - shrink (shrink3 f) - - pruneGen = - hoist prune + type GenBase (Strict.WriterT w m) = + Strict.WriterT w (GenBase m) - scaleGen f = - hoist (scale f) + toGenT = + distributeT . hoist toGenT - freezeGen m0 = - Strict.RWST $ \r s0 -> do - ((x, s, w), m) <- freeze (Strict.runRWST m0 r s0) - pure ((x, Strict.RWST (\_ _ -> m)), s, w) + fromGenT = + hoist fromGenT . distributeT ------------------------------------------------------------------------ -- GenT instances instance (Monad m, Semigroup a) => Semigroup (GenT m a) where - (<>) = liftA2 (Semigroup.<>) + (<>) = + liftA2 (Semigroup.<>) instance (Monad m, Monoid a) => Monoid (GenT m a) where - mappend = liftA2 mappend - mempty = return mempty + mappend = + liftA2 mappend + mempty = + return mempty + instance Functor m => Functor (GenT m) where fmap f gen = GenT $ \seed size -> fmap f (runGenT seed size gen) +-- +-- implementation: parallel shrinking +-- instance Monad m => Applicative (GenT m) where pure = - return - (<*>) = - ap + fromTreeMaybeT . pure + (<*>) f m = + GenT $ \ size seed -> + case Seed.split seed of + (sf, sm) -> + uncurry ($) <$> + runGenT size sf f `mzip` + runGenT size sm m + +-- +-- implementation: satisfies law (ap = <*>) +-- +--instance Monad m => Applicative (GenT m) where +-- pure = +-- fromTreeMaybeT . pure +-- (<*>) f m = +-- GenT $ \ size seed -> +-- case Seed.split seed of +-- (sf, sm) -> +-- runGenT size sf f <*> +-- runGenT size sm m + instance Monad m => Monad (GenT m) where return = - liftTree . pure + pure (>>=) m k = GenT $ \size seed -> @@ -553,15 +486,23 @@ runGenT size sk . k =<< runGenT size sm m + fail = + Fail.fail + +instance Monad m => MonadFail (GenT m) where + fail = + error + instance Monad m => Alternative (GenT m) where empty = mzero + (<|>) = mplus instance Monad m => MonadPlus (GenT m) where mzero = - liftTree mzero + fromTreeMaybeT mzero mplus x y = GenT $ \size seed -> @@ -572,70 +513,79 @@ instance MonadTrans GenT where lift = - liftTree . Trans.lift . Trans.lift + fromTreeMaybeT . lift . lift instance MFunctor GenT where hoist f = mapGenT (hoist (hoist f)) -embedMaybe :: +embedMaybeT :: MonadTrans t => Monad n => Monad (t (MaybeT n)) => (forall a. m a -> t (MaybeT n) a) -> MaybeT m b -> t (MaybeT n) b -embedMaybe f m = - Trans.lift . MaybeT . pure =<< f (runMaybeT m) +embedMaybeT f m = + lift . MaybeT . pure =<< f (runMaybeT m) -embedTree :: Monad n => (forall a. m a -> Tree (MaybeT n) a) -> Tree (MaybeT m) b -> Tree (MaybeT n) b -embedTree f tree = - embed (embedMaybe f) tree +embedTreeMaybeT :: + Monad n + => (forall a. m a -> TreeT (MaybeT n) a) + -> TreeT (MaybeT m) b + -> TreeT (MaybeT n) b +embedTreeMaybeT f tree_ = + embed (embedMaybeT f) tree_ -embedGen :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b -embedGen f gen = +embedGenT :: + Monad n + => (forall a. m a -> GenT n a) + -> GenT m b + -> GenT n b +embedGenT f gen = GenT $ \size seed -> case Seed.split seed of (sf, sg) -> - (runGenT size sf . f) `embedTree` + (runGenT size sf . f) `embedTreeMaybeT` (runGenT size sg gen) instance MMonad GenT where embed = - embedGen + embedGenT -distributeGen :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a -distributeGen x = - join . Trans.lift . GenT $ \size seed -> - pure . hoist liftTree . distribute . hoist distribute $ runGenT size seed x +distributeGenT :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a +distributeGenT x = + join . lift . GenT $ \size seed -> + pure . hoist fromTreeMaybeT . distributeT . hoist distributeT $ runGenT size seed x -instance Distributive GenT where +instance MonadTransDistributive GenT where type Transformer t GenT m = ( Monad (t (GenT m)) , Transformer t MaybeT m - , Transformer t Tree (MaybeT m) + , Transformer t TreeT (MaybeT m) ) - distribute = - distributeGen + distributeT = + distributeGenT instance PrimMonad m => PrimMonad (GenT m) where type PrimState (GenT m) = PrimState m + primitive = - Trans.lift . primitive + lift . primitive instance MonadIO m => MonadIO (GenT m) where liftIO = - Trans.lift . liftIO + lift . liftIO instance MonadBase b m => MonadBase b (GenT m) where liftBase = - Trans.lift . liftBase + lift . liftBase instance MonadThrow m => MonadThrow (GenT m) where throwM = - Trans.lift . throwM + lift . throwM instance MonadCatch m => MonadCatch (GenT m) where catch m onErr = @@ -647,31 +597,33 @@ instance MonadReader r m => MonadReader r (GenT m) where ask = - Trans.lift ask + lift ask local f m = mapGenT (local f) m instance MonadState s m => MonadState s (GenT m) where get = - Trans.lift get + lift get put = - Trans.lift . put + lift . put state = - Trans.lift . state + lift . state instance MonadWriter w m => MonadWriter w (GenT m) where writer = - Trans.lift . writer + lift . writer tell = - Trans.lift . tell + lift . tell listen = - mapGenT listen + undefined + --mapGenT listen pass = - mapGenT pass + undefined + --mapGenT pass instance MonadError e m => MonadError e (GenT m) where throwError = - Trans.lift . throwError + lift . throwError catchError m onErr = GenT $ \size seed -> case Seed.split seed of @@ -681,22 +633,16 @@ instance MonadResource m => MonadResource (GenT m) where liftResourceT = - Trans.lift . liftResourceT + lift . liftResourceT ------------------------------------------------------------------------ -- Combinators --- | Lift a vanilla 'Gen' in to a 'MonadGen'. --- -lift :: MonadGen m => Gen a -> m a -lift = - liftGen - -- | Generate a value with no shrinks from a 'Size' and a 'Seed'. -- generate :: MonadGen m => (Size -> Seed -> a) -> m a generate f = - liftGen . GenT $ \size seed -> + fromGenT . GenT $ \size seed -> pure (f size seed) ------------------------------------------------------------------------ @@ -708,14 +654,14 @@ -- the existing shrinks intact. -- shrink :: MonadGen m => (a -> [a]) -> m a -> m a -shrink = - shrinkGen +shrink f = + withGenT $ mapGenT (Tree.expand f) -- | Throw away a generator's shrink tree. -- prune :: MonadGen m => m a -> m a prune = - pruneGen + withGenT $ mapGenT (Tree.prune 0) ------------------------------------------------------------------------ -- Combinators - Size @@ -736,8 +682,17 @@ -- | Adjust the size parameter by transforming it with the given function. -- scale :: MonadGen m => (Size -> Size) -> m a -> m a -scale = - scaleGen +scale f = + withGenT $ \gen -> + GenT $ \size0 seed -> + let + size = + f size0 + in + if size < 0 then + error "Hedgehog.Gen.scale: negative size" + else + runGenT size seed gen -- | Make a generator smaller by scaling its size parameter. -- @@ -957,6 +912,8 @@ -- enumBounded :: 'Gen' 'Bool' -- @ -- +-- /This is implemented in terms of the 'Enum' class, and thus may be +-- partial for integral types larger than 'Int', e.g. 'Word64'./ enumBounded :: (MonadGen m, Enum a, Bounded a) => m a enumBounded = enum minBound maxBound @@ -1049,7 +1006,7 @@ -- | Generates a Unicode character, excluding noncharacters and invalid standalone surrogates: -- @'\0'..'\1114111' (excluding '\55296'..'\57343')@ -- -unicode :: MonadGen m => m Char +unicode :: (MonadGen m, GenBase m ~ Identity) => m Char unicode = filter (not . isNoncharacter) $ filter (not . isSurrogate) unicodeAll @@ -1229,7 +1186,7 @@ -- discard :: MonadGen m => m a discard = - liftGen mzero + fromGenT empty -- | Discards the generator if the generated value does not satisfy the -- predicate. @@ -1247,32 +1204,49 @@ -- This is essentially: -- -- @ --- filter p gen = 'mfilter' p gen '<|>' filter p gen +-- filter p gen = 'mfilter' p gen '<|>' filter p gen -- @ -- -- It differs from the above in that we keep some state to avoid looping -- forever. If we trigger these limits then the whole generator is discarded. -- -filter :: MonadGen m => (a -> Bool) -> m a -> m a -filter p gen = +filter :: (MonadGen m, GenBase m ~ Identity) => (a -> Bool) -> m a -> m a +filter p gen0 = let try k = if k > 100 then discard else do - x <- scale (2 * k +) gen + (x, gen) <- freeze $ scale (2 * k +) gen0 + if p x then - pure x + withGenT (mapGenT (Tree.filterMaybeT p)) gen else try (k + 1) in try 0 +filterT :: MonadGen m => (a -> Bool) -> m a -> m a +filterT p gen0 = + let + try k = + if k > 100 then + discard + else do + (x, gen) <- freeze $ scale (2 * k +) gen0 + + if p x then + withGenT (mapGenT (Tree.filterT p)) gen + else + try (k + 1) + in + try 0 + -- | Runs a 'Maybe' generator until it produces a 'Just'. -- -- This is implemented using 'filter' and has the same caveats. -- -just :: MonadGen m => m (Maybe a) -> m a +just :: (MonadGen m, GenBase m ~ Identity) => m (Maybe a) -> m a just g = do mx <- filter Maybe.isJust g case mx of @@ -1281,6 +1255,19 @@ Nothing -> error "Hedgehog.Gen.just: internal error, unexpected Nothing" +-- | Runs a 'Maybe' generator until it produces a 'Just'. +-- +-- This is implemented using 'filter' and has the same caveats. +-- +justT :: MonadGen m => m (Maybe a) -> m a +justT g = do + mx <- filterT Maybe.isJust g + case mx of + Just x -> + pure x + Nothing -> + error "Hedgehog.Gen.just: internal error, unexpected Nothing" + ------------------------------------------------------------------------ -- Combinators - Collections @@ -1298,13 +1285,20 @@ -- list :: MonadGen m => Range Int -> m a -> m [a] list range gen = - sized $ \size -> - (traverse snd =<<) . - ensure (atLeast $ Range.lowerBound size range) . - shrink Shrink.list $ do - k <- integral_ range - replicateM k (freeze gen) + let + interleave = + (interleaveTreeT . nodeValue =<<) + in + sized $ \size -> + ensure (atLeast $ Range.lowerBound size range) . + withGenT (mapGenT (TreeT . interleave . runTreeT)) $ do + n <- integral_ range + replicateM n (toTreeMaybeT gen) +interleaveTreeT :: Monad m => [TreeT m a] -> m (NodeT m [a]) +interleaveTreeT = + fmap Tree.interleave . traverse runTreeT + -- | Generates a seq using a 'Range' to determine the length. -- seq :: MonadGen m => Range Int -> m a -> m (Seq a) @@ -1416,7 +1410,14 @@ -- freeze :: MonadGen m => m a -> m (a, m a) freeze = - freezeGen + withGenT $ \gen -> + GenT $ \size seed -> do + mx <- lift . lift . runMaybeT . runTreeT $ runGenT size seed gen + case mx of + Nothing -> + empty + Just (NodeT x xs) -> + pure (x, fromGenT . fromTreeMaybeT . Tree.fromNodeT $ NodeT x xs) shrinkSubterms :: Subterms n a -> [Subterms n a] shrinkSubterms = \case @@ -1541,46 +1542,14 @@ error "Hedgehog.Gen.sample: too many discards, could not generate a sample" else do seed <- Seed.random - case runIdentity . runMaybeT . runTree $ runGenT 30 seed gen of + case evalGen 30 seed gen of Nothing -> loop (n - 1) Just x -> - pure $ nodeValue x + pure $ Tree.treeValue x in loop (100 :: Int) --- | Print the value produced by a generator, and the first level of shrinks, --- for the given size and seed. --- --- Use 'print' to generate a value from a random seed. --- -printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () -printWith size seed gen = - liftIO $ do - let - Node x ss = - runIdentity . runTree $ renderNodes size seed gen - - putStrLn "=== Outcome ===" - putStrLn x - putStrLn "=== Shrinks ===" - - for_ ss $ \s -> - let - Node y _ = - runIdentity $ runTree s - in - putStrLn y - --- | Print the shrink tree produced by a generator, for the given size and --- seed. --- --- Use 'printTree' to generate a value from a random seed. --- -printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () -printTreeWith size seed gen = do - liftIO . putStr . runIdentity . Tree.render $ renderNodes size seed gen - -- | Run a generator with a random seed and print the outcome, and the first -- level of shrinks. -- @@ -1600,6 +1569,35 @@ seed <- liftIO Seed.random printWith 30 seed gen +-- | Print the value produced by a generator, and the first level of shrinks, +-- for the given size and seed. +-- +-- Use 'print' to generate a value from a random seed. +-- +printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () +printWith size seed gen = + liftIO $ do + case evalGen size seed gen of + Nothing -> do + putStrLn "=== Outcome ===" + putStrLn "" + + Just tree_ -> do + let + NodeT x ss = + runIdentity (runTreeT tree_) + + putStrLn "=== Outcome ===" + putStrLn (show x) + putStrLn "=== Shrinks ===" + + for_ ss $ \s -> + let + NodeT y _ = + runIdentity $ runTreeT s + in + putStrLn (show y) + -- | Run a generator with a random seed and print the resulting shrink tree. -- -- @ @@ -1622,11 +1620,26 @@ seed <- liftIO Seed.random printTreeWith 30 seed gen --- | Render a generator as a tree of strings. +-- | Print the shrink tree produced by a generator, for the given size and +-- seed. -- -renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen a -> Tree m String -renderNodes size seed = - fmap (Maybe.maybe "" show) . runDiscardEffect . runGenT size seed . lift +-- Use 'printTree' to generate a value from a random seed. +-- +printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m () +printTreeWith size seed gen = do + liftIO . putStr $ + renderTree size seed gen + +-- | Render the shrink tree produced by a generator, for the given size and +-- seed. +-- +renderTree :: Show a => Size -> Seed -> Gen a -> String +renderTree size seed gen = + case evalGen size seed gen of + Nothing -> + "" + Just x -> + Tree.render (fmap show x) ------------------------------------------------------------------------ -- Internal diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs --- a/src/Hedgehog/Internal/Property.hs +++ b/src/Hedgehog/Internal/Property.hs @@ -1,6 +1,10 @@ {-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -21,8 +25,11 @@ , PropertyName(..) , PropertyConfig(..) , TestLimit(..) + , TestCount(..) , DiscardLimit(..) + , DiscardCount(..) , ShrinkLimit(..) + , ShrinkCount(..) , ShrinkRetries(..) , withTests , withDiscards @@ -39,12 +46,14 @@ -- * Group , Group(..) , GroupName(..) + , PropertyCount(..) -- * TestT , MonadTest(..) , Test , TestT(..) , Log(..) + , Journal(..) , Failure(..) , Diff(..) , annotate @@ -54,6 +63,7 @@ , failure , success , assert + , diff , (===) , (/==) @@ -63,6 +73,25 @@ , evalEither , evalExceptT + -- * Coverage + , Coverage(..) + , Label(..) + , LabelName(..) + , cover + , classify + , label + , collect + , coverPercentage + , labelCovered + , coverageSuccess + , coverageFailures + , journalCoverage + + , Cover(..) + , CoverCount(..) + , CoverPercentage(..) + , toCoverCount + -- * Internal -- $internal , defaultConfig @@ -84,6 +113,8 @@ import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Catch (SomeException(..), displayException) import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Fail (MonadFail (..)) +import qualified Control.Monad.Fail as Fail import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Primitive (PrimMonad(..)) @@ -108,8 +139,10 @@ import qualified Data.Char as Char import Data.Functor.Identity (Identity(..)) +import Data.Map (Map) +import qualified Data.Map.Strict as Map import qualified Data.List as List -import Data.Semigroup (Semigroup) +import Data.Semigroup (Semigroup(..)) import Data.String (IsString) import Data.Typeable (typeOf) @@ -120,7 +153,7 @@ import Hedgehog.Internal.Show import Hedgehog.Internal.Source -import Language.Haskell.TH.Lift (deriveLift) +import Language.Haskell.TH.Syntax (Lift) ------------------------------------------------------------------------ @@ -151,6 +184,8 @@ , MonadState s , MonadError e ) +-- NOTE: Move this to the deriving list above when we drop 7.10 +deriving instance MonadResource m => MonadResource (PropertyT m) -- | A test monad allows the assertion of expectations. -- @@ -161,7 +196,7 @@ -- newtype TestT m a = TestT { - unTest :: ExceptT Failure (Lazy.WriterT [Log] m) a + unTest :: ExceptT Failure (Lazy.WriterT Journal m) a } deriving ( Functor , Applicative @@ -184,7 +219,7 @@ newtype PropertyName = PropertyName { unPropertyName :: String - } deriving (Eq, Ord, Show, IsString, Semigroup) + } deriving (Eq, Ord, Show, IsString, Semigroup, Lift) -- | Configuration for a property test. -- @@ -194,7 +229,7 @@ , propertyDiscardLimit :: !DiscardLimit , propertyShrinkLimit :: !ShrinkLimit , propertyShrinkRetries :: !ShrinkRetries - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Lift) -- | The number of successful tests that need to be run before a property test -- is considered successful. @@ -207,8 +242,20 @@ -- newtype TestLimit = TestLimit Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) + +-- | The number of tests a property ran successfully. +-- +newtype TestCount = + TestCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) +-- | The number of tests a property had to discard. +-- +newtype DiscardCount = + DiscardCount Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + -- | The number of discards to allow before giving up. -- -- Can be constructed using numeric literals: @@ -220,7 +267,7 @@ -- newtype DiscardLimit = DiscardLimit Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | The number of shrinks to try before giving up on shrinking. -- @@ -232,6 +279,12 @@ -- newtype ShrinkLimit = ShrinkLimit Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) + +-- | The numbers of times a property was able to shrink after a failing test. +-- +newtype ShrinkCount = + ShrinkCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | The number of times to re-run a test during shrinking. This is useful if @@ -251,7 +304,7 @@ -- newtype ShrinkRetries = ShrinkRetries Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) -- | A named collection of property tests. -- @@ -272,12 +325,18 @@ newtype GroupName = GroupName { unGroupName :: String - } deriving (Eq, Ord, Show, IsString, Semigroup) + } deriving (Eq, Ord, Show, IsString, Semigroup, Lift) +-- | The number of properties in a group. -- +newtype PropertyCount = + PropertyCount Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +-- -- FIXME This whole Log/Failure thing could be a lot more structured to allow -- FIXME for richer user controlled error messages, think Doc. Ideally we'd --- FIXME allow user's to create their own diffs anywhere. +-- FIXME allow user's to crete their own diffs anywhere. -- -- | Log messages which are recorded during a test run. @@ -285,8 +344,15 @@ data Log = Annotation (Maybe Span) String | Footnote String + | Label (Label Cover) deriving (Eq, Show) +-- | A record containing the details of a test run. +newtype Journal = + Journal { + journalLogs :: [Log] + } deriving (Eq, Show, Semigroup, Monoid) + -- | Details on where and why a test failed. -- data Failure = @@ -305,18 +371,89 @@ , diffValue :: ValueDiff } deriving (Eq, Show) +-- | Whether a test is covered by a classifier, and therefore belongs to a +-- 'Class'. +-- +data Cover = + NoCover + | Cover + deriving (Eq, Ord, Show) + +-- | The total number of tests which are covered by a classifier. +-- +-- Can be constructed using numeric literals: +-- +-- @ +-- 30 :: CoverCount +-- @ +-- +newtype CoverCount = + CoverCount { + unCoverCount :: Int + } deriving (Eq, Ord, Show, Num) + +-- | The relative number of tests which are covered by a classifier. +-- +-- Can be constructed using numeric literals: +-- +-- @ +-- 30 :: CoverPercentage +-- @ +-- +newtype CoverPercentage = + CoverPercentage { + unCoverPercentage :: Double + } deriving (Eq, Ord, Show, Num) + +-- | The name of a classifier. +-- +-- Can be constructed using `OverloadedStrings`: +-- +-- @ +-- "apples" :: LabelName +-- @ +-- +newtype LabelName = + LabelName { + unLabelName :: String + } deriving (Eq, Ord, Show, IsString) + +-- | The extent to which a test is covered by a classifier. +-- +-- /When a classifier's coverage does not exceed the required minimum, the +-- test will be failed./ +-- +data Label a = + MkLabel { + labelName :: !LabelName + , labelLocation :: !(Maybe Span) + , labelMinimum :: !CoverPercentage + , labelAnnotation :: !a + } deriving (Eq, Show, Functor, Foldable, Traversable) + +-- | The extent to which all classifiers cover a test. +-- +-- /When a given classification's coverage does not exceed the required +-- minimum, the test will be failed./ +-- +newtype Coverage a = + Coverage { + coverageLabels :: Map LabelName (Label a) + } deriving (Eq, Show, Functor, Foldable, Traversable) + ------------------------------------------------------------------------ -- TestT instance Monad m => Monad (TestT m) where return = - TestT . return + pure (>>=) m k = TestT $ unTest m >>= unTest . k +instance Monad m => MonadFail (TestT m) where fail err = TestT . ExceptT . pure . Left $ Failure Nothing err Nothing @@ -328,16 +465,16 @@ hoist f = TestT . hoist (hoist f) . unTest -instance Distributive TestT where +instance MonadTransDistributive TestT where type Transformer t TestT m = ( - Transformer t (Lazy.WriterT [Log]) m - , Transformer t (ExceptT Failure) (Lazy.WriterT [Log] m) + Transformer t (Lazy.WriterT Journal) m + , Transformer t (ExceptT Failure) (Lazy.WriterT Journal m) ) - distribute = + distributeT = hoist TestT . - distribute . - hoist distribute . + distributeT . + hoist distributeT . unTest instance PrimMonad m => PrimMonad (TestT m) where @@ -362,10 +499,10 @@ instance MonadTransControl TestT where type StT TestT a = - (Either Failure a, [Log]) + (Either Failure a, Journal) liftWith f = - mkTestT . fmap (, []) . fmap Right $ f $ runTestT + mkTestT . fmap (, mempty) . fmap Right $ f $ runTestT restoreT = mkTestT @@ -435,19 +572,19 @@ liftTest = lift . liftTest -mkTestT :: m (Either Failure a, [Log]) -> TestT m a +mkTestT :: m (Either Failure a, Journal) -> TestT m a mkTestT = TestT . ExceptT . Lazy.WriterT -mkTest :: (Either Failure a, [Log]) -> Test a +mkTest :: (Either Failure a, Journal) -> Test a mkTest = mkTestT . Identity -runTestT :: TestT m a -> m (Either Failure a, [Log]) +runTestT :: TestT m a -> m (Either Failure a, Journal) runTestT = Lazy.runWriterT . runExceptT . unTest -runTest :: Test a -> (Either Failure a, [Log]) +runTest :: Test a -> (Either Failure a, Journal) runTest = runIdentity . runTestT @@ -455,14 +592,14 @@ -- writeLog :: MonadTest m => Log -> m () writeLog x = - liftTest $ mkTest (pure (), [x]) + liftTest $ mkTest (pure (), (Journal [x])) -- | Fail the test with an error message, useful for building other failure -- combinators. -- failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a -failWith diff msg = - liftTest $ mkTest (Left $ Failure (getCaller callStack) msg diff, []) +failWith mdiff msg = + liftTest $ mkTest (Left $ Failure (getCaller callStack) msg mdiff, mempty) -- | Annotates the source code with a message that might be useful for -- debugging a test failure. @@ -492,22 +629,31 @@ footnoteShow = writeLog . Footnote . showPretty --- | Fails with an error which shows the difference between two values. --- +-- | Fails with an error that shows the difference between two values. failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m () failDiff x y = case valueDiff <$> mkValue x <*> mkValue y of Nothing -> withFrozenCallStack $ - failWith Nothing $ unlines [ - "━━━ Not Equal ━━━" + failWith Nothing $ + unlines $ [ + "Failed" + , "━━ lhs ━━" , showPretty x + , "━━ rhs ━━" , showPretty y ] - Just diff -> + + Just vdiff@(ValueSame _) -> withFrozenCallStack $ - failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) "" + failWith (Just $ + Diff "━━━ Failed (" "" "no differences" "" ") ━━━" vdiff) "" + Just vdiff -> + withFrozenCallStack $ + failWith (Just $ + Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) "" + -- | Fails with an error which renders the type of an exception and its error -- message. -- @@ -515,7 +661,7 @@ failException (SomeException x) = withFrozenCallStack $ failWith Nothing $ unlines [ - "━━━ Exception: " ++ show (typeOf x) ++ " ━━━" + "━━━ Exception (" ++ show (typeOf x) ++ ") ━━━" , List.dropWhileEnd Char.isSpace (displayException x) ] @@ -541,33 +687,48 @@ else withFrozenCallStack failure -infix 4 === - --- | Fails the test if the two arguments provided are not equal. +-- | Fails the test and shows a git-like diff if the comparison operation +-- evaluates to 'False' when applied to its arguments. -- -(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m () -(===) x y = do - ok <- withFrozenCallStack $ eval (x == y) +-- The comparison function is the second argument, which may be +-- counter-intuitive to Haskell programmers. However, it allows operators to +-- be written infix for easy reading: +-- +-- @ +-- diff y (<) 87 +-- diff x (<=) 'r' +-- @ +-- +-- /This function behaves like the unix `diff` tool, which gives a `0` exit +-- code if the compared files are identical, or a `1` exit code code +-- otherwise. Like unix `diff`, if the arguments fail the comparison, a diff +-- is shown./ +-- +diff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> (a -> b -> Bool) -> b -> m () +diff x op y = do + ok <- withFrozenCallStack $ eval (x `op` y) if ok then success else withFrozenCallStack $ failDiff x y +infix 4 === + +-- | Fails the test if the two arguments provided are not equal. +-- +(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m () +(===) x y = + withFrozenCallStack $ + diff x (==) y + infix 4 /== -- | Fails the test if the two arguments provided are equal. -- (/==) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m () -(/==) x y = do - ok <- withFrozenCallStack $ eval (x /= y) - if ok then - success - else - withFrozenCallStack $ - failWith Nothing $ unlines [ - "━━━ Both equal to ━━━" - , showPretty x - ] +(/==) x y = + withFrozenCallStack $ + diff x (/=) y -- | Fails the test if the value throws an exception when evaluated to weak -- head normal form (WHNF). @@ -618,20 +779,24 @@ lift = PropertyT . lift . lift +instance Monad m => MonadFail (PropertyT m) where + fail err = + PropertyT (Fail.fail err) + instance MFunctor PropertyT where hoist f = PropertyT . hoist (hoist f) . unPropertyT -instance Distributive PropertyT where +instance MonadTransDistributive PropertyT where type Transformer t PropertyT m = ( Transformer t GenT m , Transformer t TestT (GenT m) ) - distribute = + distributeT = hoist PropertyT . - distribute . - hoist distribute . + distributeT . + hoist distributeT . unPropertyT instance PrimMonad m => PrimMonad (PropertyT m) where @@ -680,10 +845,11 @@ -- forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a forAllWith render gen = - withFrozenCallStack $ forAllWithT render $ Gen.lift gen + withFrozenCallStack $ forAllWithT render $ Gen.generalize gen -- | Generates a random input for the test by running the provided generator. -- +-- forAllT :: (Monad m, Show a, HasCallStack) => GenT m a -> PropertyT m a forAllT gen = withFrozenCallStack $ forAllWithT showPretty gen @@ -698,7 +864,7 @@ -- discard :: Monad m => PropertyT m a discard = - PropertyT $ lift Gen.discard + PropertyT $ lift (Gen.generalize Gen.discard) -- | Lift a test in to a property. -- @@ -708,14 +874,9 @@ -- instance at the expense of not being able to generate additional inputs -- using 'forAll'. -- --- One use case for this is writing tests which use 'ResourceT': --- --- @ --- property $ do --- n <- forAll $ Gen.int64 Range.linearBounded --- test . runResourceT $ do --- -- test with resource usage here --- @ +-- An example where this is useful is parallel state machine testing, as +-- 'Hedgehog.Internal.State.executeParallel' requires 'MonadBaseControl' 'IO' +-- in order to be able to spawn threads in 'MonadTest'. -- test :: Monad m => TestT m a -> PropertyT m a test = @@ -786,15 +947,156 @@ withFrozenCallStack (evalM m) ------------------------------------------------------------------------ --- FIXME Replace with DeriveLift when we drop 7.10 support. +-- Coverage -$(deriveLift ''GroupName) -$(deriveLift ''PropertyName) -$(deriveLift ''PropertyConfig) -$(deriveLift ''TestLimit) -$(deriveLift ''DiscardLimit) -$(deriveLift ''ShrinkLimit) -$(deriveLift ''ShrinkRetries) +instance Semigroup Cover where + (<>) NoCover NoCover = + NoCover + (<>) _ _ = + Cover + +instance Monoid Cover where + mempty = + NoCover + mappend = + (<>) + +instance Semigroup CoverCount where + (<>) (CoverCount n0) (CoverCount n1) = + CoverCount (n0 + n1) + +instance Monoid CoverCount where + mempty = + CoverCount 0 + mappend = + (<>) + +toCoverCount :: Cover -> CoverCount +toCoverCount = \case + NoCover -> + CoverCount 0 + Cover -> + CoverCount 1 + +-- | This semigroup is right biased. The name, location and percentage from the +-- rightmost `Label` will be kept. This shouldn't be a problem since the +-- library doesn't allow setting multiple classes with the same 'ClassifierName'. +instance Semigroup a => Semigroup (Label a) where + (<>) (MkLabel _ _ _ m0) (MkLabel name location percentage m1) = + MkLabel name location percentage (m0 <> m1) + +instance Semigroup a => Semigroup (Coverage a) where + (<>) (Coverage c0) (Coverage c1) = + Coverage $ + Map.foldrWithKey (Map.insertWith (<>)) c0 c1 + +instance (Semigroup a, Monoid a) => Monoid (Coverage a) where + mempty = + Coverage mempty + mappend = + (<>) + +coverPercentage :: TestCount -> CoverCount -> CoverPercentage +coverPercentage (TestCount tests) (CoverCount count) = + let + percentage :: Double + percentage = + fromIntegral count / fromIntegral tests * 100 + + thousandths :: Int + thousandths = + round $ percentage * 10 + in + CoverPercentage (fromIntegral thousandths / 10) + +labelCovered :: TestCount -> Label CoverCount -> Bool +labelCovered tests (MkLabel _ _ minimum_ population) = + coverPercentage tests population >= minimum_ + +coverageSuccess :: TestCount -> Coverage CoverCount -> Bool +coverageSuccess tests = + null . coverageFailures tests + +coverageFailures :: TestCount -> Coverage CoverCount -> [Label CoverCount] +coverageFailures tests (Coverage kvs) = + filter (not . labelCovered tests) (Map.elems kvs) + +fromLabel :: Label a -> Coverage a +fromLabel x = + Coverage $ + Map.singleton (labelName x) x + +unionsCoverage :: Semigroup a => [Coverage a] -> Coverage a +unionsCoverage = + Coverage . + Map.unionsWith (<>) . + fmap coverageLabels + +journalCoverage :: Journal -> Coverage CoverCount +journalCoverage (Journal logs) = + fmap toCoverCount . + unionsCoverage $ do + Label x <- logs + pure (fromLabel x) + +-- | Require a certain percentage of the tests to be covered by the +-- classifier. +-- +-- @ +-- prop_with_coverage :: Property +-- prop_with_coverage = +-- property $ do +-- match <- forAll Gen.bool +-- cover 30 "True" $ match +-- cover 30 "False" $ not match +-- @ +-- +-- The example above requires a minimum of 30% coverage for both +-- classifiers. If these requirements are not met, it will fail the test. +-- +cover :: (MonadTest m, HasCallStack) => CoverPercentage -> LabelName -> Bool -> m () +cover minimum_ name covered = + let + cover_ = + if covered then + Cover + else + NoCover + in + writeLog . Label $ + MkLabel name (getCaller callStack) minimum_ cover_ + +-- | Records the proportion of tests which satisfy a given condition. +-- +-- @ +-- prop_with_classifier :: Property +-- prop_with_classifier = +-- property $ do +-- xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha +-- for_ xs $ \x -> do +-- classify "newborns" $ x == 0 +-- classify "children" $ x > 0 && x < 13 +-- classify "teens" $ x > 12 && x < 20 +-- @ +classify :: (MonadTest m, HasCallStack) => LabelName -> Bool -> m () +classify name covered = + withFrozenCallStack $ + cover 0 name covered + +-- | Add a label for each test run. It produces a table showing the percentage +-- of test runs that produced each label. +-- +label :: (MonadTest m, HasCallStack) => LabelName -> m () +label name = + withFrozenCallStack $ + cover 0 name True + +-- | Like 'label', but uses 'Show' to render its argument for display. +-- +collect :: (MonadTest m, Show a, HasCallStack) => a -> m () +collect x = + withFrozenCallStack $ + cover 0 (LabelName (show x)) True ------------------------------------------------------------------------ -- Internal diff --git a/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs --- a/src/Hedgehog/Internal/Report.hs +++ b/src/Hedgehog/Internal/Report.hs @@ -8,6 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} + module Hedgehog.Internal.Report ( -- * Report Summary(..) @@ -17,11 +18,6 @@ , FailureReport(..) , FailedAnnotation(..) - , ShrinkCount(..) - , TestCount(..) - , DiscardCount(..) - , PropertyCount(..) - , Style(..) , Markup(..) @@ -50,11 +46,19 @@ import qualified Data.Map as Map import Data.Maybe (mapMaybe, catMaybes) import Data.Semigroup (Semigroup(..)) +import Data.Traversable (for) import Hedgehog.Internal.Config import Hedgehog.Internal.Discovery (Pos(..), Position(..)) import qualified Hedgehog.Internal.Discovery as Discovery +import Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..)) +import Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..)) import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..)) +import Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..)) +import Hedgehog.Internal.Property (TestCount(..), DiscardCount(..)) +import Hedgehog.Internal.Property (coverPercentage, coverageFailures) +import Hedgehog.Internal.Property (labelCovered) + import Hedgehog.Internal.Seed (Seed) import Hedgehog.Internal.Show import Hedgehog.Internal.Source @@ -64,6 +68,7 @@ import System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..)) import System.Console.ANSI (SGR(..), setSGRCode) import System.Directory (makeRelativeToCurrentDirectory) + #if mingw32_HOST_OS import System.IO (hSetEncoding, stdout, stderr, utf8) #endif @@ -75,30 +80,6 @@ ------------------------------------------------------------------------ -- Data --- | The numbers of times a property was able to shrink after a failing test. --- -newtype ShrinkCount = - ShrinkCount Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) - --- | The number of tests a property ran successfully. --- -newtype TestCount = - TestCount Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) - --- | The number of tests a property had to discard. --- -newtype DiscardCount = - DiscardCount Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) - --- | The number of properties in a group. --- -newtype PropertyCount = - PropertyCount Int - deriving (Eq, Ord, Show, Num, Enum, Real, Integral) - data FailedAnnotation = FailedAnnotation { failedSpan :: !(Maybe Span) @@ -110,6 +91,7 @@ failureSize :: !Size , failureSeed :: !Seed , failureShrinks :: !ShrinkCount + , failureCoverage :: !(Maybe (Coverage CoverCount)) , failureAnnotations :: ![FailedAnnotation] , failureLocation :: !(Maybe Span) , failureMessage :: !String @@ -141,6 +123,7 @@ Report { reportTests :: !TestCount , reportDiscards :: !DiscardCount + , reportCoverage :: !(Coverage CoverCount) , reportStatus :: !a } deriving (Show, Functor, Foldable, Traversable) @@ -220,11 +203,14 @@ | ShrinkingIcon | ShrinkingHeader | FailedIcon - | FailedHeader + | FailedText | GaveUpIcon - | GaveUpHeader + | GaveUpText | SuccessIcon - | SuccessHeader + | SuccessText + | CoverageIcon + | CoverageText + | CoverageFill | DeclarationLocation | StyledLineNo !Style | StyledBorder !Style @@ -279,12 +265,13 @@ Size -> Seed -> ShrinkCount + -> Maybe (Coverage CoverCount) -> Maybe Span -> String -> Maybe Diff -> [Log] -> FailureReport -mkFailure size seed shrinks location message diff logs = +mkFailure size seed shrinks mcoverage location message diff logs = let inputs = mapMaybe takeAnnotation logs @@ -292,7 +279,7 @@ footnotes = mapMaybe takeFootnote logs in - FailureReport size seed shrinks inputs location message diff footnotes + FailureReport size seed shrinks mcoverage inputs location message diff footnotes ------------------------------------------------------------------------ -- Pretty Printing @@ -496,19 +483,19 @@ ppDiff :: Diff -> [Doc Markup] ppDiff (Diff prefix removed infix_ added suffix diff) = [ markup DiffPrefix (WL.text prefix) <> - markup DiffRemoved (WL.text removed) <+> - markup DiffInfix (WL.text infix_) <+> + markup DiffRemoved (WL.text removed) <> + markup DiffInfix (WL.text infix_) <> markup DiffAdded (WL.text added) <> markup DiffSuffix (WL.text suffix) ] ++ fmap ppLineDiff (toLineDiff diff) ppFailureLocation :: MonadIO m - => String + => [Doc Markup] -> Maybe Diff -> Span -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))) -ppFailureLocation msg mdiff sloc = +ppFailureLocation msgs mdiff sloc = runMaybeT $ do decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc (startCol, endCol) <- bimap fromIntegral fromIntegral <$> lastLineSpan sloc decl @@ -523,7 +510,7 @@ markup FailureGutter (WL.text "│ ") <> x msgDocs = - fmap ((StyleFailure, ) . ppFailure . markup FailureMessage . WL.text) (List.lines msg) + fmap ((StyleFailure, ) . ppFailure . markup FailureMessage) msgs diffDocs = case mdiff of @@ -619,9 +606,9 @@ ppTextLines = fmap WL.text . List.lines -ppFailureReport :: MonadIO m => Maybe PropertyName -> FailureReport -> m (Doc Markup) -ppFailureReport name (FailureReport size seed _ inputs0 mlocation0 msg mdiff msgs0) = do - (msgs, mlocation) <- +ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> FailureReport -> m [Doc Markup] +ppFailureReport name tests (FailureReport size seed _ mcoverage inputs0 mlocation0 msg mdiff msgs0) = do + (msgs1, mlocation) <- case mlocation0 of Nothing -> -- Move the failure message to the end section if we have @@ -638,16 +625,37 @@ pure (docs, Nothing) Just location0 -> - (concatMap ppTextLines msgs0,) - <$> ppFailureLocation msg mdiff location0 + fmap (concatMap ppTextLines msgs0,) $ + ppFailureLocation (fmap WL.text $ List.lines msg) mdiff location0 - (args, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0 + coverageLocations <- + case mcoverage of + Nothing -> + pure [] + Just coverage -> + for (coverageFailures tests coverage) $ \(MkLabel _ mclocation _ count) -> + case mclocation of + Nothing -> + pure Nothing + Just clocation -> + let + coverageMsg = + WL.cat [ + "Failed (" + , WL.annotate CoverageText $ + ppCoverPercentage (coverPercentage tests count) <> " coverage" + , ")" + ] + in + ppFailureLocation [coverageMsg] Nothing clocation + (args, idecls) <- fmap partitionEithers $ zipWithM ppFailedInput [0..] inputs0 + let decls = mergeDeclarations . catMaybes $ - mlocation : fmap pure idecls + mlocation : coverageLocations <> fmap pure idecls with xs f = if null xs then @@ -655,14 +663,31 @@ else [f xs] - pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [ + whenSome f xs = + if null xs then + xs + else + f xs + + bottom = + maybe [ppReproduce name size seed] (const []) mcoverage + + pure . + whenSome (mempty :) . + whenSome (++ [mempty]) . + WL.punctuate WL.line . + fmap (WL.vsep . fmap (WL.indent 2)) . + fmap (id :: [Doc Markup] -> [Doc Markup]) . + filter (not . null) $ + concat [ with args $ - WL.vsep . WL.punctuate WL.line + WL.punctuate WL.line , with decls $ - WL.vsep . WL.punctuate WL.line . fmap ppDeclaration - , with msgs $ - WL.vsep - , [ppReproduce name size seed] + WL.punctuate WL.line . fmap ppDeclaration + , with msgs1 $ + id + , with bottom $ + id ] ppName :: Maybe PropertyName -> Doc a @@ -673,15 +698,18 @@ WL.text name ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup) -ppProgress name (Report tests discards status) = +ppProgress name (Report tests discards coverage status) = case status of Running -> - pure . icon RunningIcon '●' . WL.annotate RunningHeader $ - ppName name <+> - "passed" <+> - ppTestCount tests <> - ppWithDiscardCount discards <+> - "(running)" + pure . WL.vsep $ [ + icon RunningIcon '●' . WL.annotate RunningHeader $ + ppName name <+> + "passed" <+> + ppTestCount tests <> + ppWithDiscardCount discards <+> + "(running)" + ] ++ + ppCoverage tests coverage Shrinking failure -> pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $ @@ -692,38 +720,283 @@ "(shrinking)" ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup) -ppResult name (Report tests discards result) = +ppResult name (Report tests discards coverage result) = do case result of Failed failure -> do - pfailure <- ppFailureReport name failure + pfailure <- ppFailureReport name tests failure pure . WL.vsep $ [ - icon FailedIcon '✗' . WL.annotate FailedHeader $ + icon FailedIcon '✗' . WL.annotate FailedText $ ppName name <+> "failed after" <+> ppTestCount tests <> ppShrinkDiscard (failureShrinks failure) discards <> "." - , mempty - , pfailure - , mempty - ] + ] ++ + ppCoverage tests coverage ++ + pfailure GaveUp -> - pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $ - ppName name <+> - "gave up after" <+> - ppDiscardCount discards <> - ", passed" <+> - ppTestCount tests <> - "." + pure . WL.vsep $ [ + icon GaveUpIcon '⚐' . WL.annotate GaveUpText $ + ppName name <+> + "gave up after" <+> + ppDiscardCount discards <> + ", passed" <+> + ppTestCount tests <> + "." + ] ++ + ppCoverage tests coverage OK -> - pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $ - ppName name <+> - "passed" <+> - ppTestCount tests <> - "." + pure . WL.vsep $ [ + icon SuccessIcon '✓' . WL.annotate SuccessText $ + ppName name <+> + "passed" <+> + ppTestCount tests <> + "." + ] ++ + ppCoverage tests coverage +ppCoverage :: TestCount -> Coverage CoverCount -> [Doc Markup] +ppCoverage tests x = + if Map.null (coverageLabels x) then + mempty + else + fmap (ppLabel tests (coverageWidth tests x)) . + List.sortOn labelLocation $ + Map.elems (coverageLabels x) + +data ColumnWidth = + ColumnWidth { + widthPercentage :: !Int + , widthMinimum :: !Int + , widthName :: !Int + , _widthNameFail :: !Int + } + +instance Semigroup ColumnWidth where + (<>) (ColumnWidth p0 m0 n0 f0) (ColumnWidth p1 m1 n1 f1) = + ColumnWidth + (max p0 p1) + (max m0 m1) + (max n0 n1) + (max f0 f1) + +instance Monoid ColumnWidth where + mempty = + ColumnWidth 0 0 0 0 + mappend = + (<>) + +coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth +coverageWidth tests (Coverage labels) = + foldMap (labelWidth tests) labels + +labelWidth :: TestCount -> Label CoverCount -> ColumnWidth +labelWidth tests x = + let + percentage = + length . + renderCoverPercentage . + coverPercentage tests $ + labelAnnotation x + + minimum_ = + if labelMinimum x == 0 then + 0 + else + length . + renderCoverPercentage $ + labelMinimum x + + name = + length . + unLabelName $ + labelName x + + nameFail = + if labelCovered tests x then + 0 + else + name + in + ColumnWidth percentage minimum_ name nameFail + +ppLeftPad :: Int -> Doc a -> Doc a +ppLeftPad n doc = + let + ndoc = + length (show doc) + + pad = + WL.text $ + List.replicate (n - ndoc) ' ' + in + pad <> doc + +ppLabel :: TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup +ppLabel tests w x@(MkLabel name _ minimum_ count) = + let + covered = + labelCovered tests x + + ltext = + if not covered then + WL.annotate CoverageText + else + id + + lborder = + WL.annotate (StyledBorder StyleDefault) + + licon = + if not covered then + WL.annotate CoverageText "⚠ " + else + " " + + lname = + WL.fill (widthName w) (ppLabelName name) + + wminimum = + ppLeftPad (widthMinimum w) $ + ppCoverPercentage minimum_ + + wcover i = + ppLeftPad (widthPercentage w + length i) $ + WL.text i <> + ppCoverPercentage (coverPercentage tests count) + + lminimum = + if widthMinimum w == 0 then + mempty + else if not covered then + " ✗ " <> wminimum + else if minimum_ == 0 then + " " <> ppLeftPad (widthMinimum w) "" + else + " ✓ " <> wminimum + + lcover = + if widthMinimum w == 0 then + wcover "" + else if not covered then + wcover "" + else if minimum_ == 0 then + wcover "" + else + wcover "" + in + WL.hcat [ + licon + , ltext lname + , lborder " " + , ltext lcover + , lborder " " + , ltext $ ppCoverBar (coverPercentage tests count) minimum_ + , lborder "" -- "│" + , ltext lminimum + ] + +ppLabelName :: LabelName -> Doc a +ppLabelName (LabelName name) = + WL.text name + +ppCoverPercentage :: CoverPercentage -> Doc Markup +ppCoverPercentage = + WL.text . renderCoverPercentage + +ppCoverBar :: CoverPercentage -> CoverPercentage -> Doc Markup +ppCoverBar (CoverPercentage percentage) (CoverPercentage minimum_) = + let + barWidth :: Int + barWidth = + 20 + + coverageRatio :: Double + coverageRatio = + percentage / 100.0 + + coverageWidth_ :: Int + coverageWidth_ = + floor $ + coverageRatio * fromIntegral barWidth + + minimumRatio :: Double + minimumRatio = + minimum_ / 100.0 + + minimumWidth :: Int + minimumWidth = + floor $ + minimumRatio * fromIntegral barWidth + + index :: [a] -> Int + index xs = + floor $ + ((coverageRatio * fromIntegral barWidth) - fromIntegral coverageWidth_) * + fromIntegral (length xs) + + part xs = + xs !! index xs + + fillWidth = + barWidth - coverageWidth_ - 1 + + fillErrorWidth = + max 0 (minimumWidth - coverageWidth_ - 1) + + fillSurplusWidth = + fillWidth - fillErrorWidth + + bar :: (Char, [Char]) -> Doc Markup + bar (full, parts) = + WL.hcat [ + WL.text $ replicate coverageWidth_ full + , if fillWidth >= 0 then + if index parts == 0 then + if fillErrorWidth > 0 then + WL.annotate FailedText $ WL.text [part parts] + else + WL.annotate CoverageFill $ WL.text [part parts] + else + WL.text [part parts] + else + "" + , WL.annotate FailedText . WL.text $ + replicate fillErrorWidth (head parts) + , WL.annotate CoverageFill . WL.text $ + replicate fillSurplusWidth (head parts) + -- + -- Uncomment when debugging: + -- + -- , WL.annotate CoverageFill . WL.text $ + -- " " ++ show barWidth + -- ++ " " ++ show coverageWidth_ + -- ++ " " ++ show minimumWidth + -- ++ " " ++ "/" + -- ++ " " ++ show fillErrorWidth + -- ++ " " ++ "+" + -- ++ " " ++ show fillSurplusWidth + -- ++ " " ++ "=" + -- ++ " " ++ show fillWidth + ] + in + bar ('█', ['·', '▏', '▎', '▍', '▌', '▋', '▊', '▉']) + + -- FIXME Maybe this should be configurable? + -- Alternative histogram bars: + --bar ('⣿', ['·', '⡀', '⡄', '⡆', '⡇', '⣇', '⣧', '⣷']) + --bar ('⣿', ['⢕', '⡀', '⣀', '⣄', '⣤', '⣦', '⣶', '⣷']) + --bar ('⣿', ['⢕', '⡵', '⢗', '⣗', '⣟']) + --bar ('⣿', [' ', '⡵', '⢗', '⣗', '⣟']) + --bar ('█', ['░','▓']) + --bar ('█', ['░']) + +renderCoverPercentage :: CoverPercentage -> String +renderCoverPercentage (CoverPercentage percentage) = + printf "%.0f" percentage <> "%" + ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a) ppWhenNonZero suffix n = if n <= 0 then @@ -734,13 +1007,13 @@ annotateSummary :: Summary -> Doc Markup -> Doc Markup annotateSummary summary = if summaryFailed summary > 0 then - icon FailedIcon '✗' . WL.annotate FailedHeader + icon FailedIcon '✗' . WL.annotate FailedText else if summaryGaveUp summary > 0 then - icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader + icon GaveUpIcon '⚐' . WL.annotate GaveUpText else if summaryWaiting summary > 0 || summaryRunning summary > 0 then icon WaitingIcon '○' . WL.annotate WaitingHeader else - icon SuccessIcon '✓' . WL.annotate SuccessHeader + icon SuccessIcon '✓' . WL.annotate SuccessText ppSummary :: MonadIO m => Summary -> m (Doc Markup) ppSummary summary = @@ -811,16 +1084,22 @@ setSGRCode [vivid Red] FailedIcon -> setSGRCode [vivid Red] - FailedHeader -> + FailedText -> setSGRCode [vivid Red] GaveUpIcon -> setSGRCode [dull Yellow] - GaveUpHeader -> + GaveUpText -> setSGRCode [dull Yellow] SuccessIcon -> setSGRCode [dull Green] - SuccessHeader -> + SuccessText -> setSGRCode [dull Green] + CoverageIcon -> + setSGRCode [dull Yellow] + CoverageText -> + setSGRCode [dull Yellow] + CoverageFill -> + setSGRCode [vivid Black] DeclarationLocation -> setSGRCode [] @@ -894,6 +1173,7 @@ hSetEncoding stdout utf8 hSetEncoding stderr utf8 #endif + pure . display . WL.renderSmart 100 $ diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs --- a/src/Hedgehog/Internal/Runner.hs +++ b/src/Hedgehog/Internal/Runner.hs @@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -31,20 +32,24 @@ import Data.Semigroup ((<>)) import Hedgehog.Internal.Config -import Hedgehog.Internal.Gen (runGenT, runDiscardEffect) +import Hedgehog.Internal.Gen (evalGenT) +import Hedgehog.Internal.Property (DiscardCount(..), ShrinkCount(..)) import Hedgehog.Internal.Property (Group(..), GroupName(..)) +import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..)) import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) +import Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT) import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests) -import Hedgehog.Internal.Property (PropertyT(..), Log(..), Failure(..), runTestT) +import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) +import Hedgehog.Internal.Property (coverageSuccess, journalCoverage) import Hedgehog.Internal.Queue import Hedgehog.Internal.Region import Hedgehog.Internal.Report import Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed -import Hedgehog.Internal.Tree (Tree(..), Node(..)) +import Hedgehog.Internal.Tree (TreeT(..), NodeT(..)) import Hedgehog.Range (Size) -import Language.Haskell.TH.Lift (deriveLift) +import Language.Haskell.TH.Syntax (Lift) #if mingw32_HOST_OS import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -65,7 +70,7 @@ -- | How verbose to be in the runner output. 'Nothing' means detect from -- the environment. , runnerVerbosity :: !(Maybe Verbosity) - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Lift) findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b findM xs0 def p = @@ -80,24 +85,24 @@ Just x -> return x -isFailure :: Node m (Maybe (Either x a, b)) -> Bool +isFailure :: NodeT m (Maybe (Either x a, b)) -> Bool isFailure = \case - Node (Just (Left _, _)) _ -> + NodeT (Just (Left _, _)) _ -> True _ -> False -isSuccess :: Node m (Maybe (Either x a, b)) -> Bool +isSuccess :: NodeT m (Maybe (Either x a, b)) -> Bool isSuccess = not . isFailure runTreeN :: Monad m => ShrinkRetries - -> Tree m (Maybe (Either x a, b)) - -> m (Node m (Maybe (Either x a, b))) + -> TreeT m (Maybe (Either x a, b)) + -> m (NodeT m (Maybe (Either x a, b))) runTreeN n m = do - o <- runTree m + o <- runTreeT m if n > 0 && isSuccess o then runTreeN (n - 1) m else @@ -111,18 +116,18 @@ -> ShrinkLimit -> ShrinkRetries -> (Progress -> m ()) - -> Node m (Maybe (Either Failure (), [Log])) + -> NodeT m (Maybe (Either Failure (), Journal)) -> m Result takeSmallest size seed shrinks slimit retries updateUI = \case - Node Nothing _ -> + NodeT Nothing _ -> pure GaveUp - Node (Just (x, w)) xs -> + NodeT (Just (x, (Journal logs))) xs -> case x of Left (Failure loc err mdiff) -> do let failure = - mkFailure size seed shrinks loc err mdiff (reverse w) + mkFailure size seed shrinks Nothing loc err mdiff (reverse logs) updateUI $ Shrinking failure @@ -155,35 +160,56 @@ test = catchAll test0 (fail . show) - loop :: TestCount -> DiscardCount -> Size -> Seed -> m (Report Result) - loop !tests !discards !size !seed = do - updateUI $ Report tests discards Running + loop :: + TestCount + -> DiscardCount + -> Size + -> Seed + -> Coverage CoverCount + -> m (Report Result) + loop !tests !discards !size !seed !coverage0 = do + updateUI $ Report tests discards coverage0 Running if size > 99 then -- size has reached limit, reset to 0 - loop tests discards 0 seed + loop tests discards 0 seed coverage0 else if tests >= fromIntegral (propertyTestLimit cfg) then - -- we've hit the test limit, test was successful - pure $ Report tests discards OK + -- we've hit the test limit + if coverageSuccess tests coverage0 then + -- all classifiers satisfied, test was successful + pure $ Report tests discards coverage0 OK + else + -- some classifiers unsatisfied, test was successful + pure . Report tests discards coverage0 . Failed $ + mkFailure + size + seed + 0 + (Just coverage0) + Nothing + "Insufficient coverage." + Nothing + [] + else if discards >= fromIntegral (propertyDiscardLimit cfg) then -- we've hit the discard limit, give up - pure $ Report tests discards GaveUp + pure $ Report tests discards coverage0 GaveUp else case Seed.split seed of (s0, s1) -> do - node@(Node x _) <- - runTree . runDiscardEffect $ runGenT size s0 . runTestT $ unPropertyT test + node@(NodeT x _) <- + runTreeT . evalGenT size s0 . runTestT $ unPropertyT test case x of Nothing -> - loop tests (discards + 1) (size + 1) s1 + loop tests (discards + 1) (size + 1) s1 coverage0 Just (Left _, _) -> let mkReport = - Report (tests + 1) discards + Report (tests + 1) discards coverage0 in fmap mkReport $ takeSmallest @@ -195,10 +221,14 @@ (updateUI . mkReport) node - Just (Right (), _) -> - loop (tests + 1) discards (size + 1) s1 + Just (Right (), journal) -> + let + coverage = + journalCoverage journal <> coverage0 + in + loop (tests + 1) discards (size + 1) s1 coverage in - loop 0 0 size0 seed0 + loop 0 0 size0 seed0 mempty checkRegion :: MonadIO m @@ -273,6 +303,7 @@ hSetEncoding stdout utf8 hSetEncoding stderr utf8 #endif + putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━" verbosity <- resolveVerbosity (runnerVerbosity config) @@ -401,8 +432,3 @@ , runnerVerbosity = Nothing } - ------------------------------------------------------------------------- --- FIXME Replace with DeriveLift when we drop 7.10 support. - -$(deriveLift ''RunnerConfig) diff --git a/src/Hedgehog/Internal/Source.hs b/src/Hedgehog/Internal/Source.hs --- a/src/Hedgehog/Internal/Source.hs +++ b/src/Hedgehog/Internal/Source.hs @@ -18,13 +18,10 @@ , withFrozenCallStack ) where -#if MIN_VERSION_base(4,9,0) import GHC.Stack (CallStack, HasCallStack, SrcLoc(..)) import GHC.Stack (callStack, getCallStack, withFrozenCallStack) -#else -import GHC.Exts (Constraint) -#endif + newtype LineNo = LineNo { unLineNo :: Int @@ -44,25 +41,7 @@ , spanEndColumn :: !ColumnNo } deriving (Eq, Ord) -#if !MIN_VERSION_base(4,9,0) -type family HasCallStack :: Constraint where - HasCallStack = () - -data CallStack = - CallStack - deriving (Show) - -callStack :: HasCallStack => CallStack -callStack = - CallStack - -withFrozenCallStack :: HasCallStack => (HasCallStack => a) -> a -withFrozenCallStack x = - x -#endif - getCaller :: CallStack -> Maybe Span -#if MIN_VERSION_base(4,9,0) getCaller stack = case getCallStack stack of [] -> @@ -74,10 +53,6 @@ (fromIntegral $ srcLocStartCol x) (fromIntegral $ srcLocEndLine x) (fromIntegral $ srcLocEndCol x) -#else -getCaller _ = - Nothing -#endif ------------------------------------------------------------------------ -- Show instances diff --git a/src/Hedgehog/Internal/State.hs b/src/Hedgehog/Internal/State.hs --- a/src/Hedgehog/Internal/State.hs +++ b/src/Hedgehog/Internal/State.hs @@ -56,27 +56,27 @@ import Control.Monad (foldM, foldM_) import Control.Monad.Catch (MonadCatch) import Control.Monad.State.Class (MonadState, get, put, modify) +import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.State (State, runState, execState) -import Control.Monad.Trans.State (StateT(..), evalStateT) +import Control.Monad.Trans.State (StateT(..), evalStateT, runStateT) import Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep) import Data.Foldable (traverse_) import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..)) -#if MIN_VERSION_transformers(0,5,0) import Data.Functor.Classes (eq1, compare1, showsPrec1) -#endif import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import Data.Typeable (Typeable, TypeRep, Proxy(..), typeRep) -import Hedgehog.Internal.Gen (MonadGen) +import Hedgehog.Internal.Distributive (distributeT) +import Hedgehog.Internal.Gen (MonadGen, GenT, GenBase) import qualified Hedgehog.Internal.Gen as Gen import Hedgehog.Internal.HTraversable (HTraversable(..)) import Hedgehog.Internal.Opaque (Opaque(..)) -import Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith) +import Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith, annotate) import Hedgehog.Internal.Range (Range) import Hedgehog.Internal.Show (showPretty) import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) @@ -92,8 +92,18 @@ showsPrec p (Name x) = showsPrec p x --- | Symbolic values. +-- | Symbolic values: Because hedgehog generates actions in a separate phase +-- before execution, you will sometimes need to refer to the result of a +-- previous action in a generator without knowing the value of the result +-- (e.g., to get the ID of a previously-created user). -- +-- Symmbolic variables provide a token to stand in for the actual variables at +-- generation time (and in 'Require'/'Update' callbacks). At execution time, +-- real values are available, so your execute actions work on 'Concrete' +-- variables. +-- +-- See also: 'Command', 'Var' +-- data Symbolic a where Symbolic :: Typeable a => Name -> Symbolic a @@ -104,7 +114,6 @@ showsPrec p (Symbolic x) = showsPrec p x -#if MIN_VERSION_transformers(0,5,0) instance Show1 Symbolic where liftShowsPrec _ _ p (Symbolic x) = showsPrec p x @@ -116,21 +125,11 @@ instance Ord1 Symbolic where liftCompare _ (Symbolic x) (Symbolic y) = compare x y -#else -instance Show1 Symbolic where - showsPrec1 p (Symbolic x) = - showsPrec p x -instance Eq1 Symbolic where - eq1 (Symbolic x) (Symbolic y) = - x == y - -instance Ord1 Symbolic where - compare1 (Symbolic x) (Symbolic y) = - compare x y -#endif - --- | Concrete values. +-- | Concrete values: At test-execution time, 'Symbolic' values from generation +-- are replaced with 'Concrete' values from performing actions. This type +-- gives us something of the same kind as 'Symbolic' to pass as a type +-- argument to 'Var'. -- newtype Concrete a where Concrete :: a -> Concrete a @@ -140,7 +139,6 @@ showsPrec = showsPrec1 -#if MIN_VERSION_transformers(0,5,0) instance Show1 Concrete where liftShowsPrec sp _ p (Concrete x) = sp p x @@ -152,20 +150,7 @@ instance Ord1 Concrete where liftCompare comp (Concrete x) (Concrete y) = comp x y -#else -instance Show1 Concrete where - showsPrec1 p (Concrete x) = - showsPrec p x -instance Eq1 Concrete where - eq1 (Concrete x) (Concrete y) = - x == y - -instance Ord1 Concrete where - compare1 (Concrete x) (Concrete y) = - compare x y -#endif - ------------------------------------------------------------------------ -- | Variables are the potential or actual result of executing an action. They @@ -185,7 +170,10 @@ -- type of variable because it is used in both the generation and the -- execution phase. -- -data Var a v = +-- The order of arguments makes 'Var' 'HTraverable', which is how 'Symbolic' +-- values are turned into 'Concrete' ones. +-- +newtype Var a v = Var (v a) -- | Take the value from a concrete variable. @@ -241,6 +229,10 @@ emptyEnvironment = Environment Map.empty +unionsEnvironment :: [Environment] -> Environment +unionsEnvironment = + Environment . Map.unions . fmap unEnvironment + -- | Insert a symbolic / concrete pairing in to the environment. -- insertConcrete :: Symbolic a -> Concrete a -> Environment -> Environment @@ -375,18 +367,24 @@ ------------------------------------------------------------------------ --- | The specification for the expected behaviour of an 'Action'. +-- | The specification for the expected behaviour of an +-- 'Action'. These are used to generate sequences of actions to test. -- -data Command n m (state :: (* -> *) -> *) = +-- This is the main type you will use when writing state machine +-- tests. @gen@ is usually an instance of 'MonadGen', and @m@ is usually +-- an instance of 'MonadTest'. These constraints appear when you pass +-- your 'Command' list to 'sequential' or 'parallel'. +-- +data Command gen m (state :: (* -> *) -> *) = forall input output. - (HTraversable input, Show (input Symbolic), Typeable output) => + (HTraversable input, Show (input Symbolic), Show output, Typeable output) => Command { -- | A generator which provides random arguments for a command. If the -- command cannot be executed in the current state, it should return -- 'Nothing'. -- commandGen :: - state Symbolic -> Maybe (n (input Symbolic)) + state Symbolic -> Maybe (gen (input Symbolic)) -- | Executes a command using the arguments generated by 'commandGen'. -- @@ -402,7 +400,7 @@ -- | Checks that input for a command can be executed in the given state. -- -commandGenOK :: Command n m state -> state Symbolic -> Bool +commandGenOK :: Command gen m state -> state Symbolic -> Bool commandGenOK (Command inputGen _ _) state = Maybe.isJust (inputGen state) @@ -411,7 +409,7 @@ -- data Action m (state :: (* -> *) -> *) = forall input output. - (HTraversable input, Show (input Symbolic)) => + (HTraversable input, Show (input Symbolic), Show output) => Action { actionInput :: input Symbolic @@ -536,11 +534,11 @@ -- | Generates a single action from a set of possible commands. -- action :: - (MonadGen n, MonadTest m) - => [Command n m state] - -> StateT (Context state) n (Action m state) + (MonadGen gen, MonadTest m) + => [Command gen m state] + -> GenT (StateT (Context state) (GenBase gen)) (Action m state) action commands = - Gen.just $ do + Gen.justT $ do Context state0 _ <- get Command mgenInput exec callbacks <- @@ -550,8 +548,8 @@ case mgenInput state0 of Nothing -> error "genCommand: internal error, tried to use generator with invalid state." - Just g -> - lift g + Just gen -> + hoist lift $ Gen.toGenT gen if not $ callbackRequire callbacks state0 input then pure Nothing @@ -569,13 +567,13 @@ (callbackEnsure callbacks) genActions :: - (MonadGen n, MonadTest m) + (MonadGen gen, MonadTest m) => Range Int - -> [Command n m state] + -> [Command gen m state] -> Context state - -> n ([Action m state], Context state) + -> gen ([Action m state], Context state) genActions range commands ctx = do - xs <- Gen.list range (action commands) `evalStateT` ctx + xs <- Gen.fromGenT . (`evalStateT` ctx) . distributeT $ Gen.list range (action commands) pure $ dropInvalid xs `runState` ctx @@ -603,6 +601,33 @@ (prefix0 ++ x) : fmap (prefix ++) xs +renderActionResult :: Environment -> Action m state -> [String] +renderActionResult env (Action _ output@(Symbolic (Name name)) _ _ _ _) = + let + prefix0 = + "Var " ++ show name ++ " = " + + prefix = + replicate (length prefix0) ' ' + + unfound = \case + EnvironmentValueNotFound _ + -> "<>" + EnvironmentTypeError _ _ + -> "<>" + + actual = + either unfound showPretty + $ reifyEnvironment env output + + in + case lines actual of + [] -> + [prefix0 ++ "?"] + x : xs -> + (prefix0 ++ x) : + fmap (prefix ++) xs + -- FIXME we should not abuse Show to get nice output for actions instance Show (Sequential m state) where show (Sequential xs) = @@ -611,11 +636,11 @@ -- | Generates a sequence of actions from an initial model state and set of commands. -- sequential :: - (MonadGen n, MonadTest m) + (MonadGen gen, MonadTest m) => Range Int -> (forall v. state v) - -> [Command n m state] - -> n (Sequential m state) + -> [Command gen m state] + -> gen (Sequential m state) sequential range initial commands = fmap (Sequential . fst) $ genActions range commands (mkContext initial) @@ -636,27 +661,32 @@ -- FIXME we should not abuse Show to get nice output for actions instance Show (Parallel m state) where - show (Parallel pre xs ys) = - unlines $ concat [ - ["━━━ Prefix ━━━"] - , (concatMap renderAction pre) - , ["", "━━━ Branch 1 ━━━"] - , (concatMap renderAction xs) - , ["", "━━━ Branch 2 ━━━"] - , (concatMap renderAction ys) - ] + show = + renderParallel renderAction +renderParallel :: (Action m state -> [String]) -> Parallel m state -> String +renderParallel render (Parallel pre xs ys) = + unlines $ concat [ + ["━━━ Prefix ━━━"] + , concatMap render pre + , ["", "━━━ Branch 1 ━━━"] + , concatMap render xs + , ["", "━━━ Branch 2 ━━━"] + , concatMap render ys + ] + + -- | Given the initial model state and set of commands, generates prefix -- actions to be run sequentially, followed by two branches to be run in -- parallel. -- parallel :: - (MonadGen n, MonadTest m) + (MonadGen gen, MonadTest m) => Range Int -> Range Int -> (forall v. state v) - -> [Command n m state] - -> n (Parallel m state) + -> [Command gen m state] + -> gen (Parallel m state) parallel prefixN parallelN initial commands = do (prefix, ctx0) <- genActions prefixN commands (mkContext initial) (branch1, ctx1) <- genActions parallelN commands ctx0 @@ -792,13 +822,17 @@ => (forall v. state v) -> Parallel m state -> m () -executeParallel initial (Parallel prefix branch1 branch2) = +executeParallel initial p@(Parallel prefix branch1 branch2) = withFrozenCallStack $ evalM $ do (s0, env0) <- foldM executeUpdateEnsure (initial, emptyEnvironment) prefix - (xs, ys) <- + ((xs, env1), (ys, env2)) <- Async.concurrently - (evalStateT (traverse execute branch1) env0) - (evalStateT (traverse execute branch2) env0) + (runStateT (traverse execute branch1) env0) + (runStateT (traverse execute branch2) env0) + let + env = unionsEnvironment [env0, env1, env2] + + annotate $ renderParallel (renderActionResult env) p linearize s0 xs ys diff --git a/src/Hedgehog/Internal/TH.hs b/src/Hedgehog/Internal/TH.hs --- a/src/Hedgehog/Internal/TH.hs +++ b/src/Hedgehog/Internal/TH.hs @@ -4,6 +4,7 @@ module Hedgehog.Internal.TH ( TExpQ , discover + , discoverPrefix ) where import qualified Data.List as List @@ -24,9 +25,12 @@ -- Functions starting with `prop_` are assumed to be properties. -- discover :: TExpQ Group -discover = do +discover = discoverPrefix "prop_" + +discoverPrefix :: String -> TExpQ Group +discoverPrefix prefix = do file <- getCurrentFile - properties <- Map.toList <$> runIO (readProperties file) + properties <- Map.toList <$> runIO (readProperties prefix file) let startLine = diff --git a/src/Hedgehog/Internal/Tree.hs b/src/Hedgehog/Internal/Tree.hs --- a/src/Hedgehog/Internal/Tree.hs +++ b/src/Hedgehog/Internal/Tree.hs @@ -1,16 +1,29 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- MonadBase module Hedgehog.Internal.Tree ( - Tree(..) - , Node(..) + Tree + , pattern Tree + , TreeT(..) + , runTree + , mapTreeT + , treeValue + , treeChildren - , fromNode + , Node + , pattern Node + , NodeT(..) + , fromNodeT , unfold , unfoldForest @@ -18,228 +31,484 @@ , expand , prune + , catMaybes + , filter + , filterMaybeT + , filterT + , depth + , interleave + , render + , renderT ) where -import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus(..), ap, join) +import Control.Applicative (Alternative(..), liftA2) +import Control.Monad (MonadPlus(..), join) import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Trans.Control () import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Morph (MFunctor(..), MMonad(..)) +import Control.Monad.Morph (MFunctor(..), MMonad(..), generalize) import Control.Monad.Primitive (PrimMonad(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Resource (MonadResource(..)) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Zip (MonadZip(..)) -#if MIN_VERSION_base(4,9,0) +import Data.Functor.Identity (Identity(..)) +import Data.Functor.Classes (Eq1(..)) import Data.Functor.Classes (Show1(..), showsPrec1) import Data.Functor.Classes (showsUnaryWith, showsBinaryWith) -#endif +import qualified Data.Maybe as Maybe import Hedgehog.Internal.Distributive +import Prelude hiding (filter) + ------------------------------------------------------------------------ +-- | A rose tree. +-- +type Tree = + TreeT Identity + +-- | Pattern to ease construction / deconstruction of pure trees. +-- +pattern Tree :: NodeT Identity a -> Tree a +pattern Tree node = + TreeT (Identity node) +{-# COMPLETE Tree #-} + -- | An effectful tree, each node in the tree can have an effect before it is -- produced. -- -newtype Tree m a = - Tree { - runTree :: m (Node m a) +newtype TreeT m a = + TreeT { + runTreeT :: m (NodeT m a) } +-- | A node in a rose tree. +-- +type Node = + NodeT Identity +{-# COMPLETE Node #-} + +-- | Pattern to ease construction / deconstruction of pure nodes. +-- +pattern Node :: a -> [Tree a] -> Node a +pattern Node x xs = + NodeT x xs + -- | A node in an effectful tree, as well as its unevaluated children. -- -data Node m a = - Node { +data NodeT m a = + NodeT { + -- | The value at this 'NodeT' in the 'TreeT'. nodeValue :: a - , nodeChildren :: [Tree m a] - } --- | Create a 'Tree' from a 'Node' + -- | The children of this 'NodeT'. + , nodeChildren :: [TreeT m a] + } deriving (Eq) + +-- | Extracts the 'Node' from a 'Tree'. -- -fromNode :: Applicative m => Node m a -> Tree m a -fromNode = - Tree . pure +runTree :: Tree a -> Node a +runTree = + runIdentity . runTreeT +-- | Map between 'TreeT' computations. +-- +mapTreeT :: (m (NodeT m a) -> m (NodeT m a)) -> TreeT m a -> TreeT m a +mapTreeT f = + TreeT . f . runTreeT + +-- | Create a 'TreeT' from a 'NodeT' +-- +fromNodeT :: Applicative m => NodeT m a -> TreeT m a +fromNodeT = + TreeT . pure + +-- | The value at the root of the 'Tree'. +-- +treeValue :: Tree a -> a +treeValue = + nodeValue . runTree + +-- | The children of the 'Tree'. +-- +treeChildren :: Tree a -> [Tree a] +treeChildren = + nodeChildren . runTree + -- | Create a tree from a value and an unfolding function. -- -unfold :: Monad m => (a -> [a]) -> a -> Tree m a +unfold :: Monad m => (a -> [a]) -> a -> TreeT m a unfold f x = - Tree . pure $ - Node x (unfoldForest f x) + TreeT . pure $ + NodeT x (unfoldForest f x) -- | Create a forest from a value and an unfolding function. -- -unfoldForest :: Monad m => (a -> [a]) -> a -> [Tree m a] +unfoldForest :: Monad m => (a -> [a]) -> a -> [TreeT m a] unfoldForest f = fmap (unfold f) . f -- | Expand a tree using an unfolding function. -- -expand :: Monad m => (a -> [a]) -> Tree m a -> Tree m a +expand :: Monad m => (a -> [a]) -> TreeT m a -> TreeT m a expand f m = - Tree $ do - Node x xs <- runTree m - pure . Node x $ + TreeT $ do + NodeT x xs <- runTreeT m + pure . NodeT x $ fmap (expand f) xs ++ unfoldForest f x --- | Throw away a tree's children. +-- | Throw away @n@ levels of a tree's children. -- -prune :: Monad m => Tree m a -> Tree m a -prune m = - Tree $ do - Node x _ <- runTree m - pure $ Node x [] +-- /@prune 0@ will throw away all of a tree's children./ +-- +prune :: Monad m => Int -> TreeT m a -> TreeT m a +prune n m = + if n <= 0 then + TreeT $ do + NodeT x _ <- runTreeT m + pure $ NodeT x [] + else + TreeT $ do + NodeT x xs0 <- runTreeT m + pure . NodeT x $ + fmap (prune (n - 1)) xs0 +-- | Returns the depth of the deepest leaf node in the tree. +-- +depth :: Tree a -> Int +depth m = + let + NodeT _ xs = + runTree m + + n = + if null xs then + 0 + else + maximum (fmap depth xs) + in + 1 + n + +-- | Takes a tree of 'Maybe's and returns a tree of all the 'Just' values. +-- +-- If the root of the tree is 'Nothing' then 'Nothing' is returned. +-- +catMaybes :: Tree (Maybe a) -> Maybe (Tree a) +catMaybes m = + let + NodeT mx mxs = + runTree m + in + case mx of + Nothing -> do + case Maybe.mapMaybe catMaybes mxs of + [] -> + Nothing + Tree (NodeT x xs0) : xs1 -> + Just . Tree $ + Node x (xs0 ++ xs1) + Just x -> + Just . Tree $ + Node x (Maybe.mapMaybe catMaybes mxs) + +-- | Returns a tree containing only elements that match the predicate. +-- +-- If the root of the tree does not match the predicate then 'Nothing' is +-- returned. +-- +filter :: (a -> Bool) -> Tree a -> Maybe (Tree a) +filter p = + catMaybes . + runTreeMaybeT . + filterMaybeT p . + hoist lift + +runTreeMaybeT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a) +runTreeMaybeT = + runMaybeT . + distributeT + +-- | Returns a tree containing only elements that match the predicate. +-- +-- If the root of the tree does not match the predicate then 'Nothing' is +-- returned. +-- +filterMaybeT :: (a -> Bool) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a +filterMaybeT p t = + case runTreeMaybeT t of + Tree (Node Nothing _) -> + TreeT . MaybeT . Identity $ Nothing + Tree (Node (Just x) xs) -> + hoist generalize $ + Tree . Node x $ + concatMap (flattenTree (maybe False p)) xs + +flattenTree :: (Maybe a -> Bool) -> Tree (Maybe a) -> [Tree a] +flattenTree p (Tree (Node mx mxs0)) = + let + mxs = + concatMap (flattenTree p) mxs0 + in + if p mx then + case mx of + Nothing -> + [] + Just x -> + [Tree (Node x mxs)] + else + mxs + +-- | Returns a tree containing only elements that match the predicate. +-- +-- When an element does not match the predicate its node is replaced with +-- 'empty'. +-- +filterT :: (Monad m, Alternative m) => (a -> Bool) -> TreeT m a -> TreeT m a +filterT p m = + TreeT $ do + NodeT x xs <- runTreeT m + if p x then + pure $ + NodeT x (fmap (filterT p) xs) + else + empty + ------------------------------------------------------------------------ --- Node/Tree instances -instance Functor m => Functor (Node m) where - fmap f (Node x xs) = - Node (f x) (fmap (fmap f) xs) +-- | All ways a list can be split +-- +-- > splits [1,2,3] +-- > == +-- > [ ([], 1, [2, 3]) +-- , ([1], 2, [3]) +-- , ([1, 2], 3, []) +-- ] +-- +splits :: [a] -> [([a], a, [a])] +splits = \case + [] -> + [] + x : xs -> + ([], x, xs) : + fmap (\(as, b, cs) -> (x : as, b, cs)) (splits xs) -instance Functor m => Functor (Tree m) where +dropOne :: Monad m => [NodeT m a] -> [TreeT m [a]] +dropOne ts = do + (xs, _y, zs) <- splits ts + pure . TreeT . pure $ + interleave (xs ++ zs) + +shrinkOne :: Monad m => [NodeT m a] -> [TreeT m [a]] +shrinkOne ts = do + (xs, y0, zs) <- splits ts + y1 <- nodeChildren y0 + pure . TreeT $ do + y2 <- runTreeT y1 + pure $ + interleave (xs ++ [y2] ++ zs) + +interleave :: forall m a. Monad m => [NodeT m a] -> NodeT m [a] +interleave ts = + NodeT (fmap nodeValue ts) $ + concat [ + dropOne ts + , shrinkOne ts + ] + +------------------------------------------------------------------------ + +instance Foldable Tree where + foldMap f (TreeT mx) = + foldMap f (runIdentity mx) + +instance Foldable Node where + foldMap f (NodeT x xs) = + f x `mappend` mconcat (fmap (foldMap f) xs) + +instance Traversable Tree where + traverse f (TreeT mx) = + TreeT <$> traverse (traverse f) mx + +instance Traversable Node where + traverse f (NodeT x xs) = + NodeT <$> f x <*> traverse (traverse f) xs + +------------------------------------------------------------------------ +-- NodeT/TreeT instances + +instance (Eq1 m, Eq a) => Eq (TreeT m a) where + TreeT m0 == TreeT m1 = + liftEq (==) m0 m1 + +instance Functor m => Functor (NodeT m) where + fmap f (NodeT x xs) = + NodeT (f x) (fmap (fmap f) xs) + +instance Functor m => Functor (TreeT m) where fmap f = - Tree . fmap (fmap f) . runTree + TreeT . fmap (fmap f) . runTreeT -instance Monad m => Applicative (Node m) where - pure = - return - (<*>) = - ap +instance Applicative m => Applicative (NodeT m) where + pure x = + NodeT x [] + (<*>) (NodeT ab tabs) na@(NodeT a tas) = + NodeT (ab a) $ + map (<*> (fromNodeT na)) tabs ++ map (fmap ab) tas -instance Monad m => Applicative (Tree m) where +instance Applicative m => Applicative (TreeT m) where pure = - return - (<*>) = - ap + TreeT . pure . pure + (<*>) (TreeT mab) (TreeT ma) = + TreeT $ + liftA2 (<*>) mab ma -instance Monad m => Monad (Node m) where - return x = - Node x [] +instance Monad m => Monad (NodeT m) where + return = + pure - (>>=) (Node x xs) k = + (>>=) (NodeT x xs) k = case k x of - Node y ys -> - Node y $ - fmap (Tree . fmap (>>= k) . runTree) xs ++ ys + NodeT y ys -> + NodeT y $ + fmap (TreeT . fmap (>>= k) . runTreeT) xs ++ ys -instance Monad m => Monad (Tree m) where - return x = - Tree . pure $ Node x [] +instance Monad m => Monad (TreeT m) where + return = + pure (>>=) m k = - Tree $ do - Node x xs <- runTree m - Node y ys <- runTree (k x) - pure . Node y $ + TreeT $ do + NodeT x xs <- runTreeT m + NodeT y ys <- runTreeT (k x) + pure . NodeT y $ fmap (>>= k) xs ++ ys -instance MonadPlus m => Alternative (Tree m) where +instance Alternative m => Alternative (TreeT m) where empty = - mzero - (<|>) = - mplus + TreeT empty + (<|>) x y = + TreeT (runTreeT x <|> runTreeT y) -instance MonadPlus m => MonadPlus (Tree m) where +instance MonadPlus m => MonadPlus (TreeT m) where mzero = - Tree mzero + TreeT mzero mplus x y = - Tree (runTree x `mplus` runTree y) + TreeT (runTreeT x `mplus` runTreeT y) -instance MonadTrans Tree where - lift m = - Tree $ do - x <- m - pure (Node x []) +zipTreeT :: forall f a b. Applicative f => TreeT f a -> TreeT f b -> TreeT f (a, b) +zipTreeT l0@(TreeT left) r0@(TreeT right) = + TreeT $ + let + zipNodeT :: NodeT f a -> NodeT f b -> NodeT f (a, b) + zipNodeT (NodeT a ls) (NodeT b rs) = + NodeT (a, b) $ + concat [ + [zipTreeT l1 r0 | l1 <- ls] + , [zipTreeT l0 r1 | r1 <- rs] + ] + in + zipNodeT <$> left <*> right -instance MFunctor Node where - hoist f (Node x xs) = - Node x (fmap (hoist f) xs) +instance Monad m => MonadZip (TreeT m) where + mzip = + zipTreeT -instance MFunctor Tree where - hoist f (Tree m) = - Tree . f $ fmap (hoist f) m +instance MonadTrans TreeT where + lift f = + TreeT $ + fmap (\x -> NodeT x []) f -embedNode :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Node t b -> Node m b -embedNode f (Node x xs) = - Node x (fmap (embedTree f) xs) +instance MFunctor NodeT where + hoist f (NodeT x xs) = + NodeT x (fmap (hoist f) xs) -embedTree :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Tree t b -> Tree m b -embedTree f (Tree m) = - Tree . pure . embedNode f =<< f m +instance MFunctor TreeT where + hoist f (TreeT m) = + TreeT . f $ fmap (hoist f) m -instance MMonad Tree where +embedNodeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b +embedNodeT f (NodeT x xs) = + NodeT x (fmap (embedTreeT f) xs) + +embedTreeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b +embedTreeT f (TreeT m) = + TreeT . pure . embedNodeT f =<< f m + +instance MMonad TreeT where embed f m = - embedTree f m + embedTreeT f m -distributeNode :: Transformer t Tree m => Node (t m) a -> t (Tree m) a -distributeNode (Node x xs) = - join . lift . fromNode . Node (pure x) $ - fmap (pure . distributeTree) xs +distributeNodeT :: Transformer t TreeT m => NodeT (t m) a -> t (TreeT m) a +distributeNodeT (NodeT x xs) = + join . lift . fromNodeT . NodeT (pure x) $ + fmap (pure . distributeTreeT) xs -distributeTree :: Transformer t Tree m => Tree (t m) a -> t (Tree m) a -distributeTree x = - distributeNode =<< hoist lift (runTree x) +distributeTreeT :: Transformer t TreeT m => TreeT (t m) a -> t (TreeT m) a +distributeTreeT x = + distributeNodeT =<< hoist lift (runTreeT x) -instance Distributive Tree where - distribute = - distributeTree +instance MonadTransDistributive TreeT where + distributeT = + distributeTreeT -instance PrimMonad m => PrimMonad (Tree m) where - type PrimState (Tree m) = +instance PrimMonad m => PrimMonad (TreeT m) where + type PrimState (TreeT m) = PrimState m primitive = lift . primitive -instance MonadIO m => MonadIO (Tree m) where +instance MonadIO m => MonadIO (TreeT m) where liftIO = lift . liftIO -instance MonadBase b m => MonadBase b (Tree m) where +instance MonadBase b m => MonadBase b (TreeT m) where liftBase = lift . liftBase -instance MonadThrow m => MonadThrow (Tree m) where +instance MonadThrow m => MonadThrow (TreeT m) where throwM = lift . throwM -handleNode :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Node m a -> Node m a -handleNode onErr (Node x xs) = - Node x $ - fmap (handleTree onErr) xs +handleNodeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> NodeT m a -> NodeT m a +handleNodeT onErr (NodeT x xs) = + NodeT x $ + fmap (handleTreeT onErr) xs -handleTree :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Tree m a -> Tree m a -handleTree onErr m = - Tree . fmap (handleNode onErr) $ - catch (runTree m) (runTree . onErr) +handleTreeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> TreeT m a -> TreeT m a +handleTreeT onErr m = + TreeT . fmap (handleNodeT onErr) $ + catch (runTreeT m) (runTreeT . onErr) -instance MonadCatch m => MonadCatch (Tree m) where +instance MonadCatch m => MonadCatch (TreeT m) where catch = - flip handleTree + flip handleTreeT -localNode :: MonadReader r m => (r -> r) -> Node m a -> Node m a -localNode f (Node x xs) = - Node x $ - fmap (localTree f) xs +localNodeT :: MonadReader r m => (r -> r) -> NodeT m a -> NodeT m a +localNodeT f (NodeT x xs) = + NodeT x $ + fmap (localTreeT f) xs -localTree :: MonadReader r m => (r -> r) -> Tree m a -> Tree m a -localTree f (Tree m) = - Tree $ - pure . localNode f =<< local f m +localTreeT :: MonadReader r m => (r -> r) -> TreeT m a -> TreeT m a +localTreeT f (TreeT m) = + TreeT $ + pure . localNodeT f =<< local f m -instance MonadReader r m => MonadReader r (Tree m) where +instance MonadReader r m => MonadReader r (TreeT m) where ask = lift ask local = - localTree + localTreeT -instance MonadState s m => MonadState s (Tree m) where +instance MonadState s m => MonadState s (TreeT m) where get = lift get put = @@ -247,72 +516,71 @@ state = lift . state -listenNode :: MonadWriter w m => w -> Node m a -> Node m (a, w) -listenNode w (Node x xs) = - Node (x, w) $ - fmap (listenTree w) xs +listenNodeT :: MonadWriter w m => w -> NodeT m a -> NodeT m (a, w) +listenNodeT w (NodeT x xs) = + NodeT (x, w) $ + fmap (listenTreeT w) xs -listenTree :: MonadWriter w m => w -> Tree m a -> Tree m (a, w) -listenTree w0 (Tree m) = - Tree $ do +listenTreeT :: MonadWriter w m => w -> TreeT m a -> TreeT m (a, w) +listenTreeT w0 (TreeT m) = + TreeT $ do (x, w) <- listen m - pure $ listenNode (mappend w0 w) x + pure $ listenNodeT (mappend w0 w) x -- FIXME This just throws away the writer modification function. -passNode :: MonadWriter w m => Node m (a, w -> w) -> Node m a -passNode (Node (x, _) xs) = - Node x $ - fmap passTree xs +passNodeT :: MonadWriter w m => NodeT m (a, w -> w) -> NodeT m a +passNodeT (NodeT (x, _) xs) = + NodeT x $ + fmap passTreeT xs -passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a -passTree (Tree m) = - Tree $ - pure . passNode =<< m +passTreeT :: MonadWriter w m => TreeT m (a, w -> w) -> TreeT m a +passTreeT (TreeT m) = + TreeT $ + pure . passNodeT =<< m -instance MonadWriter w m => MonadWriter w (Tree m) where +instance MonadWriter w m => MonadWriter w (TreeT m) where writer = lift . writer tell = lift . tell listen = - listenTree mempty + listenTreeT mempty pass = - passTree + passTreeT -handleErrorNode :: MonadError e m => (e -> Tree m a) -> Node m a -> Node m a -handleErrorNode onErr (Node x xs) = - Node x $ - fmap (handleErrorTree onErr) xs +handleErrorNodeT :: MonadError e m => (e -> TreeT m a) -> NodeT m a -> NodeT m a +handleErrorNodeT onErr (NodeT x xs) = + NodeT x $ + fmap (handleErrorTreeT onErr) xs -handleErrorTree :: MonadError e m => (e -> Tree m a) -> Tree m a -> Tree m a -handleErrorTree onErr m = - Tree . fmap (handleErrorNode onErr) $ - catchError (runTree m) (runTree . onErr) +handleErrorTreeT :: MonadError e m => (e -> TreeT m a) -> TreeT m a -> TreeT m a +handleErrorTreeT onErr m = + TreeT . fmap (handleErrorNodeT onErr) $ + catchError (runTreeT m) (runTreeT . onErr) -instance MonadError e m => MonadError e (Tree m) where +instance MonadError e m => MonadError e (TreeT m) where throwError = lift . throwError catchError = - flip handleErrorTree + flip handleErrorTreeT -instance MonadResource m => MonadResource (Tree m) where +instance MonadResource m => MonadResource (TreeT m) where liftResourceT = lift . liftResourceT ------------------------------------------------------------------------ -- Show/Show1 instances -#if MIN_VERSION_base(4,9,0) -instance (Show1 m, Show a) => Show (Node m a) where +instance (Show1 m, Show a) => Show (NodeT m a) where showsPrec = showsPrec1 -instance (Show1 m, Show a) => Show (Tree m a) where +instance (Show1 m, Show a) => Show (TreeT m a) where showsPrec = showsPrec1 -instance Show1 m => Show1 (Node m) where - liftShowsPrec sp sl d (Node x xs) = +instance Show1 m => Show1 (NodeT m) where + liftShowsPrec sp sl d (NodeT x xs) = let sp1 = liftShowsPrec sp sl @@ -323,10 +591,10 @@ sp2 = liftShowsPrec sp1 sl1 in - showsBinaryWith sp sp2 "Node" d x xs + showsBinaryWith sp sp2 "NodeT" d x xs -instance Show1 m => Show1 (Tree m) where - liftShowsPrec sp sl d (Tree m) = +instance Show1 m => Show1 (TreeT m) where + liftShowsPrec sp sl d (TreeT m) = let sp1 = liftShowsPrec sp sl @@ -337,8 +605,7 @@ sp2 = liftShowsPrec sp1 sl1 in - showsUnaryWith sp2 "Tree" d m -#endif + showsUnaryWith sp2 "TreeT" d m ------------------------------------------------------------------------ -- Pretty Printing @@ -347,22 +614,22 @@ -- Rendering implementation based on the one from containers/Data.Tree -- -renderTreeLines :: Monad m => Tree m String -> m [String] -renderTreeLines (Tree m) = do - Node x xs0 <- m +renderTreeTLines :: Monad m => TreeT m String -> m [String] +renderTreeTLines (TreeT m) = do + NodeT x xs0 <- m xs <- renderForestLines xs0 pure $ - lines (renderNode x) ++ xs + lines (renderNodeT x) ++ xs -renderNode :: String -> String -renderNode xs = +renderNodeT :: String -> String +renderNodeT xs = case xs of [_] -> ' ' : xs _ -> xs -renderForestLines :: Monad m => [Tree m String] -> m [String] +renderForestLines :: Monad m => [TreeT m String] -> m [String] renderForestLines xs0 = let shift hd other = @@ -373,18 +640,25 @@ pure [] [x] -> do - s <- renderTreeLines x + s <- renderTreeTLines x pure $ shift " └╼" " " s x : xs -> do - s <- renderTreeLines x + s <- renderTreeTLines x ss <- renderForestLines xs pure $ shift " ├╼" " │ " s ++ ss +-- | Render a tree of strings. +-- +render :: Tree String -> String +render = + runIdentity . renderT + -- | Render a tree of strings, note that this forces all the delayed effects in -- the tree. -render :: Monad m => Tree m String -> m String -render = - fmap unlines . renderTreeLines +-- +renderT :: Monad m => TreeT m String -> m String +renderT = + fmap unlines . renderTreeTLines diff --git a/src/Hedgehog/Internal/Tripping.hs b/src/Hedgehog/Internal/Tripping.hs --- a/src/Hedgehog/Internal/Tripping.hs +++ b/src/Hedgehog/Internal/Tripping.hs @@ -3,13 +3,24 @@ tripping ) where -import Hedgehog.Internal.Property -import Hedgehog.Internal.Show -import Hedgehog.Internal.Source +import Hedgehog.Internal.Property (MonadTest, Diff(..), success, failWith) +import Hedgehog.Internal.Show (valueDiff, mkValue, showPretty) +import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) -- | Test that a pair of encode / decode functions are compatible. -- +-- Given a printer from some type 'a -> b', and a parser with a +-- potential failure case 'b -> f a'. Ensure that a valid 'a' round +-- trips through the "print" and "parse" to yield the same 'a'. +-- +-- For example, types __should__ have tripping 'Read' and 'Show' +-- instances. +-- +-- @ +-- trippingShowRead :: (Show a, Read a, Eq a, MonadTest m) => a -> m () +-- trippingShowRead a = tripping a show readEither +-- @ tripping :: (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack) => a @@ -45,7 +56,8 @@ Just diff -> withFrozenCallStack $ failWith - (Just $ Diff "━━━ " "- Original" "/" "+ Roundtrip" " ━━━" diff) $ + (Just $ + Diff "━━━ " "- Original" ") (" "+ Roundtrip" " ━━━" diff) $ unlines [ "━━━ Intermediate ━━━" , showPretty i diff --git a/src/Hedgehog/Main.hs b/src/Hedgehog/Main.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Main.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +module Hedgehog.Main ( + -- * Running tests + defaultMain + ) where + +import Control.Monad (unless) + +import System.Exit (exitFailure) +import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout) + +-- | An entry point that can be used as a main function. +-- +defaultMain :: [IO Bool] -> IO () +defaultMain tests = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + result <- and <$> sequence tests + unless result + exitFailure diff --git a/test/Test/Hedgehog/Applicative.hs b/test/Test/Hedgehog/Applicative.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hedgehog/Applicative.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +module Test.Hedgehog.Applicative where + +import Control.Monad.Morph (hoist) +import Control.Monad.State.Class (MonadState(..), modify) +import qualified Control.Monad.Trans.State.Lazy as Lazy + +import Data.Foldable (traverse_) +import qualified Data.List as List +import qualified Data.Map as Map + +import Hedgehog hiding (Command, Var) +import qualified Hedgehog.Range as Range + +import qualified Hedgehog.Internal.Gen as Gen +import qualified Hedgehog.Internal.Tree as Tree + + +newtype Var = + Var Int + deriving (Eq, Ord, Show) + +data Command = + Add + | Remove + deriving (Eq, Ord, Show) + +data a :<- b = + a :<- b + deriving (Eq, Ord, Show) + +takeVar :: a :<- b -> a +takeVar (var :<- _) = + var + +genVar :: (MonadState Int m, MonadGen m) => m Var +genVar = do + modify (+1) + Var <$> get + +genCommand :: MonadGen m => m Command +genCommand = + Gen.element [Add, Remove] + +genCommands :: (MonadState Int m, MonadGen m) => m [Var :<- Command] +genCommands = + Gen.list (Range.constant 0 3) $ do + var <- genVar + cmd <- genCommand + pure $ + var :<- cmd + +-- | Uncomment to observe invalid Applicative behaviour +-- +-- /This actually also works, if you comment out the ApplicativeDo above./ +-- +xprop_StateT_inside :: Property +xprop_StateT_inside = + propVars $ hoist (`Lazy.evalStateT` 0) genCommands + +prop_StateT_outside :: Property +prop_StateT_outside = + propVars . (`Lazy.evalStateT` 0) $ distributeT genCommands + +propVars :: Gen [Var :<- Command] -> Property +propVars gen = + property $ do + let + + tree <- + forAllWith (Tree.render . fmap show . Tree.prune 3) $ + Gen.toTree gen + + let + noDuplicates xs = + let + sorted = + List.sort xs + + unique = + Map.elems (Map.fromList (fmap (\x -> (takeVar x, x)) xs)) + + varsEq ys zs = + fmap takeVar ys == + fmap takeVar zs + in + diff sorted varsEq unique + + traverse_ noDuplicates tree + +tests :: IO Bool +tests = + checkParallel $$(discover) diff --git a/test/Test/Hedgehog/Filter.hs b/test/Test/Hedgehog/Filter.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hedgehog/Filter.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module Test.Hedgehog.Filter where + +import Data.Foldable (toList) +import qualified Data.Set as Set + +import Hedgehog +import qualified Hedgehog.Range as Range + +import qualified Hedgehog.Internal.Gen as Gen +import Hedgehog.Internal.Tree (NodeT(..)) +import qualified Hedgehog.Internal.Tree as Tree + +-- | Prevent this bug from returning: +-- +-- https://stackoverflow.com/questions/54412108/why-the-does-this-shrink-tree-looks-the-way-it-does-when-using-filter +-- +-- I'm trying to understand what is the effect that filter has in the shrink +-- tree of a generator when using _integrated shrinking_. +-- +-- Consider the following function: +-- +-- @ +-- {-# LANGUAGE OverloadedStrings #-} +-- +-- import Hedgehog +-- import qualified Hedgehog.Gen as Gen +-- +-- genChar:: Gen Char +-- genChar = +-- Gen.filter (`elem` ("x" :: String)) (Gen.element "yx") +-- +-- @ +-- +-- When a print the shrink tree: +-- +-- @ +-- >>> Gen.printTree genChar +-- @ +-- +-- I'd get shrink trees that look as follow: +-- +-- @ +-- 'x' +-- └╼'x' +-- └╼'x' +-- └╼'x' +-- ... +-- +-- └╼ +-- @ +-- +-- This is, a very deep tree containing only @x@'s, and a @discard@ at the +-- end. +-- +prop_filter_repetition :: Property +prop_filter_repetition = + property $ do + let + genChar:: Gen Char + genChar = + Gen.filter (`elem` ("x" :: String)) (Gen.element "yx") + + tree <- forAllWith (Tree.render . fmap show . Tree.prune 10) (Gen.toTree genChar) + Tree.depth tree === 1 + +prop_filter_even :: Property +prop_filter_even = + property $ do + let + genEven :: Gen Int + genEven = + Gen.filter even (Gen.int (Range.constant 0 8)) + + tree <- forAllWith (Tree.render . fmap show . Tree.prune 5) (Gen.toTree genEven) + + let + NodeT x _ = + Tree.runTree tree + + required = + Set.fromList (filter even [0..x]) + + actual = + Set.fromList (toList tree) + + missing = + required `Set.difference` actual + + annotateShow missing + required === actual + +tests :: IO Bool +tests = + checkParallel $$(discover) diff --git a/test/Test/Hedgehog/Zip.hs b/test/Test/Hedgehog/Zip.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hedgehog/Zip.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module Test.Hedgehog.Zip where + +import Control.Monad.Zip (mzip) + +import Data.Maybe (fromJust) + +import Hedgehog +import qualified Hedgehog.Range as Range + +import qualified Hedgehog.Internal.Gen as Gen +import qualified Hedgehog.Internal.Shrink as Shrink +import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) +import Hedgehog.Internal.Tree (Tree) +import qualified Hedgehog.Internal.Tree as Tree + + +mkTree :: Int -> Tree Int +mkTree n = + Tree.expand (Shrink.towards 0) (pure n) + +mkGen :: Int -> Gen Int +mkGen = + Gen.fromTree . mkTree + +render :: Show a => HasCallStack => Tree a -> PropertyT IO () +render x = + withFrozenCallStack $ do + annotate . Tree.render $ fmap show x + +prop_gen_applicative :: Property +prop_gen_applicative = + property $ do + let + treeApplicative n m = + (,) <$> mkTree n <*> mkTree m + + treeZip n m = + mzip (mkTree n) (mkTree m) + + genApplicative n m = + fromJust . + Gen.evalGen 0 (Seed 0 0) $ + (,) <$> mkGen n <*> mkGen m + + n <- forAll $ Gen.int (Range.constant 1 5) + m <- forAll $ Gen.int (Range.constant 1 5) + + render $ genApplicative n m + render $ treeZip n m + render $ treeApplicative n m + + genApplicative n m === treeZip n m + genApplicative n m /== treeApplicative n m + + success + +tests :: IO Bool +tests = + checkParallel $$(discover) diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,20 +1,18 @@ -import Control.Monad (unless) -import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) -import System.Exit (exitFailure) +import Hedgehog.Main (defaultMain) +import qualified Test.Hedgehog.Applicative +import qualified Test.Hedgehog.Filter import qualified Test.Hedgehog.Seed import qualified Test.Hedgehog.Text +import qualified Test.Hedgehog.Zip main :: IO () -main = do - hSetBuffering stdout LineBuffering - hSetBuffering stderr LineBuffering - - results <- sequence [ - Test.Hedgehog.Text.tests +main = + defaultMain [ + Test.Hedgehog.Applicative.tests + , Test.Hedgehog.Filter.tests , Test.Hedgehog.Seed.tests + , Test.Hedgehog.Text.tests + , Test.Hedgehog.Zip.tests ] - - unless (and results) $ - exitFailure