hedgehog-0.6.1/0000755000000000000000000000000013351371600011455 5ustar0000000000000000hedgehog-0.6.1/Setup.hs0000644000000000000000000000005613351371600013112 0ustar0000000000000000import Distribution.Simple main = defaultMain hedgehog-0.6.1/LICENSE0000644000000000000000000000275413351371600012472 0ustar0000000000000000Copyright 2017-2018, Jacob Stanley All Rights Reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hedgehog-0.6.1/CHANGELOG.md0000644000000000000000000001554413351371600013277 0ustar0000000000000000## Version 0.6.1 (2018-09-22) - Set stdout/stderr encoding to UTF-8 on Windows ([#218][218], [@moodmosaic][moodmosaic]) ## Version 0.6 (2018-05-14) - Pass [Dieharder][Dieharder] statistical/randomness tests ([#185][185], [@moodmosaic][moodmosaic]) - Catch `readFile` exceptions on the repl ([#184][184], [@thumphries][thumphries]) ## Version 0.5.3 (2018-03-12) - Add `Semigroup` and `Monoid` instances for `GenT` that lift the inner `Monoid` ([#156][156], [@andrewthad][andrewthad]) - `Gen.unicode` no longer generates non-characters ([#154][154], [@johnchandlerburnham][johnchandlerburnham]) - Documentation improvements ([#162][162], [@fisx][fisx]) - Documentation fixes ([#157][157], [@dredozubov][dredozubov]) ## Version 0.5.2 (2018-02-05) - Add doc explaining use of `withTests 1` ([#134][134], [@chris-martin][chris-martin]) - Explicitly define `Semigroup` instance for `Summary` ([#142][142], [@gwils][gwils]) - Depend on `semigroups` ([#140][140], [@LightAndLight][LightAndLight]) - Support `transformers-0.4` ([#150][150], [@gwils][gwils]) ## Version 0.5.1 (2017-12-06) - Only invoke `setNumCapabilities` when using the `-threaded` runtime ([#130][130], [@ekmett][ekmett]) - Correct `mixGamma` oddness check ([#124][124], [@markhibberd][markhibberd]) ## 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]) - 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]) ## 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]) ## 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]) ## Version 0.2.2 (2017-05-16) - Fixed scope of `unicode` character generators ([#76][76], [@moodmosaic][moodmosaic]) - Widen version bounds for some dependencies ([#80][80], [@amarpotghan][amarpotghan]) - Expose test modules to fix build on nix / hydra ([#78][78], [@amarpotghan][amarpotghan]) - Fixes for GHC 8.2 RC2 ([#77][77], [@erikd][erikd]) ## Version 0.2.1 (2017-05-09) - Added `ascii`, `latin1`, `unicode` character generators ([#73][73], [@jystic][jystic]) ## 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]) [Dieharder]: https://webhome.phy.duke.edu/~rgb/General/dieharder.php [jystic]: https://github.com/jystic [chris-martin]: https://github.com/chris-martin [thumphries]: https://github.com/thumphries [moodmosaic]: https://github.com/moodmosaic [amarpotghan]: https://github.com/amarpotghan [erikd]: https://github.com/erikd [ekmett]: https://github.com/ekmett [markhibberd]: https://github.com/markhibberd [gwils]: https://github.com/gwils [LightAndLight]: https://github.com/LightAndLight [johnchandlerburnham]: https://github.com/johnchandlerburnham [andrewthad]: https://github.com/andrewthad [dredozubov]: https://github.com/dredozubov [fisx]: https://github.com/fisx [185]: https://github.com/hedgehogqa/haskell-hedgehog/pull/185 [184]: https://github.com/hedgehogqa/haskell-hedgehog/pull/184 [162]: https://github.com/hedgehogqa/haskell-hedgehog/pull/162 [157]: https://github.com/hedgehogqa/haskell-hedgehog/pull/157 [156]: https://github.com/hedgehogqa/haskell-hedgehog/pull/156 [154]: https://github.com/hedgehogqa/haskell-hedgehog/pull/154 [150]: https://github.com/hedgehogqa/haskell-hedgehog/pull/150 [142]: https://github.com/hedgehogqa/haskell-hedgehog/pull/142 [140]: https://github.com/hedgehogqa/haskell-hedgehog/pull/140 [134]: https://github.com/hedgehogqa/haskell-hedgehog/pull/134 [130]: https://github.com/hedgehogqa/haskell-hedgehog/pull/130 [124]: https://github.com/hedgehogqa/haskell-hedgehog/pull/124 [99]: https://github.com/hedgehogqa/haskell-hedgehog/pull/99 [98]: https://github.com/hedgehogqa/haskell-hedgehog/pull/98 [96]: https://github.com/hedgehogqa/haskell-hedgehog/pull/96 [95]: https://github.com/hedgehogqa/haskell-hedgehog/pull/95 [94]: https://github.com/hedgehogqa/haskell-hedgehog/pull/94 [93]: https://github.com/hedgehogqa/haskell-hedgehog/pull/93 [91]: https://github.com/hedgehogqa/haskell-hedgehog/pull/91 [89]: https://github.com/hedgehogqa/haskell-hedgehog/pull/89 [85]: https://github.com/hedgehogqa/haskell-hedgehog/pull/85 [83]: https://github.com/hedgehogqa/haskell-hedgehog/pull/83 [80]: https://github.com/hedgehogqa/haskell-hedgehog/pull/80 [78]: https://github.com/hedgehogqa/haskell-hedgehog/pull/78 [77]: https://github.com/hedgehogqa/haskell-hedgehog/pull/77 [76]: https://github.com/hedgehogqa/haskell-hedgehog/pull/76 [73]: https://github.com/hedgehogqa/haskell-hedgehog/pull/73 [43]: https://github.com/hedgehogqa/haskell-hedgehog/pull/43 hedgehog-0.6.1/README.md0000644000000000000000000000522013351371600012733 0ustar0000000000000000hedgehog [![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. ## Features - Integrated shrinking, shrinks obey invariants by construction. - Abstract state machine testing. - Generators allow monadic effects. - Range combinators for full control over the scope of generated numbers and collections. - Equality and roundtrip assertions show a diff instead of the two inequal values. - Template Haskell test runner which executes properties concurrently. ## Example The main module, [Hedgehog][haddock-hedgehog], includes almost everything you need to get started writing property tests with Hedgehog. It is designed to be used alongside [Hedgehog.Gen][haddock-hedgehog-gen] and [Hedgehog.Range][haddock-hedgehog-range] which should be imported qualified. You also need to enable Template Haskell so the Hedgehog test runner can find your properties. ```hs {-# LANGUAGE TemplateHaskell #-} import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range ``` Once you have your imports set up, you can write a simple property: ```hs prop_reverse :: Property prop_reverse = property $ do xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha reverse (reverse xs) === xs ``` And add the Template Haskell splice which will discover your properties: ```hs tests :: IO Bool tests = checkParallel $$(discover) ``` If you prefer to avoid macros, you can specify the group of properties to run manually instead: ```hs {-# LANGUAGE OverloadedStrings #-} tests :: IO Bool tests = checkParallel $ Group "Test.Example" [ ("prop_reverse", prop_reverse) ] ``` You can then load the module in GHCi, and run it: ``` λ tests ━━━ Test.Example ━━━ ✓ prop_reverse passed 100 tests. ``` [hackage]: http://hackage.haskell.org/package/hedgehog [hackage-shield]: https://img.shields.io/badge/hackage-v0.5-blue.svg [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html [haddock-hedgehog-range]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Range.html hedgehog-0.6.1/hedgehog.cabal0000644000000000000000000000763213351371600014223 0ustar0000000000000000version: 0.6.1 name: hedgehog author: Jacob Stanley maintainer: Jacob Stanley homepage: https://hedgehog.qa bug-reports: https://github.com/hedgehogqa/haskell-hedgehog/issues synopsis: Hedgehog will eat all your bugs. 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. . To get started quickly, see the examples: category: Testing license: BSD3 license-file: LICENSE cabal-version: >= 1.8 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.2.2 , GHC == 8.4.1 , GHC == 8.4.2 , GHC == 8.4.3 extra-source-files: README.md CHANGELOG.md source-repository head type: git location: git://github.com/hedgehogqa/haskell-hedgehog.git library build-depends: base >= 3 && < 5 , ansi-terminal >= 0.6 && < 0.9 , 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 , 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 , 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 , 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 , wl-pprint-annotated >= 0.0 && < 0.2 if !os(windows) build-depends: unix >= 2.6 && < 2.8 ghc-options: -Wall hs-source-dirs: src exposed-modules: Hedgehog Hedgehog.Gen Hedgehog.Range Hedgehog.Internal.Config Hedgehog.Internal.Discovery Hedgehog.Internal.Distributive Hedgehog.Internal.Exception Hedgehog.Internal.Gen Hedgehog.Internal.HTraversable Hedgehog.Internal.Opaque Hedgehog.Internal.Property Hedgehog.Internal.Queue Hedgehog.Internal.Range Hedgehog.Internal.Region Hedgehog.Internal.Report Hedgehog.Internal.Runner Hedgehog.Internal.Seed Hedgehog.Internal.Show Hedgehog.Internal.Shrink Hedgehog.Internal.Source Hedgehog.Internal.State Hedgehog.Internal.TH Hedgehog.Internal.Tree Hedgehog.Internal.Tripping test-suite test type: exitcode-stdio-1.0 main-is: test.hs ghc-options: -Wall -threaded -O2 hs-source-dirs: test other-modules: Test.Hedgehog.Seed Test.Hedgehog.Text build-depends: hedgehog , base >= 3 && < 5 , containers >= 0.4 && < 0.7 , pretty-show >= 1.6 && < 1.8 , semigroups >= 0.16 && < 0.19 , text >= 1.1 && < 1.3 , transformers >= 0.3 && < 0.6 hedgehog-0.6.1/test/0000755000000000000000000000000013351371600012434 5ustar0000000000000000hedgehog-0.6.1/test/test.hs0000644000000000000000000000072213351371600013750 0ustar0000000000000000import Control.Monad (unless) import System.IO (BufferMode(..), hSetBuffering, stdout, stderr) import System.Exit (exitFailure) import qualified Test.Hedgehog.Seed import qualified Test.Hedgehog.Text main :: IO () main = do hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering results <- sequence [ Test.Hedgehog.Text.tests , Test.Hedgehog.Seed.tests ] unless (and results) $ exitFailure hedgehog-0.6.1/test/Test/0000755000000000000000000000000013351371600013353 5ustar0000000000000000hedgehog-0.6.1/test/Test/Hedgehog/0000755000000000000000000000000013351371600015065 5ustar0000000000000000hedgehog-0.6.1/test/Test/Hedgehog/Text.hs0000644000000000000000000000332013351371600016343 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Hedgehog.Text where import Data.Int (Int64) import Data.Typeable (Typeable) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Text.Read (readEither) genSize :: Gen Size genSize = Size <$> Gen.enumBounded genOdd :: Gen Int64 genOdd = let mkOdd x = if odd x then x else pred x in mkOdd <$> Gen.int64 (Range.constant 1 maxBound) genSeed :: Gen Seed genSeed = Seed <$> Gen.word64 Range.constantBounded <*> fmap fromIntegral genOdd genPrecedence :: Gen Int genPrecedence = Gen.int (Range.constant 0 11) genString :: Gen String genString = Gen.string (Range.constant 0 100) Gen.alpha checkShowAppend :: (Typeable a, Show a) => Gen a -> Property checkShowAppend gen = property $ do prec <- forAll genPrecedence x <- forAll gen xsuffix <- forAll genString ysuffix <- forAll genString showsPrec prec x xsuffix ++ ysuffix === showsPrec prec x (xsuffix ++ ysuffix) trippingReadShow :: (Eq a, Typeable a, Show a, Read a) => Gen a -> Property trippingReadShow gen = property $ do prec <- forAll genPrecedence x <- forAll gen tripping x (\z -> showsPrec prec z "") readEither prop_show_append_size :: Property prop_show_append_size = checkShowAppend genSize prop_tripping_append_size :: Property prop_tripping_append_size = trippingReadShow genSize prop_show_append_seed :: Property prop_show_append_seed = checkShowAppend genSeed prop_tripping_append_seed :: Property prop_tripping_append_seed = trippingReadShow genSeed tests :: IO Bool tests = checkParallel $$(discover) hedgehog-0.6.1/test/Test/Hedgehog/Seed.hs0000644000000000000000000000465713351371600016315 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Test.Hedgehog.Seed ( tests ) where import Data.Foldable (for_) import Hedgehog import qualified Hedgehog.Internal.Seed as Seed data Assert = Assert { expected :: !Seed , actual :: !Seed } deriving (Show) -- | Verify that SplitMix avoids pathological γ-values, as discussed by -- Melissa E. O'Neill in the post with title Bugs in SplitMix(es), at -- http://www.pcg-random.org/posts/bugs-in-splitmix.html -- -- See also: -- https://github.com/hedgehogqa/haskell-hedgehog/issues/191 -- prop_avoid_pathological_gamma_values :: Property prop_avoid_pathological_gamma_values = withTests 1 . property $ do for_ asserts $ \a -> expected a === actual a asserts :: [Assert] asserts = [ Assert (Seed 15210016002011668638 12297829382473034411) (Seed.from 0x61c8864680b583eb) , Assert (Seed 11409286845259996466 12297829382473034411) (Seed.from 0xf8364607e9c949bd) , Assert (Seed 1931727433621677744 12297829382473034411) (Seed.from 0x88e48f4fcc823718) , Assert (Seed 307741759840609752 12297829382473034411) (Seed.from 0x7f83ab8da2e71dd1) , Assert (Seed 8606169619657412120 12297829382473034413) (Seed.from 0x7957d809e827ff4c) , Assert (Seed 13651108307767328632 12297829382473034413) (Seed.from 0xf8d059aee4c53639) , Assert (Seed 125750466559701114 12297829382473034413) (Seed.from 0x9cd9f015db4e58b7) , Assert (Seed 6781260234005250507 12297829382473034413) (Seed.from 0xf4077b0dbebc73c0) , Assert (Seed 15306535823716590088 12297829382473034405) (Seed.from 0x305cb877109d0686) , Assert (Seed 7344074043290227165 12297829382473034405) (Seed.from 0x359e58eeafebd527) , Assert (Seed 9920554987610416076 12297829382473034405) (Seed.from 0xbeb721c511b0da6d) , Assert (Seed 3341781972484278810 12297829382473034405) (Seed.from 0x86466fd0fcc363a6) , Assert (Seed 12360157267739240775 12297829382473034421) (Seed.from 0xefee3e7b93db3075) , Assert (Seed 600595566262245170 12297829382473034421) (Seed.from 0x79629ee76aa83059) , Assert (Seed 1471112649570176389 12297829382473034421) (Seed.from 0x05d507d05e785673) , Assert (Seed 8100917074368564322 12297829382473034421) (Seed.from 0x76442b62dddf926c) ] tests :: IO Bool tests = checkParallel $$(discover) hedgehog-0.6.1/src/0000755000000000000000000000000013351371600012244 5ustar0000000000000000hedgehog-0.6.1/src/Hedgehog.hs0000644000000000000000000001053513351371600014316 0ustar0000000000000000-- | -- This module includes almost everything you need to get started writing -- property tests with Hedgehog. -- -- It is designed to be used alongside "Hedgehog.Gen" and "Hedgehog.Range", -- which should be imported qualified. You also need to enable Template Haskell -- so the Hedgehog test runner can find your properties. -- -- > {-# LANGUAGE TemplateHaskell #-} -- > -- > import Hedgehog -- > import qualified Hedgehog.Gen as Gen -- > import qualified Hedgehog.Range as Range -- -- Once you have your imports set up, you can write a simple property: -- -- > prop_reverse :: Property -- > prop_reverse = -- > property $ do -- > xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha -- > reverse (reverse xs) === xs -- -- And add the Template Haskell splice which will discover your properties: -- -- > tests :: IO Bool -- > tests = -- > checkParallel $$(discover) -- -- If you prefer to avoid macros, you can specify the group of properties to -- run manually instead: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > tests :: IO Bool -- > tests = -- > checkParallel $ Group "Test.Example" [ -- > ("prop_reverse", prop_reverse) -- > ] -- -- You can then load the module in GHCi, and run it: -- -- > λ tests -- > ━━━ Test.Example ━━━ -- > ✓ prop_reverse passed 100 tests. -- module Hedgehog ( -- * Properties Property , PropertyT , Group(..) , PropertyName , GroupName , property , test , forAll , forAllWith , discard , check , recheck , discover , checkParallel , checkSequential , withTests , TestLimit , withDiscards , DiscardLimit , withShrinks , ShrinkLimit , withRetries , ShrinkRetries -- * Generating Test Data , Gen , GenT , MonadGen(..) , Range , Size(..) , Seed(..) -- * Tests , Test , TestT , MonadTest(..) , annotate , annotateShow , footnote , footnoteShow , success , failure , assert , (===) , (/==) , tripping , eval , evalM , evalIO , evalEither , evalExceptT -- * State Machine Tests , Command(..) , Callback(..) , Action , Sequential(..) , Parallel(..) , executeSequential , executeParallel , Var(..) , concrete , opaque , Symbolic , Concrete(..) , Opaque(..) -- * Transformers , distribute -- * Functors , HTraversable(..) , Eq1 , eq1 , Ord1 , compare1 , Show1 , showsPrec1 ) where import Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1) import Hedgehog.Internal.Distributive (Distributive(..)) 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 (discard, failure, success) import Hedgehog.Internal.Property (DiscardLimit, withDiscards) import Hedgehog.Internal.Property (eval, evalM, evalIO) import Hedgehog.Internal.Property (evalEither, evalExceptT) import Hedgehog.Internal.Property (footnote, footnoteShow) import Hedgehog.Internal.Property (forAll, forAllWith) import Hedgehog.Internal.Property (MonadTest(..)) import Hedgehog.Internal.Property (Property, PropertyT, PropertyName) import Hedgehog.Internal.Property (Group(..), GroupName) import Hedgehog.Internal.Property (ShrinkLimit, withShrinks) import Hedgehog.Internal.Property (ShrinkRetries, withRetries) import Hedgehog.Internal.Property (Test, TestT, property, test) import Hedgehog.Internal.Property (TestLimit, withTests) 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.Tripping (tripping) hedgehog-0.6.1/src/Hedgehog/0000755000000000000000000000000013351371600013756 5ustar0000000000000000hedgehog-0.6.1/src/Hedgehog/Gen.hs0000644000000000000000000000251213351371600015023 0ustar0000000000000000module Hedgehog.Gen ( -- * Combinators lift -- ** Shrinking , shrink , prune -- ** Size , small , scale , resize , sized -- ** Integral , integral , integral_ , int , int8 , int16 , int32 , int64 , word , word8 , word16 , word32 , word64 -- ** Floating-point , realFloat , realFrac_ , float , double -- ** Enumeration , enum , enumBounded , bool , bool_ -- ** Characters , binit , octit , digit , hexit , lower , upper , alpha , alphaNum , ascii , latin1 , unicode , unicodeAll -- ** Strings , string , text , utf8 , bytes -- ** Choice , constant , element , choice , frequency , recursive -- ** Conditional , discard , filter , just -- ** Collections , maybe , list , seq , nonEmpty , set , map -- ** Subterms , freeze , subterm , subtermM , subterm2 , subtermM2 , subterm3 , subtermM3 -- ** Combinations & Permutations , subsequence , shuffle -- ** Abstract State Machine , sequential , parallel -- * Sampling Generators , sample , print , printTree , printWith , printTreeWith ) where import Hedgehog.Internal.Gen import Hedgehog.Internal.State (sequential, parallel) import Prelude hiding (filter, print, maybe, map, seq) hedgehog-0.6.1/src/Hedgehog/Range.hs0000644000000000000000000000101013351371600015336 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hedgehog.Range ( -- * Size Size(..) -- * Range , Range , origin , bounds , lowerBound , upperBound -- * Constant , singleton , constant , constantFrom , constantBounded -- * Linear , linear , linearFrom , linearFrac , linearFracFrom , linearBounded -- * Exponential , exponential , exponentialFrom , exponentialBounded , exponentialFloat , exponentialFloatFrom ) where import Hedgehog.Internal.Range hedgehog-0.6.1/src/Hedgehog/Internal/0000755000000000000000000000000013351371600015532 5ustar0000000000000000hedgehog-0.6.1/src/Hedgehog/Internal/Seed.hs0000644000000000000000000001320413351371600016746 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} -- | -- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele -- et. al. [1]. -- -- The paper's algorithm provides decent randomness for most purposes but -- sacrifices cryptographic-quality randomness in favor of speed. The original -- implementation is tested with DieHarder and BigCrush; see the paper for -- details. -- -- This implementation, originally from [2], is a port from the paper. -- -- It also takes in to account the SplittableRandom.java source code in OpenJDK -- v8u40-b25 as well as splittable_random.ml in Jane Street's standard library -- overlay (kernel) v113.33.03, and Random.fs in FsCheck v3. -- -- Other than the choice of initial seed for 'from' this port should be -- faithful. -- -- 1. Guy L. Steele, Jr., Doug Lea, Christine H. Flood -- Fast splittable pseudorandom number generators -- Comm ACM, 49(10), Oct 2014, pp453-472. -- -- 2. Nikos Baxevanis -- https://github.com/moodmosaic/SplitMix/blob/master/SplitMix.hs -- #include "MachDeps.h" module Hedgehog.Internal.Seed ( Seed(..) , random , from , split , nextInteger , nextDouble -- * Internal -- $internal , goldenGamma , nextWord64 , nextWord32 , mix64 , mix64variant13 , mix32 , mixGamma ) where import Control.Monad.IO.Class (MonadIO(..)) import Data.Bifunctor (first) import Data.Bits ((.|.), xor, shiftR, popCount) #if (SIZEOF_HSINT == 8) import Data.Int (Int64) #else import Data.Int (Int32) #endif import Data.Time.Clock.POSIX (getPOSIXTime) import Data.IORef (IORef) import qualified Data.IORef as IORef import Data.Word (Word32, Word64) import System.IO.Unsafe (unsafePerformIO) import System.Random (RandomGen) import qualified System.Random as Random -- | A splittable random number generator. -- data Seed = Seed { seedValue :: !Word64 , seedGamma :: !Word64 -- ^ must be an odd number } deriving (Eq, Ord) instance Show Seed where showsPrec p (Seed v g) = showParen (p > 10) $ showString "Seed " . showsPrec 11 v . showChar ' ' . showsPrec 11 g instance Read Seed where readsPrec p = readParen (p > 10) $ \r0 -> do ("Seed", r1) <- lex r0 (v, r2) <- readsPrec 11 r1 (g, r3) <- readsPrec 11 r2 pure (Seed v g, r3) global :: IORef Seed global = unsafePerformIO $ do -- FIXME use /dev/urandom on posix seconds <- getPOSIXTime IORef.newIORef $ from (round (seconds * 1000)) {-# NOINLINE global #-} -- | Create a random 'Seed' using an effectful source of randomness. -- random :: MonadIO m => m Seed random = liftIO $ IORef.atomicModifyIORef' global split -- | Create a 'Seed' using a 'Word64'. -- from :: Word64 -> Seed from x = Seed (mix64 x) (mixGamma (x + goldenGamma)) -- | A predefined gamma value's needed for initializing the "root" instances of -- 'Seed'. That is, instances not produced by splitting an already existing -- instance. -- -- We choose: the odd integer closest to @2^64/φ@, where @φ = (1 + √5)/2@ is -- the golden ratio. -- goldenGamma :: Word64 goldenGamma = 0x9e3779b97f4a7c15 -- | Get the next value in the SplitMix sequence. -- next :: Seed -> (Word64, Seed) next (Seed v0 g) = let v = v0 + g in (v, Seed v g) -- | Splits a random number generator in to two. -- split :: Seed -> (Seed, Seed) split s0 = let (v0, s1) = next s0 (g0, s2) = next s1 in (s2, Seed (mix64 v0) (mixGamma g0)) -- | Generate a random 'Word64'. -- nextWord64 :: Seed -> (Word64, Seed) nextWord64 s0 = let (v0, s1) = next s0 in (mix64 v0, s1) -- | Generate a random 'Word32'. -- nextWord32 :: Seed -> (Word32, Seed) nextWord32 s0 = let (v0, s1) = next s0 in (mix32 v0, s1) -- | Generate a random 'Integer' in the [inclusive,inclusive] range. -- nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed) nextInteger lo hi = Random.randomR (lo, hi) -- | Generate a random 'Double' in the [inclusive,exclusive) range. -- nextDouble :: Double -> Double -> Seed -> (Double, Seed) nextDouble lo hi = Random.randomR (lo, hi) mix64 :: Word64 -> Word64 mix64 x = let y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53 in z `xor` (z `shiftR` 33) mix32 :: Word64 -> Word32 mix32 x = let y = (x `xor` (x `shiftR` 33)) * 0xff51afd7ed558ccd z = (y `xor` (y `shiftR` 33)) * 0xc4ceb9fe1a85ec53 in fromIntegral (z `shiftR` 32) mix64variant13 :: Word64 -> Word64 mix64variant13 x = let y = (x `xor` (x `shiftR` 30)) * 0xbf58476d1ce4e5b9 z = (y `xor` (y `shiftR` 27)) * 0x94d049bb133111eb in z `xor` (z `shiftR` 31) mixGamma :: Word64 -> Word64 mixGamma x = let y = mix64variant13 x .|. 1 n = popCount $ y `xor` (y `shiftR` 1) in if n < 24 then y `xor` 0xaaaaaaaaaaaaaaaa else y ------------------------------------------------------------------------ -- RandomGen instances #if (SIZEOF_HSINT == 8) instance RandomGen Seed where next = first fromIntegral . nextWord64 genRange _ = (fromIntegral (minBound :: Int64), fromIntegral (maxBound :: Int64)) split = split #else instance RandomGen Seed where next = first fromIntegral . nextWord32 genRange _ = (fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32)) split = split #endif ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-0.6.1/src/Hedgehog/Internal/State.hs0000644000000000000000000005244213351371600017155 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} module Hedgehog.Internal.State ( -- * Variables Var(..) , concrete , opaque , Concrete(..) , Symbolic(..) , Name(..) -- * Environment , Environment(..) , EnvironmentError(..) , emptyEnvironment , insertConcrete , reifyDynamic , reifyEnvironment , reify -- * Commands , Command(..) , Callback(..) , commandGenOK -- * Actions , Action(..) , Sequential(..) , Parallel(..) , takeVariables , variablesOK , dropInvalid , action , sequential , parallel , executeSequential , executeParallel ) where import qualified Control.Concurrent.Async.Lifted as Async import Control.Monad (foldM, foldM_) import Control.Monad.Catch (MonadCatch) import Control.Monad.State.Class (MonadState, get, put, modify) 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 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 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.Range (Range) import Hedgehog.Internal.Show (showPretty) import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) -- | Symbolic variable names. -- newtype Name = Name Int deriving (Eq, Ord, Num) instance Show Name where showsPrec p (Name x) = showsPrec p x -- | Symbolic values. -- data Symbolic a where Symbolic :: Typeable a => Name -> Symbolic a deriving instance Eq (Symbolic a) deriving instance Ord (Symbolic a) instance Show (Symbolic a) where 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 instance Eq1 Symbolic where liftEq _ (Symbolic x) (Symbolic y) = x == y 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. -- newtype Concrete a where Concrete :: a -> Concrete a deriving (Eq, Ord, Functor, Foldable, Traversable) instance Show a => Show (Concrete a) where showsPrec = showsPrec1 #if MIN_VERSION_transformers(0,5,0) instance Show1 Concrete where liftShowsPrec sp _ p (Concrete x) = sp p x instance Eq1 Concrete where liftEq eq (Concrete x) (Concrete y) = eq x y 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 -- are parameterised by either `Symbolic` or `Concrete` depending on the -- phase of the test. -- -- `Symbolic` variables are the potential results of actions. These are used -- when generating the sequence of actions to execute. They allow actions -- which occur later in the sequence to make use of the result of an action -- which came earlier in the sequence. -- -- `Concrete` variables are the actual results of actions. These are used -- during test execution. They provide access to the actual runtime value of -- a variable. -- -- The state update `Callback` for a command needs to be polymorphic in the -- type of variable because it is used in both the generation and the -- execution phase. -- data Var a v = Var (v a) -- | Take the value from a concrete variable. -- concrete :: Var a Concrete -> a concrete (Var (Concrete x)) = x -- | Take the value from an opaque concrete variable. -- opaque :: Var (Opaque a) Concrete -> a opaque (Var (Concrete (Opaque x))) = x instance (Eq a, Eq1 v) => Eq (Var a v) where (==) (Var x) (Var y) = eq1 x y instance (Ord a, Ord1 v) => Ord (Var a v) where compare (Var x) (Var y) = compare1 x y instance (Show a, Show1 v) => Show (Var a v) where showsPrec p (Var x) = showParen (p >= 11) $ showString "Var " . showsPrec1 11 x instance HTraversable (Var a) where htraverse f (Var v) = fmap Var (f v) ------------------------------------------------------------------------ -- Symbolic Environment -- | A mapping of symbolic values to concrete values. -- newtype Environment = Environment { unEnvironment :: Map Name Dynamic } deriving (Show) -- | Environment errors. -- data EnvironmentError = EnvironmentValueNotFound !Name | EnvironmentTypeError !TypeRep !TypeRep deriving (Eq, Ord, Show) -- | Create an empty environment. -- emptyEnvironment :: Environment emptyEnvironment = Environment Map.empty -- | Insert a symbolic / concrete pairing in to the environment. -- insertConcrete :: Symbolic a -> Concrete a -> Environment -> Environment insertConcrete (Symbolic k) (Concrete v) = Environment . Map.insert k (toDyn v) . unEnvironment -- | Cast a 'Dynamic' in to a concrete value. -- reifyDynamic :: forall a. Typeable a => Dynamic -> Either EnvironmentError (Concrete a) reifyDynamic dyn = case fromDynamic dyn of Nothing -> Left $ EnvironmentTypeError (typeRep (Proxy :: Proxy a)) (dynTypeRep dyn) Just x -> Right $ Concrete x -- | Turns an environment in to a function for looking up a concrete value from -- a symbolic one. -- reifyEnvironment :: Environment -> (forall a. Symbolic a -> Either EnvironmentError (Concrete a)) reifyEnvironment (Environment vars) (Symbolic n) = case Map.lookup n vars of Nothing -> Left $ EnvironmentValueNotFound n Just dyn -> reifyDynamic dyn -- | Convert a symbolic structure to a concrete one, using the provided environment. -- reify :: HTraversable t => Environment -> t Symbolic -> Either EnvironmentError (t Concrete) reify vars = htraverse (reifyEnvironment vars) ------------------------------------------------------------------------ -- Callbacks -- | Optional command configuration. -- data Callback input output state = -- | A pre-condition for a command that must be verified before the command -- can be executed. This is mainly used during shrinking to ensure that it -- is still OK to run a command despite the fact that some previously -- executed commands may have been removed from the sequence. -- Require (state Symbolic -> input Symbolic -> Bool) -- | Updates the model state, given the input and output of the command. Note -- that this function is polymorphic in the type of values. This is because -- it must work over 'Symbolic' values when we are generating actions, and -- 'Concrete' values when we are executing them. -- | Update (forall v. Ord1 v => state v -> input v -> Var output v -> state v) -- | A post-condition for a command that must be verified for the command to -- be considered a success. -- -- This callback receives the state prior to execution as the first -- argument, and the state after execution as the second argument. -- | Ensure (state Concrete -> state Concrete -> input Concrete -> output -> Test ()) callbackRequire1 :: state Symbolic -> input Symbolic -> Callback input output state -> Bool callbackRequire1 s i = \case Require f -> f s i Update _ -> True Ensure _ -> True callbackUpdate1 :: Ord1 v => state v -> input v -> Var output v -> Callback input output state -> state v callbackUpdate1 s i o = \case Require _ -> s Update f -> f s i o Ensure _ -> s callbackEnsure1 :: state Concrete -> state Concrete -> input Concrete -> output -> Callback input output state -> Test () callbackEnsure1 s0 s i o = \case Require _ -> success Update _ -> success Ensure f -> f s0 s i o callbackRequire :: [Callback input output state] -> state Symbolic -> input Symbolic -> Bool callbackRequire callbacks s i = all (callbackRequire1 s i) callbacks callbackUpdate :: Ord1 v => [Callback input output state] -> state v -> input v -> Var output v -> state v callbackUpdate callbacks s0 i o = foldl (\s -> callbackUpdate1 s i o) s0 callbacks callbackEnsure :: [Callback input output state] -> state Concrete -> state Concrete -> input Concrete -> output -> Test () callbackEnsure callbacks s0 s i o = traverse_ (callbackEnsure1 s0 s i o) callbacks ------------------------------------------------------------------------ -- | The specification for the expected behaviour of an 'Action'. -- data Command n m (state :: (* -> *) -> *) = forall input output. (HTraversable input, Show (input Symbolic), 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)) -- | Executes a command using the arguments generated by 'commandGen'. -- , commandExecute :: input Concrete -> m output -- | A set of callbacks which provide optional command configuration such -- as pre-condtions, post-conditions and state updates. -- , commandCallbacks :: [Callback input output state] } -- | Checks that input for a command can be executed in the given state. -- commandGenOK :: Command n m state -> state Symbolic -> Bool commandGenOK (Command inputGen _ _) state = Maybe.isJust (inputGen state) -- | An instantiation of a 'Command' which can be executed, and its effect -- evaluated. -- data Action m (state :: (* -> *) -> *) = forall input output. (HTraversable input, Show (input Symbolic)) => Action { actionInput :: input Symbolic , actionOutput :: Symbolic output , actionExecute :: input Concrete -> m output , actionRequire :: state Symbolic -> input Symbolic -> Bool , actionUpdate :: forall v. Ord1 v => state v -> input v -> Var output v -> state v , actionEnsure :: state Concrete -> state Concrete -> input Concrete -> output -> Test () } instance Show (Action m state) where showsPrec p (Action input (Symbolic (Name output)) _ _ _ _) = showParen (p > 10) $ showString "Var " . showsPrec 11 output . showString " :<- " . showsPrec 11 input -- | Extract the variable name and the type from a symbolic value. -- takeSymbolic :: forall a. Symbolic a -> (Name, TypeRep) takeSymbolic (Symbolic name) = (name, typeRep (Proxy :: Proxy a)) -- | Insert a symbolic variable in to a map of variables to types. -- insertSymbolic :: Symbolic a -> Map Name TypeRep -> Map Name TypeRep insertSymbolic s = let (name, typ) = takeSymbolic s in Map.insert name typ -- | Collects all the symbolic values in a data structure and produces a set of -- all the variables they refer to. -- takeVariables :: forall t. HTraversable t => t Symbolic -> Map Name TypeRep takeVariables xs = let go x = do modify (insertSymbolic x) pure x in flip execState Map.empty $ htraverse go xs -- | Checks that the symbolic values in the data structure refer only to the -- variables in the provided set, and that they are of the correct type. -- variablesOK :: HTraversable t => t Symbolic -> Map Name TypeRep -> Bool variablesOK xs allowed = let vars = takeVariables xs in Map.null (vars `Map.difference` allowed) && and (Map.intersectionWith (==) vars allowed) data Context state = Context { contextState :: state Symbolic , _contextVars :: Map Name TypeRep } mkContext :: state Symbolic -> Context state mkContext initial = Context initial Map.empty contextUpdate :: MonadState (Context state) m => state Symbolic -> m () contextUpdate state = do Context _ vars <- get put $ Context state vars contextNewVar :: (MonadState (Context state) m, Typeable a) => m (Symbolic a) contextNewVar = do Context state vars <- get let var = case Map.maxViewWithKey vars of Nothing -> Symbolic 0 Just ((name, _), _) -> Symbolic (name + 1) put $ Context state (insertSymbolic var vars) pure var -- | Drops invalid actions from the sequence. -- dropInvalid :: [Action m state] -> State (Context state) [Action m state] dropInvalid = let loop step@(Action input output _execute require update _ensure) = do Context state0 vars0 <- get if require state0 input && variablesOK input vars0 then do let state = update state0 input (Var output) vars = insertSymbolic output vars0 put $ Context state vars pure $ Just step else pure Nothing in fmap Maybe.catMaybes . traverse loop -- | 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) action commands = Gen.just $ do Context state0 _ <- get Command mgenInput exec callbacks <- Gen.element $ filter (\c -> commandGenOK c state0) commands input <- case mgenInput state0 of Nothing -> error "genCommand: internal error, tried to use generator with invalid state." Just g -> lift g if not $ callbackRequire callbacks state0 input then pure Nothing else do output <- contextNewVar contextUpdate $ callbackUpdate callbacks state0 input (Var output) pure . Just $ Action input output exec (callbackRequire callbacks) (callbackUpdate callbacks) (callbackEnsure callbacks) genActions :: (MonadGen n, MonadTest m) => Range Int -> [Command n m state] -> Context state -> n ([Action m state], Context state) genActions range commands ctx = do xs <- Gen.list range (action commands) `evalStateT` ctx pure $ dropInvalid xs `runState` ctx -- | A sequence of actions to execute. -- data Sequential m state = Sequential { -- | The sequence of actions. sequentialActions :: [Action m state] } renderAction :: Action m state -> [String] renderAction (Action input (Symbolic (Name output)) _ _ _ _) = let prefix0 = "Var " ++ show output ++ " = " prefix = replicate (length prefix0) ' ' in case lines (showPretty input) 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) = unlines $ concatMap renderAction xs -- | Generates a sequence of actions from an initial model state and set of commands. -- sequential :: (MonadGen n, MonadTest m) => Range Int -> (forall v. state v) -> [Command n m state] -> n (Sequential m state) sequential range initial commands = fmap (Sequential . fst) $ genActions range commands (mkContext initial) -- | A sequential prefix of actions to execute, with two branches to execute in parallel. -- data Parallel m state = Parallel { -- | The sequential prefix. parallelPrefix :: [Action m state] -- | The first branch. , parallelBranch1 :: [Action m state] -- | The second branch. , parallelBranch2 :: [Action m state] } -- 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) ] -- | 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) => Range Int -> Range Int -> (forall v. state v) -> [Command n m state] -> n (Parallel m state) parallel prefixN parallelN initial commands = do (prefix, ctx0) <- genActions prefixN commands (mkContext initial) (branch1, ctx1) <- genActions parallelN commands ctx0 (branch2, _ctx2) <- genActions parallelN commands ctx1 { contextState = contextState ctx0 } pure $ Parallel prefix branch1 branch2 data ActionCheck state = ActionCheck { checkUpdate :: state Concrete -> state Concrete , checkEnsure :: state Concrete -> state Concrete -> Test () } execute :: (MonadTest m, HasCallStack) => Action m state -> StateT Environment m (ActionCheck state) execute (Action sinput soutput exec _require update ensure) = withFrozenCallStack $ do env0 <- get input <- evalEither $ reify env0 sinput output <- lift $ exec input let coutput = Concrete output env = insertConcrete soutput coutput env0 put env pure $ ActionCheck (\s0 -> update s0 input (Var coutput)) (\s0 s -> ensure s0 s input output) -- | Executes a single action in the given evironment. -- executeUpdateEnsure :: (MonadTest m, HasCallStack) => (state Concrete, Environment) -> Action m state -> m (state Concrete, Environment) executeUpdateEnsure (state0, env0) (Action sinput soutput exec _require update ensure) = withFrozenCallStack $ do input <- evalEither $ reify env0 sinput output <- exec input let coutput = Concrete output state = update state0 input (Var coutput) env = insertConcrete soutput coutput env0 liftTest $ ensure state0 state input output pure (state, env) -- | Executes a list of actions sequentially, verifying that all -- post-conditions are met and no exceptions are thrown. -- -- To generate a sequence of actions to execute, see the -- 'Hedgehog.Gen.sequential' combinator in the "Hedgehog.Gen" module. -- executeSequential :: (MonadTest m, MonadCatch m, HasCallStack) => (forall v. state v) -> Sequential m state -> m () executeSequential initial (Sequential xs) = withFrozenCallStack $ evalM $ foldM_ executeUpdateEnsure (initial, emptyEnvironment) xs successful :: Test () -> Bool successful x = case runTest x of (Left _, _) -> False (Right _, _) -> True interleave :: [a] -> [a] -> [[a]] interleave xs00 ys00 = case (xs00, ys00) of ([], []) -> [] (xs, []) -> [xs] ([], ys) -> [ys] (xs0@(x:xs), ys0@(y:ys)) -> [ x : zs | zs <- interleave xs ys0 ] ++ [ y : zs | zs <- interleave xs0 ys ] checkActions :: state Concrete -> [ActionCheck state] -> Test () checkActions s0 = \case [] -> pure () x : xs -> do let s = checkUpdate x s0 checkEnsure x s0 s checkActions s xs linearize :: MonadTest m => state Concrete -> [ActionCheck state] -> [ActionCheck state] -> m () linearize initial branch1 branch2 = withFrozenCallStack $ let ok = any successful . fmap (checkActions initial) $ interleave branch1 branch2 in if ok then pure () else failWith Nothing "no valid interleaving" -- | Executes the prefix actions sequentially, then executes the two branches -- in parallel, verifying that no exceptions are thrown and that there is at -- least one sequential interleaving where all the post-conditions are met. -- -- To generate parallel actions to execute, see the 'Hedgehog.Gen.parallel' -- combinator in the "Hedgehog.Gen" module. -- executeParallel :: (MonadTest m, MonadCatch m, MonadBaseControl IO m, HasCallStack) => (forall v. state v) -> Parallel m state -> m () executeParallel initial (Parallel prefix branch1 branch2) = withFrozenCallStack $ evalM $ do (s0, env0) <- foldM executeUpdateEnsure (initial, emptyEnvironment) prefix (xs, ys) <- Async.concurrently (evalStateT (traverse execute branch1) env0) (evalStateT (traverse execute branch2) env0) linearize s0 xs ys hedgehog-0.6.1/src/Hedgehog/Internal/Report.hs0000644000000000000000000005536713351371600017361 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Hedgehog.Internal.Report ( -- * Report Summary(..) , Report(..) , Progress(..) , Result(..) , FailureReport(..) , FailedAnnotation(..) , ShrinkCount(..) , TestCount(..) , DiscardCount(..) , PropertyCount(..) , Style(..) , Markup(..) , renderProgress , renderResult , renderSummary , renderDoc , ppProgress , ppResult , ppSummary , fromResult , mkFailure ) where import Control.Monad (zipWithM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.Bifunctor (bimap, first, second) import qualified Data.Char as Char import Data.Either (partitionEithers) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe, catMaybes) import Data.Semigroup (Semigroup(..)) import Hedgehog.Internal.Config import Hedgehog.Internal.Discovery (Pos(..), Position(..)) import qualified Hedgehog.Internal.Discovery as Discovery import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..)) import Hedgehog.Internal.Seed (Seed) import Hedgehog.Internal.Show import Hedgehog.Internal.Source import Hedgehog.Range (Size) import System.Console.ANSI (ColorIntensity(..), Color(..)) 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 import Text.PrettyPrint.Annotated.WL (Doc, (<+>)) import qualified Text.PrettyPrint.Annotated.WL as WL import Text.Printf (printf) ------------------------------------------------------------------------ -- 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) , failedValue :: !String } deriving (Eq, Show) data FailureReport = FailureReport { failureSize :: !Size , failureSeed :: !Seed , failureShrinks :: !ShrinkCount , failureAnnotations :: ![FailedAnnotation] , failureLocation :: !(Maybe Span) , failureMessage :: !String , failureDiff :: !(Maybe Diff) , failureFootnotes :: ![String] } deriving (Eq, Show) -- | The status of a running property test. -- data Progress = Running | Shrinking !FailureReport deriving (Eq, Show) -- | The status of a completed property test. -- -- In the case of a failure it provides the seed used for the test, the -- number of shrinks, and the execution log. -- data Result = Failed !FailureReport | GaveUp | OK deriving (Eq, Show) -- | A report on a running or completed property test. -- data Report a = Report { reportTests :: !TestCount , reportDiscards :: !DiscardCount , reportStatus :: !a } deriving (Show, Functor, Foldable, Traversable) -- | A summary of all the properties executed. -- data Summary = Summary { summaryWaiting :: !PropertyCount , summaryRunning :: !PropertyCount , summaryFailed :: !PropertyCount , summaryGaveUp :: !PropertyCount , summaryOK :: !PropertyCount } deriving (Show) instance Monoid Summary where mempty = Summary 0 0 0 0 0 mappend (Summary x1 x2 x3 x4 x5) (Summary y1 y2 y3 y4 y5) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) (x5 + y5) instance Semigroup Summary where (<>) = mappend -- | Construct a summary from a single result. -- fromResult :: Result -> Summary fromResult = \case Failed _ -> mempty { summaryFailed = 1 } GaveUp -> mempty { summaryGaveUp = 1 } OK -> mempty { summaryOK = 1 } summaryCompleted :: Summary -> PropertyCount summaryCompleted (Summary _ _ x3 x4 x5) = x3 + x4 + x5 summaryTotal :: Summary -> PropertyCount summaryTotal (Summary x1 x2 x3 x4 x5) = x1 + x2 + x3 + x4 + x5 ------------------------------------------------------------------------ -- Pretty Printing Helpers data Line a = Line { _lineAnnotation :: !a , lineNumber :: !LineNo , _lineSource :: !String } deriving (Eq, Ord, Show, Functor) data Declaration a = Declaration { declarationFile :: !FilePath , declarationLine :: !LineNo , _declarationName :: !String , declarationSource :: !(Map LineNo (Line a)) } deriving (Eq, Ord, Show, Functor) data Style = StyleDefault | StyleAnnotation | StyleFailure deriving (Eq, Ord, Show) data Markup = WaitingIcon | WaitingHeader | RunningIcon | RunningHeader | ShrinkingIcon | ShrinkingHeader | FailedIcon | FailedHeader | GaveUpIcon | GaveUpHeader | SuccessIcon | SuccessHeader | DeclarationLocation | StyledLineNo !Style | StyledBorder !Style | StyledSource !Style | AnnotationGutter | AnnotationValue | FailureArrows | FailureGutter | FailureMessage | DiffPrefix | DiffInfix | DiffSuffix | DiffSame | DiffRemoved | DiffAdded | ReproduceHeader | ReproduceGutter | ReproduceSource deriving (Eq, Ord, Show) instance Semigroup Style where (<>) x y = case (x, y) of (StyleFailure, _) -> StyleFailure (_, StyleFailure) -> StyleFailure (StyleAnnotation, _) -> StyleAnnotation (_, StyleAnnotation) -> StyleAnnotation (StyleDefault, _) -> StyleDefault ------------------------------------------------------------------------ takeAnnotation :: Log -> Maybe FailedAnnotation takeAnnotation = \case Annotation loc val -> Just $ FailedAnnotation loc val _ -> Nothing takeFootnote :: Log -> Maybe String takeFootnote = \case Footnote x -> Just x _ -> Nothing mkFailure :: Size -> Seed -> ShrinkCount -> Maybe Span -> String -> Maybe Diff -> [Log] -> FailureReport mkFailure size seed shrinks location message diff logs = let inputs = mapMaybe takeAnnotation logs footnotes = mapMaybe takeFootnote logs in FailureReport size seed shrinks inputs location message diff footnotes ------------------------------------------------------------------------ -- Pretty Printing ppShow :: Show x => x -> Doc a ppShow = -- unfortunate naming clash WL.text . show markup :: Markup -> Doc Markup -> Doc Markup markup = WL.annotate gutter :: Markup -> Doc Markup -> Doc Markup gutter m x = markup m ">" <+> x icon :: Markup -> Char -> Doc Markup -> Doc Markup icon m i x = markup m (WL.char i) <+> x ppTestCount :: TestCount -> Doc a ppTestCount = \case TestCount 1 -> "1 test" TestCount n -> ppShow n <+> "tests" ppDiscardCount :: DiscardCount -> Doc a ppDiscardCount = \case DiscardCount 1 -> "1 discard" DiscardCount n -> ppShow n <+> "discards" ppShrinkCount :: ShrinkCount -> Doc a ppShrinkCount = \case ShrinkCount 1 -> "1 shrink" ShrinkCount n -> ppShow n <+> "shrinks" ppRawPropertyCount :: PropertyCount -> Doc a ppRawPropertyCount (PropertyCount n) = ppShow n ppWithDiscardCount :: DiscardCount -> Doc Markup ppWithDiscardCount = \case DiscardCount 0 -> mempty n -> " with" <+> ppDiscardCount n ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup ppShrinkDiscard s d = case (s, d) of (0, 0) -> "" (0, _) -> " and" <+> ppDiscardCount d (_, 0) -> " and" <+> ppShrinkCount s (_, _) -> "," <+> ppShrinkCount s <+> "and" <+> ppDiscardCount d mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a)) -> Declaration a -> Declaration a mapSource f decl = decl { declarationSource = f (declarationSource decl) } -- | The span of non-whitespace characters for the line. -- -- The result is @[inclusive, exclusive)@. -- lineSpan :: Line a -> (ColumnNo, ColumnNo) lineSpan (Line _ _ x0) = let (pre, x1) = span Char.isSpace x0 (_, x2) = span Char.isSpace (reverse x1) start = length pre end = start + length x2 in (fromIntegral start, fromIntegral end) takeLines :: Span -> Declaration a -> Map LineNo (Line a) takeLines sloc = fst . Map.split (spanEndLine sloc + 1) . snd . Map.split (spanStartLine sloc - 1) . declarationSource readDeclaration :: MonadIO m => Span -> m (Maybe (Declaration ())) readDeclaration sloc = runMaybeT $ do path <- liftIO . makeRelativeToCurrentDirectory $ spanFile sloc (name, Pos (Position _ line0 _) src) <- MaybeT $ Discovery.readDeclaration path (spanEndLine sloc) let line = fromIntegral line0 pure . Declaration path line name . Map.fromList . zip [line..] . zipWith (Line ()) [line..] $ lines src defaultStyle :: Declaration a -> Declaration (Style, [(Style, Doc Markup)]) defaultStyle = fmap $ const (StyleDefault, []) lastLineSpan :: Monad m => Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo) lastLineSpan sloc decl = case reverse . Map.elems $ takeLines sloc decl of [] -> MaybeT $ pure Nothing x : _ -> pure $ lineSpan x ppFailedInputTypedArgument :: Int -> FailedAnnotation -> Doc Markup ppFailedInputTypedArgument ix (FailedAnnotation _ val) = WL.vsep [ WL.text "forAll" <> ppShow ix <+> "=" , WL.indent 2 . WL.vsep . fmap (markup AnnotationValue . WL.text) $ lines val ] ppFailedInputDeclaration :: MonadIO m => FailedAnnotation -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))) ppFailedInputDeclaration (FailedAnnotation msloc val) = runMaybeT $ do sloc <- MaybeT $ pure msloc decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc startCol <- fromIntegral . fst <$> lastLineSpan sloc decl let ppValLine = WL.indent startCol . (markup AnnotationGutter (WL.text "│ ") <>) . markup AnnotationValue . WL.text valDocs = fmap ((StyleAnnotation, ) . ppValLine) $ List.lines val startLine = fromIntegral $ spanStartLine sloc endLine = fromIntegral $ spanEndLine sloc styleInput kvs = foldr (Map.adjust . fmap . first $ const StyleAnnotation) kvs [startLine..endLine] insertDoc = Map.adjust (fmap . second $ const valDocs) endLine pure $ mapSource (styleInput . insertDoc) decl ppFailedInput :: MonadIO m => Int -> FailedAnnotation -> m (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))) ppFailedInput ix input = do mdecl <- ppFailedInputDeclaration input case mdecl of Nothing -> pure . Left $ ppFailedInputTypedArgument ix input Just decl -> pure $ Right decl ppLineDiff :: LineDiff -> Doc Markup ppLineDiff = \case LineSame x -> markup DiffSame $ " " <> WL.text x LineRemoved x -> markup DiffRemoved $ "- " <> WL.text x LineAdded x -> markup DiffAdded $ "+ " <> WL.text x 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 DiffAdded (WL.text added) <> markup DiffSuffix (WL.text suffix) ] ++ fmap ppLineDiff (toLineDiff diff) ppFailureLocation :: MonadIO m => String -> Maybe Diff -> Span -> m (Maybe (Declaration (Style, [(Style, Doc Markup)]))) ppFailureLocation msg mdiff sloc = runMaybeT $ do decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc (startCol, endCol) <- bimap fromIntegral fromIntegral <$> lastLineSpan sloc decl let arrowDoc = WL.indent startCol $ markup FailureArrows (WL.text (replicate (endCol - startCol) '^')) ppFailure x = WL.indent startCol $ markup FailureGutter (WL.text "│ ") <> x msgDocs = fmap ((StyleFailure, ) . ppFailure . markup FailureMessage . WL.text) (List.lines msg) diffDocs = case mdiff of Nothing -> [] Just diff -> fmap ((StyleFailure, ) . ppFailure) (ppDiff diff) docs = [(StyleFailure, arrowDoc)] ++ msgDocs ++ diffDocs startLine = spanStartLine sloc endLine = spanEndLine sloc styleFailure kvs = foldr (Map.adjust . fmap . first $ const StyleFailure) kvs [startLine..endLine] insertDoc = Map.adjust (fmap . second $ const docs) endLine pure $ mapSource (styleFailure . insertDoc) decl ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup ppDeclaration decl = case Map.maxView $ declarationSource decl of Nothing -> mempty Just (lastLine, _) -> let ppLocation = WL.indent (digits + 1) $ markup (StyledBorder StyleDefault) "┏━━" <+> markup DeclarationLocation (WL.text (declarationFile decl)) <+> markup (StyledBorder StyleDefault) "━━━" digits = length . show . unLineNo $ lineNumber lastLine ppLineNo = WL.text . printf ("%" <> show digits <> "d") . unLineNo ppEmptyNo = WL.text $ replicate digits ' ' ppSource style n src = markup (StyledLineNo style) (ppLineNo n) <+> markup (StyledBorder style) "┃" <+> markup (StyledSource style) (WL.text src) ppAnnot (style, doc) = markup (StyledLineNo style) ppEmptyNo <+> markup (StyledBorder style) "┃" <+> doc ppLines = do Line (style, xs) n src <- Map.elems $ declarationSource decl ppSource style n src : fmap ppAnnot xs in WL.vsep (ppLocation : ppLines) ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup ppReproduce name size seed = WL.vsep [ markup ReproduceHeader "This failure can be reproduced by running:" , gutter ReproduceGutter . markup ReproduceSource $ "recheck" <+> WL.text (showsPrec 11 size "") <+> WL.text (showsPrec 11 seed "") <+> maybe "" (WL.text . unPropertyName) name ] mergeLine :: Semigroup a => Line a -> Line a -> Line a mergeLine (Line x no src) (Line y _ _) = Line (x <> y) no src mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) = Declaration file line name $ Map.unionWith mergeLine src0 src1 mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a] mergeDeclarations = Map.elems . Map.fromListWith mergeDeclaration . fmap (\d -> ((declarationFile d, declarationLine d), d)) ppTextLines :: String -> [Doc Markup] 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) <- case mlocation0 of Nothing -> -- Move the failure message to the end section if we have -- no source location. let msgs1 = msgs0 ++ (if null msg then [] else [msg]) docs = concatMap ppTextLines msgs1 ++ maybe [] ppDiff mdiff in pure (docs, Nothing) Just location0 -> (concatMap ppTextLines msgs0,) <$> ppFailureLocation msg mdiff location0 (args, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0 let decls = mergeDeclarations . catMaybes $ mlocation : fmap pure idecls with xs f = if null xs then [] else [f xs] pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [ with args $ WL.vsep . WL.punctuate WL.line , with decls $ WL.vsep . WL.punctuate WL.line . fmap ppDeclaration , with msgs $ WL.vsep , [ppReproduce name size seed] ] ppName :: Maybe PropertyName -> Doc a ppName = \case Nothing -> "" Just (PropertyName name) -> WL.text name ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup) ppProgress name (Report tests discards status) = case status of Running -> pure . icon RunningIcon '●' . WL.annotate RunningHeader $ ppName name <+> "passed" <+> ppTestCount tests <> ppWithDiscardCount discards <+> "(running)" Shrinking failure -> pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $ ppName name <+> "failed after" <+> ppTestCount tests <> ppShrinkDiscard (failureShrinks failure) discards <+> "(shrinking)" ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup) ppResult name (Report tests discards result) = case result of Failed failure -> do pfailure <- ppFailureReport name failure pure . WL.vsep $ [ icon FailedIcon '✗' . WL.annotate FailedHeader $ ppName name <+> "failed after" <+> ppTestCount tests <> ppShrinkDiscard (failureShrinks failure) discards <> "." , mempty , pfailure , mempty ] GaveUp -> pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $ ppName name <+> "gave up after" <+> ppDiscardCount discards <> ", passed" <+> ppTestCount tests <> "." OK -> pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $ ppName name <+> "passed" <+> ppTestCount tests <> "." ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a) ppWhenNonZero suffix n = if n <= 0 then Nothing else Just $ ppRawPropertyCount n <+> suffix annotateSummary :: Summary -> Doc Markup -> Doc Markup annotateSummary summary = if summaryFailed summary > 0 then icon FailedIcon '✗' . WL.annotate FailedHeader else if summaryGaveUp summary > 0 then icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader else if summaryWaiting summary > 0 || summaryRunning summary > 0 then icon WaitingIcon '○' . WL.annotate WaitingHeader else icon SuccessIcon '✓' . WL.annotate SuccessHeader ppSummary :: MonadIO m => Summary -> m (Doc Markup) ppSummary summary = let complete = summaryCompleted summary == summaryTotal summary prefix end = if complete then mempty else ppRawPropertyCount (summaryCompleted summary) <> "/" <> ppRawPropertyCount (summaryTotal summary) <+> "complete" <> end addPrefix xs = if null xs then prefix mempty : [] else prefix ": " : xs suffix = if complete then "." else " (running)" in pure . annotateSummary summary . (<> suffix) . WL.hcat . addPrefix . WL.punctuate ", " $ catMaybes [ ppWhenNonZero "failed" (summaryFailed summary) , ppWhenNonZero "gave up" (summaryGaveUp summary) , if complete then ppWhenNonZero "succeeded" (summaryOK summary) else Nothing ] renderDoc :: MonadIO m => Maybe UseColor -> Doc Markup -> m String renderDoc mcolor doc = do let dull = SetColor Foreground Dull vivid = SetColor Foreground Vivid bold = SetConsoleIntensity BoldIntensity start = \case WaitingIcon -> setSGRCode [] WaitingHeader -> setSGRCode [] RunningIcon -> setSGRCode [] RunningHeader -> setSGRCode [] ShrinkingIcon -> setSGRCode [vivid Red] ShrinkingHeader -> setSGRCode [vivid Red] FailedIcon -> setSGRCode [vivid Red] FailedHeader -> setSGRCode [vivid Red] GaveUpIcon -> setSGRCode [dull Yellow] GaveUpHeader -> setSGRCode [dull Yellow] SuccessIcon -> setSGRCode [dull Green] SuccessHeader -> setSGRCode [dull Green] DeclarationLocation -> setSGRCode [] StyledLineNo StyleDefault -> setSGRCode [] StyledSource StyleDefault -> setSGRCode [] StyledBorder StyleDefault -> setSGRCode [] StyledLineNo StyleAnnotation -> setSGRCode [dull Magenta] StyledSource StyleAnnotation -> setSGRCode [] StyledBorder StyleAnnotation -> setSGRCode [] AnnotationGutter -> setSGRCode [dull Magenta] AnnotationValue -> setSGRCode [dull Magenta] StyledLineNo StyleFailure -> setSGRCode [vivid Red] StyledSource StyleFailure -> setSGRCode [vivid Red, bold] StyledBorder StyleFailure -> setSGRCode [] FailureArrows -> setSGRCode [vivid Red] FailureMessage -> setSGRCode [] FailureGutter -> setSGRCode [] DiffPrefix -> setSGRCode [] DiffInfix -> setSGRCode [] DiffSuffix -> setSGRCode [] DiffSame -> setSGRCode [] DiffRemoved -> setSGRCode [dull Red] DiffAdded -> setSGRCode [dull Green] ReproduceHeader -> setSGRCode [] ReproduceGutter -> setSGRCode [] ReproduceSource -> setSGRCode [] end _ = setSGRCode [Reset] color <- resolveColor mcolor let display = case color of EnableColor -> WL.displayDecorated start end id DisableColor -> WL.display #if mingw32_HOST_OS liftIO $ do hSetEncoding stdout utf8 hSetEncoding stderr utf8 #endif pure . display . WL.renderSmart 100 $ WL.indent 2 doc renderProgress :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Progress -> m String renderProgress mcolor name x = renderDoc mcolor =<< ppProgress name x renderResult :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Result -> m String renderResult mcolor name x = renderDoc mcolor =<< ppResult name x renderSummary :: MonadIO m => Maybe UseColor -> Summary -> m String renderSummary mcolor x = renderDoc mcolor =<< ppSummary x hedgehog-0.6.1/src/Hedgehog/Internal/Distributive.hs0000644000000000000000000000277013351371600020551 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} module Hedgehog.Internal.Distributive ( Distributive(..) ) where import Control.Monad (join) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Writer (WriterT(..)) import GHC.Exts (Constraint) class Distributive 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 ) -- | Distribute one monad transformer over another. -- distribute :: 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 Distributive (ExceptT x) where distribute x = lift . ExceptT . pure =<< hoist lift (runExceptT x) instance Monoid w => Distributive (WriterT w) where distribute x = lift . WriterT . pure =<< hoist lift (runWriterT x) instance Distributive (ReaderT r) where distribute x = join . lift . ReaderT $ \r -> pure . hoist lift $ runReaderT x r hedgehog-0.6.1/src/Hedgehog/Internal/Source.hs0000644000000000000000000000456413351371600017337 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} module Hedgehog.Internal.Source ( LineNo(..) , ColumnNo(..) , Span(..) , getCaller -- * Re-exports from "GHC.Stack" , CallStack , HasCallStack , callStack , 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 } deriving (Eq, Ord, Num, Enum, Real, Integral) newtype ColumnNo = ColumnNo { unColumnNo :: Int } deriving (Eq, Ord, Num, Enum, Real, Integral) data Span = Span { spanFile :: !FilePath , spanStartLine :: !LineNo , spanStartColumn :: !ColumnNo , spanEndLine :: !LineNo , 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 [] -> Nothing (_, x) : _ -> Just $ Span (srcLocFile x) (fromIntegral $ srcLocStartLine x) (fromIntegral $ srcLocStartCol x) (fromIntegral $ srcLocEndLine x) (fromIntegral $ srcLocEndCol x) #else getCaller _ = Nothing #endif ------------------------------------------------------------------------ -- Show instances instance Show Span where showsPrec p (Span file sl sc el ec) = showParen (p > 10) $ showString "Span " . showsPrec 11 file . showChar ' ' . showsPrec 11 sl . showChar ' ' . showsPrec 11 sc . showChar ' ' . showsPrec 11 el . showChar ' ' . showsPrec 11 ec instance Show LineNo where showsPrec p (LineNo x) = showParen (p > 10) $ showString "LineNo " . showsPrec 11 x instance Show ColumnNo where showsPrec p (ColumnNo x) = showParen (p > 10) $ showString "ColumnNo " . showsPrec 11 x hedgehog-0.6.1/src/Hedgehog/Internal/HTraversable.hs0000644000000000000000000000056313351371600020454 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Internal.HTraversable ( HTraversable(..) ) where -- | Higher-order traversable functors. -- -- This is used internally to make symbolic variables concrete given an 'Environment'. -- class HTraversable t where htraverse :: Applicative f => (forall a. g a -> f (h a)) -> t g -> f (t h) hedgehog-0.6.1/src/Hedgehog/Internal/Discovery.hs0000644000000000000000000001325313351371600020041 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Hedgehog.Internal.Discovery ( PropertySource(..) , readProperties , findProperties , readDeclaration , Pos(..) , Position(..) ) where import Control.Exception (IOException, handle) import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.Char as Char import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Ord as Ord import Data.Semigroup (Semigroup(..)) import Hedgehog.Internal.Property (PropertyName(..)) import Hedgehog.Internal.Source (LineNo(..), ColumnNo(..)) ------------------------------------------------------------------------ -- Property Extraction newtype PropertySource = PropertySource { propertySource :: Pos String } deriving (Eq, Ord, Show) readProperties :: MonadIO m => FilePath -> m (Map PropertyName PropertySource) readProperties path = findProperties path <$> liftIO (readFile path) readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String)) readDeclaration path line = do mfile <- liftIO $ readFileSafe path pure $ do file <- mfile takeHead . List.sortBy (Ord.comparing $ Ord.Down . posLine . posPostion . snd) . filter ((<= line) . posLine . posPostion . snd) $ Map.toList (findDeclarations path file) readFileSafe :: MonadIO m => FilePath -> m (Maybe String) readFileSafe path = liftIO $ handle (\(_ :: IOException) -> pure Nothing) (Just <$> readFile path) takeHead :: [a] -> Maybe a takeHead = \case [] -> Nothing x : _ -> Just x findProperties :: FilePath -> String -> Map PropertyName PropertySource findProperties path = Map.map PropertySource . Map.mapKeysMonotonic PropertyName . Map.filterWithKey (\k _ -> isProperty k) . findDeclarations path findDeclarations :: FilePath -> String -> Map String (Pos String) findDeclarations path = declarations . classified . positioned path isProperty :: String -> Bool isProperty = List.isPrefixOf "prop_" ------------------------------------------------------------------------ -- Declaration Identification declarations :: [Classified (Pos Char)] -> Map String (Pos String) declarations = let loop = \case [] -> [] x : xs -> let (ys, zs) = break isDeclaration xs in tagWithName (forget x $ trimEnd ys) : loop zs in Map.fromListWith (<>) . loop . dropWhile (not . isDeclaration) trimEnd :: [Classified (Pos Char)] -> [Classified (Pos Char)] trimEnd xs = let (space0, code) = span isWhitespace $ reverse xs (line_tail0, space) = span (\(Classified _ (Pos _ x)) -> x /= '\n') $ reverse space0 line_tail = case space of [] -> line_tail0 x : _ -> line_tail0 ++ [x] in reverse code ++ line_tail isWhitespace :: Classified (Pos Char) -> Bool isWhitespace (Classified c (Pos _ x)) = c == Comment || Char.isSpace x tagWithName :: Pos String -> (String, Pos String) tagWithName (Pos p x) = (takeName x, Pos p x) takeName :: String -> String takeName xs = case words xs of [] -> "" x : _ -> x forget :: Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String forget (Classified _ (Pos p x)) xs = Pos p $ x : fmap (posValue . classifiedValue) xs isDeclaration :: Classified (Pos Char) -> Bool isDeclaration (Classified c (Pos p x)) = c == NotComment && posColumn p == 1 && (Char.isLower x || x == '_') ------------------------------------------------------------------------ -- Comment Classification data Class = NotComment | Comment deriving (Eq, Ord, Show) data Classified a = Classified { _classifiedClass :: !Class , classifiedValue :: !a } deriving (Eq, Ord, Show) classified :: [Pos Char] -> [Classified (Pos Char)] classified = let ok = Classified NotComment ko = Classified Comment loop nesting in_line = \case [] -> [] x@(Pos _ '\n') : xs | in_line -> ok x : loop nesting False xs x : xs | in_line -> ko x : loop nesting in_line xs x@(Pos _ '{') : y@(Pos _ '-') : xs -> ko x : ko y : loop (nesting + 1) in_line xs x@(Pos _ '-') : y@(Pos _ '}') : xs | nesting > 0 -> ko x : ko y : loop (nesting - 1) in_line xs x : xs | nesting > 0 -> ko x : loop nesting in_line xs -- FIXME This is not technically correct, we should allow arbitrary runs -- FIXME of dashes followed by a symbol character. Here we have only -- FIXME allowed two. x@(Pos _ '-') : y@(Pos _ '-') : z@(Pos _ zz) : xs | not (Char.isSymbol zz) -> ko x : ko y : loop nesting True (z : xs) x : xs -> ok x : loop nesting in_line xs in loop (0 :: Int) False ------------------------------------------------------------------------ -- Character Positioning data Position = Position { _posPath :: !FilePath , posLine :: !LineNo , posColumn :: !ColumnNo } deriving (Eq, Ord, Show) data Pos a = Pos { posPostion :: !Position , posValue :: a } deriving (Eq, Ord, Show, Functor) instance Semigroup a => Semigroup (Pos a) where (<>) (Pos p x) (Pos q y) = if p < q then Pos p (x <> y) else Pos q (y <> x) positioned :: FilePath -> [Char] -> [Pos Char] positioned path = let loop l c = \case [] -> [] '\n' : xs -> Pos (Position path l c) '\n' : loop (l + 1) 1 xs x : xs -> Pos (Position path l c) x : loop l (c + 1) xs in loop 1 1 hedgehog-0.6.1/src/Hedgehog/Internal/Property.hs0000644000000000000000000005227713351371600017727 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Distributive module Hedgehog.Internal.Property ( -- * Property Property(..) , PropertyT(..) , PropertyName(..) , PropertyConfig(..) , TestLimit(..) , DiscardLimit(..) , ShrinkLimit(..) , ShrinkRetries(..) , withTests , withDiscards , withShrinks , withRetries , property , test , forAll , forAllT , forAllWith , forAllWithT , discard -- * Group , Group(..) , GroupName(..) -- * TestT , MonadTest(..) , Test , TestT(..) , Log(..) , Failure(..) , Diff(..) , annotate , annotateShow , footnote , footnoteShow , failure , success , assert , (===) , (/==) , eval , evalM , evalIO , evalEither , evalExceptT -- * Internal -- $internal , defaultConfig , mapConfig , failDiff , failException , failWith , writeLog , mkTest , mkTestT , runTest , runTestT ) where import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus(..)) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Catch (SomeException(..), displayException) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Morph (MFunctor(..)) 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.Cont (ContT) import Control.Monad.Trans.Control (ComposeSt, defaultLiftBaseWith, defaultRestoreM) import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Identity (IdentityT) import Control.Monad.Trans.Maybe (MaybeT) import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Resource (MonadResource(..)) import Control.Monad.Trans.Resource (ResourceT) 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 qualified Data.Char as Char import Data.Functor.Identity (Identity(..)) import qualified Data.List as List import Data.Semigroup (Semigroup) import Data.String (IsString) import Data.Typeable (typeOf) import Hedgehog.Internal.Distributive import Hedgehog.Internal.Exception import Hedgehog.Internal.Gen (Gen, GenT) import qualified Hedgehog.Internal.Gen as Gen import Hedgehog.Internal.Show import Hedgehog.Internal.Source import Language.Haskell.TH.Lift (deriveLift) ------------------------------------------------------------------------ -- | A property test, along with some configurable limits like how many times -- to run the test. -- data Property = Property { propertyConfig :: !PropertyConfig , propertyTest :: PropertyT IO () } -- | The property monad transformer allows both the generation of test inputs -- and the assertion of expectations. -- newtype PropertyT m a = PropertyT { unPropertyT :: TestT (GenT m) a } deriving ( Functor , Applicative , Monad , MonadIO , MonadBase b , MonadThrow , MonadCatch , MonadReader r , MonadState s , MonadError e ) -- | A test monad allows the assertion of expectations. -- type Test = TestT Identity -- | A test monad transformer allows the assertion of expectations. -- newtype TestT m a = TestT { unTest :: ExceptT Failure (Lazy.WriterT [Log] m) a } deriving ( Functor , Applicative , MonadIO , MonadBase b , MonadThrow , MonadCatch , MonadReader r , MonadState s ) -- | The name of a property. -- -- Can be constructed using `OverloadedStrings`: -- -- @ -- "apples" :: PropertyName -- @ -- newtype PropertyName = PropertyName { unPropertyName :: String } deriving (Eq, Ord, Show, IsString, Semigroup) -- | Configuration for a property test. -- data PropertyConfig = PropertyConfig { propertyTestLimit :: !TestLimit , propertyDiscardLimit :: !DiscardLimit , propertyShrinkLimit :: !ShrinkLimit , propertyShrinkRetries :: !ShrinkRetries } deriving (Eq, Ord, Show) -- | The number of successful tests that need to be run before a property test -- is considered successful. -- -- Can be constructed using numeric literals: -- -- @ -- 200 :: TestLimit -- @ -- newtype TestLimit = TestLimit Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | The number of discards to allow before giving up. -- -- Can be constructed using numeric literals: -- -- @ -- 10000 :: DiscardLimit -- @ -- -- newtype DiscardLimit = DiscardLimit Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | The number of shrinks to try before giving up on shrinking. -- -- Can be constructed using numeric literals: -- -- @ -- 1000 :: ShrinkLimit -- @ -- newtype ShrinkLimit = ShrinkLimit Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | The number of times to re-run a test during shrinking. This is useful if -- you are testing something which fails non-deterministically and you want to -- increase the change of getting a good shrink. -- -- If you are doing parallel state machine testing, you should probably set -- shrink retries to something like @10@. This will mean that during -- shrinking, a parallel test case requires 10 successful runs before it is -- passes and we try a different shrink. -- -- Can be constructed using numeric literals: -- -- @ -- 0 :: ShrinkRetries -- @ -- newtype ShrinkRetries = ShrinkRetries Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -- | A named collection of property tests. -- data Group = Group { groupName :: !GroupName , groupProperties :: ![(PropertyName, Property)] } -- | The name of a group of properties. -- -- Can be constructed using `OverloadedStrings`: -- -- @ -- "fruit" :: GroupName -- @ -- newtype GroupName = GroupName { unGroupName :: String } deriving (Eq, Ord, Show, IsString, Semigroup) -- -- 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. -- -- | Log messages which are recorded during a test run. -- data Log = Annotation (Maybe Span) String | Footnote String deriving (Eq, Show) -- | Details on where and why a test failed. -- data Failure = Failure (Maybe Span) String (Maybe Diff) deriving (Eq, Show) -- | The difference between some expected and actual value. -- data Diff = Diff { diffPrefix :: String , diffRemoved :: String , diffInfix :: String , diffAdded :: String , diffSuffix :: String , diffValue :: ValueDiff } deriving (Eq, Show) ------------------------------------------------------------------------ -- TestT instance Monad m => Monad (TestT m) where return = TestT . return (>>=) m k = TestT $ unTest m >>= unTest . k fail err = TestT . ExceptT . pure . Left $ Failure Nothing err Nothing instance MonadTrans TestT where lift = TestT . lift . lift instance MFunctor TestT where hoist f = TestT . hoist (hoist f) . unTest instance Distributive TestT where type Transformer t TestT m = ( Transformer t (Lazy.WriterT [Log]) m , Transformer t (ExceptT Failure) (Lazy.WriterT [Log] m) ) distribute = hoist TestT . distribute . hoist distribute . unTest instance PrimMonad m => PrimMonad (TestT m) where type PrimState (TestT m) = PrimState m primitive = lift . primitive -- FIXME instance MonadWriter w m => MonadWriter w (TestT m) instance MonadError e m => MonadError e (TestT m) where throwError = lift . throwError catchError m onErr = TestT . ExceptT $ (runExceptT $ unTest m) `catchError` (runExceptT . unTest . onErr) instance MonadResource m => MonadResource (TestT m) where liftResourceT = lift . liftResourceT instance MonadTransControl TestT where type StT TestT a = (Either Failure a, [Log]) liftWith f = mkTestT . fmap (, []) . fmap Right $ f $ runTestT restoreT = mkTestT instance MonadBaseControl b m => MonadBaseControl b (TestT m) where type StM (TestT m) a = ComposeSt TestT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM class Monad m => MonadTest m where liftTest :: Test a -> m a instance Monad m => MonadTest (TestT m) where liftTest = hoist (pure . runIdentity) instance MonadTest m => MonadTest (IdentityT m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (MaybeT m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ExceptT x m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ReaderT r m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (Lazy.StateT s m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (Strict.StateT s m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Lazy.WriterT w m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Strict.WriterT w m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Lazy.RWST r w s m) where liftTest = lift . liftTest instance (MonadTest m, Monoid w) => MonadTest (Strict.RWST r w s m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ContT r m) where liftTest = lift . liftTest instance MonadTest m => MonadTest (ResourceT m) where liftTest = lift . liftTest mkTestT :: m (Either Failure a, [Log]) -> TestT m a mkTestT = TestT . ExceptT . Lazy.WriterT mkTest :: (Either Failure a, [Log]) -> Test a mkTest = mkTestT . Identity runTestT :: TestT m a -> m (Either Failure a, [Log]) runTestT = Lazy.runWriterT . runExceptT . unTest runTest :: Test a -> (Either Failure a, [Log]) runTest = runIdentity . runTestT -- | Log some information which might be relevant to a potential test failure. -- writeLog :: MonadTest m => Log -> m () writeLog x = liftTest $ mkTest (pure (), [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, []) -- | Annotates the source code with a message that might be useful for -- debugging a test failure. -- annotate :: (MonadTest m, HasCallStack) => String -> m () annotate x = do writeLog $ Annotation (getCaller callStack) x -- | Annotates the source code with a value that might be useful for -- debugging a test failure. -- annotateShow :: (MonadTest m, Show a, HasCallStack) => a -> m () annotateShow x = do withFrozenCallStack $ annotate (showPretty x) -- | Logs a message to be displayed as additional information in the footer of -- the failure report. -- footnote :: MonadTest m => String -> m () footnote = writeLog . Footnote -- | Logs a value to be displayed as additional information in the footer of -- the failure report. -- footnoteShow :: (MonadTest m, Show a) => a -> m () footnoteShow = writeLog . Footnote . showPretty -- | Fails with an error which 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 ━━━" , showPretty x , showPretty y ] Just diff -> withFrozenCallStack $ failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) "" -- | Fails with an error which renders the type of an exception and its error -- message. -- failException :: (MonadTest m, HasCallStack) => SomeException -> m a failException (SomeException x) = withFrozenCallStack $ failWith Nothing $ unlines [ "━━━ Exception: " ++ show (typeOf x) ++ " ━━━" , List.dropWhileEnd Char.isSpace (displayException x) ] -- | Causes a test to fail. -- failure :: (MonadTest m, HasCallStack) => m a failure = withFrozenCallStack $ failWith Nothing "" -- | Another name for @pure ()@. -- success :: MonadTest m => m () success = pure () -- | Fails the test if the condition provided is 'False'. -- assert :: (MonadTest m, HasCallStack) => Bool -> m () assert b = do ok <- withFrozenCallStack $ eval b if ok then success else withFrozenCallStack failure 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 = do ok <- withFrozenCallStack $ eval (x == y) if ok then success else withFrozenCallStack $ failDiff 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 ] -- | Fails the test if the value throws an exception when evaluated to weak -- head normal form (WHNF). -- eval :: (MonadTest m, HasCallStack) => a -> m a eval x = either (withFrozenCallStack failException) pure (tryEvaluate x) -- | Fails the test if the action throws an exception. -- -- /The benefit of using this over simply letting the exception bubble up is/ -- /that the location of the closest 'evalM' will be shown in the output./ -- evalM :: (MonadTest m, MonadCatch m, HasCallStack) => m a -> m a evalM m = either (withFrozenCallStack failException) pure =<< tryAll m -- | Fails the test if the 'IO' action throws an exception. -- -- /The benefit of using this over 'liftIO' is that the location of the/ -- /exception will be shown in the output./ -- evalIO :: (MonadTest m, MonadIO m, HasCallStack) => IO a -> m a evalIO m = either (withFrozenCallStack failException) pure =<< liftIO (tryAll m) -- | Fails the test if the 'Either' is 'Left', otherwise returns the value in -- the 'Right'. -- evalEither :: (MonadTest m, Show x, HasCallStack) => Either x a -> m a evalEither = \case Left x -> withFrozenCallStack $ failWith Nothing $ showPretty x Right x -> pure x -- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in -- the 'Right'. -- evalExceptT :: (MonadTest m, Show x, HasCallStack) => ExceptT x m a -> m a evalExceptT m = withFrozenCallStack evalEither =<< runExceptT m ------------------------------------------------------------------------ -- PropertyT instance MonadTrans PropertyT where lift = PropertyT . lift . lift instance MFunctor PropertyT where hoist f = PropertyT . hoist (hoist f) . unPropertyT instance Distributive PropertyT where type Transformer t PropertyT m = ( Transformer t GenT m , Transformer t TestT (GenT m) ) distribute = hoist PropertyT . distribute . hoist distribute . unPropertyT instance PrimMonad m => PrimMonad (PropertyT m) where type PrimState (PropertyT m) = PrimState m primitive = lift . primitive ---- FIXME instance MonadWriter w m => MonadWriter w (PropertyT m) instance Monad m => MonadTest (PropertyT m) where liftTest = PropertyT . hoist (pure . runIdentity) instance MonadPlus m => MonadPlus (PropertyT m) where mzero = discard mplus (PropertyT x) (PropertyT y) = PropertyT . mkTestT $ mplus (runTestT x) (runTestT y) instance MonadPlus m => Alternative (PropertyT m) where empty = mzero (<|>) = mplus -- | Generates a random input for the test by running the provided generator. -- -- /This is a the same as 'forAllT' but allows the user to provide a custom/ -- /rendering function. This is useful for values which don't have a/ -- /'Show' instance./ -- forAllWithT :: (Monad m, HasCallStack) => (a -> String) -> GenT m a -> PropertyT m a forAllWithT render gen = do x <- PropertyT $ lift gen withFrozenCallStack $ annotate (render x) return x -- | Generates a random input for the test by running the provided generator. -- -- /This is a the same as 'forAll' but allows the user to provide a custom/ -- /rendering function. This is useful for values which don't have a/ -- /'Show' instance./ -- forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a forAllWith render gen = withFrozenCallStack $ forAllWithT render $ Gen.lift 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 -- | Generates a random input for the test by running the provided generator. -- forAll :: (Monad m, Show a, HasCallStack) => Gen a -> PropertyT m a forAll gen = withFrozenCallStack $ forAllWith showPretty gen -- | Discards the current test entirely. -- discard :: Monad m => PropertyT m a discard = PropertyT $ lift Gen.discard -- | Lift a test in to a property. -- -- Because both 'TestT' and 'PropertyT' have 'MonadTest' instances, this -- function is not often required. It can however be useful for writing -- functions directly in 'TestT' and thus gaining a 'MonadTransControl' -- 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 -- @ -- test :: Monad m => TestT m a -> PropertyT m a test = PropertyT . hoist lift ------------------------------------------------------------------------ -- Property -- | The default configuration for a property test. -- defaultConfig :: PropertyConfig defaultConfig = PropertyConfig { propertyTestLimit = 100 , propertyDiscardLimit = 100 , propertyShrinkLimit = 1000 , propertyShrinkRetries = 0 } -- | Map a config modification function over a property. -- mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property mapConfig f (Property cfg t) = Property (f cfg) t -- | Set the number of times a property should be executed before it is considered -- successful. -- -- If you have a test that does not involve any generators and thus does not -- need to run repeatedly, you can use @withTests 1@ to define a property that -- will only be checked once. -- withTests :: TestLimit -> Property -> Property withTests n = mapConfig $ \config -> config { propertyTestLimit = n } -- | Set the number of times a property is allowed to discard before the test -- runner gives up. -- withDiscards :: DiscardLimit -> Property -> Property withDiscards n = mapConfig $ \config -> config { propertyDiscardLimit = n } -- | Set the number of times a property is allowed to shrink before the test -- runner gives up and prints the counterexample. -- withShrinks :: ShrinkLimit -> Property -> Property withShrinks n = mapConfig $ \config -> config { propertyShrinkLimit = n } -- | Set the number of times a property will be executed for each shrink before -- the test runner gives up and tries a different shrink. See 'ShrinkRetries' -- for more information. -- withRetries :: ShrinkRetries -> Property -> Property withRetries n = mapConfig $ \config -> config { propertyShrinkRetries = n } -- | Creates a property with the default configuration. -- property :: HasCallStack => PropertyT IO () -> Property property m = Property defaultConfig $ withFrozenCallStack (evalM m) ------------------------------------------------------------------------ -- FIXME Replace with DeriveLift when we drop 7.10 support. $(deriveLift ''GroupName) $(deriveLift ''PropertyName) $(deriveLift ''PropertyConfig) $(deriveLift ''TestLimit) $(deriveLift ''DiscardLimit) $(deriveLift ''ShrinkLimit) $(deriveLift ''ShrinkRetries) ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-0.6.1/src/Hedgehog/Internal/Tripping.hs0000644000000000000000000000236713351371600017672 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Tripping ( tripping ) where import Hedgehog.Internal.Property import Hedgehog.Internal.Show import Hedgehog.Internal.Source -- | Test that a pair of encode / decode functions are compatible. -- tripping :: (MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack) => a -> (a -> b) -> (b -> f a) -> m () tripping x encode decode = let mx = pure x i = encode x my = decode i in if mx == my then success else case valueDiff <$> mkValue mx <*> mkValue my of Nothing -> withFrozenCallStack $ failWith Nothing $ unlines [ "━━━ Original ━━━" , showPretty mx , "━━━ Intermediate ━━━" , showPretty i , "━━━ Roundtrip ━━━" , showPretty my ] Just diff -> withFrozenCallStack $ failWith (Just $ Diff "━━━ " "- Original" "/" "+ Roundtrip" " ━━━" diff) $ unlines [ "━━━ Intermediate ━━━" , showPretty i ] hedgehog-0.6.1/src/Hedgehog/Internal/Gen.hs0000644000000000000000000011615313351371600016606 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- MonadBase module Hedgehog.Internal.Gen ( -- * Transformer Gen , GenT(..) , MonadGen(..) -- * Combinators , lift -- ** Shrinking , shrink , prune -- ** Size , small , scale , resize , sized -- ** Integral , integral , integral_ , int , int8 , int16 , int32 , int64 , word , word8 , word16 , word32 , word64 -- ** Floating-point , realFloat , realFrac_ , float , double -- ** Enumeration , enum , enumBounded , bool , bool_ -- ** Characters , binit , octit , digit , hexit , lower , upper , alpha , alphaNum , ascii , latin1 , unicode , unicodeAll -- ** Strings , string , text , utf8 , bytes -- ** Choice , constant , element , choice , frequency , recursive -- ** Conditional , discard , ensure , filter , just -- ** Collections , maybe , list , seq , nonEmpty , set , map -- ** Subterms , freeze , subterm , subtermM , subterm2 , subtermM2 , subterm3 , subtermM3 -- ** Combinations & Permutations , subsequence , shuffle -- * Sampling Generators , sample , print , printTree , printWith , printTreeWith -- * Internal -- $internal -- ** Transfomer , runGenT , mapGenT , generate , liftTree , runDiscardEffect -- ** Size , golden -- ** Shrinking , atLeast -- ** Characters , isSurrogate , isNoncharacter -- ** Subterms , Vec(..) , Nat(..) , subtermMVec -- ** Sampling , renderNodes ) where import Control.Applicative (Alternative(..),liftA2) import Control.Monad (MonadPlus(..), filterM, replicateM, ap, join) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) 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 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.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 Data.Bifunctor (first, second) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Char as Char import Data.Foldable (for_, toList) import Data.Functor.Identity (Identity(..)) import Data.Int (Int8, Int16, Int32, Int64) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import Data.Semigroup (Semigroup) import qualified Data.Semigroup as Semigroup import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Set (Set) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word8, Word16, Word32, Word64) import Hedgehog.Internal.Distributive (Distributive(..)) 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 qualified Hedgehog.Internal.Tree as Tree import Hedgehog.Range (Size, Range) import qualified Hedgehog.Range as Range import Prelude hiding (filter, print, maybe, map, seq) ------------------------------------------------------------------------ -- Generator transformer -- | Generator for random values of @a@. -- type Gen = GenT Identity -- | Monad transformer which can generate random values of @a@. -- newtype GenT m a = GenT { unGen :: Size -> Seed -> Tree (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) = m 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 f gen = GenT $ \size seed -> f (runGenT size seed gen) -- | 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) -- | 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. -- runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a) runDiscardEffect = runMaybeT . distribute ------------------------------------------------------------------------ -- 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 -- | See @Gen.@'Hedgehog.Gen.prune' -- pruneGen :: m a -> m a -- | See @Gen.@'Hedgehog.Gen.scale' -- scaleGen :: (Size -> Size) -> m a -> m a -- | See @Gen.@'Hedgehog.Gen.freeze' -- freezeGen :: m a -> m (a, m a) instance Monad m => MonadGen (GenT m) where liftGen gen = hoist generalize gen shrinkGen = mapGenT . Tree.expand pruneGen = mapGenT Tree.prune 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 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) 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) shrink2 :: (a -> [a]) -> (a, b) -> [(a, b)] shrink2 f (x, y) = fmap (, y) (f x) shrink3 :: (a -> [a]) -> (a, b, c) -> [(a, b, c)] shrink3 f (x, y, z) = fmap (, y, z) (f x) instance MonadGen m => MonadGen (MaybeT m) where liftGen = Trans.lift . liftGen shrinkGen f = mapMaybeT $ shrink (shrinkMaybe f) pruneGen = hoist prune scaleGen f = hoist (scale f) freezeGen = mapMaybeT $ \m0 -> do (mx, m) <- freeze m0 pure $ fmap (, MaybeT m) mx instance MonadGen m => MonadGen (ExceptT x m) where liftGen = Trans.lift . liftGen shrinkGen f = mapExceptT $ shrink (shrinkEither f) pruneGen = hoist prune scaleGen f = hoist (scale f) freezeGen = mapExceptT $ \m0 -> do (mx, m) <- freeze m0 pure $ fmap (, ExceptT m) mx 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 scaleGen f = hoist (scale f) freezeGen m0 = Strict.StateT $ \s0 -> do ((x, s), m) <- freeze (Strict.runStateT m0 s0) pure ((x, Strict.StateT (const m)), s) 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 scaleGen f = hoist (scale f) freezeGen m0 = Lazy.WriterT $ do ((x, w), m) <- freeze (Lazy.runWriterT m0) pure ((x, Lazy.WriterT m), w) 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 scaleGen f = hoist (scale f) freezeGen m0 = Strict.RWST $ \r s0 -> do ((x, s, w), m) <- freeze (Strict.runRWST m0 r s0) pure ((x, Strict.RWST (\_ _ -> m)), s, w) ------------------------------------------------------------------------ -- GenT instances instance (Monad m, Semigroup a) => Semigroup (GenT m a) where (<>) = liftA2 (Semigroup.<>) instance (Monad m, Monoid a) => Monoid (GenT m a) where 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) instance Monad m => Applicative (GenT m) where pure = return (<*>) = ap instance Monad m => Monad (GenT m) where return = liftTree . pure (>>=) m k = GenT $ \size seed -> case Seed.split seed of (sk, sm) -> runGenT size sk . k =<< runGenT size sm m instance Monad m => Alternative (GenT m) where empty = mzero (<|>) = mplus instance Monad m => MonadPlus (GenT m) where mzero = liftTree mzero mplus x y = GenT $ \size seed -> case Seed.split seed of (sx, sy) -> runGenT size sx x `mplus` runGenT size sy y instance MonadTrans GenT where lift = liftTree . Trans.lift . Trans.lift instance MFunctor GenT where hoist f = mapGenT (hoist (hoist f)) embedMaybe :: 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) 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 embedGen :: Monad n => (forall a. m a -> GenT n a) -> GenT m b -> GenT n b embedGen f gen = GenT $ \size seed -> case Seed.split seed of (sf, sg) -> (runGenT size sf . f) `embedTree` (runGenT size sg gen) instance MMonad GenT where embed = embedGen 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 instance Distributive GenT where type Transformer t GenT m = ( Monad (t (GenT m)) , Transformer t MaybeT m , Transformer t Tree (MaybeT m) ) distribute = distributeGen instance PrimMonad m => PrimMonad (GenT m) where type PrimState (GenT m) = PrimState m primitive = Trans.lift . primitive instance MonadIO m => MonadIO (GenT m) where liftIO = Trans.lift . liftIO instance MonadBase b m => MonadBase b (GenT m) where liftBase = Trans.lift . liftBase instance MonadThrow m => MonadThrow (GenT m) where throwM = Trans.lift . throwM instance MonadCatch m => MonadCatch (GenT m) where catch m onErr = GenT $ \size seed -> case Seed.split seed of (sm, se) -> (runGenT size sm m) `catch` (runGenT size se . onErr) instance MonadReader r m => MonadReader r (GenT m) where ask = Trans.lift ask local f m = mapGenT (local f) m instance MonadState s m => MonadState s (GenT m) where get = Trans.lift get put = Trans.lift . put state = Trans.lift . state instance MonadWriter w m => MonadWriter w (GenT m) where writer = Trans.lift . writer tell = Trans.lift . tell listen = mapGenT listen pass = mapGenT pass instance MonadError e m => MonadError e (GenT m) where throwError = Trans.lift . throwError catchError m onErr = GenT $ \size seed -> case Seed.split seed of (sm, se) -> (runGenT size sm m) `catchError` (runGenT size se . onErr) instance MonadResource m => MonadResource (GenT m) where liftResourceT = Trans.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 -> pure (f size seed) ------------------------------------------------------------------------ -- Combinators - Shrinking -- | Apply a shrinking function to a generator. -- -- This will give the generator additional shrinking options, while keeping -- the existing shrinks intact. -- shrink :: MonadGen m => (a -> [a]) -> m a -> m a shrink = shrinkGen -- | Throw away a generator's shrink tree. -- prune :: MonadGen m => m a -> m a prune = pruneGen ------------------------------------------------------------------------ -- Combinators - Size -- | Construct a generator that depends on the size parameter. -- sized :: MonadGen m => (Size -> m a) -> m a sized f = do f =<< generate (\size _ -> size) -- | Override the size parameter. Returns a generator which uses the given size -- instead of the runtime-size parameter. -- resize :: MonadGen m => Size -> m a -> m a resize size gen = scale (const size) gen -- | Adjust the size parameter by transforming it with the given function. -- scale :: MonadGen m => (Size -> Size) -> m a -> m a scale = scaleGen -- | Make a generator smaller by scaling its size parameter. -- small :: MonadGen m => m a -> m a small = scale golden -- | Scale a size using the golden ratio. -- -- > golden x = x / φ -- > golden x = x / 1.61803.. -- golden :: Size -> Size golden x = round (fromIntegral x * 0.61803398875 :: Double) ------------------------------------------------------------------------ -- Combinators - Integral -- | Generates a random integral number in the given @[inclusive,inclusive]@ range. -- -- When the generator tries to shrink, it will shrink towards the -- 'Range.origin' of the specified 'Range'. -- -- For example, the following generator will produce a number between @1970@ -- and @2100@, but will shrink towards @2000@: -- -- @ -- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int' -- @ -- -- Some sample outputs from this generator might look like: -- -- > === Outcome === -- > 1973 -- > === Shrinks === -- > 2000 -- > 1987 -- > 1980 -- > 1976 -- > 1974 -- -- > === Outcome === -- > 2061 -- > === Shrinks === -- > 2000 -- > 2031 -- > 2046 -- > 2054 -- > 2058 -- > 2060 -- integral :: (MonadGen m, Integral a) => Range a -> m a integral range = shrink (Shrink.towards $ Range.origin range) (integral_ range) -- | Generates a random integral number in the [inclusive,inclusive] range. -- -- /This generator does not shrink./ -- integral_ :: (MonadGen m, Integral a) => Range a -> m a integral_ range = generate $ \size seed -> let (x, y) = Range.bounds size range in fromInteger . fst $ Seed.nextInteger (toInteger x) (toInteger y) seed -- | Generates a random machine integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int :: MonadGen m => Range Int -> m Int int = integral -- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int8 :: MonadGen m => Range Int8 -> m Int8 int8 = integral -- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int16 :: MonadGen m => Range Int16 -> m Int16 int16 = integral -- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int32 :: MonadGen m => Range Int32 -> m Int32 int32 = integral -- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- int64 :: MonadGen m => Range Int64 -> m Int64 int64 = integral -- | Generates a random machine word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word :: MonadGen m => Range Word -> m Word word = integral -- | Generates a random byte in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word8 :: MonadGen m => Range Word8 -> m Word8 word8 = integral -- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word16 :: MonadGen m => Range Word16 -> m Word16 word16 = integral -- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word32 :: MonadGen m => Range Word32 -> m Word32 word32 = integral -- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range. -- -- /This is a specialization of 'integral', offered for convenience./ -- word64 :: MonadGen m => Range Word64 -> m Word64 word64 = integral ------------------------------------------------------------------------ -- Combinators - Fractional / Floating-Point -- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. -- -- This generator works the same as 'integral', but for floating point numbers. -- realFloat :: (MonadGen m, RealFloat a) => Range a -> m a realFloat range = shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range) -- | Generates a random fractional number in the [inclusive,exclusive) range. -- -- /This generator does not shrink./ -- realFrac_ :: (MonadGen m, RealFrac a) => Range a -> m a realFrac_ range = generate $ \size seed -> let (x, y) = Range.bounds size range in realToFrac . fst $ Seed.nextDouble (realToFrac x) (realToFrac y) seed -- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. -- -- /This is a specialization of 'realFloat', offered for convenience./ -- float :: MonadGen m => Range Float -> m Float float = realFloat -- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. -- -- /This is a specialization of 'realFloat', offered for convenience./ -- double :: MonadGen m => Range Double -> m Double double = realFloat ------------------------------------------------------------------------ -- Combinators - Enumeration -- | Generates an element from an enumeration. -- -- This generator shrinks towards the first argument. -- -- For example: -- -- @ -- enum \'a' \'z' :: 'Gen' 'Char' -- @ -- enum :: (MonadGen m, Enum a) => a -> a -> m a enum lo hi = fmap toEnum . integral $ Range.constant (fromEnum lo) (fromEnum hi) -- | Generates a random value from a bounded enumeration. -- -- This generator shrinks towards 'minBound'. -- -- For example: -- -- @ -- enumBounded :: 'Gen' 'Bool' -- @ -- enumBounded :: (MonadGen m, Enum a, Bounded a) => m a enumBounded = enum minBound maxBound -- | Generates a random boolean. -- -- This generator shrinks to 'False'. -- -- /This is a specialization of 'enumBounded', offered for convenience./ -- bool :: MonadGen m => m Bool bool = enumBounded -- | Generates a random boolean. -- -- /This generator does not shrink./ -- bool_ :: MonadGen m => m Bool bool_ = generate $ \_ seed -> (/= 0) . fst $ Seed.nextInteger 0 1 seed ------------------------------------------------------------------------ -- Combinators - Characters -- | Generates an ASCII binit: @'0'..'1'@ -- binit :: MonadGen m => m Char binit = enum '0' '1' -- | Generates an ASCII octit: @'0'..'7'@ -- octit :: MonadGen m => m Char octit = enum '0' '7' -- | Generates an ASCII digit: @'0'..'9'@ -- digit :: MonadGen m => m Char digit = enum '0' '9' -- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@ -- hexit :: MonadGen m => m Char hexit = -- FIXME optimize lookup, use a SmallArray or something. element "0123456789aAbBcCdDeEfF" -- | Generates an ASCII lowercase letter: @\'a\'..\'z\'@ -- lower :: MonadGen m => m Char lower = enum 'a' 'z' -- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@ -- upper :: MonadGen m => m Char upper = enum 'A' 'Z' -- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@ -- alpha :: MonadGen m => m Char alpha = -- FIXME optimize lookup, use a SmallArray or something. element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" -- | Generates an ASCII letter or digit: @\'a\'..\'z\', \'A\'..\'Z\', \'0\'..\'9\'@ -- alphaNum :: MonadGen m => m Char alphaNum = -- FIXME optimize lookup, use a SmallArray or something. element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" -- | Generates an ASCII character: @'\0'..'\127'@ -- ascii :: MonadGen m => m Char ascii = enum '\0' '\127' -- | Generates a Latin-1 character: @'\0'..'\255'@ -- latin1 :: MonadGen m => m Char latin1 = enum '\0' '\255' -- | Generates a Unicode character, excluding noncharacters and invalid standalone surrogates: -- @'\0'..'\1114111' (excluding '\55296'..'\57343')@ -- unicode :: MonadGen m => m Char unicode = filter (not . isNoncharacter) $ filter (not . isSurrogate) unicodeAll -- | Generates a Unicode character, including noncharacters and invalid standalone surrogates: -- @'\0'..'\1114111'@ -- unicodeAll :: MonadGen m => m Char unicodeAll = enumBounded -- | Check if a character is in the surrogate category. -- isSurrogate :: Char -> Bool isSurrogate x = x >= '\55296' && x <= '\57343' -- | Check if a character is one of the noncharacters '\65534', '\65535'. -- isNoncharacter :: Char -> Bool isNoncharacter x = x == '\65534' || x == '\65535' ------------------------------------------------------------------------ -- Combinators - Strings -- | Generates a string using 'Range' to determine the length. -- -- /This is a specialization of 'list', offered for convenience./ -- string :: MonadGen m => Range Int -> m Char -> m String string = list -- | Generates a string using 'Range' to determine the length. -- text :: MonadGen m => Range Int -> m Char -> m Text text range = fmap Text.pack . string range -- | Generates a UTF-8 encoded string, using 'Range' to determine the length. -- utf8 :: MonadGen m => Range Int -> m Char -> m ByteString utf8 range = fmap Text.encodeUtf8 . text range -- | Generates a random 'ByteString', using 'Range' to determine the -- length. -- bytes :: MonadGen m => Range Int -> m ByteString bytes range = fmap ByteString.pack $ choice [ list range . word8 $ Range.constant (fromIntegral $ Char.ord 'a') (fromIntegral $ Char.ord 'z') , list range . word8 $ Range.constant minBound maxBound ] ------------------------------------------------------------------------ -- Combinators - Choice -- | Trivial generator that always produces the same element. -- -- /This is another name for 'pure' \/ 'return'./ constant :: MonadGen m => a -> m a constant = pure -- | Randomly selects one of the elements in the list. -- -- This generator shrinks towards the first element in the list. -- -- /The input list must be non-empty./ -- element :: MonadGen m => [a] -> m a element = \case [] -> error "Hedgehog.Gen.element: used with empty list" xs -> do n <- integral $ Range.constant 0 (length xs - 1) pure $ xs !! n -- | Randomly selects one of the generators in the list. -- -- This generator shrinks towards the first generator in the list. -- -- /The input list must be non-empty./ -- choice :: MonadGen m => [m a] -> m a choice = \case [] -> error "Hedgehog.Gen.choice: used with empty list" xs -> do n <- integral $ Range.constant 0 (length xs - 1) xs !! n -- | Uses a weighted distribution to randomly select one of the generators in -- the list. -- -- This generator shrinks towards the first generator in the list. -- -- /The input list must be non-empty./ -- frequency :: MonadGen m => [(Int, m a)] -> m a frequency = \case [] -> error "Hedgehog.Gen.frequency: used with empty list" xs0 -> do let pick n = \case [] -> error "Hedgehog.Gen.frequency/pick: used with empty list" (k, x) : xs -> if n <= k then x else pick (n - k) xs total = sum (fmap fst xs0) n <- integral $ Range.constant 1 total pick n xs0 -- | Modifies combinators which choose from a list of generators, like 'choice' -- or 'frequency', so that they can be used in recursive scenarios. -- -- This combinator modifies its target to select one of the generators in -- either the non-recursive or the recursive list. When a selection is made -- from the recursive list, the 'Size' is halved. When the 'Size' gets to one -- or less, selections are no longer made from the recursive list, this -- ensures termination. -- -- A good example of where this might be useful is abstract syntax trees: -- -- @ -- data Expr = -- Var String -- | Lam String Expr -- | App Expr Expr -- -- -- Assuming we have a name generator -- genName :: 'MonadGen' m => m String -- -- -- We can write a generator for expressions -- genExpr :: 'MonadGen' m => m Expr -- genExpr = -- Gen.'recursive' Gen.'choice' [ -- -- non-recursive generators -- Var '<$>' genName -- ] [ -- -- recursive generators -- Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x) -- , Gen.'subterm2' genExpr genExpr App -- ] -- @ -- -- If we wrote the above example using only 'choice', it is likely that it -- would fail to terminate. This is because for every call to @genExpr@, -- there is a 2 in 3 chance that we will recurse again. -- recursive :: MonadGen m => ([m a] -> m a) -> [m a] -> [m a] -> m a recursive f nonrec rec = sized $ \n -> if n <= 1 then f nonrec else f $ nonrec ++ fmap small rec ------------------------------------------------------------------------ -- Combinators - Conditional -- | Discards the whole generator. -- discard :: MonadGen m => m a discard = liftGen mzero -- | Discards the generator if the generated value does not satisfy the -- predicate. -- ensure :: MonadGen m => (a -> Bool) -> m a -> m a ensure p gen = do x <- gen if p x then pure x else discard -- | Generates a value that satisfies a predicate. -- -- This is essentially: -- -- @ -- 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 = let try k = if k > 100 then discard else do x <- scale (2 * k +) gen if p x then pure x 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 g = do mx <- filter Maybe.isJust g case mx of Just x -> pure x Nothing -> error "Hedgehog.Gen.just: internal error, unexpected Nothing" ------------------------------------------------------------------------ -- Combinators - Collections -- | Generates a 'Nothing' some of the time. -- maybe :: MonadGen m => m a -> m (Maybe a) maybe gen = sized $ \n -> frequency [ (2, pure Nothing) , (1 + fromIntegral n, Just <$> gen) ] -- | Generates a list using a 'Range' to determine the length. -- 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) -- | Generates a seq using a 'Range' to determine the length. -- seq :: MonadGen m => Range Int -> m a -> m (Seq a) seq range gen = Seq.fromList <$> list range gen -- | Generates a non-empty list using a 'Range' to determine the length. -- nonEmpty :: MonadGen m => Range Int -> m a -> m (NonEmpty a) nonEmpty range gen = do xs <- list (fmap (max 1) range) gen case xs of [] -> error "Hedgehog.Gen.nonEmpty: internal error, generated empty list" _ -> pure $ NonEmpty.fromList xs -- | Generates a set using a 'Range' to determine the length. -- -- /This may fail to generate anything if the element generator/ -- /cannot produce a large enough number of unique items to satify/ -- /the required set size./ -- set :: (MonadGen m, Ord a) => Range Int -> m a -> m (Set a) set range gen = fmap Map.keysSet . map range $ fmap (, ()) gen -- | Generates a map using a 'Range' to determine the length. -- -- /This may fail to generate anything if the keys produced by the/ -- /generator do not account for a large enough number of unique/ -- /items to satify the required map size./ -- map :: (MonadGen m, Ord k) => Range Int -> m (k, v) -> m (Map k v) map range gen = sized $ \size -> ensure ((>= Range.lowerBound size range) . Map.size) . fmap Map.fromList . (sequence =<<) . shrink Shrink.list $ do k <- integral_ range uniqueByKey k gen -- | Generate exactly 'n' unique generators. -- uniqueByKey :: (MonadGen m, Ord k) => Int -> m (k, v) -> m [m (k, v)] uniqueByKey n gen = let try k xs0 = if k > 100 then discard else replicateM n (freeze gen) >>= \kvs -> case uniqueInsert n xs0 (fmap (first fst) kvs) of Left xs -> pure $ Map.elems xs Right xs -> try (k + 1) xs in try (0 :: Int) Map.empty uniqueInsert :: Ord k => Int -> Map k v -> [(k, v)] -> Either (Map k v) (Map k v) uniqueInsert n xs kvs0 = if Map.size xs >= n then Left xs else case kvs0 of [] -> Right xs (k, v) : kvs -> uniqueInsert n (Map.insertWith (\x _ -> x) k v xs) kvs -- | Check that list contains at least a certain number of elements. -- atLeast :: Int -> [a] -> Bool atLeast n = if n == 0 then const True else not . null . drop (n - 1) ------------------------------------------------------------------------ -- Combinators - Subterms data Subterms n a = One a | All (Vec n a) deriving (Functor, Foldable, Traversable) data Nat = Z | S Nat data Vec n a where Nil :: Vec 'Z a (:.) :: a -> Vec n a -> Vec ('S n) a infixr 5 :. deriving instance Functor (Vec n) deriving instance Foldable (Vec n) deriving instance Traversable (Vec n) -- | Freeze the size and seed used by a generator, so we can inspect the value -- which it will produce. -- -- This is used for implementing `list` and `subtermMVec`. It allows us to -- shrink the list itself before trying to shrink the values inside the list. -- freeze :: MonadGen m => m a -> m (a, m a) freeze = freezeGen shrinkSubterms :: Subterms n a -> [Subterms n a] shrinkSubterms = \case One _ -> [] All xs -> fmap One $ toList xs genSubterms :: MonadGen m => Vec n (m a) -> m (Subterms n a) genSubterms = (sequence =<<) . shrink shrinkSubterms . fmap All . mapM (fmap snd . freeze) fromSubterms :: Applicative m => (Vec n a -> m a) -> Subterms n a -> m a fromSubterms f = \case One x -> pure x All xs -> f xs -- | Constructs a generator from a number of sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subtermMVec :: MonadGen m => Vec n (m a) -> (Vec n a -> m a) -> m a subtermMVec gs f = fromSubterms f =<< genSubterms gs -- | Constructs a generator from a sub-term generator. -- -- /Shrinks to the sub-term if possible./ -- subtermM :: MonadGen m => m a -> (a -> m a) -> m a subtermM gx f = subtermMVec (gx :. Nil) $ \(x :. Nil) -> f x -- | Constructs a generator from a sub-term generator. -- -- /Shrinks to the sub-term if possible./ -- subterm :: MonadGen m => m a -> (a -> a) -> m a subterm gx f = subtermM gx $ \x -> pure (f x) -- | Constructs a generator from two sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subtermM2 :: MonadGen m => m a -> m a -> (a -> a -> m a) -> m a subtermM2 gx gy f = subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) -> f x y -- | Constructs a generator from two sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subterm2 :: MonadGen m => m a -> m a -> (a -> a -> a) -> m a subterm2 gx gy f = subtermM2 gx gy $ \x y -> pure (f x y) -- | Constructs a generator from three sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subtermM3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> m a) -> m a subtermM3 gx gy gz f = subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) -> f x y z -- | Constructs a generator from three sub-term generators. -- -- /Shrinks to one of the sub-terms if possible./ -- subterm3 :: MonadGen m => m a -> m a -> m a -> (a -> a -> a -> a) -> m a subterm3 gx gy gz f = subtermM3 gx gy gz $ \x y z -> pure (f x y z) ------------------------------------------------------------------------ -- Combinators - Combinations & Permutations -- | Generates a random subsequence of a list. -- subsequence :: MonadGen m => [a] -> m [a] subsequence xs = shrink Shrink.list $ filterM (const bool_) xs -- | Generates a random permutation of a list. -- -- This shrinks towards the order of the list being identical to the input -- list. -- shuffle :: MonadGen m => [a] -> m [a] shuffle = \case [] -> pure [] xs0 -> do n <- integral $ Range.constant 0 (length xs0 - 1) case splitAt n xs0 of (xs, y : ys) -> (y :) <$> shuffle (xs ++ ys) (_, []) -> error "Hedgehog.Gen.shuffle: internal error, split generated empty list" ------------------------------------------------------------------------ -- Sampling -- | Generate a sample from a generator. -- sample :: MonadIO m => Gen a -> m a sample gen = liftIO $ let loop n = if n <= 0 then 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 Nothing -> loop (n - 1) Just x -> pure $ nodeValue 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. -- -- @ -- Gen.print (Gen.'enum' \'a\' \'f\') -- @ -- -- > === Outcome === -- > 'd' -- > === Shrinks === -- > 'a' -- > 'b' -- > 'c' -- print :: (MonadIO m, Show a) => Gen a -> m () print gen = do seed <- liftIO Seed.random printWith 30 seed gen -- | Run a generator with a random seed and print the resulting shrink tree. -- -- @ -- Gen.printTree (Gen.'enum' \'a\' \'f\') -- @ -- -- > 'd' -- > ├╼'a' -- > ├╼'b' -- > │ └╼'a' -- > └╼'c' -- > ├╼'a' -- > └╼'b' -- > └╼'a' -- -- /This may not terminate when the tree is very large./ -- printTree :: (MonadIO m, Show a) => Gen a -> m () printTree gen = do seed <- liftIO Seed.random printTreeWith 30 seed gen -- | Render a generator as a tree of strings. -- renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen a -> Tree m String renderNodes size seed = fmap (Maybe.maybe "" show) . runDiscardEffect . runGenT size seed . lift ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-0.6.1/src/Hedgehog/Internal/Config.hs0000644000000000000000000000742413351371600017302 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.Config ( UseColor(..) , resolveColor , Verbosity(..) , resolveVerbosity , WorkerCount(..) , resolveWorkers , detectMark , detectColor , detectVerbosity , detectWorkers ) where import Control.Monad.IO.Class (MonadIO(..)) import qualified GHC.Conc as Conc import Language.Haskell.TH.Lift (deriveLift) 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) -- | Whether to render output using ANSI colors or not. -- data UseColor = DisableColor -- ^ Disable ANSI colors in report output. | EnableColor -- ^ Enable ANSI colors in report output. deriving (Eq, Ord, Show) -- | How verbose should the report output be. -- data Verbosity = Quiet -- ^ 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) -- | The number of workers to use when running properties in parallel. -- newtype WorkerCount = WorkerCount Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral) detectMark :: MonadIO m => m Bool detectMark = do #if mingw32_HOST_OS pure False #else user <- liftIO getEffectiveUserName pure $ user == "mth" #endif lookupBool :: MonadIO m => String -> m (Maybe Bool) lookupBool key = liftIO $ do menv <- lookupEnv key case menv of Just "0" -> pure $ Just False Just "no" -> pure $ Just False Just "false" -> pure $ Just False Just "1" -> pure $ Just True Just "yes" -> pure $ Just True Just "true" -> pure $ Just True _ -> pure Nothing detectColor :: MonadIO m => m UseColor detectColor = liftIO $ do ok <- lookupBool "HEDGEHOG_COLOR" case ok of Just False -> pure DisableColor Just True -> pure EnableColor Nothing -> do mth <- detectMark if mth then pure DisableColor -- avoid getting fired :) else do enable <- hSupportsANSI stdout if enable then pure EnableColor else pure DisableColor detectVerbosity :: MonadIO m => m Verbosity detectVerbosity = liftIO $ do menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_VERBOSITY" case menv of Just (0 :: Int) -> pure Quiet Just (1 :: Int) -> pure Normal _ -> do mth <- detectMark if mth then pure Quiet else pure Normal detectWorkers :: MonadIO m => m WorkerCount detectWorkers = do liftIO $ do menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_WORKERS" case menv of Nothing -> WorkerCount <$> Conc.getNumProcessors Just env -> pure $ WorkerCount env resolveColor :: MonadIO m => Maybe UseColor -> m UseColor resolveColor = \case Nothing -> detectColor Just x -> pure x resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity resolveVerbosity = \case Nothing -> detectVerbosity Just x -> pure x resolveWorkers :: MonadIO m => Maybe WorkerCount -> m WorkerCount resolveWorkers = \case Nothing -> detectWorkers Just x -> pure x ------------------------------------------------------------------------ -- FIXME Replace with DeriveLift when we drop 7.10 support. $(deriveLift ''UseColor) $(deriveLift ''Verbosity) $(deriveLift ''WorkerCount) hedgehog-0.6.1/src/Hedgehog/Internal/Shrink.hs0000644000000000000000000000543613351371600017334 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Shrink ( towards , towardsFloat , list , halves , removes , consNub ) where -- | Shrink an integral number by edging towards a destination. -- -- >>> towards 0 100 -- [0,50,75,88,94,97,99] -- -- >>> towards 500 1000 -- [500,750,875,938,969,985,993,997,999] -- -- >>> towards (-50) (-26) -- [-50,-38,-32,-29,-27] -- -- /Note we always try the destination first, as that is the optimal shrink./ -- towards :: Integral a => a -> a -> [a] towards destination x = if destination == x then [] else let -- Halve the operands before subtracting them so they don't overflow. -- Consider 'minBound' and 'maxBound' for a fixed sized type like 'Int64'. diff = (x `quot` 2) - (destination `quot` 2) in destination `consNub` fmap (x -) (halves diff) -- | Shrink a floating-point number by edging towards a destination. -- -- >>> take 7 (towardsFloat 0.0 100) -- [0.0,50.0,75.0,87.5,93.75,96.875,98.4375] -- -- >>> take 7 (towardsFloat 1.0 0.5) -- [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125] -- -- /Note we always try the destination first, as that is the optimal shrink./ -- towardsFloat :: RealFloat a => a -> a -> [a] towardsFloat destination x = if destination == x then [] else let diff = x - destination ok y = y /= x && not (isNaN y) && not (isInfinite y) in takeWhile ok . fmap (x -) $ iterate (/ 2) diff -- | Shrink a list by edging towards the empty list. -- -- >>> list [1,2,3] -- [[],[2,3],[1,3],[1,2]] -- -- >>> list "abcd" -- ["","cd","ab","bcd","acd","abd","abc"] -- -- /Note we always try the empty list first, as that is the optimal shrink./ -- list :: [a] -> [[a]] list xs = concatMap (\k -> removes k xs) (halves $ length xs) -- | Produce all permutations of removing 'k' elements from a list. -- -- >>> removes 2 "abcdef" -- ["cdef","abef","abcd"] -- removes :: Int -> [a] -> [[a]] removes k0 xs0 = let loop k n xs = let (hd, tl) = splitAt k xs in if k > n then [] else if null tl then [[]] else tl : fmap (hd ++) (loop k (n - k) tl) in loop k0 (length xs0) xs0 -- | Produce a list containing the progressive halving of an integral. -- -- >>> halves 15 -- [15,7,3,1] -- -- >>> halves 100 -- [100,50,25,12,6,3,1] -- -- >>> halves (-26) -- [-26,-13,-6,-3,-1] -- halves :: Integral a => a -> [a] halves = takeWhile (/= 0) . iterate (`quot` 2) -- | Cons an element on to the front of a list unless it is already there. -- consNub :: Eq a => a -> [a] -> [a] consNub x ys0 = case ys0 of [] -> x : [] y : ys -> if x == y then y : ys else x : y : ys hedgehog-0.6.1/src/Hedgehog/Internal/Exception.hs0000644000000000000000000000124713351371600020030 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Exception ( tryAll , tryEvaluate ) where import Control.Exception (Exception(..), AsyncException, SomeException(..), evaluate) import Control.Monad.Catch (MonadCatch(..), throwM) import System.IO.Unsafe (unsafePerformIO) tryAll :: MonadCatch m => m a -> m (Either SomeException a) tryAll m = catch (fmap Right m) $ \exception -> case fromException exception :: Maybe AsyncException of Nothing -> pure $ Left exception Just async -> throwM async tryEvaluate :: a -> Either SomeException a tryEvaluate x = unsafePerformIO (tryAll (evaluate x)) hedgehog-0.6.1/src/Hedgehog/Internal/Runner.hs0000644000000000000000000002625113351371600017345 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.Runner ( -- * Running Individual Properties check , recheck -- * Running Groups of Properties , RunnerConfig(..) , checkParallel , checkSequential , checkGroup -- * Internal , checkReport , checkRegion , checkNamed ) where import Control.Concurrent.STM (TVar, atomically) import qualified Control.Concurrent.STM.TVar as TVar import Control.Monad.Catch (MonadCatch(..), catchAll) import Control.Monad.IO.Class (MonadIO(..)) import Data.Semigroup ((<>)) import Hedgehog.Internal.Config import Hedgehog.Internal.Gen (runGenT, runDiscardEffect) import Hedgehog.Internal.Property (Group(..), GroupName(..)) import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests) import Hedgehog.Internal.Property (PropertyT(..), Log(..), Failure(..), runTestT) 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.Range (Size) import Language.Haskell.TH.Lift (deriveLift) #if mingw32_HOST_OS import System.IO (hSetEncoding, stdout, stderr, utf8) #endif -- | Configuration for a property test run. -- data RunnerConfig = RunnerConfig { -- | The number of property tests to run concurrently. 'Nothing' means -- use one worker per processor. runnerWorkers :: !(Maybe WorkerCount) -- | Whether to use colored output or not. 'Nothing' means detect from -- the environment. , runnerColor :: !(Maybe UseColor) -- | How verbose to be in the runner output. 'Nothing' means detect from -- the environment. , runnerVerbosity :: !(Maybe Verbosity) } deriving (Eq, Ord, Show) findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b findM xs0 def p = case xs0 of [] -> return def x0 : xs -> p x0 >>= \m -> case m of Nothing -> findM xs def p Just x -> return x isFailure :: Node m (Maybe (Either x a, b)) -> Bool isFailure = \case Node (Just (Left _, _)) _ -> True _ -> False isSuccess :: Node 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))) runTreeN n m = do o <- runTree m if n > 0 && isSuccess o then runTreeN (n - 1) m else pure o takeSmallest :: MonadIO m => Size -> Seed -> ShrinkCount -> ShrinkLimit -> ShrinkRetries -> (Progress -> m ()) -> Node m (Maybe (Either Failure (), [Log])) -> m Result takeSmallest size seed shrinks slimit retries updateUI = \case Node Nothing _ -> pure GaveUp Node (Just (x, w)) xs -> case x of Left (Failure loc err mdiff) -> do let failure = mkFailure size seed shrinks loc err mdiff (reverse w) updateUI $ Shrinking failure if shrinks >= fromIntegral slimit then -- if we've hit the shrink limit, don't shrink any further pure $ Failed failure else findM xs (Failed failure) $ \m -> do o <- runTreeN retries m if isFailure o then Just <$> takeSmallest size seed (shrinks + 1) slimit retries updateUI o else return Nothing Right () -> return OK checkReport :: forall m. MonadIO m => MonadCatch m => PropertyConfig -> Size -> Seed -> PropertyT m () -> (Report Progress -> m ()) -> m (Report Result) checkReport cfg size0 seed0 test0 updateUI = let test = catchAll test0 (fail . show) loop :: TestCount -> DiscardCount -> Size -> Seed -> m (Report Result) loop !tests !discards !size !seed = do updateUI $ Report tests discards Running if size > 99 then -- size has reached limit, reset to 0 loop tests discards 0 seed else if tests >= fromIntegral (propertyTestLimit cfg) then -- we've hit the test limit, test was successful pure $ Report tests discards OK else if discards >= fromIntegral (propertyDiscardLimit cfg) then -- we've hit the discard limit, give up pure $ Report tests discards GaveUp else case Seed.split seed of (s0, s1) -> do node@(Node x _) <- runTree . runDiscardEffect $ runGenT size s0 . runTestT $ unPropertyT test case x of Nothing -> loop tests (discards + 1) (size + 1) s1 Just (Left _, _) -> let mkReport = Report (tests + 1) discards in fmap mkReport $ takeSmallest size seed 0 (propertyShrinkLimit cfg) (propertyShrinkRetries cfg) (updateUI . mkReport) node Just (Right (), _) -> loop (tests + 1) discards (size + 1) s1 in loop 0 0 size0 seed0 checkRegion :: MonadIO m => Region -> Maybe UseColor -> Maybe PropertyName -> Size -> Seed -> Property -> m (Report Result) checkRegion region mcolor name size seed prop = liftIO $ do result <- checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do ppprogress <- renderProgress mcolor name progress case reportStatus progress of Running -> setRegion region ppprogress Shrinking _ -> openRegion region ppprogress ppresult <- renderResult mcolor name result case reportStatus result of Failed _ -> openRegion region ppresult GaveUp -> openRegion region ppresult OK -> setRegion region ppresult pure result checkNamed :: MonadIO m => Region -> Maybe UseColor -> Maybe PropertyName -> Property -> m (Report Result) checkNamed region mcolor name prop = do seed <- liftIO Seed.random checkRegion region mcolor name 0 seed prop -- | Check a property. -- check :: MonadIO m => Property -> m Bool check prop = liftIO . displayRegion $ \region -> (== OK) . reportStatus <$> checkNamed region Nothing Nothing prop -- | Check a property using a specific size and seed. -- recheck :: MonadIO m => Size -> Seed -> Property -> m () recheck size seed prop0 = do let prop = withTests 1 prop0 _ <- liftIO . displayRegion $ \region -> checkRegion region Nothing Nothing size seed prop pure () -- | Check a group of properties using the specified runner config. -- checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool checkGroup config (Group group props) = liftIO $ do n <- resolveWorkers (runnerWorkers config) -- ensure few spare capabilities for concurrent-output, it's likely that -- our tests will saturate all the capabilities they're given. updateNumCapabilities (n + 2) #if mingw32_HOST_OS hSetEncoding stdout utf8 hSetEncoding stderr utf8 #endif putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━" verbosity <- resolveVerbosity (runnerVerbosity config) summary <- checkGroupWith n verbosity (runnerColor config) props pure $ summaryFailed summary == 0 && summaryGaveUp summary == 0 updateSummary :: Region -> TVar Summary -> Maybe UseColor -> (Summary -> Summary) -> IO () updateSummary sregion svar mcolor f = do summary <- atomically (TVar.modifyTVar' svar f >> TVar.readTVar svar) setRegion sregion =<< renderSummary mcolor summary checkGroupWith :: WorkerCount -> Verbosity -> Maybe UseColor -> [(PropertyName, Property)] -> IO Summary checkGroupWith n verbosity mcolor props = displayRegion $ \sregion -> do svar <- atomically . TVar.newTVar $ mempty { summaryWaiting = PropertyCount (length props) } let start (TasksRemaining tasks) _ix (name, prop) = liftIO $ do updateSummary sregion svar mcolor $ \x -> x { summaryWaiting = PropertyCount tasks , summaryRunning = summaryRunning x + 1 } atomically $ do region <- case verbosity of Quiet -> newEmptyRegion Normal -> newOpenRegion moveToBottom sregion pure (name, prop, region) finish (_name, _prop, _region) = updateSummary sregion svar mcolor $ \x -> x { summaryRunning = summaryRunning x - 1 } finalize (_name, _prop, region) = finishRegion region summary <- fmap (mconcat . fmap (fromResult . reportStatus)) $ runTasks n props start finish finalize $ \(name, prop, region) -> do result <- checkNamed region mcolor (Just name) prop updateSummary sregion svar mcolor (<> fromResult (reportStatus result)) pure result updateSummary sregion svar mcolor (const summary) pure summary -- | Check a group of properties sequentially. -- -- Using Template Haskell for property discovery: -- -- > tests :: IO Bool -- > tests = -- > checkSequential $$(discover) -- -- With manually specified properties: -- -- > tests :: IO Bool -- > tests = -- > checkSequential $ Group "Test.Example" [ -- > ("prop_reverse", prop_reverse) -- > ] -- -- checkSequential :: MonadIO m => Group -> m Bool checkSequential = checkGroup RunnerConfig { runnerWorkers = Just 1 , runnerColor = Nothing , runnerVerbosity = Nothing } -- | Check a group of properties in parallel. -- -- /Warning: although this check function runs tests faster than/ -- /'checkSequential', it should be noted that it may cause problems with/ -- /properties that are not self-contained. For example, if you have a group/ -- /of tests which all use the same database table, you may find that they/ -- /interfere with each other when being run in parallel./ -- -- Using Template Haskell for property discovery: -- -- > tests :: IO Bool -- > tests = -- > checkParallel $$(discover) -- -- With manually specified properties: -- -- > tests :: IO Bool -- > tests = -- > checkParallel $ Group "Test.Example" [ -- > ("prop_reverse", prop_reverse) -- > ] -- checkParallel :: MonadIO m => Group -> m Bool checkParallel = checkGroup RunnerConfig { runnerWorkers = Nothing , runnerColor = Nothing , runnerVerbosity = Nothing } ------------------------------------------------------------------------ -- FIXME Replace with DeriveLift when we drop 7.10 support. $(deriveLift ''RunnerConfig) hedgehog-0.6.1/src/Hedgehog/Internal/Tree.hs0000644000000000000000000002207513351371600016773 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- MonadBase module Hedgehog.Internal.Tree ( Tree(..) , Node(..) , fromNode , unfold , unfoldForest , expand , prune , render ) where import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus(..), ap, join) import Control.Monad.Base (MonadBase(..)) 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.Primitive (PrimMonad(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Resource (MonadResource(..)) import Control.Monad.Writer.Class (MonadWriter(..)) #if MIN_VERSION_base(4,9,0) import Data.Functor.Classes (Show1(..), showsPrec1) import Data.Functor.Classes (showsUnaryWith, showsBinaryWith) #endif import Hedgehog.Internal.Distributive ------------------------------------------------------------------------ -- | 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) } -- | A node in an effectful tree, as well as its unevaluated children. -- data Node m a = Node { nodeValue :: a , nodeChildren :: [Tree m a] } -- | Create a 'Tree' from a 'Node' -- fromNode :: Applicative m => Node m a -> Tree m a fromNode = Tree . pure -- | Create a tree from a value and an unfolding function. -- unfold :: Monad m => (a -> [a]) -> a -> Tree m a unfold f x = Tree . pure $ Node x (unfoldForest f x) -- | Create a forest from a value and an unfolding function. -- unfoldForest :: Monad m => (a -> [a]) -> a -> [Tree 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 f m = Tree $ do Node x xs <- runTree m pure . Node x $ fmap (expand f) xs ++ unfoldForest f x -- | Throw away a tree's children. -- prune :: Monad m => Tree m a -> Tree m a prune m = Tree $ do Node x _ <- runTree m pure $ Node x [] ------------------------------------------------------------------------ -- Node/Tree instances instance Functor m => Functor (Node m) where fmap f (Node x xs) = Node (f x) (fmap (fmap f) xs) instance Functor m => Functor (Tree m) where fmap f = Tree . fmap (fmap f) . runTree instance Monad m => Applicative (Node m) where pure = return (<*>) = ap instance Monad m => Applicative (Tree m) where pure = return (<*>) = ap instance Monad m => Monad (Node m) where return x = Node x [] (>>=) (Node x xs) k = case k x of Node y ys -> Node y $ fmap (Tree . fmap (>>= k) . runTree) xs ++ ys instance Monad m => Monad (Tree m) where return x = Tree . pure $ Node x [] (>>=) m k = Tree $ do Node x xs <- runTree m Node y ys <- runTree (k x) pure . Node y $ fmap (>>= k) xs ++ ys instance MonadPlus m => Alternative (Tree m) where empty = mzero (<|>) = mplus instance MonadPlus m => MonadPlus (Tree m) where mzero = Tree mzero mplus x y = Tree (runTree x `mplus` runTree y) instance MonadTrans Tree where lift m = Tree $ do x <- m pure (Node x []) instance MFunctor Node where hoist f (Node x xs) = Node x (fmap (hoist f) xs) instance MFunctor Tree where hoist f (Tree m) = Tree . f $ fmap (hoist f) m 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) 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 MMonad Tree where embed f m = embedTree 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 distributeTree :: Transformer t Tree m => Tree (t m) a -> t (Tree m) a distributeTree x = distributeNode =<< hoist lift (runTree x) instance Distributive Tree where distribute = distributeTree instance PrimMonad m => PrimMonad (Tree m) where type PrimState (Tree m) = PrimState m primitive = lift . primitive instance MonadIO m => MonadIO (Tree m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (Tree m) where liftBase = lift . liftBase instance MonadThrow m => MonadThrow (Tree 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 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) instance MonadCatch m => MonadCatch (Tree m) where catch = flip handleTree localNode :: MonadReader r m => (r -> r) -> Node m a -> Node m a localNode f (Node x xs) = Node x $ fmap (localTree 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 instance MonadReader r m => MonadReader r (Tree m) where ask = lift ask local = localTree instance MonadState s m => MonadState s (Tree m) where get = lift get put = lift . put 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 listenTree :: MonadWriter w m => w -> Tree m a -> Tree m (a, w) listenTree w0 (Tree m) = Tree $ do (x, w) <- listen m pure $ listenNode (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 passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a passTree (Tree m) = Tree $ pure . passNode =<< m instance MonadWriter w m => MonadWriter w (Tree m) where writer = lift . writer tell = lift . tell listen = listenTree mempty pass = passTree 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 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) instance MonadError e m => MonadError e (Tree m) where throwError = lift . throwError catchError = flip handleErrorTree instance MonadResource m => MonadResource (Tree 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 showsPrec = showsPrec1 instance (Show1 m, Show a) => Show (Tree m a) where showsPrec = showsPrec1 instance Show1 m => Show1 (Node m) where liftShowsPrec sp sl d (Node x xs) = let sp1 = liftShowsPrec sp sl sl1 = liftShowList sp sl sp2 = liftShowsPrec sp1 sl1 in showsBinaryWith sp sp2 "Node" d x xs instance Show1 m => Show1 (Tree m) where liftShowsPrec sp sl d (Tree m) = let sp1 = liftShowsPrec sp sl sl1 = liftShowList sp sl sp2 = liftShowsPrec sp1 sl1 in showsUnaryWith sp2 "Tree" d m #endif ------------------------------------------------------------------------ -- Pretty Printing -- -- 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 xs <- renderForestLines xs0 pure $ lines (renderNode x) ++ xs renderNode :: String -> String renderNode xs = case xs of [_] -> ' ' : xs _ -> xs renderForestLines :: Monad m => [Tree m String] -> m [String] renderForestLines xs0 = let shift hd other = zipWith (++) (hd : repeat other) in case xs0 of [] -> pure [] [x] -> do s <- renderTreeLines x pure $ shift " └╼" " " s x : xs -> do s <- renderTreeLines x ss <- renderForestLines xs pure $ shift " ├╼" " │ " s ++ ss -- | 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 hedgehog-0.6.1/src/Hedgehog/Internal/Show.hs0000644000000000000000000001401113351371600017003 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} module Hedgehog.Internal.Show ( Name , Value(..) , ValueDiff(..) , LineDiff(..) , mkValue , showPretty , valueDiff , lineDiff , toLineDiff , renderValue , renderValueDiff , renderLineDiff , takeLeft , takeRight ) where import Data.Bifunctor (second) import Text.Show.Pretty (Value(..), Name, reify, valToStr, ppShow) data ValueDiff = ValueCon Name [ValueDiff] | ValueRec Name [(Name, ValueDiff)] | ValueTuple [ValueDiff] | ValueList [ValueDiff] | ValueSame Value | ValueDiff Value Value deriving (Eq, Show) data LineDiff = LineSame String | LineRemoved String | LineAdded String deriving (Eq, Show) data DocDiff = DocSame Int String | DocRemoved Int String | DocAdded Int String | DocOpen Int String | DocItem Int String [DocDiff] | DocClose Int String deriving (Eq, Show) renderValue :: Value -> String renderValue = valToStr renderValueDiff :: ValueDiff -> String renderValueDiff = unlines . fmap renderLineDiff . toLineDiff renderLineDiff :: LineDiff -> String renderLineDiff = \case LineSame x -> " " ++ x LineRemoved x -> "- " ++ x LineAdded x -> "+ " ++ x mkValue :: Show a => a -> Maybe Value mkValue = reify showPretty :: Show a => a -> String showPretty = ppShow lineDiff :: Value -> Value -> [LineDiff] lineDiff x y = toLineDiff $ valueDiff x y toLineDiff :: ValueDiff -> [LineDiff] toLineDiff = concatMap (mkLineDiff 0 "") . collapseOpen . dropLeadingSep . mkDocDiff 0 valueDiff :: Value -> Value -> ValueDiff valueDiff x y = if x == y then ValueSame x else case (x, y) of (Con nx xs, Con ny ys) | nx == ny , length xs == length ys -> ValueCon nx (zipWith valueDiff xs ys) (Rec nx nxs, Rec ny nys) | nx == ny , fmap fst nxs == fmap fst nys , ns <- fmap fst nxs , xs <- fmap snd nxs , ys <- fmap snd nys -> ValueRec nx (zip ns (zipWith valueDiff xs ys)) (Tuple xs, Tuple ys) | length xs == length ys -> ValueTuple (zipWith valueDiff xs ys) (List xs, List ys) | length xs == length ys -> ValueList (zipWith valueDiff xs ys) _ -> ValueDiff x y takeLeft :: ValueDiff -> Value takeLeft = \case ValueCon n xs -> Con n (fmap takeLeft xs) ValueRec n nxs -> Rec n (fmap (second takeLeft) nxs) ValueTuple xs -> Tuple (fmap takeLeft xs) ValueList xs -> List (fmap takeLeft xs) ValueSame x -> x ValueDiff x _ -> x takeRight :: ValueDiff -> Value takeRight = \case ValueCon n xs -> Con n (fmap takeRight xs) ValueRec n nxs -> Rec n (fmap (second takeRight) nxs) ValueTuple xs -> Tuple (fmap takeRight xs) ValueList xs -> List (fmap takeRight xs) ValueSame x -> x ValueDiff _ x -> x mkLineDiff :: Int -> String -> DocDiff -> [LineDiff] mkLineDiff indent0 prefix0 diff = let mkLinePrefix indent = spaces indent0 ++ prefix0 ++ spaces indent mkLineIndent indent = indent0 + length prefix0 + indent in case diff of DocSame indent x -> [LineSame $ mkLinePrefix indent ++ x] DocRemoved indent x -> [LineRemoved $ mkLinePrefix indent ++ x] DocAdded indent x -> [LineAdded $ mkLinePrefix indent ++ x] DocOpen indent x -> [LineSame $ mkLinePrefix indent ++ x] DocItem _ _ [] -> [] DocItem indent prefix (x@DocRemoved{} : y@DocAdded{} : xs) -> mkLineDiff (mkLineIndent indent) prefix x ++ mkLineDiff (mkLineIndent indent) prefix y ++ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs DocItem indent prefix (x : xs) -> mkLineDiff (mkLineIndent indent) prefix x ++ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs DocClose indent x -> [LineSame $ spaces (mkLineIndent indent) ++ x] spaces :: Int -> String spaces indent = replicate indent ' ' collapseOpen :: [DocDiff] -> [DocDiff] collapseOpen = \case DocSame indent line : DocOpen _ bra : xs -> DocSame indent (line ++ " " ++ bra) : collapseOpen xs DocItem indent prefix xs : ys -> DocItem indent prefix (collapseOpen xs) : collapseOpen ys x : xs -> x : collapseOpen xs [] -> [] dropLeadingSep :: [DocDiff] -> [DocDiff] dropLeadingSep = \case DocOpen oindent bra : DocItem indent prefix xs : ys -> DocOpen oindent bra : DocItem (indent + length prefix) "" (dropLeadingSep xs) : dropLeadingSep ys DocItem indent prefix xs : ys -> DocItem indent prefix (dropLeadingSep xs) : dropLeadingSep ys x : xs -> x : dropLeadingSep xs [] -> [] mkDocDiff :: Int -> ValueDiff -> [DocDiff] mkDocDiff indent = \case ValueSame x -> same indent (renderValue x) diff | x <- takeLeft diff , y <- takeRight diff , oneLiner x , oneLiner y -> removed indent (renderValue x) ++ added indent (renderValue y) ValueCon n xs -> same indent n ++ concatMap (mkDocDiff (indent + 2)) xs ValueRec n nxs -> same indent n ++ [DocOpen indent "{"] ++ fmap (\(name, x) -> DocItem (indent + 2) ", " (same 0 (name ++ " =") ++ mkDocDiff 2 x)) nxs ++ [DocClose (indent + 2) "}"] ValueTuple xs -> [DocOpen indent "("] ++ fmap (DocItem indent ", " . mkDocDiff 0) xs ++ [DocClose indent ")"] ValueList xs -> [DocOpen indent "["] ++ fmap (DocItem indent ", " . mkDocDiff 0) xs ++ [DocClose indent "]"] ValueDiff x y -> removed indent (renderValue x) ++ added indent (renderValue y) oneLiner :: Value -> Bool oneLiner x = case lines (renderValue x) of _ : _ : _ -> False _ -> True same :: Int -> String -> [DocDiff] same indent = fmap (DocSame indent) . lines removed :: Int -> String -> [DocDiff] removed indent = fmap (DocRemoved indent) . lines added :: Int -> String -> [DocDiff] added indent = fmap (DocAdded indent) . lines hedgehog-0.6.1/src/Hedgehog/Internal/Queue.hs0000644000000000000000000000566513351371600017166 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} module Hedgehog.Internal.Queue ( TaskIndex(..) , TasksRemaining(..) , runTasks , finalizeTask , runActiveFinalizers , dequeueMVar , updateNumCapabilities ) where import Control.Concurrent (rtsSupportsBoundThreads) import Control.Concurrent.Async (forConcurrently) import Control.Concurrent.MVar (MVar) import qualified Control.Concurrent.MVar as MVar import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified GHC.Conc as Conc import Hedgehog.Internal.Config newtype TaskIndex = TaskIndex Int deriving (Eq, Ord, Enum, Num) newtype TasksRemaining = TasksRemaining Int dequeueMVar :: MVar [(TaskIndex, a)] -> (TasksRemaining -> TaskIndex -> a -> IO b) -> IO (Maybe (TaskIndex, b)) dequeueMVar mvar start = MVar.modifyMVar mvar $ \case [] -> pure ([], Nothing) (ix, x) : xs -> do y <- start (TasksRemaining $ length xs) ix x pure (xs, Just (ix, y)) runTasks :: WorkerCount -> [a] -> (TasksRemaining -> TaskIndex -> a -> IO b) -> (b -> IO ()) -> (b -> IO ()) -> (b -> IO c) -> IO [c] runTasks n tasks start finish finalize runTask = do qvar <- MVar.newMVar (zip [0..] tasks) fvar <- MVar.newMVar (-1, Map.empty) let worker rs = do mx <- dequeueMVar qvar start case mx of Nothing -> pure rs Just (ix, x) -> do r <- runTask x finish x finalizeTask fvar ix (finalize x) worker (r : rs) -- FIXME ensure all workers have finished running fmap concat . forConcurrently [1..max 1 n] $ \_ix -> worker [] runActiveFinalizers :: MonadIO m => MVar (TaskIndex, Map TaskIndex (IO ())) -> m () runActiveFinalizers mvar = liftIO $ do again <- MVar.modifyMVar mvar $ \original@(minIx, finalizers0) -> case Map.minViewWithKey finalizers0 of Nothing -> pure (original, False) Just ((ix, finalize), finalizers) -> if ix == minIx + 1 then do finalize pure ((ix, finalizers), True) else pure (original, False) when again $ runActiveFinalizers mvar finalizeTask :: MonadIO m => MVar (TaskIndex, Map TaskIndex (IO ())) -> TaskIndex -> IO () -> m () finalizeTask mvar ix finalize = do liftIO . MVar.modifyMVar_ mvar $ \(minIx, finalizers) -> pure (minIx, Map.insert ix finalize finalizers) runActiveFinalizers mvar -- | Update the number of capabilities but never set it lower than it already -- is. -- updateNumCapabilities :: WorkerCount -> IO () updateNumCapabilities (WorkerCount n) = when rtsSupportsBoundThreads $ do ncaps <- Conc.getNumCapabilities Conc.setNumCapabilities (max n ncaps) hedgehog-0.6.1/src/Hedgehog/Internal/TH.hs0000644000000000000000000000306713351371600016407 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.TH ( TExpQ , discover ) where import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Ord as Ord import Hedgehog.Internal.Discovery import Hedgehog.Internal.Property import Language.Haskell.TH (Exp(..), Q, TExp, location, runIO) import Language.Haskell.TH.Syntax (Loc(..), mkName, unTypeQ, unsafeTExpCoerce) type TExpQ a = Q (TExp a) -- | Discover all the properties in a module. -- -- Functions starting with `prop_` are assumed to be properties. -- discover :: TExpQ Group discover = do file <- getCurrentFile properties <- Map.toList <$> runIO (readProperties file) let startLine = Ord.comparing $ posLine . posPostion . propertySource . snd names = fmap (mkNamedProperty . fst) $ List.sortBy startLine properties [|| Group $$(moduleName) $$(listTE names) ||] mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property) mkNamedProperty name = do [|| (name, $$(unsafeProperty name)) ||] unsafeProperty :: PropertyName -> TExpQ Property unsafeProperty = unsafeTExpCoerce . pure . VarE . mkName . unPropertyName listTE :: [TExpQ a] -> TExpQ [a] listTE xs = do unsafeTExpCoerce . pure . ListE =<< traverse unTypeQ xs moduleName :: TExpQ GroupName moduleName = do loc <- GroupName . loc_module <$> location [|| loc ||] getCurrentFile :: Q FilePath getCurrentFile = loc_filename <$> location hedgehog-0.6.1/src/Hedgehog/Internal/Opaque.hs0000644000000000000000000000106013351371600017315 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Opaque ( Opaque(..) ) where -- | Opaque values. -- -- Useful if you want to put something without a 'Show' instance inside -- something which you'd like to be able to display. -- -- For example: -- -- @ -- data State v = -- State { -- stateRefs :: [Var (Opaque (IORef Int)) v] -- } deriving (Eq, Show) -- @ -- newtype Opaque a = Opaque { unOpaque :: a } deriving (Eq, Ord) instance Show (Opaque a) where showsPrec _ (Opaque _) = showString "Opaque" hedgehog-0.6.1/src/Hedgehog/Internal/Range.hs0000644000000000000000000002576413351371600017140 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Hedgehog.Internal.Range ( -- * Size Size(..) -- * Range , Range(..) , origin , bounds , lowerBound , upperBound -- * Constant , singleton , constant , constantFrom , constantBounded -- * Linear , linear , linearFrom , linearFrac , linearFracFrom , linearBounded -- * Exponential , exponential , exponentialFrom , exponentialBounded , exponentialFloat , exponentialFloatFrom -- * Internal -- $internal , clamp , scaleLinear , scaleLinearFrac , scaleExponential , scaleExponentialFloat ) where import Data.Bifunctor (bimap) import Prelude hiding (minimum, maximum) -- $setup -- >>> import Data.Int (Int8) -- >>> let x = 3 -- | Tests are parameterized by the size of the randomly-generated data, the -- meaning of which depends on the particular generator used. -- newtype Size = Size { unSize :: Int } deriving (Eq, Ord, Num, Real, Enum, Integral) instance Show Size where showsPrec p (Size x) = showParen (p > 10) $ showString "Size " . showsPrec 11 x instance Read Size where readsPrec p = readParen (p > 10) $ \r0 -> do ("Size", r1) <- lex r0 (s, r2) <- readsPrec 11 r1 pure (Size s, r2) -- | A range describes the bounds of a number to generate, which may or may not -- be dependent on a 'Size'. -- -- The constructor takes an origin between the lower and upper bound, and a -- function from 'Size' to bounds. As the size goes towards @0@, the values -- go towards the origin. -- data Range a = Range !a (Size -> (a, a)) instance Functor Range where fmap f (Range z g) = Range (f z) $ \sz -> bimap f f (g sz) -- | Get the origin of a range. This might be the mid-point or the lower bound, -- depending on what the range represents. -- -- The 'bounds' of a range are scaled around this value when using the -- 'linear' family of combinators. -- -- When using a 'Range' to generate numbers, the shrinking function will -- shrink towards the origin. -- origin :: Range a -> a origin (Range z _) = z -- | Get the extents of a range, for a given size. -- bounds :: Size -> Range a -> (a, a) bounds sz (Range _ f) = f sz -- | Get the lower bound of a range for the given size. -- lowerBound :: Ord a => Size -> Range a -> a lowerBound sz range = let (x, y) = bounds sz range in min x y -- | Get the upper bound of a range for the given size. -- upperBound :: Ord a => Size -> Range a -> a upperBound sz range = let (x, y) = bounds sz range in max x y -- | Construct a range which represents a constant single value. -- -- >>> bounds x $ singleton 5 -- (5,5) -- -- >>> origin $ singleton 5 -- 5 -- singleton :: a -> Range a singleton x = Range x $ \_ -> (x, x) -- | Construct a range which is unaffected by the size parameter. -- -- A range from @0@ to @10@, with the origin at @0@: -- -- >>> bounds x $ constant 0 10 -- (0,10) -- -- >>> origin $ constant 0 10 -- 0 -- constant :: a -> a -> Range a constant x y = constantFrom x x y -- | Construct a range which is unaffected by the size parameter with a origin -- point which may differ from the bounds. -- -- A range from @-10@ to @10@, with the origin at @0@: -- -- >>> bounds x $ constantFrom 0 (-10) 10 -- (-10,10) -- -- >>> origin $ constantFrom 0 (-10) 10 -- 0 -- -- A range from @1970@ to @2100@, with the origin at @2000@: -- -- >>> bounds x $ constantFrom 2000 1970 2100 -- (1970,2100) -- -- >>> origin $ constantFrom 2000 1970 2100 -- 2000 -- constantFrom :: a -- ^ Origin (the value produced when the size parameter is 0). -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). -> a -- ^ Upper bound (the top of the range when the size parameter is 99). -> Range a constantFrom z x y = Range z $ \_ -> (x, y) -- | Construct a range which is unaffected by the size parameter using the full -- range of a data type. -- -- A range from @-128@ to @127@, with the origin at @0@: -- -- >>> bounds x (constantBounded :: Range Int8) -- (-128,127) -- -- >>> origin (constantBounded :: Range Int8) -- 0 -- constantBounded :: (Bounded a, Num a) => Range a constantBounded = constantFrom 0 minBound maxBound -- | Construct a range which scales the second bound relative to the size -- parameter. -- -- >>> bounds 0 $ linear 0 10 -- (0,0) -- -- >>> bounds 50 $ linear 0 10 -- (0,5) -- -- >>> bounds 99 $ linear 0 10 -- (0,10) -- linear :: Integral a => a -> a -> Range a linear x y = linearFrom x x y -- | Construct a range which scales the bounds relative to the size parameter. -- -- >>> bounds 0 $ linearFrom 0 (-10) 10 -- (0,0) -- -- >>> bounds 50 $ linearFrom 0 (-10) 20 -- (-5,10) -- -- >>> bounds 99 $ linearFrom 0 (-10) 20 -- (-10,20) -- linearFrom :: Integral a => a -- ^ Origin (the value produced when the size parameter is 0). -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). -> a -- ^ Upper bound (the top of the range when the size parameter is 99). -> Range a linearFrom z x y = Range z $ \sz -> let x_sized = clamp x y $ scaleLinear sz z x y_sized = clamp x y $ scaleLinear sz z y in (x_sized, y_sized) -- | Construct a range which is scaled relative to the size parameter and uses -- the full range of a data type. -- -- >>> bounds 0 (linearBounded :: Range Int8) -- (0,0) -- -- >>> bounds 50 (linearBounded :: Range Int8) -- (-64,64) -- -- >>> bounds 99 (linearBounded :: Range Int8) -- (-128,127) -- linearBounded :: (Bounded a, Integral a) => Range a linearBounded = linearFrom 0 minBound maxBound -- | Construct a range which scales the second bound relative to the size -- parameter. -- -- This works the same as 'linear', but for fractional values. -- linearFrac :: (Fractional a, Ord a) => a -> a -> Range a linearFrac x y = linearFracFrom x x y -- | Construct a range which scales the bounds relative to the size parameter. -- -- This works the same as 'linearFrom', but for fractional values. -- linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a linearFracFrom z x y = Range z $ \sz -> let x_sized = clamp x y $ scaleLinearFrac sz z x y_sized = clamp x y $ scaleLinearFrac sz z y in (x_sized, y_sized) -- | Truncate a value so it stays within some range. -- -- >>> clamp 5 10 15 -- 10 -- -- >>> clamp 5 10 0 -- 5 -- clamp :: Ord a => a -> a -> a -> a clamp x y n = if x > y then min x (max y n) else min y (max x n) -- | Scale an integral linearly with the size parameter. -- scaleLinear :: Integral a => Size -> a -> a -> a scaleLinear sz0 z0 n0 = let sz = max 0 (min 99 sz0) z = toInteger z0 n = toInteger n0 diff = ((n - z) * fromIntegral sz) `quot` 99 in fromInteger $ z + diff -- | Scale a fractional number linearly with the size parameter. -- scaleLinearFrac :: Fractional a => Size -> a -> a -> a scaleLinearFrac sz0 z n = let sz = max 0 (min 99 sz0) diff = (n - z) * (fromIntegral sz / 99) in z + diff -- | Construct a range which scales the second bound exponentially relative to -- the size parameter. -- -- >>> bounds 0 $ exponential 1 512 -- (1,1) -- -- >>> bounds 11 $ exponential 1 512 -- (1,2) -- -- >>> bounds 22 $ exponential 1 512 -- (1,4) -- -- >>> bounds 77 $ exponential 1 512 -- (1,128) -- -- >>> bounds 88 $ exponential 1 512 -- (1,256) -- -- >>> bounds 99 $ exponential 1 512 -- (1,512) -- exponential :: Integral a => a -> a -> Range a exponential x y = exponentialFrom x x y -- | Construct a range which scales the bounds exponentially relative to the -- size parameter. -- -- >>> bounds 0 $ exponentialFrom 0 (-128) 512 -- (0,0) -- -- >>> bounds 25 $ exponentialFrom 0 (-128) 512 -- (-2,4) -- -- >>> bounds 50 $ exponentialFrom 0 (-128) 512 -- (-11,22) -- -- >>> bounds 75 $ exponentialFrom 0 (-128) 512 -- (-39,112) -- -- >>> bounds 99 $ exponentialFrom x (-128) 512 -- (-128,512) -- exponentialFrom :: Integral a => a -- ^ Origin (the value produced when the size parameter is 0). -> a -- ^ Lower bound (the bottom of the range when the size parameter is 99). -> a -- ^ Upper bound (the top of the range when the size parameter is 99). -> Range a exponentialFrom z x y = Range z $ \sz -> let sized_x = clamp x y $ scaleExponential sz z x sized_y = clamp x y $ scaleExponential sz z y in (sized_x, sized_y) -- | Construct a range which is scaled exponentially relative to the size -- parameter and uses the full range of a data type. -- -- >>> bounds 0 (exponentialBounded :: Range Int8) -- (0,0) -- -- >>> bounds 50 (exponentialBounded :: Range Int8) -- (-11,11) -- -- >>> bounds 99 (exponentialBounded :: Range Int8) -- (-128,127) -- exponentialBounded :: (Bounded a, Integral a) => Range a exponentialBounded = exponentialFrom 0 minBound maxBound -- | Construct a range which scales the second bound exponentially relative to -- the size parameter. -- -- This works the same as 'exponential', but for floating-point values. -- -- >>> bounds 0 $ exponentialFloat 0 10 -- (0.0,0.0) -- -- >>> bounds 50 $ exponentialFloat 0 10 -- (0.0,2.357035250656098) -- -- >>> bounds 99 $ exponentialFloat 0 10 -- (0.0,10.0) -- exponentialFloat :: (Floating a, Ord a) => a -> a -> Range a exponentialFloat x y = exponentialFloatFrom x x y -- | Construct a range which scales the bounds exponentially relative to the -- size parameter. -- -- This works the same as 'exponentialFrom', but for floating-point values. -- -- >>> bounds 0 $ exponentialFloatFrom 0 (-10) 20 -- (0.0,0.0) -- -- >>> bounds 50 $ exponentialFloatFrom 0 (-10) 20 -- (-2.357035250656098,3.6535836249197002) -- -- >>> bounds 99 $ exponentialFloatFrom x (-10) 20 -- (-10.0,20.0) -- exponentialFloatFrom :: (Floating a, Ord a) => a -> a -> a -> Range a exponentialFloatFrom z x y = Range z $ \sz -> let sized_x = clamp x y $ scaleExponentialFloat sz z x sized_y = clamp x y $ scaleExponentialFloat sz z y in (sized_x, sized_y) -- | Scale an integral exponentially with the size parameter. -- scaleExponential :: Integral a => Size -> a -> a -> a scaleExponential sz z0 n0 = let z = fromIntegral z0 n = fromIntegral n0 in round (scaleExponentialFloat sz z n :: Double) -- | Scale a floating-point number exponentially with the size parameter. -- scaleExponentialFloat :: Floating a => Size -> a -> a -> a scaleExponentialFloat sz0 z n = let sz = clamp 0 99 sz0 diff = (((abs (n - z) + 1) ** (realToFrac sz / 99)) - 1) * signum (n - z) in z + diff ------------------------------------------------------------------------ -- Internal -- $internal -- -- These functions are exported in case you need them in a pinch, but are not -- part of the public API and may change at any time, even as part of a minor -- update. hedgehog-0.6.1/src/Hedgehog/Internal/Region.hs0000644000000000000000000000562113351371600017315 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} module Hedgehog.Internal.Region ( Region(..) , newEmptyRegion , newOpenRegion , openRegion , setRegion , displayRegions , displayRegion , moveToBottom , finishRegion ) where import Control.Concurrent.STM (STM, TVar) import qualified Control.Concurrent.STM.TMVar as TMVar import qualified Control.Concurrent.STM.TVar as TVar import Control.Monad.Catch (MonadMask(..), bracket) import Control.Monad.IO.Class (MonadIO(..)) import System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion(..)) import qualified System.Console.Regions as Console data Body = Empty | Open ConsoleRegion | Closed newtype Region = Region { unRegion :: TVar Body } newEmptyRegion :: LiftRegion m => m Region newEmptyRegion = liftRegion $ do ref <- TVar.newTVar Empty pure $ Region ref newOpenRegion :: LiftRegion m => m Region newOpenRegion = liftRegion $ do region <- Console.openConsoleRegion Linear ref <- TVar.newTVar $ Open region pure $ Region ref openRegion :: LiftRegion m => Region -> String -> m () openRegion (Region var) content = liftRegion $ do body <- TVar.readTVar var case body of Empty -> do region <- Console.openConsoleRegion Linear TVar.writeTVar var $ Open region Console.setConsoleRegion region content Open region -> Console.setConsoleRegion region content Closed -> pure () setRegion :: LiftRegion m => Region -> String -> m () setRegion (Region var) content = liftRegion $ do body <- TVar.readTVar var case body of Empty -> pure () Open region -> Console.setConsoleRegion region content Closed -> pure () displayRegions :: (MonadIO m, MonadMask m) => m a -> m a displayRegions io = Console.displayConsoleRegions io displayRegion :: MonadIO m => MonadMask m => LiftRegion m => (Region -> m a) -> m a displayRegion = displayRegions . bracket newOpenRegion finishRegion moveToBottom :: Region -> STM () moveToBottom (Region var) = liftRegion $ do body <- TVar.readTVar var case body of Empty -> pure () Open region -> do mxs <- TMVar.tryTakeTMVar Console.regionList case mxs of Nothing -> pure () Just xs0 -> let xs1 = filter (/= region) xs0 in TMVar.putTMVar Console.regionList (region : xs1) Closed -> pure () finishRegion :: LiftRegion m => Region -> m () finishRegion (Region var) = liftRegion $ do body <- TVar.readTVar var case body of Empty -> do TVar.writeTVar var Closed Open region -> do content <- Console.getConsoleRegion region Console.finishConsoleRegion region content TVar.writeTVar var Closed Closed -> pure ()