+
+# Release with confidence.
+
+[![Hackage][hackage-shield]][hackage] [![GitHub CI][github-shield]][github-ci]
+
+
+
+[Hedgehog](https://hackage.haskell.org/package/hedgehog) automatically generates a comprehensive array of test cases, exercising your software in ways human testers would never imagine.
+
+Generate hundreds of test cases automatically, exposing even the most insidious of corner cases. Failures are automatically simplified, giving developers coherent, intelligible error messages.
+
## Features
- Integrated shrinking, shrinks obey invariants by construction.
@@ -28,6 +40,7 @@
qualified. You also need to enable Template Haskell so the Hedgehog test
runner can find your properties.
+
```hs
{-# LANGUAGE TemplateHaskell #-}
@@ -76,11 +89,31 @@
```
+## In Memory of Jacob Stanley
+
+As we come to the end of our guide to haskell-hedgehog, we'd like to take a moment to remember and honor one of its key contributors, our dear friend, author and co-founder, Jacob Stanley.
+
+Jacob's passion for Haskell and his commitment to creating high-quality, reliable software was truly inspiring. His work has shaped haskell-hedgehog in countless ways, and without him, it wouldn't be the project it is today.
+
+Jacob passed away unexpectedly on April 9th. His absence is deeply felt, but his impact on this project, and on all of us who had the privilege to work with him, remains. We continue to maintain and develop haskell-hedgehog in his memory and in honor of his dedication to excellence in programming.
+
+As you explore haskell-hedgehog, and possibly contribute to its ongoing development, we invite you to join us in remembering Jacob Stanley — a tremendous developer, collaborator, and friend.
+
+
+
+
+
+## Contributors
+
+
+ 
+
+
[hackage]: http://hackage.haskell.org/package/hedgehog
- [hackage-shield]: https://img.shields.io/badge/hackage-v0.5-blue.svg
+ [hackage-shield]: https://img.shields.io/hackage/v/hedgehog.svg?style=flat
- [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog
- [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master
+ [github-shield]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/haskell-ci.yml/badge.svg
+ [github-ci]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/haskell-ci.yml
[haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html
[haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html
diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/hedgehog.cabal b/hedgehog.cabal
--- a/hedgehog.cabal
+++ b/hedgehog.cabal
@@ -1,4 +1,4 @@
-version: 0.6.1
+version: 1.7
name:
hedgehog
@@ -7,18 +7,21 @@
maintainer:
Jacob Stanley
homepage:
- https://hedgehog.qa
+ http://github.com/hedgehogqa/haskell-hedgehog
bug-reports:
https://github.com/hedgehogqa/haskell-hedgehog/issues
synopsis:
- Hedgehog will eat all your bugs.
+ Release with confidence.
description:
- Hedgehog is a modern property-based testing system, in the spirit of
- QuickCheck. Hedgehog uses integrated shrinking, so shrinks obey the
- invariants of generated values by construction.
+ automatically generates a comprehensive array
+ of test cases, exercising your software in ways human testers would never
+ imagine.
.
- To get started quickly, see the examples:
-
+ Generate hundreds of test cases automatically, exposing even the
+ most insidious of corner cases. Failures are automatically simplified, giving
+ developers coherent, intelligible error messages.
+ .
+ To get started quickly, see the .
category:
Testing
license:
@@ -26,59 +29,62 @@
license-file:
LICENSE
cabal-version:
- >= 1.8
+ >= 1.10
build-type:
Simple
tested-with:
- GHC == 7.10.2
- , GHC == 7.10.3
- , GHC == 8.0.1
- , GHC == 8.0.2
- , GHC == 8.2.1
- , GHC == 8.2.2
- , GHC == 8.4.1
- , GHC == 8.4.2
- , GHC == 8.4.3
+ GHC == 8.2.2
+ , GHC == 8.4.4
+ , GHC == 8.6.5
+ , GHC == 8.8.3
+ , GHC == 8.10.1
+ , GHC == 9.0.2
+ , GHC == 9.2.7
+ , GHC == 9.4.8
+ , GHC == 9.6.6
+ , GHC == 9.8.4
+ , GHC == 9.10.1
+ , GHC == 9.12.1
+
extra-source-files:
README.md
CHANGELOG.md
source-repository head
type: git
- location: git://github.com/hedgehogqa/haskell-hedgehog.git
+ location: https://github.com/hedgehogqa/haskell-hedgehog
library
build-depends:
- base >= 3 && < 5
- , ansi-terminal >= 0.6 && < 0.9
+ -- GHC 8.0.1 / base-4.9.0.0 (May 2016)
+ base >= 4.9 && < 5
+ , ansi-terminal >= 0.6 && < 1.2
, async >= 2.0 && < 2.3
- , bytestring >= 0.10 && < 0.11
+ , barbies >= 1.0 && < 2.2
+ , bytestring >= 0.10 && < 0.13
, concurrent-output >= 1.7 && < 1.11
- , containers >= 0.4 && < 0.7
+ , containers >= 0.4 && < 0.9
+ , deepseq >= 1.1.0.0 && < 1.6
, directory >= 1.2 && < 1.4
+ , erf >= 2.0 && < 2.1
, exceptions >= 0.7 && < 0.11
- , lifted-async >= 0.7 && < 0.11
- , mmorph >= 1.0 && < 1.2
+ , lifted-async >= 0.7 && < 0.12
+ , mmorph >= 1.0 && < 1.3
, 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
+ , mtl >= 2.1 && < 2.4
+ , pretty-show >= 1.6 && < 1.11
+ , primitive >= 0.6 && < 0.10
+ , random >= 1.1 && < 1.4
+ , resourcet >= 1.1 && < 1.4
+ , safe-exceptions >= 0.1 && < 0.2
+ , stm >= 2.4 && < 2.6
+ , template-haskell >= 2.10 && < 2.24
+ , text >= 1.1 && < 2.2
+ , time >= 1.4 && < 1.15
+ , transformers >= 0.5 && < 0.7
+ , transformers-base >= 0.4.5.1 && < 0.5
, wl-pprint-annotated >= 0.0 && < 0.2
- if !os(windows)
- build-depends:
- unix >= 2.6 && < 2.8
-
ghc-options:
-Wall
@@ -88,8 +94,10 @@
exposed-modules:
Hedgehog
Hedgehog.Gen
+ Hedgehog.Main
Hedgehog.Range
+ Hedgehog.Internal.Barbie
Hedgehog.Internal.Config
Hedgehog.Internal.Discovery
Hedgehog.Internal.Distributive
@@ -97,6 +105,7 @@
Hedgehog.Internal.Gen
Hedgehog.Internal.HTraversable
Hedgehog.Internal.Opaque
+ Hedgehog.Internal.Prelude
Hedgehog.Internal.Property
Hedgehog.Internal.Queue
Hedgehog.Internal.Range
@@ -112,6 +121,9 @@
Hedgehog.Internal.Tree
Hedgehog.Internal.Tripping
+ default-language:
+ Haskell2010
+
test-suite test
type:
exitcode-stdio-1.0
@@ -126,14 +138,24 @@
test
other-modules:
+ Test.Hedgehog.Applicative
+ Test.Hedgehog.Confidence
+ Test.Hedgehog.Filter
+ Test.Hedgehog.Maybe
Test.Hedgehog.Seed
+ Test.Hedgehog.Skip
Test.Hedgehog.Text
+ Test.Hedgehog.Zip
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
+ , containers >= 0.4 && < 0.9
+ , mmorph >= 1.0 && < 1.3
+ , mtl >= 2.1 && < 2.4
+ , pretty-show >= 1.6 && < 1.11
+ , text >= 1.1 && < 2.2
+ , transformers >= 0.3 && < 0.7
+
+ default-language:
+ Haskell2010
diff --git a/src/Hedgehog.hs b/src/Hedgehog.hs
--- a/src/Hedgehog.hs
+++ b/src/Hedgehog.hs
@@ -60,11 +60,17 @@
, check
, recheck
+ , recheckAt
, discover
+ , discoverPrefix
, checkParallel
, checkSequential
+ , Confidence
+ , verifiedTermination
+ , withConfidence
+
, withTests
, TestLimit
@@ -77,6 +83,9 @@
, withRetries
, ShrinkRetries
+ , withSkip
+ , Skip
+
-- * Generating Test Data
, Gen
, GenT
@@ -97,16 +106,28 @@
, success
, failure
, assert
+ , diff
, (===)
, (/==)
, tripping
, eval
+ , evalNF
, evalM
, evalIO
, evalEither
+ , evalEitherM
, evalExceptT
+ , evalMaybe
+ , evalMaybeM
+ -- * Coverage
+ , LabelName
+ , classify
+ , cover
+ , label
+ , collect
+
-- * State Machine Tests
, Command(..)
, Callback(..)
@@ -125,10 +146,13 @@
, Opaque(..)
-- * Transformers
- , distribute
+ , distributeT
-- * Functors
- , HTraversable(..)
+ -- $functors
+ , FunctorB(..)
+ , TraversableB(..)
+ , Rec(..)
, Eq1
, eq1
@@ -138,35 +162,80 @@
, Show1
, showsPrec1
+
+ -- * Deprecated
+ , HTraversable(..)
) where
import Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1)
-import Hedgehog.Internal.Distributive (Distributive(..))
+import Hedgehog.Internal.Barbie (FunctorB(..), TraversableB(..), Rec(..))
+import Hedgehog.Internal.Distributive (distributeT)
import Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..))
import Hedgehog.Internal.HTraversable (HTraversable(..))
import Hedgehog.Internal.Opaque (Opaque(..))
import Hedgehog.Internal.Property (annotate, annotateShow)
-import Hedgehog.Internal.Property (assert, (===), (/==))
+import Hedgehog.Internal.Property (assert, diff, (===), (/==))
+import Hedgehog.Internal.Property (classify, cover)
import Hedgehog.Internal.Property (discard, failure, success)
import Hedgehog.Internal.Property (DiscardLimit, withDiscards)
-import Hedgehog.Internal.Property (eval, evalM, evalIO)
-import Hedgehog.Internal.Property (evalEither, evalExceptT)
+import Hedgehog.Internal.Property (eval, evalNF, evalM, evalIO)
+import Hedgehog.Internal.Property (evalEither, evalEitherM, evalExceptT, evalMaybe, evalMaybeM)
import Hedgehog.Internal.Property (footnote, footnoteShow)
import Hedgehog.Internal.Property (forAll, forAllWith)
-import Hedgehog.Internal.Property (MonadTest(..))
+import Hedgehog.Internal.Property (LabelName, MonadTest(..))
import Hedgehog.Internal.Property (Property, PropertyT, PropertyName)
import Hedgehog.Internal.Property (Group(..), GroupName)
+import Hedgehog.Internal.Property (Confidence, verifiedTermination, withConfidence)
import Hedgehog.Internal.Property (ShrinkLimit, withShrinks)
import Hedgehog.Internal.Property (ShrinkRetries, withRetries)
+import Hedgehog.Internal.Property (Skip, withSkip)
import Hedgehog.Internal.Property (Test, TestT, property, test)
import Hedgehog.Internal.Property (TestLimit, withTests)
+import Hedgehog.Internal.Property (collect, label)
import Hedgehog.Internal.Range (Range, Size(..))
-import Hedgehog.Internal.Runner (check, recheck, checkSequential, checkParallel)
+import Hedgehog.Internal.Runner (check, recheck, recheckAt, checkSequential, checkParallel)
import Hedgehog.Internal.Seed (Seed(..))
import Hedgehog.Internal.State (Command(..), Callback(..))
import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..))
import Hedgehog.Internal.State (executeSequential, executeParallel)
import Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque)
-import Hedgehog.Internal.TH (discover)
+import Hedgehog.Internal.TH (discover, discoverPrefix)
import Hedgehog.Internal.Tripping (tripping)
+
+
+-- $functors
+--
+-- 'FunctorB' and 'TraversableB' must be implemented for all 'Command' @input@ types.
+--
+-- This is most easily achieved using `DeriveGeneric`:
+--
+-- @
+-- data Register v =
+-- Register Name (Var Pid v)
+-- deriving (Eq, Show, Generic)
+--
+-- instance FunctorB Register
+-- instance TraversableB Register
+--
+-- newtype Unregister (v :: * -> *) =
+-- Unregister Name
+-- deriving (Eq, Show, Generic)
+--
+-- instance FunctorB Unregister
+-- instance TraversableB Unregister
+-- @
+--
+-- `DeriveAnyClass` and `DerivingStrategies` allow a more compact syntax:
+--
+-- @
+-- data Register v =
+-- Register Name (Var Pid v)
+-- deriving (Eq, Show, Generic, FunctorB, TraversableB)
+--
+-- newtype Unregister (v :: * -> *) =
+-- Unregister Name
+-- deriving (Eq, Show, Generic)
+-- deriving anyclass (FunctorB, TraversableB)
+-- @
+--
diff --git a/src/Hedgehog/Gen.hs b/src/Hedgehog/Gen.hs
--- a/src/Hedgehog/Gen.hs
+++ b/src/Hedgehog/Gen.hs
@@ -1,9 +1,6 @@
module Hedgehog.Gen (
- -- * Combinators
- lift
-
-- ** Shrinking
- , shrink
+ shrink
, prune
-- ** Size
@@ -70,10 +67,16 @@
-- ** Conditional
, discard
, filter
+ , filterT
+ , mapMaybe
+ , mapMaybeT
, just
+ , justT
-- ** Collections
, maybe
+ , either
+ , either_
, list
, seq
, nonEmpty
@@ -91,6 +94,7 @@
-- ** Combinations & Permutations
, subsequence
+ , subset
, shuffle
-- ** Abstract State Machine
@@ -108,4 +112,4 @@
import Hedgehog.Internal.Gen
import Hedgehog.Internal.State (sequential, parallel)
-import Prelude hiding (filter, print, maybe, map, seq)
+import Prelude hiding (either, filter, print, maybe, map, seq)
diff --git a/src/Hedgehog/Internal/Barbie.hs b/src/Hedgehog/Internal/Barbie.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Internal/Barbie.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE CPP #-}
+
+-- | For compatibility across different versions of the @barbie@ package.
+--
+module Hedgehog.Internal.Barbie (
+ FunctorB(..)
+ , TraversableB(..)
+ , Rec(..)
+ ) where
+
+-- Hide CPP in here instead of the State.hs file.
+
+#if MIN_VERSION_barbies(2,0,0)
+import Data.Functor.Barbie (FunctorB(..), TraversableB(..), Rec(..))
+#else
+import Data.Barbie (FunctorB(..), TraversableB(..), Rec(..))
+#endif
diff --git a/src/Hedgehog/Internal/Config.hs b/src/Hedgehog/Internal/Config.hs
--- a/src/Hedgehog/Internal/Config.hs
+++ b/src/Hedgehog/Internal/Config.hs
@@ -1,5 +1,5 @@
{-# OPTIONS_HADDOCK not-home #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
@@ -9,32 +9,42 @@
UseColor(..)
, resolveColor
+ , Seed(..)
+ , resolveSeed
+
, Verbosity(..)
, resolveVerbosity
, WorkerCount(..)
, resolveWorkers
+ , Skip(..)
+ , resolveSkip
+
, detectMark
, detectColor
+ , detectSeed
, detectVerbosity
, detectWorkers
+ , detectSkip
) where
import Control.Monad.IO.Class (MonadIO(..))
+import qualified Data.Text as Text
+
import qualified GHC.Conc as Conc
-import Language.Haskell.TH.Lift (deriveLift)
+import Hedgehog.Internal.Seed (Seed(..))
+import qualified Hedgehog.Internal.Seed as Seed
+import Hedgehog.Internal.Property (Skip(..), skipDecompress)
+import Language.Haskell.TH.Syntax (Lift)
+
import System.Console.ANSI (hSupportsANSI)
import System.Environment (lookupEnv)
import System.IO (stdout)
-#if !mingw32_HOST_OS
-import System.Posix.User (getEffectiveUserName)
-#endif
-
import Text.Read (readMaybe)
@@ -45,7 +55,7 @@
-- ^ Disable ANSI colors in report output.
| EnableColor
-- ^ Enable ANSI colors in report output.
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Lift)
-- | How verbose should the report output be.
--
@@ -54,22 +64,18 @@
-- ^ Only display the summary of the test run.
| Normal
-- ^ Display each property as it is running, as well as the summary.
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Lift)
-- | The number of workers to use when running properties in parallel.
--
newtype WorkerCount =
WorkerCount Int
- deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
detectMark :: MonadIO m => m Bool
detectMark = do
-#if mingw32_HOST_OS
- pure False
-#else
- user <- liftIO getEffectiveUserName
- pure $ user == "mth"
-#endif
+ user <- liftIO $ lookupEnv "USER"
+ pure $ user == Just "mth"
lookupBool :: MonadIO m => String -> m (Maybe Bool)
lookupBool key =
@@ -115,6 +121,28 @@
else
pure DisableColor
+splitOn :: String -> String -> [String]
+splitOn needle haystack =
+ fmap Text.unpack $ Text.splitOn (Text.pack needle) (Text.pack haystack)
+
+parseSeed :: String -> Maybe Seed
+parseSeed env =
+ case splitOn " " env of
+ [value, gamma] ->
+ Seed <$> readMaybe value <*> readMaybe gamma
+ _ ->
+ Nothing
+
+detectSeed :: MonadIO m => m Seed
+detectSeed =
+ liftIO $ do
+ menv <- lookupEnv "HEDGEHOG_SEED"
+ case parseSeed =<< menv of
+ Nothing ->
+ Seed.random
+ Just seed ->
+ pure seed
+
detectVerbosity :: MonadIO m => m Verbosity
detectVerbosity =
liftIO $ do
@@ -143,6 +171,22 @@
Just env ->
pure $ WorkerCount env
+detectSkip :: MonadIO m => m Skip
+detectSkip =
+ liftIO $ do
+ menv <- lookupEnv "HEDGEHOG_SKIP"
+ case menv of
+ Nothing ->
+ pure SkipNothing
+ Just env ->
+ case skipDecompress env of
+ Nothing ->
+ -- It's clearer for the user if we error out here, rather than
+ -- silently defaulting to SkipNothing.
+ error "HEDGEHOG_SKIP is not a valid Skip."
+ Just skip ->
+ pure skip
+
resolveColor :: MonadIO m => Maybe UseColor -> m UseColor
resolveColor = \case
Nothing ->
@@ -150,6 +194,13 @@
Just x ->
pure x
+resolveSeed :: MonadIO m => Maybe Seed -> m Seed
+resolveSeed = \case
+ Nothing ->
+ detectSeed
+ Just x ->
+ pure x
+
resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity
resolveVerbosity = \case
Nothing ->
@@ -164,9 +215,9 @@
Just x ->
pure x
-------------------------------------------------------------------------
--- FIXME Replace with DeriveLift when we drop 7.10 support.
-
-$(deriveLift ''UseColor)
-$(deriveLift ''Verbosity)
-$(deriveLift ''WorkerCount)
+resolveSkip :: MonadIO m => Maybe Skip -> m Skip
+resolveSkip = \case
+ Nothing ->
+ detectSkip
+ Just x ->
+ pure x
diff --git a/src/Hedgehog/Internal/Discovery.hs b/src/Hedgehog/Internal/Discovery.hs
--- a/src/Hedgehog/Internal/Discovery.hs
+++ b/src/Hedgehog/Internal/Discovery.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Hedgehog.Internal.Discovery (
PropertySource(..)
, readProperties
@@ -20,11 +21,14 @@
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(..))
+#if __GLASGOW_HASKELL__ < 808
+import Data.Semigroup (Semigroup(..))
+#endif
+
------------------------------------------------------------------------
-- Property Extraction
@@ -33,9 +37,9 @@
propertySource :: Pos String
} deriving (Eq, Ord, Show)
-readProperties :: MonadIO m => FilePath -> m (Map PropertyName PropertySource)
-readProperties path =
- findProperties path <$> liftIO (readFile path)
+readProperties :: MonadIO m => String -> FilePath -> m (Map PropertyName PropertySource)
+readProperties prefix path =
+ findProperties prefix path <$> liftIO (readFile path)
readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String))
readDeclaration path line = do
@@ -59,11 +63,11 @@
x : _ ->
Just x
-findProperties :: FilePath -> String -> Map PropertyName PropertySource
-findProperties path =
+findProperties :: String -> FilePath -> String -> Map PropertyName PropertySource
+findProperties prefix path =
Map.map PropertySource .
Map.mapKeysMonotonic PropertyName .
- Map.filterWithKey (\k _ -> isProperty k) .
+ Map.filterWithKey (\k _ -> List.isPrefixOf prefix k) .
findDeclarations path
findDeclarations :: FilePath -> String -> Map String (Pos String)
@@ -71,10 +75,6 @@
declarations .
classified .
positioned path
-
-isProperty :: String -> Bool
-isProperty =
- List.isPrefixOf "prop_"
------------------------------------------------------------------------
-- Declaration Identification
diff --git a/src/Hedgehog/Internal/Distributive.hs b/src/Hedgehog/Internal/Distributive.hs
--- a/src/Hedgehog/Internal/Distributive.hs
+++ b/src/Hedgehog/Internal/Distributive.hs
@@ -1,54 +1,103 @@
{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE TypeOperators #-}
module Hedgehog.Internal.Distributive (
- Distributive(..)
+ MonadTransDistributive(..)
) where
import Control.Monad (join)
import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Identity (IdentityT(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..))
+import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
import Control.Monad.Trans.Reader (ReaderT(..))
-import Control.Monad.Trans.Writer (WriterT(..))
+import qualified Control.Monad.Trans.State.Lazy as Lazy
+import qualified Control.Monad.Trans.State.Strict as Strict
+import qualified Control.Monad.Trans.Writer.Lazy as Lazy
+import qualified Control.Monad.Trans.Writer.Strict as Strict
+import Data.Kind (Type)
import GHC.Exts (Constraint)
+------------------------------------------------------------------------
+-- * MonadTransDistributive
-class Distributive g where
+class MonadTransDistributive g where
type Transformer
- (f :: (* -> *) -> * -> *)
- (g :: (* -> *) -> * -> *)
- (m :: * -> *) :: Constraint
+ (f :: (Type -> Type) -> Type -> Type)
+ (g :: (Type -> Type) -> Type -> Type)
+ (m :: Type -> Type) :: Constraint
type Transformer f g m = (
- Monad m
- , Monad (f m)
- , Monad (g m)
- , Monad (f (g m))
- , MonadTrans f
- , MFunctor f
- )
+ Monad m
+ , Monad (f m)
+ , Monad (g m)
+ , Monad (f (g m))
+ , MonadTrans f
+ , MFunctor f
+ )
-- | Distribute one monad transformer over another.
--
- distribute :: Transformer f g m => g (f m) a -> f (g m) a
+ distributeT :: Transformer f g m => g (f m) a -> f (g m) a
-instance Distributive MaybeT where
- distribute x =
- lift . MaybeT . pure =<< hoist lift (runMaybeT x)
+instance MonadTransDistributive IdentityT where
+ distributeT m =
+ lift . IdentityT . pure =<< hoist lift (runIdentityT m)
-instance Distributive (ExceptT x) where
- distribute x =
- lift . ExceptT . pure =<< hoist lift (runExceptT x)
+instance MonadTransDistributive MaybeT where
+ distributeT m =
+ lift . MaybeT . pure =<< hoist lift (runMaybeT m)
-instance Monoid w => Distributive (WriterT w) where
- distribute x =
- lift . WriterT . pure =<< hoist lift (runWriterT x)
+instance MonadTransDistributive (ExceptT x) where
+ distributeT m =
+ lift . ExceptT . pure =<< hoist lift (runExceptT m)
-instance Distributive (ReaderT r) where
- distribute x =
+instance MonadTransDistributive (ReaderT r) where
+ distributeT m =
join . lift . ReaderT $ \r ->
- pure . hoist lift $ runReaderT x r
+ pure . hoist lift $ runReaderT m r
+
+instance Monoid w => MonadTransDistributive (Lazy.WriterT w) where
+ distributeT m =
+ lift . Lazy.WriterT . pure =<< hoist lift (Lazy.runWriterT m)
+
+instance Monoid w => MonadTransDistributive (Strict.WriterT w) where
+ distributeT m = do
+ lift . Strict.WriterT . pure =<< hoist lift (Strict.runWriterT m)
+
+instance MonadTransDistributive (Lazy.StateT s) where
+ distributeT m = do
+ s <- lift Lazy.get
+ (a, s') <- hoist lift (Lazy.runStateT m s)
+ lift (Lazy.put s')
+ return a
+
+instance MonadTransDistributive (Strict.StateT s) where
+ distributeT m = do
+ s <- lift Strict.get
+ (a, s') <- hoist lift (Strict.runStateT m s)
+ lift (Strict.put s')
+ return a
+
+instance Monoid w => MonadTransDistributive (Lazy.RWST r w s) where
+ distributeT m = do
+ -- ask and get combined
+ (r, s0) <- lift . Lazy.RWST $ \r s -> return ((r, s), s, mempty)
+ (a, s1, w) <- hoist lift (Lazy.runRWST m r s0)
+ -- tell and put combined
+ lift $ Lazy.RWST $ \_ _ -> return (a, s1, w)
+
+instance Monoid w => MonadTransDistributive (Strict.RWST r w s) where
+ distributeT m = do
+ -- ask and get combined
+ (r, s0) <- lift . Strict.RWST $ \r s -> return ((r, s), s, mempty)
+ (a, s1, w) <- hoist lift (Strict.runRWST m r s0)
+ -- tell and put combined
+ lift $ Strict.RWST $ \_ _ -> return (a, s1, w)
diff --git a/src/Hedgehog/Internal/Exception.hs b/src/Hedgehog/Internal/Exception.hs
--- a/src/Hedgehog/Internal/Exception.hs
+++ b/src/Hedgehog/Internal/Exception.hs
@@ -5,7 +5,7 @@
) where
import Control.Exception (Exception(..), AsyncException, SomeException(..), evaluate)
-import Control.Monad.Catch (MonadCatch(..), throwM)
+import Control.Exception.Safe (MonadCatch, catch, throwM)
import System.IO.Unsafe (unsafePerformIO)
diff --git a/src/Hedgehog/Internal/Gen.hs b/src/Hedgehog/Internal/Gen.hs
--- a/src/Hedgehog/Internal/Gen.hs
+++ b/src/Hedgehog/Internal/Gen.hs
@@ -1,1632 +1,1930 @@
{-# 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
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-} -- MonadBase
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE DerivingVia #-}
+#endif
+
+module Hedgehog.Internal.Gen (
+ -- * Transformer
+ Gen
+ , GenT(..)
+ , MonadGen(..)
+
+ -- * Combinators
+ , generalize
+
+ -- ** 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
+ , element_
+ , choice
+ , frequency
+ , recursive
+
+ -- ** Conditional
+ , discard
+ , ensure
+ , filter
+ , mapMaybe
+ , filterT
+ , mapMaybeT
+ , just
+ , justT
+
+ -- ** Collections
+ , maybe
+ , either
+ , either_
+ , list
+ , seq
+ , nonEmpty
+ , set
+ , map
+
+ -- ** Subterms
+ , freeze
+ , subterm
+ , subtermM
+ , subterm2
+ , subtermM2
+ , subterm3
+ , subtermM3
+
+ -- ** Combinations & Permutations
+ , subsequence
+ , subset
+ , shuffle
+ , shuffleSeq
+
+ -- * Sampling Generators
+ , sample
+ , print
+ , printTree
+ , printWith
+ , printTreeWith
+ , renderTree
+
+ -- * Internal
+ -- $internal
+
+ -- ** Transfomer
+ , runGenT
+ , evalGen
+ , evalGenT
+ , mapGenT
+ , generate
+ , toTree
+ , toTreeMaybeT
+ , fromTree
+ , fromTreeT
+ , fromTreeMaybeT
+ , runDiscardEffect
+ , runDiscardEffectT
+
+ -- ** Size
+ , golden
+
+ -- ** Shrinking
+ , atLeast
+
+ -- ** Characters
+ , isSurrogate
+ , isNoncharacter
+
+ -- ** Subterms
+ , Vec(..)
+ , Nat(..)
+ , subtermMVec
+ ) where
+
+#if !MIN_VERSION_base(4,18,0)
+import Control.Applicative (liftA2)
+#endif
+import Control.Applicative (Alternative(..))
+import Control.Monad (MonadPlus(..), filterM, guard, replicateM, join)
+import Control.Monad.Base (MonadBase(..))
+import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch))
+import Control.Monad.Trans.Control (MonadBaseControl(..))
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Morph (MFunctor(..), MMonad(..))
+import qualified Control.Monad.Morph as Morph
+import Control.Monad.Primitive (PrimMonad(..))
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.State.Class (MonadState(..))
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Except (ExceptT(..))
+import Control.Monad.Trans.Identity (IdentityT(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Trans.Reader (ReaderT(..))
+import Control.Monad.Trans.Resource (MonadResource(..))
+import qualified Control.Monad.Trans.State.Lazy as Lazy
+import qualified Control.Monad.Trans.State.Strict as Strict
+import qualified Control.Monad.Trans.Writer.Lazy as Lazy
+import qualified Control.Monad.Trans.Writer.Strict as Strict
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Zip (MonadZip(..))
+
+import Data.Bifunctor (first)
+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.Kind (Type)
+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 qualified Data.Semigroup as Semigroup
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.Set (Set)
+import qualified Data.Set as 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 (MonadTransDistributive(..))
+import Hedgehog.Internal.Prelude hiding (either, maybe, seq)
+import Hedgehog.Internal.Seed (Seed)
+import qualified Hedgehog.Internal.Seed as Seed
+import qualified Hedgehog.Internal.Shrink as Shrink
+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
+import Hedgehog.Internal.Tree (Tree, TreeT(..), NodeT(..))
+import qualified Hedgehog.Internal.Tree as Tree
+import Hedgehog.Range (Size, Range)
+import qualified Hedgehog.Range as Range
+
+#if __GLASGOW_HASKELL__ < 808
+import qualified Control.Monad.Fail as Fail
+#endif
+#if __GLASGOW_HASKELL__ < 806
+import Data.Coerce (coerce)
+#endif
+
+------------------------------------------------------------------------
+-- 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 {
+ unGenT :: Size -> Seed -> TreeT (MaybeT m) a
+ }
+
+-- | Runs a generator, producing its shrink tree.
+--
+runGenT :: Size -> Seed -> GenT m a -> TreeT (MaybeT m) a
+runGenT size seed (GenT m) =
+ m size seed
+
+-- | Run a generator, producing its shrink tree.
+--
+-- 'Nothing' means discarded, 'Just' means we have a value.
+--
+evalGen :: Size -> Seed -> Gen a -> Maybe (Tree a)
+evalGen size seed =
+ Tree.mapMaybe id .
+ evalGenT size seed
+
+-- | Runs a generator, producing its shrink tree.
+--
+evalGenT :: Monad m => Size -> Seed -> GenT m a -> TreeT m (Maybe a)
+evalGenT size seed =
+ runDiscardEffectT .
+ runGenT size seed
+
+-- | Map over a generator's shrink tree.
+--
+mapGenT :: (TreeT (MaybeT m) a -> TreeT (MaybeT n) b) -> GenT m a -> GenT n b
+mapGenT f gen =
+ GenT $ \size seed ->
+ f (runGenT size seed gen)
+
+-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the
+-- size.
+--
+fromTree :: MonadGen m => Tree a -> m a
+fromTree =
+ fromTreeT .
+ hoist (Morph.generalize)
+
+-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the
+-- size.
+--
+fromTreeT :: MonadGen m => TreeT (GenBase m) a -> m a
+fromTreeT x =
+ fromTreeMaybeT $
+ hoist (MaybeT . fmap Just) x
+
+-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the
+-- size.
+--
+fromTreeMaybeT :: MonadGen m => TreeT (MaybeT (GenBase m)) a -> m a
+fromTreeMaybeT x =
+ fromGenT . GenT $ \_ _ ->
+ x
+
+-- | Observe a generator's shrink tree.
+--
+toTree :: forall m a. (MonadGen m, GenBase m ~ Identity) => m a -> m (Tree a)
+toTree =
+ withGenT $ mapGenT (Maybe.maybe empty pure . runDiscardEffect)
+
+-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the
+-- size.
+--
+toTreeMaybeT :: MonadGen m => m a -> m (TreeT (MaybeT (GenBase m)) a)
+toTreeMaybeT =
+ withGenT $ mapGenT pure
+
+-- | Lazily run the discard effects through the tree and reify it a
+-- @Maybe (Tree a)@.
+--
+-- 'Nothing' means discarded, 'Just' means we have a value.
+--
+-- Discards in the child nodes of the tree are simply removed.
+--
+runDiscardEffect :: TreeT (MaybeT Identity) a -> Maybe (Tree a)
+runDiscardEffect =
+ Tree.mapMaybe id .
+ runDiscardEffectT
+
+-- | Run the discard effects through the tree and reify them as 'Maybe' values
+-- at the nodes.
+--
+-- 'Nothing' means discarded, 'Just' means we have a value.
+--
+runDiscardEffectT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a)
+runDiscardEffectT =
+ runMaybeT .
+ distributeT
+
+-- | Lift a @Gen / GenT Identity@ in to a @Monad m => GenT m@
+--
+generalize :: Monad m => Gen a -> GenT m a
+generalize =
+ hoist Morph.generalize
+
+------------------------------------------------------------------------
+-- MonadGen
+
+-- | Class of monads which can generate input data for tests.
+--
+class (Monad m, Monad (GenBase m)) => MonadGen m where
+ type GenBase m :: (Type -> Type)
+
+ -- | Extract a 'GenT' from a 'MonadGen'.
+ --
+ toGenT :: m a -> GenT (GenBase m) a
+
+ -- | Lift a 'GenT' in to a 'MonadGen'.
+ --
+ fromGenT :: GenT (GenBase m) a -> m a
+
+-- | Transform a 'MonadGen' as a 'GenT'.
+--
+withGenT :: (MonadGen m, MonadGen n) => (GenT (GenBase m) a -> GenT (GenBase n) b) -> m a -> n b
+withGenT f =
+ fromGenT . f . toGenT
+
+instance Monad m => MonadGen (GenT m) where
+ -- | The type of the transformer stack's base 'Monad'.
+ --
+ type GenBase (GenT m) =
+ m
+
+ -- | Convert a 'MonadGen' to a 'GenT'.
+ --
+ toGenT =
+ id
+
+ -- | Convert a 'GenT' to a 'MonadGen'.
+ --
+ fromGenT =
+ id
+
+instance MonadGen m => MonadGen (IdentityT m) where
+ type GenBase (IdentityT m) =
+ IdentityT (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+instance MonadGen m => MonadGen (MaybeT m) where
+ type GenBase (MaybeT m) =
+ MaybeT (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+instance MonadGen m => MonadGen (ExceptT x m) where
+ type GenBase (ExceptT x m) =
+ ExceptT x (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+instance MonadGen m => MonadGen (ReaderT r m) where
+ type GenBase (ReaderT r m) =
+ ReaderT r (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+instance MonadGen m => MonadGen (Lazy.StateT r m) where
+ type GenBase (Lazy.StateT r m) =
+ Lazy.StateT r (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+instance MonadGen m => MonadGen (Strict.StateT r m) where
+ type GenBase (Strict.StateT r m) =
+ Strict.StateT r (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+instance (MonadGen m, Monoid w) => MonadGen (Lazy.WriterT w m) where
+ type GenBase (Lazy.WriterT w m) =
+ Lazy.WriterT w (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+instance (MonadGen m, Monoid w) => MonadGen (Strict.WriterT w m) where
+ type GenBase (Strict.WriterT w m) =
+ Strict.WriterT w (GenBase m)
+
+ toGenT =
+ distributeT . hoist toGenT
+
+ fromGenT =
+ hoist fromGenT . distributeT
+
+------------------------------------------------------------------------
+-- GenT instances
+
+instance (Monad m, Semigroup a) => Semigroup (GenT m a) where
+ (<>) =
+ liftA2 (Semigroup.<>)
+
+instance (
+ Monad m, Monoid a
+#if !MIN_VERSION_base(4,11,0)
+ , Semigroup a
+#endif
+ ) => Monoid (GenT m a) where
+#if !MIN_VERSION_base(4,11,0)
+ mappend = (Semigroup.<>)
+#endif
+
+ mempty =
+ return mempty
+
+instance Functor m => Functor (GenT m) where
+ fmap f gen =
+ GenT $ \seed size ->
+ fmap f (runGenT seed size gen)
+
+--
+-- implementation: parallel shrinking
+--
+instance Monad m => Applicative (GenT m) where
+ pure =
+ fromTreeMaybeT . pure
+
+ (<*>) f m =
+ GenT $ \ size seed ->
+ case Seed.split seed of
+ (sf, sm) ->
+ uncurry ($) <$>
+ runGenT size sf f `mzip`
+ runGenT size sm m
+
+--
+-- implementation: satisfies law (ap = <*>)
+--
+--instance Monad m => Applicative (GenT m) where
+-- pure =
+-- fromTreeMaybeT . pure
+-- (<*>) f m =
+-- GenT $ \ size seed ->
+-- case Seed.split seed of
+-- (sf, sm) ->
+-- runGenT size sf f <*>
+-- runGenT size sm m
+
+instance Monad m => Monad (GenT m) where
+ return =
+ pure
+
+ (>>=) m k =
+ GenT $ \size seed ->
+ case Seed.split seed of
+ (sk, sm) ->
+ runGenT size sk . k =<<
+ runGenT size sm m
+
+#if __GLASGOW_HASKELL__ < 808
+ fail =
+ Fail.fail
+#endif
+
+instance Monad m => MonadFail (GenT m) where
+ fail =
+ error
+
+instance Monad m => Alternative (GenT m) where
+ empty =
+ mzero
+
+ (<|>) =
+ mplus
+
+instance Monad m => MonadPlus (GenT m) where
+ mzero =
+ fromTreeMaybeT 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 =
+ fromTreeMaybeT . lift . lift
+
+instance MFunctor GenT where
+ hoist f =
+ mapGenT (hoist (hoist f))
+
+embedMaybeT ::
+ MonadTrans t
+ => Monad n
+ => Monad (t (MaybeT n))
+ => (forall a. m a -> t (MaybeT n) a)
+ -> MaybeT m b
+ -> t (MaybeT n) b
+embedMaybeT f m =
+ lift . MaybeT . pure =<< f (runMaybeT m)
+
+embedTreeMaybeT ::
+ Monad n
+ => (forall a. m a -> TreeT (MaybeT n) a)
+ -> TreeT (MaybeT m) b
+ -> TreeT (MaybeT n) b
+embedTreeMaybeT f tree_ =
+ embed (embedMaybeT f) tree_
+
+embedGenT ::
+ Monad n
+ => (forall a. m a -> GenT n a)
+ -> GenT m b
+ -> GenT n b
+embedGenT f gen =
+ GenT $ \size seed ->
+ case Seed.split seed of
+ (sf, sg) ->
+ (runGenT size sf . f) `embedTreeMaybeT`
+ (runGenT size sg gen)
+
+instance MMonad GenT where
+ embed =
+ embedGenT
+
+distributeGenT :: Transformer t GenT m => GenT (t m) a -> t (GenT m) a
+distributeGenT x =
+ join . lift . GenT $ \size seed ->
+ pure . hoist fromTreeMaybeT . distributeT . hoist distributeT $ runGenT size seed x
+
+instance MonadTransDistributive GenT where
+ type Transformer t GenT m = (
+ Monad (t (GenT m))
+ , Transformer t MaybeT m
+ , Transformer t TreeT (MaybeT m)
+ )
+
+ distributeT =
+ distributeGenT
+
+instance PrimMonad m => PrimMonad (GenT m) where
+ type PrimState (GenT m) =
+ PrimState m
+
+ primitive =
+ lift . primitive
+
+instance MonadIO m => MonadIO (GenT m) where
+ liftIO =
+ lift . liftIO
+
+instance MonadBase b m => MonadBase b (GenT m) where
+ liftBase =
+ lift . liftBase
+
+#if __GLASGOW_HASKELL__ >= 806
+deriving via (ReaderT Size (ReaderT Seed (TreeT (MaybeT m))))
+ instance MonadBaseControl b m => MonadBaseControl b (GenT m)
+#else
+instance MonadBaseControl b m => MonadBaseControl b (GenT m) where
+ type StM (GenT m) a = StM (GloopT m) a
+ liftBaseWith g = gloopToGen $ liftBaseWith $ \q -> g (\gen -> q (genToGloop gen))
+ restoreM = gloopToGen . restoreM
+
+type GloopT m = ReaderT Size (ReaderT Seed (TreeT (MaybeT m)))
+
+gloopToGen :: GloopT m a -> GenT m a
+gloopToGen = coerce
+
+genToGloop :: GenT m a -> GloopT m a
+genToGloop = coerce
+#endif
+
+instance MonadThrow m => MonadThrow (GenT m) where
+ throwM =
+ 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 =
+ lift ask
+ local f m =
+ mapGenT (local f) m
+
+instance MonadState s m => MonadState s (GenT m) where
+ get =
+ lift get
+ put =
+ lift . put
+ state =
+ lift . state
+
+instance MonadWriter w m => MonadWriter w (GenT m) where
+ writer =
+ lift . writer
+ tell =
+ lift . tell
+ listen m =
+ GenT $ \size seed ->
+ listen $ runGenT size seed m
+ pass m =
+ GenT $ \size seed ->
+ pass $ runGenT size seed m
+
+instance MonadError e m => MonadError e (GenT m) where
+ throwError =
+ 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 =
+ lift . liftResourceT
+
+------------------------------------------------------------------------
+-- Combinators
+
+-- | Generate a value with no shrinks from a 'Size' and a 'Seed'.
+--
+generate :: MonadGen m => (Size -> Seed -> a) -> m a
+generate f =
+ fromGenT . 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 f =
+ withGenT $ mapGenT (Tree.expand f)
+
+-- | Throw away a generator's shrink tree.
+--
+prune :: MonadGen m => m a -> m a
+prune =
+ withGenT $ mapGenT (Tree.prune 0)
+
+------------------------------------------------------------------------
+-- 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 :: (HasCallStack, MonadGen m) => (Size -> Size) -> m a -> m a
+scale f =
+ withFrozenCallStack $
+ withGenT $ \gen ->
+ GenT $ \size0 seed ->
+ let
+ size =
+ f size0
+ in
+ if size < 0 then
+ error "Hedgehog.Gen.scale: negative size"
+ else
+ runGenT size seed gen
+
+-- | Make a generator smaller by scaling its size parameter.
+--
+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 :: forall m a. (MonadGen m, Integral a) => Range a -> m a
+integral range =
+ -- https://github.com/hedgehogqa/haskell-hedgehog/pull/413/files
+ let
+ origin_ =
+ Range.origin range
+
+ binarySearchTree bottom top =
+ Tree.Tree $
+ let
+ shrinks =
+ Shrink.towards bottom top
+ children =
+ zipWith binarySearchTree shrinks (drop 1 shrinks)
+ in
+ Tree.NodeT top children
+
+ createTree root =
+ if root == origin_ then
+ pure root
+ else
+ hoist Morph.generalize $
+ Tree.consChild origin_ $
+ binarySearchTree origin_ root
+
+ in
+ fromGenT . GenT $ \size seed ->
+ createTree $ integralHelper range size seed
+
+-- | 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_ =
+ generate . integralHelper
+
+
+-- | Generates a random integral value from a range.
+integralHelper :: (Integral a, Num c) => Range a -> Size -> Seed -> c
+integralHelper range 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'
+-- @
+--
+-- /This is implemented in terms of the 'Enum' class, and thus may be/
+-- /partial for integral types larger than 'Int', e.g. 'Word64'./
+enumBounded :: (MonadGen m, Enum a, Bounded a) => m a
+enumBounded =
+ enum minBound maxBound
+
+-- | 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', '\65534', '\65535')@
+--
+unicode :: (MonadGen m) => m Char
+unicode =
+ let
+ s1 =
+ (55296, enum '\0' '\55295')
+ s2 =
+ (8190, enum '\57344' '\65533')
+ s3 =
+ (1048576, enum '\65536' '\1114111')
+ in
+ frequency [s1, s2, s3]
+
+-- | 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 :: (HasCallStack, Foldable f, MonadGen m) => f a -> m a
+element fa = withFrozenCallStack $ case toList fa of
+ [] ->
+ error "Hedgehog.Gen.element: used with empty Foldable"
+ xs -> do
+ n <- integral $ Range.constant 0 (length xs - 1)
+ pure $ xs !! n
+
+-- | Randomly selects one of the elements in the list.
+--
+-- This generator does not shrink the choice of element.
+--
+-- /The input list must be non-empty./
+--
+element_ :: (HasCallStack, MonadGen m) => [a] -> m a
+element_ l = withFrozenCallStack $ case l of
+ [] ->
+ 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 :: (HasCallStack, MonadGen m) => [m a] -> m a
+choice l = withFrozenCallStack $ case l of
+ [] ->
+ 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 :: (HasCallStack, MonadGen m) => [(Int, m a)] -> m a
+frequency l = withFrozenCallStack $ case l of
+ [] ->
+ 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
+
+ iis =
+ scanl1 (+) (fmap fst xs0)
+
+ total =
+ sum (fmap fst xs0)
+
+ n <- shrink (\n -> takeWhile (< n) iis) $ 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 =
+ fromGenT empty
+
+-- | 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
+
+fromPred :: (a -> Bool) -> a -> Maybe a
+fromPred p a = a <$ guard (p a)
+
+-- | Generates a value that satisfies a predicate.
+--
+-- Shrinks of the generated value will also satisfy the predicate. From the
+-- original generator's shrink tree, any values that fail the predicate will
+-- be removed, but any subsequent shrinks that satisfy it will be retained.
+-- Compared to 'filter', shrinking may be slower but will be optimal.
+--
+-- It's possible that the predicate will never pass, or will only pass at a
+-- larger size than we're currently running at. To avoid looping forever, we
+-- limit the number of retries, and grow the size with each retry. If we retry
+-- too many times then the whole generator is discarded.
+--
+filter :: (MonadGen m, GenBase m ~ Identity) => (a -> Bool) -> m a -> m a
+filter p =
+ mapMaybe (fromPred p)
+
+-- | Generates a value which is the result of the given function returning a
+-- 'Just'.
+--
+-- The original generator's shrink tree will be retained, with values
+-- returning 'Nothing' removed. Subsequent shrinks of those values will be
+-- retained. Compared to 'mapMaybeT', shrinking may be slower but will be
+-- optimal.
+--
+-- It's possible that the function will never return 'Just', or will only do
+-- so a larger size than we're currently running at. To avoid looping forever,
+-- we limit the number of retries, and grow the size with each retry. If we
+-- retry too many times then the whole generator is discarded.
+--
+mapMaybe :: (MonadGen m, GenBase m ~ Identity) => (a -> Maybe b) -> m a -> m b
+mapMaybe p gen0 =
+ let
+ try k =
+ if k > 100 then
+ discard
+ else do
+ (x, gen) <- freeze $ scale (2 * k +) gen0
+
+ case p x of
+ Just _ ->
+ withGenT (mapGenT (Tree.mapMaybeMaybeT p)) gen
+ Nothing ->
+ try (k + 1)
+ in
+ try 0
+
+-- | Generates a value that satisfies a predicate.
+--
+-- Shrinks of the generated value will also satisfy the predicate. From the
+-- original generator's shrink tree, any values that fail the predicate will
+-- be removed, along with their subsequent shrinks. Compared to 'filter',
+-- shrinking may be faster but may also be less optimal.
+--
+-- The type is also more general, because the shrink behavior from 'filter'
+-- would force the entire shrink tree to be evaluated when applied to an
+-- impure tree.
+--
+-- This is essentially:
+--
+-- @
+-- filterT p gen = 'mfilter' p gen '<|>' filterT p gen
+-- @
+--
+-- But that could loop forever, if the predicate will never pass or will only
+-- pass at a larger size than we're currently running at. We differ from the
+-- above in keeping some state to avoid that. We limit the number of retries,
+-- and grow the size with each retry. If we retry too many times then the
+-- whole generator is discarded.
+--
+filterT :: MonadGen m => (a -> Bool) -> m a -> m a
+filterT p =
+ mapMaybeT (fromPred p)
+
+-- | Generates a value which is the result of the given function returning a
+-- 'Just'.
+--
+-- The original generator's shrink tree will be retained, with values
+-- returning 'Nothing' removed. Subsequent shrinks of those values will be
+-- retained. Compared to 'mapMaybeT', shrinking may be slower but will be
+-- optimal.
+--
+-- The type is also more general, because the shrink behavior from 'mapMaybe'
+-- would force the entire shrink tree to be evaluated when applied to an
+-- impure tree.
+--
+-- It's possible that the function will never return 'Just', or will only do
+-- so a larger size than we're currently running at. To avoid looping forever,
+-- we limit the number of retries, and grow the size with each retry. If we
+-- retry too many times then the whole generator is discarded.
+--
+mapMaybeT :: MonadGen m => (a -> Maybe b) -> m a -> m b
+mapMaybeT p gen0 =
+ let
+ try k =
+ if k > 100 then
+ discard
+ else do
+ (x, gen) <- freeze $ scale (2 * k +) gen0
+
+ case p x of
+ Just _ ->
+ withGenT (mapGenT (Tree.mapMaybeT p)) gen
+ Nothing ->
+ 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, GenBase m ~ Identity) => 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"
+
+-- | Runs a 'Maybe' generator until it produces a 'Just'.
+--
+-- /This is implemented using 'filter' and has the same caveats./
+--
+justT :: MonadGen m => m (Maybe a) -> m a
+justT g = do
+ mx <- filterT Maybe.isJust g
+ case mx of
+ Just x ->
+ pure x
+ Nothing ->
+ error "Hedgehog.Gen.just: internal error, unexpected Nothing"
+
+------------------------------------------------------------------------
+-- Combinators - Collections
+
+-- | 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 either an 'a' or a 'b'.
+--
+-- As the size grows, this generator generates @Right@s more often than @Left@s.
+--
+either :: MonadGen m => m a -> m b -> m (Either a b)
+either genA genB =
+ sized $ \n ->
+ frequency [
+ (2, Left <$> genA)
+ , (1 + fromIntegral n, Right <$> genB)
+ ]
+
+-- | Generates either an 'a' or a 'b', without bias.
+--
+-- This generator generates as many @Right@s as it does @Left@s.
+--
+either_ :: MonadGen m => m a -> m b -> m (Either a b)
+either_ genA genB =
+ choice [
+ Left <$> genA
+ , Right <$> genB
+ ]
+
+-- | Generates a list using a 'Range' to determine the length.
+--
+list :: MonadGen m => Range Int -> m a -> m [a]
+list range gen =
+ let
+ interleave =
+ (interleaveTreeT . nodeValue =<<)
+ in
+ sized $ \size ->
+ ensure (atLeast $ Range.lowerBound size range) .
+ withGenT (mapGenT (TreeT . interleave . runTreeT)) $ do
+ n <- integral_ range
+ replicateM n (toTreeMaybeT gen)
+
+interleaveTreeT :: Monad m => [TreeT m a] -> m (NodeT m [a])
+interleaveTreeT =
+ fmap Tree.interleave . traverse runTreeT
+
+-- | Generates a seq using a 'Range' to determine the length.
+--
+seq :: MonadGen m => Range Int -> m a -> m (Seq a)
+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 =
+ withGenT $ \gen ->
+ GenT $ \size seed -> do
+ mx <- lift . lift . runMaybeT . runTreeT $ runGenT size seed gen
+ case mx of
+ Nothing ->
+ empty
+ Just (NodeT x xs) ->
+ pure (x, fromGenT . fromTreeMaybeT . Tree.fromNodeT $ NodeT x xs)
+
+shrinkSubterms :: Subterms n a -> [Subterms n a]
+shrinkSubterms = \case
+ 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.
+--
+-- For example:
+--
+-- @
+-- Gen.print (Gen.subsequence [1..5])
+-- @
+--
+-- > === Outcome ===
+-- > [1,2,4]
+-- > === Shrinks ===
+-- > []
+-- > [2,4]
+-- > [1,4]
+-- > [1,2]
+--
+subsequence :: MonadGen m => [a] -> m [a]
+subsequence xs =
+ shrink Shrink.list $ filterM (const bool_) xs
+
+-- | Generates a random subset of a set.
+--
+-- /This shrinks towards the empty set./
+--
+subset :: MonadGen m => Set a -> m (Set a)
+-- Set.fromDistinctAscList has an unchecked precondition that the list
+-- must be strictly ascending. This precondition is satisfied because
+-- Set.toAscList produces a strictly ascending list, and the 'subsequence'
+-- generator only removes elements from the list; it never adds or
+-- rearranges elements, so the strictly ascending property is undisturbed.
+subset =
+ fmap Set.fromDistinctAscList . subsequence . Set.toAscList
+
+-- | 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]
+-- We shuffle sequences instead of lists to make extracting an arbitrary
+-- element logarithmic instead of linear, and to make length calculation
+-- constant-time instead of linear. We could probably do better, but
+-- this is at least reasonably quick.
+shuffle = fmap toList . shuffleSeq . Seq.fromList
+
+-- | Generates a random permutation of a sequence.
+--
+-- /This shrinks towards the order of the sequence being identical to the input/
+-- /sequence./
+--
+shuffleSeq :: MonadGen m => Seq a -> m (Seq a)
+shuffleSeq xs =
+ if null xs then
+ pure Seq.empty
+ else do
+ n <- integral $ Range.constant 0 (length xs - 1)
+#if MIN_VERSION_containers(0,5,8)
+ -- Data.Sequence should offer a version of deleteAt that returns the
+ -- deleted element, but it does not currently do so. Lookup followed
+ -- by deletion seems likely faster than splitting and then appending,
+ -- but I haven't actually tested that. It's certainly easier to see
+ -- what's going on.
+ case Seq.lookup n xs of
+ Just y ->
+ (y Seq.<|) <$> shuffleSeq (Seq.deleteAt n xs)
+ Nothing ->
+ error "Hedgehog.Gen.shuffleSeq: internal error, lookup in empty sequence"
+#else
+ case Seq.splitAt n xs of
+ (beginning, end) ->
+ case Seq.viewl end of
+ y Seq.:< end' ->
+ (y Seq.<|) <$> shuffleSeq (beginning Seq.>< end')
+ Seq.EmptyL ->
+ error "Hedgehog.Gen.shuffleSeq: internal error, lookup in empty sequence"
+#endif
+
+------------------------------------------------------------------------
+-- Sampling
+
+-- | Generate a sample from a generator.
+--
+-- This function is useful for examining a 'Gen' in GHCi or other contexts.
+-- It is not appropriate for use in a test suite directly. You will only
+-- get a single sample from this function, and it will not give you
+-- a property test. The seed is random, so the test is not deterministic.
+--
+-- If you only want a single test to run, then use @'withTests' 1@:
+--
+-- @
+-- prop_OnlyRunOnce :: Property
+-- prop_OnlyRunOnce =
+-- 'withTests' 1 $ 'property' $ do
+-- i <- Gen.int
+-- i /== 0
+-- @
+sample :: (HasCallStack, MonadIO m) => Gen a -> m a
+sample gen =
+ withFrozenCallStack $
+ 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 evalGen 30 seed gen of
+ Nothing ->
+ loop (n - 1)
+ Just x ->
+ pure $ Tree.treeValue x
+ in
+ loop (100 :: Int)
+
+-- | 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
+
+-- | Print the value produced by a generator, and the first level of shrinks,
+-- for the given size and seed.
+--
+-- Use 'print' to generate a value from a random seed.
+--
+printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen a -> m ()
+printWith size seed gen =
+ liftIO $ do
+ case evalGen size seed gen of
+ Nothing -> do
+ putStrLn "=== Outcome ==="
+ putStrLn ""
+
+ Just tree_ -> do
+ let
+ NodeT x ss =
+ runIdentity (runTreeT tree_)
+
+ putStrLn "=== Outcome ==="
+ putStrLn (show x)
+ putStrLn "=== Shrinks ==="
+
+ for_ ss $ \s ->
+ let
+ NodeT y _ =
+ runIdentity $ runTreeT s
+ in
+ putStrLn (show y)
+
+-- | Run a generator with a random seed and print the resulting shrink tree.
+--
+-- @
+-- 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
+
+-- | 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 $
+ renderTree size seed gen
+
+-- | Render the shrink tree produced by a generator, for the given size and
+-- seed.
+--
+renderTree :: Show a => Size -> Seed -> Gen a -> String
+renderTree size seed gen =
+ case evalGen size seed gen of
+ Nothing ->
+ ""
+ Just x ->
+ Tree.render (fmap show x)
------------------------------------------------------------------------
-- Internal
diff --git a/src/Hedgehog/Internal/HTraversable.hs b/src/Hedgehog/Internal/HTraversable.hs
--- a/src/Hedgehog/Internal/HTraversable.hs
+++ b/src/Hedgehog/Internal/HTraversable.hs
@@ -1,13 +1,20 @@
{-# OPTIONS_HADDOCK not-home #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# LANGUAGE RankNTypes #-}
module Hedgehog.Internal.HTraversable (
HTraversable(..)
) where
+import Hedgehog.Internal.Barbie (TraversableB)
-- | Higher-order traversable functors.
--
--- This is used internally to make symbolic variables concrete given an 'Environment'.
+-- /Deprecated in favor of 'TraversableB' which can be derived using "GHC.Generics"/
--
class HTraversable t where
htraverse :: Applicative f => (forall a. g a -> f (h a)) -> t g -> f (t h)
+
+{-#
+ DEPRECATED HTraversable
+ "Replace with Hedgehog.TraversableB (defined in Data.Functor.Barbie) which can be derived automatically using GHC.Generics"
+#-}
diff --git a/src/Hedgehog/Internal/Prelude.hs b/src/Hedgehog/Internal/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Internal/Prelude.hs
@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Mostly for compatibility across different base Prelude changes.
+--
+module Hedgehog.Internal.Prelude (
+ Semigroup(..)
+ , MonadFail
+ , module Prelude
+ ) where
+
+import Control.Monad.Fail (MonadFail)
+
+import Data.Semigroup (Semigroup(..))
+
+import Prelude hiding (filter, print, map)
diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs
--- a/src/Hedgehog/Internal/Property.hs
+++ b/src/Hedgehog/Internal/Property.hs
@@ -1,19 +1,27 @@
{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Distributive
+
module Hedgehog.Internal.Property (
-- * Property
Property(..)
@@ -21,30 +29,43 @@
, PropertyName(..)
, PropertyConfig(..)
, TestLimit(..)
+ , TestCount(..)
, DiscardLimit(..)
+ , DiscardCount(..)
, ShrinkLimit(..)
+ , ShrinkCount(..)
+ , Skip(..)
+ , ShrinkPath(..)
, ShrinkRetries(..)
, withTests
, withDiscards
, withShrinks
, withRetries
+ , withSkip
, property
, test
, forAll
, forAllT
, forAllWith
, forAllWithT
+ , defaultMinTests
, discard
+ , skipCompress
+ , shrinkPathCompress
+ , skipDecompress
+ , shrinkPathDecompress
-- * Group
, Group(..)
, GroupName(..)
+ , PropertyCount(..)
-- * TestT
, MonadTest(..)
, Test
, TestT(..)
, Log(..)
+ , Journal(..)
, Failure(..)
, Diff(..)
, annotate
@@ -54,15 +75,48 @@
, failure
, success
, assert
+ , diff
, (===)
, (/==)
, eval
+ , evalNF
, evalM
, evalIO
, evalEither
+ , evalEitherM
, evalExceptT
+ , evalMaybe
+ , evalMaybeM
+ -- * Coverage
+ , Coverage(..)
+ , Label(..)
+ , LabelName(..)
+ , cover
+ , classify
+ , label
+ , collect
+ , coverPercentage
+ , labelCovered
+ , coverageSuccess
+ , coverageFailures
+ , journalCoverage
+
+ , Cover(..)
+ , CoverCount(..)
+ , CoverPercentage(..)
+ , toCoverCount
+
+ -- * Confidence
+ , Confidence(..)
+ , TerminationCriteria(..)
+ , confidenceSuccess
+ , confidenceFailure
+ , withConfidence
+ , verifiedTermination
+ , defaultConfidence
+
-- * Internal
-- $internal
, defaultConfig
@@ -76,14 +130,18 @@
, mkTestT
, runTest
, runTestT
+
+ , wilsonBounds
) where
import Control.Applicative (Alternative(..))
-import Control.Monad (MonadPlus(..))
+import Control.DeepSeq (NFData, rnf)
+import Control.Exception.Safe (MonadThrow, MonadCatch)
+import Control.Exception.Safe (SomeException(..), displayException)
+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 qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Primitive (PrimMonad(..))
@@ -107,21 +165,31 @@
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Data.Char as Char
+import Data.Functor (($>))
import Data.Functor.Identity (Identity(..))
+import Data.Int (Int64)
+import Data.Map (Map)
+import qualified Data.Map.Strict as Map
+import Data.Number.Erf (invnormcdf)
import qualified Data.List as List
-import Data.Semigroup (Semigroup)
-import Data.String (IsString)
+import Data.String (IsString(..))
+import Data.Ratio ((%))
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.Prelude
import Hedgehog.Internal.Show
import Hedgehog.Internal.Source
-import Language.Haskell.TH.Lift (deriveLift)
+import Language.Haskell.TH.Syntax (Lift)
+import qualified Numeric
+
+import Text.Read (readMaybe)
+
------------------------------------------------------------------------
-- | A property test, along with some configurable limits like how many times
@@ -151,7 +219,19 @@
, MonadState s
, MonadError e
)
+-- NOTE: Move this to the deriving list above when we drop 7.10
+deriving instance MonadResource m => MonadResource (PropertyT m)
+-- NOTE: Move this to the deriving list above when we drop 8.0
+#if __GLASGOW_HASKELL__ >= 802
+deriving instance MonadBaseControl b m => MonadBaseControl b (PropertyT m)
+#else
+instance MonadBaseControl b m => MonadBaseControl b (PropertyT m) where
+ type StM (PropertyT m) a = StM (TestT (GenT m)) a
+ liftBaseWith f = PropertyT $ liftBaseWith $ \rib -> f (rib . unPropertyT)
+ restoreM = PropertyT . restoreM
+#endif
+
-- | A test monad allows the assertion of expectations.
--
type Test =
@@ -161,7 +241,7 @@
--
newtype TestT m a =
TestT {
- unTest :: ExceptT Failure (Lazy.WriterT [Log] m) a
+ unTest :: ExceptT Failure (Lazy.WriterT Journal m) a
} deriving (
Functor
, Applicative
@@ -175,7 +255,7 @@
-- | The name of a property.
--
--- Can be constructed using `OverloadedStrings`:
+-- Should be constructed using `OverloadedStrings`:
--
-- @
-- "apples" :: PropertyName
@@ -184,18 +264,31 @@
newtype PropertyName =
PropertyName {
unPropertyName :: String
- } deriving (Eq, Ord, Show, IsString, Semigroup)
+ } deriving (Eq, Ord, Show, IsString, Semigroup, Lift)
+-- | The acceptable occurrence of false positives
+--
+-- Example, @Confidence 10^9@ would mean that you'd accept a false positive
+-- for 1 in 10^9 tests.
+newtype Confidence =
+ Confidence {
+ unConfidence :: Int64
+ } deriving (Eq, Ord, Show, Num, Lift)
+
-- | Configuration for a property test.
--
data PropertyConfig =
PropertyConfig {
- propertyTestLimit :: !TestLimit
- , propertyDiscardLimit :: !DiscardLimit
+ propertyDiscardLimit :: !DiscardLimit
, propertyShrinkLimit :: !ShrinkLimit
, propertyShrinkRetries :: !ShrinkRetries
- } deriving (Eq, Ord, Show)
+ , propertyTerminationCriteria :: !TerminationCriteria
+ -- | If this is 'Nothing', we take the Skip from the environment variable
+ -- @HEDGEHOG_SKIP@.
+ , propertySkip :: Maybe Skip
+ } deriving (Eq, Ord, Show, Lift)
+
-- | The number of successful tests that need to be run before a property test
-- is considered successful.
--
@@ -207,8 +300,24 @@
--
newtype TestLimit =
TestLimit Int
- deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
+-- | The number of tests a property ran successfully.
+--
+newtype TestCount =
+ TestCount Int
+ deriving (Eq, Ord, Num, Enum, Real, Integral, Lift)
+
+instance Show TestCount where
+ showsPrec p (TestCount n) =
+ showsPrec p n
+
+-- | The number of tests a property had to discard.
+--
+newtype DiscardCount =
+ DiscardCount Int
+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
+
-- | The number of discards to allow before giving up.
--
-- Can be constructed using numeric literals:
@@ -220,7 +329,7 @@
--
newtype DiscardLimit =
DiscardLimit Int
- deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
-- | The number of shrinks to try before giving up on shrinking.
--
@@ -232,8 +341,192 @@
--
newtype ShrinkLimit =
ShrinkLimit Int
+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
+
+-- | The numbers of times a property was able to shrink after a failing test.
+--
+newtype ShrinkCount =
+ ShrinkCount Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+-- | Where to start running a property's tests.
+--
+data Skip =
+ -- | Don't skip anything.
+ --
+ SkipNothing
+
+ -- | Skip to a specific test number. If it fails, shrink as normal. If it
+ -- passes, move on to the next test. Coverage checks are disabled.
+ --
+ -- We also need to count discards, since failing "after 7 tests" points at a
+ -- different generated value than failing "after 7 tests and 5 discards".
+ --
+ | SkipToTest TestCount DiscardCount
+
+ -- | Skip to a specific test number and shrink state. If it fails, stop
+ -- without shrinking further. If it passes, the property will pass without
+ -- running any more tests.
+ --
+ -- Due to implementation details, all intermediate shrink states - those on
+ -- the direct path from the original test input to the target state - will
+ -- be tested too, and their results discarded.
+ --
+ | SkipToShrink TestCount DiscardCount ShrinkPath
+ deriving (Eq, Ord, Show, Lift)
+
+-- | We use this instance to support usage like
+--
+-- @
+-- withSkip "3:aB"
+-- @
+--
+-- It throws an error if the input is not a valid compressed 'Skip'.
+--
+instance IsString Skip where
+ fromString s =
+ case skipDecompress s of
+ Nothing ->
+ error $ "fromString: Not a valid Skip: " ++ s
+ Just skip ->
+ skip
+
+-- | The path taken to reach a shrink state.
+--
+newtype ShrinkPath =
+ ShrinkPath [Int]
+ deriving (Eq, Ord, Show, Lift)
+
+-- | Compress a Skip into a hopefully-short alphanumeric string.
+--
+-- The bit that might be long is the 'ShrinkPath' in 'SkipToShrink'. For that,
+-- we encode the path components in base 26, alternating between uppercase and
+-- lowercase alphabets to distinguish list elements. Additionally when we have
+-- runs of equal components, we use the normal base 10 encoding to indicate
+-- the length.
+--
+-- This gives something which is hopefully quite short, but a human can
+-- roughly interpret it by eyeball.
+--
+skipCompress :: Skip -> String
+skipCompress =
+ let
+ showTD (TestCount t) (DiscardCount d) =
+ show t ++ (if d == 0 then "" else "/" ++ show d)
+ in \case
+ SkipNothing ->
+ ""
+ SkipToTest t d->
+ showTD t d
+ SkipToShrink t d sp ->
+ showTD t d ++ ":" ++ shrinkPathCompress sp
+
+-- | Compress a 'ShrinkPath' into a hopefully-short alphanumeric string.
+--
+-- We encode the path components in base 26, alternating between uppercase and
+-- lowercase alphabets to distinguish list elements. Additionally when we have
+-- runs of equal components, we use the normal base 10 encoding to indicate
+-- the length.
+shrinkPathCompress :: ShrinkPath -> String
+shrinkPathCompress (ShrinkPath sp) =
+ let
+ groups = List.map (\l -> (head l, length l)) $ List.group sp
+ in
+ (mconcat
+ $ zipWith
+ (\alphabet (loc, count) ->
+ Numeric.showIntAtBase 26 (alphabet !!) loc
+ <> if count == 1 then mempty else shows count
+ )
+ (cycle [['a'..'z'], ['A'..'Z']])
+ groups
+ )
+ ""
+
+-- | Decompress a 'Skip'.
+--
+-- This satisfies
+--
+-- @
+-- skipDecompress (skipCompress a) == Just a
+-- @
+--
+skipDecompress :: String -> Maybe Skip
+skipDecompress str =
+ if null str then
+ Just SkipNothing
+ else do
+ let
+ (tcDcStr, spStr)
+ = span (/= ':') str
+
+ (tcStr, dcStr)
+ = span (/= '/') tcDcStr
+
+ tc <- TestCount <$> readMaybe tcStr
+ dc <- DiscardCount <$> if null dcStr
+ then Just 0
+ else readMaybe (drop 1 dcStr)
+
+ if null spStr then
+ Just $ SkipToTest tc dc
+ else do
+ sp <- shrinkPathDecompress $ drop 1 spStr
+ Just $ SkipToShrink tc dc sp
+
+-- | Decompress a 'ShrinkPath'.
+--
+-- This satisfies
+--
+-- @
+-- shrinkPathDecompress (shrinkPathCompress a) == Just a
+-- @
+shrinkPathDecompress :: String -> Maybe ShrinkPath
+shrinkPathDecompress str =
+ let
+ isDigit c = '0' <= c && c <= '9'
+ isLower c = 'a' <= c && c <= 'z'
+ isUpper c = 'A' <= c && c <= 'Z'
+ classifyChar c = (isDigit c, isLower c, isUpper c)
+
+ readSNum "" = []
+ readSNum s@(c1:_) =
+ if isDigit c1 then
+ Numeric.readInt 10 isDigit (\c -> fromEnum c - fromEnum '0') s
+ else if isLower c1 then
+ Numeric.readInt 26 isLower (\c -> fromEnum c - fromEnum 'a') s
+ else if isUpper c1 then
+ Numeric.readInt 26 isUpper (\c -> fromEnum c - fromEnum 'A') s
+ else
+ []
+
+ readNumMaybe s =
+ case readSNum s of
+ [(num, "")] -> Just num
+ _ -> Nothing
+
+ spGroups :: [(Maybe Int, Maybe Int)] =
+ let
+ go [] =
+ []
+ go (c1:cs) =
+ let
+ (hd, tl1) =
+ span (\c -> classifyChar c == classifyChar c1) cs
+ (digs, tl2) =
+ span isDigit tl1
+ in
+ ( readNumMaybe (c1:hd)
+ , readNumMaybe $ if null digs then "1" else digs
+ )
+ : go tl2
+ in
+ go str
+ in do
+ sp <- concat <$>
+ traverse (\(mNum, mCount) -> replicate <$> mCount <*> mNum) spGroups
+ Just $ ShrinkPath sp
+
-- | 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.
@@ -251,7 +544,7 @@
--
newtype ShrinkRetries =
ShrinkRetries Int
- deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift)
-- | A named collection of property tests.
--
@@ -263,7 +556,7 @@
-- | The name of a group of properties.
--
--- Can be constructed using `OverloadedStrings`:
+-- Should be constructed using `OverloadedStrings`:
--
-- @
-- "fruit" :: GroupName
@@ -272,12 +565,24 @@
newtype GroupName =
GroupName {
unGroupName :: String
- } deriving (Eq, Ord, Show, IsString, Semigroup)
+ } deriving (Eq, Ord, Show, IsString, Semigroup, Lift)
+-- | The number of properties in a group.
--
+newtype PropertyCount =
+ PropertyCount Int
+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
+
+data TerminationCriteria =
+ EarlyTermination Confidence TestLimit
+ | NoEarlyTermination Confidence TestLimit
+ | NoConfidenceTermination TestLimit
+ deriving (Eq, Ord, Show, Lift)
+
+--
-- FIXME This whole Log/Failure thing could be a lot more structured to allow
-- FIXME for richer user controlled error messages, think Doc. Ideally we'd
--- FIXME allow user's to create their own diffs anywhere.
+-- FIXME allow user's to crete their own diffs anywhere.
--
-- | Log messages which are recorded during a test run.
@@ -285,8 +590,15 @@
data Log =
Annotation (Maybe Span) String
| Footnote String
+ | Label (Label Cover)
deriving (Eq, Show)
+-- | A record containing the details of a test run.
+newtype Journal =
+ Journal {
+ journalLogs :: [Log]
+ } deriving (Eq, Show, Semigroup, Monoid)
+
-- | Details on where and why a test failed.
--
data Failure =
@@ -305,18 +617,89 @@
, diffValue :: ValueDiff
} deriving (Eq, Show)
+-- | Whether a test is covered by a classifier, and therefore belongs to a
+-- 'Class'.
+--
+data Cover =
+ NoCover
+ | Cover
+ deriving (Eq, Ord, Show)
+
+-- | The total number of tests which are covered by a classifier.
+--
+-- Can be constructed using numeric literals:
+--
+-- @
+-- 30 :: CoverCount
+-- @
+--
+newtype CoverCount =
+ CoverCount {
+ unCoverCount :: Int
+ } deriving (Eq, Ord, Show, Num)
+
+-- | The relative number of tests which are covered by a classifier.
+--
+-- Can be constructed using numeric literals:
+--
+-- @
+-- 30 :: CoverPercentage
+-- @
+--
+newtype CoverPercentage =
+ CoverPercentage {
+ unCoverPercentage :: Double
+ } deriving (Eq, Ord, Show, Num, Fractional)
+
+-- | The name of a classifier.
+--
+-- Should be constructed using `OverloadedStrings`:
+--
+-- @
+-- "apples" :: LabelName
+-- @
+--
+newtype LabelName =
+ LabelName {
+ unLabelName :: String
+ } deriving (Eq, Monoid, Ord, Semigroup, Show, IsString)
+
+-- | The extent to which a test is covered by a classifier.
+--
+-- /When a classifier's coverage does not exceed the required minimum, the/
+-- /test will be failed./
+--
+data Label a =
+ MkLabel {
+ labelName :: !LabelName
+ , labelLocation :: !(Maybe Span)
+ , labelMinimum :: !CoverPercentage
+ , labelAnnotation :: !a
+ } deriving (Eq, Show, Functor, Foldable, Traversable)
+
+-- | The extent to which all classifiers cover a test.
+--
+-- /When a given classification's coverage does not exceed the required/
+-- /minimum, the test will be failed./
+--
+newtype Coverage a =
+ Coverage {
+ coverageLabels :: Map LabelName (Label a)
+ } deriving (Eq, Show, Functor, Foldable, Traversable)
+
------------------------------------------------------------------------
-- TestT
instance Monad m => Monad (TestT m) where
return =
- TestT . return
+ pure
(>>=) m k =
TestT $
unTest m >>=
unTest . k
+instance Monad m => MonadFail (TestT m) where
fail err =
TestT . ExceptT . pure . Left $ Failure Nothing err Nothing
@@ -328,16 +711,16 @@
hoist f =
TestT . hoist (hoist f) . unTest
-instance Distributive TestT where
+instance MonadTransDistributive TestT where
type Transformer t TestT m = (
- Transformer t (Lazy.WriterT [Log]) m
- , Transformer t (ExceptT Failure) (Lazy.WriterT [Log] m)
+ Transformer t (Lazy.WriterT Journal) m
+ , Transformer t (ExceptT Failure) (Lazy.WriterT Journal m)
)
- distribute =
+ distributeT =
hoist TestT .
- distribute .
- hoist distribute .
+ distributeT .
+ hoist distributeT .
unTest
instance PrimMonad m => PrimMonad (TestT m) where
@@ -362,10 +745,10 @@
instance MonadTransControl TestT where
type StT TestT a =
- (Either Failure a, [Log])
+ (Either Failure a, Journal)
liftWith f =
- mkTestT . fmap (, []) . fmap Right $ f $ runTestT
+ mkTestT . fmap (, mempty) . fmap Right $ f $ runTestT
restoreT =
mkTestT
@@ -435,19 +818,19 @@
liftTest =
lift . liftTest
-mkTestT :: m (Either Failure a, [Log]) -> TestT m a
+mkTestT :: m (Either Failure a, Journal) -> TestT m a
mkTestT =
TestT . ExceptT . Lazy.WriterT
-mkTest :: (Either Failure a, [Log]) -> Test a
+mkTest :: (Either Failure a, Journal) -> Test a
mkTest =
mkTestT . Identity
-runTestT :: TestT m a -> m (Either Failure a, [Log])
+runTestT :: TestT m a -> m (Either Failure a, Journal)
runTestT =
Lazy.runWriterT . runExceptT . unTest
-runTest :: Test a -> (Either Failure a, [Log])
+runTest :: Test a -> (Either Failure a, Journal)
runTest =
runIdentity . runTestT
@@ -455,14 +838,14 @@
--
writeLog :: MonadTest m => Log -> m ()
writeLog x =
- liftTest $ mkTest (pure (), [x])
+ liftTest $ mkTest (pure (), (Journal [x]))
-- | Fail the test with an error message, useful for building other failure
-- combinators.
--
failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a
-failWith diff msg =
- liftTest $ mkTest (Left $ Failure (getCaller callStack) msg diff, [])
+failWith mdiff msg =
+ liftTest $ mkTest (Left $ Failure (getCaller callStack) msg mdiff, mempty)
-- | Annotates the source code with a message that might be useful for
-- debugging a test failure.
@@ -492,30 +875,47 @@
footnoteShow =
writeLog . Footnote . showPretty
--- | Fails with an error which shows the difference between two values.
---
+-- | Fails with an error that shows the difference between two values.
failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m ()
failDiff x y =
case valueDiff <$> mkValue x <*> mkValue y of
Nothing ->
withFrozenCallStack $
- failWith Nothing $ unlines [
- "━━━ Not Equal ━━━"
+ failWith Nothing $
+ unlines $ [
+ "Failed"
+ , "━━ lhs ━━"
, showPretty x
+ , "━━ rhs ━━"
, showPretty y
]
- Just diff ->
+
+ Just vdiff@(ValueSame _) ->
withFrozenCallStack $
- failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) ""
+ failWith (Just $
+ Diff "━━━ Failed (" "" "no differences" "" ") ━━━" vdiff) ""
+ Just vdiff ->
+ withFrozenCallStack $
+ failWith (Just $
+ Diff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) ""
+
-- | Fails with an error which renders the type of an exception and its error
-- message.
--
failException :: (MonadTest m, HasCallStack) => SomeException -> m a
-failException (SomeException x) =
+failException x =
withFrozenCallStack $
- failWith Nothing $ unlines [
- "━━━ Exception: " ++ show (typeOf x) ++ " ━━━"
+ failExceptionWith [] x
+
+-- | Fails with an error which renders the given messages, the type of an exception,
+-- and its error message.
+--
+failExceptionWith :: (MonadTest m, HasCallStack) => [String] -> SomeException -> m a
+failExceptionWith messages (SomeException x) =
+ withFrozenCallStack
+ failWith Nothing $ unlines $ messages <> [
+ "━━━ Exception (" ++ show (typeOf x) ++ ") ━━━"
, List.dropWhileEnd Char.isSpace (displayException x)
]
@@ -541,33 +941,48 @@
else
withFrozenCallStack failure
-infix 4 ===
-
--- | Fails the test if the two arguments provided are not equal.
+-- | Fails the test and shows a git-like diff if the comparison operation
+-- evaluates to 'False' when applied to its arguments.
--
-(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
-(===) x y = do
- ok <- withFrozenCallStack $ eval (x == y)
+-- The comparison function is the second argument, which may be
+-- counter-intuitive to Haskell programmers. However, it allows operators to
+-- be written infix for easy reading:
+--
+-- @
+-- diff y (<) 87
+-- diff x (<=) 'r'
+-- @
+--
+-- This function behaves like the unix @diff@ tool, which gives a 0 exit
+-- code if the compared files are identical, or a 1 exit code code
+-- otherwise. Like unix @diff@, if the arguments fail the comparison, a
+-- /diff is shown.
+--
+diff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> (a -> b -> Bool) -> b -> m ()
+diff x op y = do
+ ok <- withFrozenCallStack $ eval (x `op` y)
if ok then
success
else
withFrozenCallStack $ failDiff x y
+infix 4 ===
+
+-- | Fails the test if the two arguments provided are not equal.
+--
+(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
+(===) x y =
+ withFrozenCallStack $
+ diff x (==) y
+
infix 4 /==
-- | Fails the test if the two arguments provided are equal.
--
(/==) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
-(/==) x y = do
- ok <- withFrozenCallStack $ eval (x /= y)
- if ok then
- success
- else
- withFrozenCallStack $
- failWith Nothing $ unlines [
- "━━━ Both equal to ━━━"
- , showPretty x
- ]
+(/==) x y =
+ withFrozenCallStack $
+ diff x (/=) y
-- | Fails the test if the value throws an exception when evaluated to weak
-- head normal form (WHNF).
@@ -576,6 +991,17 @@
eval x =
either (withFrozenCallStack failException) pure (tryEvaluate x)
+-- | Fails the test if the value throws an exception when evaluated to
+-- normal form (NF).
+--
+evalNF :: (MonadTest m, NFData a, HasCallStack) => a -> m a
+evalNF x =
+ let
+ messages =
+ ["━━━ Value could not be evaluated to normal form ━━━"]
+ in
+ either (withFrozenCallStack (failExceptionWith messages)) pure (tryEvaluate (rnf x)) $> x
+
-- | Fails the test if the action throws an exception.
--
-- /The benefit of using this over simply letting the exception bubble up is/
@@ -604,6 +1030,13 @@
Right x ->
pure x
+-- | Fails the test if the action throws an exception, or if the
+-- 'Either' is 'Left', otherwise returns the value in the 'Right'.
+--
+evalEitherM :: (MonadTest m, Show x, MonadCatch m, HasCallStack) => m (Either x a) -> m a
+evalEitherM =
+ withFrozenCallStack $ evalEither <=< evalM
+
-- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in
-- the 'Right'.
--
@@ -611,6 +1044,23 @@
evalExceptT m =
withFrozenCallStack evalEither =<< runExceptT m
+-- | Fails the test if the 'Maybe' is 'Nothing', otherwise returns the value in
+-- the 'Just'.
+--
+evalMaybe :: (MonadTest m, HasCallStack) => Maybe a -> m a
+evalMaybe = \case
+ Nothing ->
+ withFrozenCallStack $ failWith Nothing "the value was Nothing"
+ Just x ->
+ pure x
+
+-- | Fails the test if the action throws an exception, or if the
+-- 'Maybe' is 'Nothing', otherwise returns the value in the 'Just'.
+--
+evalMaybeM :: (MonadTest m, MonadCatch m, HasCallStack) => m (Maybe a) -> m a
+evalMaybeM =
+ withFrozenCallStack $ evalMaybe <=< evalM
+
------------------------------------------------------------------------
-- PropertyT
@@ -618,20 +1068,24 @@
lift =
PropertyT . lift . lift
+instance Monad m => MonadFail (PropertyT m) where
+ fail err =
+ PropertyT (Fail.fail err)
+
instance MFunctor PropertyT where
hoist f =
PropertyT . hoist (hoist f) . unPropertyT
-instance Distributive PropertyT where
+instance MonadTransDistributive PropertyT where
type Transformer t PropertyT m = (
Transformer t GenT m
, Transformer t TestT (GenT m)
)
- distribute =
+ distributeT =
hoist PropertyT .
- distribute .
- hoist distribute .
+ distributeT .
+ hoist distributeT .
unPropertyT
instance PrimMonad m => PrimMonad (PropertyT m) where
@@ -680,10 +1134,11 @@
--
forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a
forAllWith render gen =
- withFrozenCallStack $ forAllWithT render $ Gen.lift gen
+ withFrozenCallStack $ forAllWithT render $ Gen.generalize gen
-- | Generates a random input for the test by running the provided generator.
--
+--
forAllT :: (Monad m, Show a, HasCallStack) => GenT m a -> PropertyT m a
forAllT gen =
withFrozenCallStack $ forAllWithT showPretty gen
@@ -698,7 +1153,7 @@
--
discard :: Monad m => PropertyT m a
discard =
- PropertyT $ lift Gen.discard
+ PropertyT $ lift (Gen.generalize Gen.discard)
-- | Lift a test in to a property.
--
@@ -708,14 +1163,9 @@
-- instance at the expense of not being able to generate additional inputs
-- using 'forAll'.
--
--- One use case for this is writing tests which use 'ResourceT':
---
--- @
--- property $ do
--- n <- forAll $ Gen.int64 Range.linearBounded
--- test . runResourceT $ do
--- -- test with resource usage here
--- @
+-- An example where this is useful is parallel state machine testing, as
+-- 'Hedgehog.Internal.State.executeParallel' requires 'MonadBaseControl' 'IO'
+-- in order to be able to spawn threads in 'MonadTest'.
--
test :: Monad m => TestT m a -> PropertyT m a
test =
@@ -729,22 +1179,62 @@
defaultConfig :: PropertyConfig
defaultConfig =
PropertyConfig {
- propertyTestLimit =
- 100
- , propertyDiscardLimit =
+ propertyDiscardLimit =
100
, propertyShrinkLimit =
1000
, propertyShrinkRetries =
0
+ , propertyTerminationCriteria =
+ NoConfidenceTermination defaultMinTests
+ , propertySkip =
+ Nothing
}
+-- | The minimum amount of tests to run for a 'Property'
+--
+defaultMinTests :: TestLimit
+defaultMinTests = 100
+
+-- | The default confidence allows one false positive in 10^9 tests
+--
+defaultConfidence :: Confidence
+defaultConfidence = 10 ^ (9 :: Int)
+
-- | Map a config modification function over a property.
--
mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property
mapConfig f (Property cfg t) =
Property (f cfg) t
+-- | Make sure that the result is statistically significant in accordance to
+-- the passed 'Confidence'
+--
+withConfidence :: Confidence -> Property -> Property
+withConfidence c =
+ let
+ setConfidence = \case
+ NoEarlyTermination _ tests -> NoEarlyTermination c tests
+ NoConfidenceTermination tests -> NoEarlyTermination c tests
+ EarlyTermination _ tests -> EarlyTermination c tests
+ in
+ mapConfig $ \config@PropertyConfig{..} ->
+ config
+ { propertyTerminationCriteria =
+ setConfidence propertyTerminationCriteria
+ }
+
+verifiedTermination :: Property -> Property
+verifiedTermination =
+ mapConfig $ \config@PropertyConfig{..} ->
+ let
+ newTerminationCriteria = case propertyTerminationCriteria of
+ NoEarlyTermination c tests -> EarlyTermination c tests
+ NoConfidenceTermination tests -> EarlyTermination defaultConfidence tests
+ EarlyTermination c tests -> EarlyTermination c tests
+ in
+ config { propertyTerminationCriteria = newTerminationCriteria }
+
-- | Set the number of times a property should be executed before it is considered
-- successful.
--
@@ -754,7 +1244,14 @@
--
withTests :: TestLimit -> Property -> Property
withTests n =
- mapConfig $ \config -> config { propertyTestLimit = n }
+ let
+ setTestLimit tests = \case
+ NoEarlyTermination c _ -> NoEarlyTermination c tests
+ NoConfidenceTermination _ -> NoConfidenceTermination tests
+ EarlyTermination c _ -> EarlyTermination c tests
+ in
+ mapConfig $ \config@PropertyConfig{..} ->
+ config { propertyTerminationCriteria = setTestLimit n propertyTerminationCriteria }
-- | Set the number of times a property is allowed to discard before the test
-- runner gives up.
@@ -778,6 +1275,12 @@
withRetries n =
mapConfig $ \config -> config { propertyShrinkRetries = n }
+-- | Set the target that a property will skip to before it starts to run.
+--
+withSkip :: Skip -> Property -> Property
+withSkip s =
+ mapConfig $ \config -> config { propertySkip = Just s }
+
-- | Creates a property with the default configuration.
--
property :: HasCallStack => PropertyT IO () -> Property
@@ -786,15 +1289,219 @@
withFrozenCallStack (evalM m)
------------------------------------------------------------------------
--- FIXME Replace with DeriveLift when we drop 7.10 support.
+-- Coverage
-$(deriveLift ''GroupName)
-$(deriveLift ''PropertyName)
-$(deriveLift ''PropertyConfig)
-$(deriveLift ''TestLimit)
-$(deriveLift ''DiscardLimit)
-$(deriveLift ''ShrinkLimit)
-$(deriveLift ''ShrinkRetries)
+instance Semigroup Cover where
+ (<>) NoCover NoCover =
+ NoCover
+ (<>) _ _ =
+ Cover
+
+instance Monoid Cover where
+ mempty =
+ NoCover
+ mappend =
+ (<>)
+
+instance Semigroup CoverCount where
+ (<>) (CoverCount n0) (CoverCount n1) =
+ CoverCount (n0 + n1)
+
+instance Monoid CoverCount where
+ mempty =
+ CoverCount 0
+ mappend =
+ (<>)
+
+toCoverCount :: Cover -> CoverCount
+toCoverCount = \case
+ NoCover ->
+ CoverCount 0
+ Cover ->
+ CoverCount 1
+
+-- | This semigroup is right biased. The name, location and percentage from the
+-- rightmost `Label` will be kept. This shouldn't be a problem since the
+-- library doesn't allow setting multiple classes with the same 'ClassifierName'.
+instance Semigroup a => Semigroup (Label a) where
+ (<>) (MkLabel _ _ _ m0) (MkLabel name location percentage m1) =
+ MkLabel name location percentage (m0 <> m1)
+
+instance Semigroup a => Semigroup (Coverage a) where
+ (<>) (Coverage c0) (Coverage c1) =
+ Coverage $
+ Map.foldrWithKey (Map.insertWith (<>)) c0 c1
+
+instance (Semigroup a, Monoid a) => Monoid (Coverage a) where
+ mempty =
+ Coverage mempty
+ mappend =
+ (<>)
+
+coverPercentage :: TestCount -> CoverCount -> CoverPercentage
+coverPercentage (TestCount tests) (CoverCount count) =
+ let
+ percentage :: Double
+ percentage =
+ fromIntegral count / fromIntegral tests * 100
+
+ thousandths :: Int
+ thousandths =
+ round $ percentage * 10
+ in
+ CoverPercentage (fromIntegral thousandths / 10)
+
+labelCovered :: TestCount -> Label CoverCount -> Bool
+labelCovered tests (MkLabel _ _ minimum_ population) =
+ coverPercentage tests population >= minimum_
+
+-- | All labels are covered
+coverageSuccess :: TestCount -> Coverage CoverCount -> Bool
+coverageSuccess tests =
+ null . coverageFailures tests
+
+coverageFailures :: TestCount -> Coverage CoverCount -> [Label CoverCount]
+coverageFailures tests (Coverage kvs) =
+ List.filter (not . labelCovered tests) (Map.elems kvs)
+
+-- | Is true when the test coverage satisfies the specified 'Confidence'
+-- contstraint for all 'Coverage CoverCount's
+confidenceSuccess :: TestCount -> Confidence -> Coverage CoverCount -> Bool
+confidenceSuccess tests confidence =
+ let
+ assertLow :: Label CoverCount -> Bool
+ assertLow coverCount@MkLabel{..} =
+ fst (boundsForLabel tests confidence coverCount)
+ >= unCoverPercentage labelMinimum / 100.0
+ in
+ and . fmap assertLow . Map.elems . coverageLabels
+
+-- | Is true when there exists a label that is sure to have failed according to
+-- the 'Confidence' constraint
+confidenceFailure :: TestCount -> Confidence -> Coverage CoverCount -> Bool
+confidenceFailure tests confidence =
+ let
+ assertHigh :: Label CoverCount -> Bool
+ assertHigh coverCount@MkLabel{..} =
+ snd (boundsForLabel tests confidence coverCount)
+ < (unCoverPercentage labelMinimum / 100.0)
+ in
+ or . fmap assertHigh . Map.elems . coverageLabels
+
+boundsForLabel :: TestCount -> Confidence -> Label CoverCount -> (Double, Double)
+boundsForLabel tests confidence MkLabel{..} =
+ wilsonBounds
+ (fromIntegral $ unCoverCount labelAnnotation)
+ (fromIntegral tests)
+ (1 / fromIntegral (unConfidence confidence))
+
+-- In order to get an accurate measurement with small sample sizes, we're
+-- using the Wilson score interval
+-- () instead of a normal approximation interval.
+wilsonBounds :: Integer -> Integer -> Double -> (Double, Double)
+wilsonBounds positives count acceptance =
+ let
+ p =
+ fromRational $ positives % count
+ n =
+ fromIntegral count
+ z =
+ invnormcdf $ 1 - acceptance / 2
+
+ midpoint =
+ p + z * z / (2 * n)
+
+ offset =
+ z / (1 + z ** 2 / n) * sqrt (p * (1 - p) / n + z ** 2 / (4 * n ** 2))
+
+ denominator =
+ 1 + z * z / n
+
+ low =
+ (midpoint - offset) / denominator
+
+ high =
+ (midpoint + offset) / denominator
+ in
+ (low, high)
+
+fromLabel :: Label a -> Coverage a
+fromLabel x =
+ Coverage $
+ Map.singleton (labelName x) x
+
+unionsCoverage :: Semigroup a => [Coverage a] -> Coverage a
+unionsCoverage =
+ Coverage .
+ Map.unionsWith (<>) .
+ fmap coverageLabels
+
+journalCoverage :: Journal -> Coverage CoverCount
+journalCoverage (Journal logs) =
+ fmap toCoverCount .
+ unionsCoverage $ do
+ Label x <- logs
+ pure (fromLabel x)
+
+-- | Require a certain percentage of the tests to be covered by the
+-- classifier.
+--
+-- @
+-- prop_with_coverage :: Property
+-- prop_with_coverage =
+-- property $ do
+-- match <- forAll Gen.bool
+-- cover 30 \"True\" $ match
+-- cover 30 \"False\" $ not match
+-- @
+--
+-- The example above requires a minimum of 30% coverage for both
+-- classifiers. If these requirements are not met, it will fail the test.
+--
+cover :: (MonadTest m, HasCallStack) => CoverPercentage -> LabelName -> Bool -> m ()
+cover minimum_ name covered =
+ let
+ cover_ =
+ if covered then
+ Cover
+ else
+ NoCover
+ in
+ writeLog . Label $
+ MkLabel name (getCaller callStack) minimum_ cover_
+
+-- | Records the proportion of tests which satisfy a given condition.
+--
+-- @
+-- prop_with_classifier :: Property
+-- prop_with_classifier =
+-- property $ do
+-- xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha
+-- for_ xs $ \\x -> do
+-- classify "newborns" $ x == 0
+-- classify "children" $ x > 0 && x < 13
+-- classify "teens" $ x > 12 && x < 20
+-- @
+classify :: (MonadTest m, HasCallStack) => LabelName -> Bool -> m ()
+classify name covered =
+ withFrozenCallStack $
+ cover 0 name covered
+
+-- | Add a label for each test run. It produces a table showing the percentage
+-- of test runs that produced each label.
+--
+label :: (MonadTest m, HasCallStack) => LabelName -> m ()
+label name =
+ withFrozenCallStack $
+ cover 0 name True
+
+-- | Like 'label', but uses 'Show' to render its argument for display.
+--
+collect :: (MonadTest m, Show a, HasCallStack) => a -> m ()
+collect x =
+ withFrozenCallStack $
+ cover 0 (LabelName (show x)) True
------------------------------------------------------------------------
-- Internal
diff --git a/src/Hedgehog/Internal/Range.hs b/src/Hedgehog/Internal/Range.hs
--- a/src/Hedgehog/Internal/Range.hs
+++ b/src/Hedgehog/Internal/Range.hs
@@ -48,8 +48,9 @@
-- >>> 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.
+-- | Tests are parameterized by the size of the randomly-generated data. The
+-- meaning of a 'Size' value depends on the particular generator used, but
+-- it must always be a number between 0 and 99 inclusive.
--
newtype Size =
Size {
@@ -253,7 +254,7 @@
-- | Construct a range which scales the second bound relative to the size
-- parameter.
--
--- This works the same as 'linear', but for fractional values.
+-- /This works the same as 'linear', but for fractional values./
--
linearFrac :: (Fractional a, Ord a) => a -> a -> Range a
linearFrac x y =
@@ -261,7 +262,7 @@
-- | Construct a range which scales the bounds relative to the size parameter.
--
--- This works the same as 'linearFrom', but for fractional values.
+-- /This works the same as 'linearFrom', but for fractional values./
--
linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a
linearFracFrom z x y =
@@ -304,8 +305,14 @@
n =
toInteger n0
+ -- @rng@ has magnitude 1 bigger than the biggest diff
+ -- i.e. it specifies the range the diff can be in [0,rng)
+ -- with the upper bound being exclusive.
+ rng =
+ n - z + signum (n - z)
+
diff =
- ((n - z) * fromIntegral sz) `quot` 99
+ (rng * fromIntegral sz) `quot` 100
in
fromInteger $ z + diff
@@ -400,7 +407,7 @@
-- | 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.
+-- /This works the same as 'exponential', but for floating-point values./
--
-- >>> bounds 0 $ exponentialFloat 0 10
-- (0.0,0.0)
@@ -418,7 +425,7 @@
-- | Construct a range which scales the bounds exponentially relative to the
-- size parameter.
--
--- This works the same as 'exponentialFrom', but for floating-point values.
+-- /This works the same as 'exponentialFrom', but for floating-point values./
--
-- >>> bounds 0 $ exponentialFloatFrom 0 (-10) 20
-- (0.0,0.0)
diff --git a/src/Hedgehog/Internal/Region.hs b/src/Hedgehog/Internal/Region.hs
--- a/src/Hedgehog/Internal/Region.hs
+++ b/src/Hedgehog/Internal/Region.hs
@@ -14,7 +14,7 @@
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.Exception.Safe (MonadMask, bracket)
import Control.Monad.IO.Class (MonadIO(..))
import System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion(..))
diff --git a/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs
--- a/src/Hedgehog/Internal/Report.hs
+++ b/src/Hedgehog/Internal/Report.hs
@@ -6,8 +6,10 @@
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
+
module Hedgehog.Internal.Report (
-- * Report
Summary(..)
@@ -17,21 +19,24 @@
, FailureReport(..)
, FailedAnnotation(..)
- , ShrinkCount(..)
- , TestCount(..)
- , DiscardCount(..)
- , PropertyCount(..)
-
, Style(..)
, Markup(..)
+ , Config(..)
+ , defaultConfig
+ , Context(..)
+ , Lines
+ , PrintPrefixIcons(..)
+
, renderProgress
, renderResult
+ , renderResultWith
, renderSummary
, renderDoc
, ppProgress
, ppResult
+ , ppResultWith
, ppSummary
, fromResult
@@ -49,56 +54,43 @@
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe, catMaybes)
-import Data.Semigroup (Semigroup(..))
+#if !MIN_VERSION_base(4,11,0)
+import qualified Data.Semigroup as Semigroup
+#endif
+import Data.Traversable (for)
import Hedgehog.Internal.Config
import Hedgehog.Internal.Discovery (Pos(..), Position(..))
import qualified Hedgehog.Internal.Discovery as Discovery
+import Hedgehog.Internal.Prelude
+import Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..))
+import Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))
import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))
-import Hedgehog.Internal.Seed (Seed)
+import Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..))
+import Hedgehog.Internal.Property (TestCount(..), DiscardCount(..))
+import Hedgehog.Internal.Property (coverPercentage, coverageFailures)
+import Hedgehog.Internal.Property (labelCovered)
+import Hedgehog.Internal.Property (ShrinkPath(..), skipCompress)
+
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 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)
@@ -107,9 +99,9 @@
data FailureReport =
FailureReport {
- failureSize :: !Size
- , failureSeed :: !Seed
- , failureShrinks :: !ShrinkCount
+ failureShrinks :: !ShrinkCount
+ , failureShrinkPath :: !ShrinkPath
+ , failureCoverage :: !(Maybe (Coverage CoverCount))
, failureAnnotations :: ![FailedAnnotation]
, failureLocation :: !(Maybe Span)
, failureMessage :: !String
@@ -141,6 +133,8 @@
Report {
reportTests :: !TestCount
, reportDiscards :: !DiscardCount
+ , reportCoverage :: !(Coverage CoverCount)
+ , reportSeed :: !Seed
, reportStatus :: !a
} deriving (Show, Functor, Foldable, Traversable)
@@ -156,9 +150,14 @@
} deriving (Show)
instance Monoid Summary where
+#if !MIN_VERSION_base(4,11,0)
+ mappend = (Semigroup.<>)
+#endif
mempty =
Summary 0 0 0 0 0
- mappend (Summary x1 x2 x3 x4 x5) (Summary y1 y2 y3 y4 y5) =
+
+instance Semigroup Summary where
+ Summary x1 x2 x3 x4 x5 <> Summary y1 y2 y3 y4 y5 =
Summary
(x1 + y1)
(x2 + y2)
@@ -166,9 +165,6 @@
(x4 + y4)
(x5 + y5)
-instance Semigroup Summary where
- (<>) = mappend
-
-- | Construct a summary from a single result.
--
fromResult :: Result -> Summary
@@ -193,7 +189,7 @@
data Line a =
Line {
- _lineAnnotation :: !a
+ lineAnnotation :: !a
, lineNumber :: !LineNo
, _lineSource :: !String
} deriving (Eq, Ord, Show, Functor)
@@ -220,11 +216,14 @@
| ShrinkingIcon
| ShrinkingHeader
| FailedIcon
- | FailedHeader
+ | FailedText
| GaveUpIcon
- | GaveUpHeader
+ | GaveUpText
| SuccessIcon
- | SuccessHeader
+ | SuccessText
+ | CoverageIcon
+ | CoverageText
+ | CoverageFill
| DeclarationLocation
| StyledLineNo !Style
| StyledBorder !Style
@@ -276,15 +275,15 @@
Nothing
mkFailure ::
- Size
- -> Seed
- -> ShrinkCount
+ ShrinkCount
+ -> ShrinkPath
+ -> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
-mkFailure size seed shrinks location message diff logs =
+mkFailure shrinks shrinkPath mcoverage location message diff logs =
let
inputs =
mapMaybe takeAnnotation logs
@@ -292,7 +291,7 @@
footnotes =
mapMaybe takeFootnote logs
in
- FailureReport size seed shrinks inputs location message diff footnotes
+ FailureReport shrinks shrinkPath mcoverage inputs location message diff footnotes
------------------------------------------------------------------------
-- Pretty Printing
@@ -309,9 +308,10 @@
gutter m x =
markup m ">" <+> x
-icon :: Markup -> Char -> Doc Markup -> Doc Markup
-icon m i x =
- markup m (WL.char i) <+> x
+icon :: PrintPrefixIcons -> Markup -> Char -> Doc Markup -> Doc Markup
+icon p m i x = case p of
+ DisablePrefixIcons -> x
+ EnablePrefixIcons -> markup m (WL.char i) <+> x
ppTestCount :: TestCount -> Doc a
ppTestCount = \case
@@ -334,6 +334,18 @@
ShrinkCount n ->
ppShow n <+> "shrinks"
+-- | Render a compressed 'Skip'.
+--
+ppSkip :: Skip -> Doc a
+ppSkip =
+ WL.text . skipCompress
+
+-- | Render a compressed 'Skip', such that it can be read back in.
+--
+ppSkipReadable :: Skip -> Doc a
+ppSkipReadable =
+ WL.text . show . skipCompress
+
ppRawPropertyCount :: PropertyCount -> Doc a
ppRawPropertyCount (PropertyCount n) =
ppShow n
@@ -496,19 +508,19 @@
ppDiff :: Diff -> [Doc Markup]
ppDiff (Diff prefix removed infix_ added suffix diff) = [
markup DiffPrefix (WL.text prefix) <>
- markup DiffRemoved (WL.text removed) <+>
- markup DiffInfix (WL.text infix_) <+>
+ markup DiffRemoved (WL.text removed) <>
+ markup DiffInfix (WL.text infix_) <>
markup DiffAdded (WL.text added) <>
markup DiffSuffix (WL.text suffix)
] ++ fmap ppLineDiff (toLineDiff diff)
ppFailureLocation ::
MonadIO m
- => String
+ => [Doc Markup]
-> Maybe Diff
-> Span
-> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))
-ppFailureLocation msg mdiff sloc =
+ppFailureLocation msgs mdiff sloc =
runMaybeT $ do
decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc
(startCol, endCol) <- bimap fromIntegral fromIntegral <$> lastLineSpan sloc decl
@@ -523,7 +535,7 @@
markup FailureGutter (WL.text "│ ") <> x
msgDocs =
- fmap ((StyleFailure, ) . ppFailure . markup FailureMessage . WL.text) (List.lines msg)
+ fmap ((StyleFailure, ) . ppFailure . markup FailureMessage) msgs
diffDocs =
case mdiff of
@@ -550,9 +562,47 @@
pure $
mapSource (styleFailure . insertDoc) decl
+type Annotation = (Style, [(Style, Doc Markup)])
+
+newtype Lines = Lines Int
+ deriving (Eq, Num)
+
+instance Show Lines where
+ showsPrec p (Lines n) = showsPrec p n
+
+data Context = FullContext | Context Lines
+ deriving (Eq, Show)
+
+applyContext :: Context -> Declaration Annotation -> Declaration Annotation
+applyContext context decl = case context of
+ FullContext -> decl
+ Context n -> decl { declarationSource = limitContextTo n (declarationSource decl) }
+
+limitContextTo :: Lines -> Map LineNo (Line Annotation) -> Map LineNo (Line Annotation)
+limitContextTo (Lines context) =
+ let
+ skipBoring xs = case span isBoring xs of
+ (boring, []) -> take context boring
+ (boring, rest) -> takeEnd context boring <> keepInteresting rest
+
+ keepInteresting xs = case break isBoring xs of
+ (interesting, rest) -> interesting <> take context rest <> skipBoring rest
+
+ isBoring = isBoringAnnotation . lineAnnotation . snd
+ in
+ Map.fromList . skipBoring . Map.toList
+
+takeEnd :: Int -> [a] -> [a]
+takeEnd n = reverse . take n . reverse
+
+isBoringAnnotation :: Annotation -> Bool
+isBoringAnnotation = \ case
+ (StyleDefault, []) -> True
+ _ -> False
+
ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup
-ppDeclaration decl =
- case Map.maxView $ declarationSource decl of
+ppDeclaration decl = let source = declarationSource decl in
+ case Map.maxView source of
Nothing ->
mempty
Just (lastLine, _) ->
@@ -569,34 +619,49 @@
ppLineNo =
WL.text . printf ("%" <> show digits <> "d") . unLineNo
+ ppEmptyNo :: Doc a
ppEmptyNo =
WL.text $ replicate digits ' '
+ ppSource :: Style -> LineNo -> String -> Doc Markup
ppSource style n src =
+ (if isOmittedLine (pred n) then addVerticalEllipsis else id) $
markup (StyledLineNo style) (ppLineNo n) <+>
markup (StyledBorder style) "┃" <+>
markup (StyledSource style) (WL.text src)
+ addVerticalEllipsis =
+ (verticalEllipsis <#>)
+
+ verticalEllipsis =
+ "\x22ee"
+
+ isOmittedLine n =
+ n >= firstLine && Map.notMember n source
+
+ firstLine =
+ fst $ Map.findMin source
+
ppAnnot (style, doc) =
markup (StyledLineNo style) ppEmptyNo <+>
markup (StyledBorder style) "┃" <+>
doc
ppLines = do
- Line (style, xs) n src <- Map.elems $ declarationSource decl
+ Line (style, xs) n src <- Map.elems source
ppSource style n src : fmap ppAnnot xs
in
WL.vsep (ppLocation : ppLines)
-ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup
-ppReproduce name size seed =
+ppReproduce :: Maybe PropertyName -> Seed -> Skip -> Doc Markup
+ppReproduce name seed skip =
WL.vsep [
markup ReproduceHeader
"This failure can be reproduced by running:"
, gutter ReproduceGutter . markup ReproduceSource $
- "recheck" <+>
- WL.text (showsPrec 11 size "") <+>
+ "recheckAt" <+>
WL.text (showsPrec 11 seed "") <+>
+ ppSkipReadable skip <+>
maybe "" (WL.text . unPropertyName) name
]
@@ -619,35 +684,65 @@
ppTextLines =
fmap WL.text . List.lines
-ppFailureReport :: MonadIO m => Maybe PropertyName -> FailureReport -> m (Doc Markup)
-ppFailureReport name (FailureReport size seed _ inputs0 mlocation0 msg mdiff msgs0) = do
- (msgs, mlocation) <-
+ppFailureReport :: MonadIO m => Config -> Maybe PropertyName -> TestCount -> DiscardCount -> Seed -> FailureReport -> m [Doc Markup]
+ppFailureReport config name tests discards seed (FailureReport _ shrinkPath mcoverage inputs0 mlocation0 msg mdiff msgs0) = do
+ let
+ basic =
+ -- Move the failure message to the end section if we have
+ -- no source location or can't find the source file.
+ let
+ msgs1 =
+ msgs0 ++
+ (if null msg then [] else [msg])
+
+ docs =
+ concatMap ppTextLines msgs1 ++
+ maybe [] ppDiff mdiff
+ in
+ (docs, Nothing)
+
+ (msgs1, 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])
+ return basic
- docs =
- concatMap ppTextLines msgs1 ++
- maybe [] ppDiff mdiff
- in
- pure (docs, Nothing)
+ Just location0 -> do
+ mAdvanced <-
+ ppFailureLocation (fmap WL.text $ List.lines msg) mdiff location0
+ case mAdvanced of
+ Just advanced ->
+ return (concatMap ppTextLines msgs0, Just advanced)
+ Nothing ->
+ return basic
- Just location0 ->
- (concatMap ppTextLines msgs0,)
- <$> ppFailureLocation msg mdiff location0
+ coverageLocations <-
+ case mcoverage of
+ Nothing ->
+ pure []
+ Just coverage ->
+ for (coverageFailures tests coverage) $ \(MkLabel _ mclocation _ count) ->
+ case mclocation of
+ Nothing ->
+ pure Nothing
+ Just clocation ->
+ let
+ coverageMsg =
+ WL.cat [
+ "Failed ("
+ , WL.annotate CoverageText $
+ ppCoverPercentage (coverPercentage tests count) <> " coverage"
+ , ")"
+ ]
+ in
+ ppFailureLocation [coverageMsg] Nothing clocation
- (args, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0
+ (args, idecls) <- fmap partitionEithers $ zipWithM ppFailedInput [0..] inputs0
let
+ decls :: [Declaration (Style, [(Style, Doc Markup)])]
decls =
- mergeDeclarations .
- catMaybes $
- mlocation : fmap pure idecls
+ mergeDeclarations $
+ catMaybes (mlocation : coverageLocations) <> idecls
with xs f =
if null xs then
@@ -655,75 +750,382 @@
else
[f xs]
- pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [
+ whenSome f xs =
+ if null xs then
+ xs
+ else
+ f xs
+
+ bottom = case mcoverage of
+ Nothing | configPrintReproduceMessage config ->
+ [ppReproduce name seed (SkipToShrink tests discards shrinkPath)]
+ _ ->
+ []
+
+ pure .
+ whenSome (mempty :) .
+ whenSome (++ [mempty]) .
+ WL.punctuate WL.line .
+ fmap (WL.vsep . fmap (indentBy $ configPrintPrefixIcons config)) .
+ fmap (id :: [Doc Markup] -> [Doc Markup]) .
+ List.filter (not . null) $
+ concat [
with args $
- WL.vsep . WL.punctuate WL.line
+ WL.punctuate WL.line
, with decls $
- WL.vsep . WL.punctuate WL.line . fmap ppDeclaration
- , with msgs $
- WL.vsep
- , [ppReproduce name size seed]
+ WL.punctuate WL.line . fmap (ppDeclaration . applyContext (configContext config))
+ , with msgs1 $
+ id
+ , with bottom $
+ id
]
+indentBy :: PrintPrefixIcons -> Doc a -> Doc a
+indentBy = \case
+ DisablePrefixIcons ->
+ id
+ EnablePrefixIcons ->
+ WL.indent 2
+
ppName :: Maybe PropertyName -> Doc a
ppName = \case
Nothing ->
- ""
+ "" <> WL.space
+ Just "" ->
+ mempty
Just (PropertyName name) ->
- WL.text name
+ WL.text name <> WL.space
ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)
-ppProgress name (Report tests discards status) =
+ppProgress name (Report tests discards coverage _ status) =
case status of
Running ->
- pure . icon RunningIcon '●' . WL.annotate RunningHeader $
- ppName name <+>
- "passed" <+>
- ppTestCount tests <>
- ppWithDiscardCount discards <+>
- "(running)"
+ pure . WL.vsep $ [
+ icon EnablePrefixIcons RunningIcon '●' . WL.annotate RunningHeader $
+ ppName name <>
+ "passed" <+>
+ ppTestCount tests <>
+ ppWithDiscardCount discards <+>
+ "(running)"
+ ] ++
+ ppCoverage EnablePrefixIcons tests coverage
Shrinking failure ->
- pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $
- ppName name <+>
- "failed after" <+>
+ pure . icon EnablePrefixIcons ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $
+ ppName name <>
+ "failed" <+> ppFailedAtLocation (failureLocation failure) <#>
+ "after" <+>
ppTestCount tests <>
ppShrinkDiscard (failureShrinks failure) discards <+>
"(shrinking)"
ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)
-ppResult name (Report tests discards result) =
+ppResult = ppResultWith defaultConfig
+
+ppResultWith :: MonadIO m => Config -> Maybe PropertyName -> Report Result -> m (Doc Markup)
+ppResultWith config name (Report tests discards coverage seed result) = do
case result of
Failed failure -> do
- pfailure <- ppFailureReport name failure
+ pfailure <- ppFailureReport config name tests discards seed failure
pure . WL.vsep $ [
- icon FailedIcon '✗' . WL.annotate FailedHeader $
- ppName name <+>
- "failed after" <+>
+ icon (configPrintPrefixIcons config) FailedIcon '✗' . WL.align . WL.annotate FailedText $
+ ppName name <>
+ (
+ if configPrintFailedAtLocation config then
+ "failed" <+> ppFailedAtLocation (failureLocation failure) <#> "after"
+ else
+ "failed after"
+ ) <+>
ppTestCount tests <>
ppShrinkDiscard (failureShrinks failure) discards <>
- "."
- , mempty
- , pfailure
- , mempty
- ]
+ "." <>
+ (
+ if configPrintShrinkPath config then
+ WL.line <>
+ "shrink path:" <+>
+ ppSkip (SkipToShrink tests discards $ failureShrinkPath failure)
+ else
+ mempty
+ )
+ ] ++
+ ppCoverage (configPrintPrefixIcons config) tests coverage ++
+ pfailure
GaveUp ->
- pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $
- ppName name <+>
- "gave up after" <+>
- ppDiscardCount discards <>
- ", passed" <+>
- ppTestCount tests <>
- "."
+ pure . WL.vsep $ [
+ icon (configPrintPrefixIcons config) GaveUpIcon '⚐' . WL.annotate GaveUpText $
+ ppName name <>
+ "gave up after" <+>
+ ppDiscardCount discards <>
+ ", passed" <+>
+ ppTestCount tests <>
+ "."
+ ] ++
+ ppCoverage (configPrintPrefixIcons config) tests coverage
OK ->
- pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $
- ppName name <+>
- "passed" <+>
- ppTestCount tests <>
- "."
+ pure . WL.vsep $ [
+ icon (configPrintPrefixIcons config) SuccessIcon '✓' . WL.annotate SuccessText $
+ ppName name <>
+ "passed" <+>
+ ppTestCount tests <>
+ "."
+ ] ++
+ ppCoverage (configPrintPrefixIcons config) tests coverage
+ppFailedAtLocation :: Maybe Span -> Doc Markup
+ppFailedAtLocation = \case
+ Just x ->
+ "at" <+>
+ WL.text (spanFile x) <> ":" <>
+ WL.pretty (unLineNo (spanStartLine x)) <> ":" <>
+ WL.pretty (unColumnNo (spanStartColumn x))
+ Nothing ->
+ mempty
+
+ppCoverage :: PrintPrefixIcons -> TestCount -> Coverage CoverCount -> [Doc Markup]
+ppCoverage icons tests x =
+ if Map.null (coverageLabels x) then
+ mempty
+ else
+ fmap (ppLabel icons tests (coverageWidth tests x)) .
+ List.sortOn labelLocation $
+ Map.elems (coverageLabels x)
+
+data ColumnWidth =
+ ColumnWidth {
+ widthPercentage :: !Int
+ , widthMinimum :: !Int
+ , widthName :: !Int
+ , _widthNameFail :: !Int
+ }
+
+instance Semigroup ColumnWidth where
+ (<>) (ColumnWidth p0 m0 n0 f0) (ColumnWidth p1 m1 n1 f1) =
+ ColumnWidth
+ (max p0 p1)
+ (max m0 m1)
+ (max n0 n1)
+ (max f0 f1)
+
+instance Monoid ColumnWidth where
+ mempty =
+ ColumnWidth 0 0 0 0
+ mappend =
+ (<>)
+
+coverageWidth :: TestCount -> Coverage CoverCount -> ColumnWidth
+coverageWidth tests (Coverage labels) =
+ foldMap (labelWidth tests) labels
+
+labelWidth :: TestCount -> Label CoverCount -> ColumnWidth
+labelWidth tests x =
+ let
+ percentage =
+ length .
+ renderCoverPercentage .
+ coverPercentage tests $
+ labelAnnotation x
+
+ minimum_ =
+ if labelMinimum x == 0 then
+ 0
+ else
+ length .
+ renderCoverPercentage $
+ labelMinimum x
+
+ name =
+ length .
+ unLabelName $
+ labelName x
+
+ nameFail =
+ if labelCovered tests x then
+ 0
+ else
+ name
+ in
+ ColumnWidth percentage minimum_ name nameFail
+
+ppLeftPad :: Int -> Doc a -> Doc a
+ppLeftPad n doc =
+ let
+ ndoc =
+ length (show doc)
+
+ pad =
+ WL.text $
+ List.replicate (n - ndoc) ' '
+ in
+ pad <> doc
+
+ppLabel :: PrintPrefixIcons -> TestCount -> ColumnWidth -> Label CoverCount -> Doc Markup
+ppLabel icons tests w x@(MkLabel name _ minimum_ count) =
+ let
+ covered =
+ labelCovered tests x
+
+ ltext =
+ if not covered then
+ WL.annotate CoverageText
+ else
+ id
+
+ lborder =
+ WL.annotate (StyledBorder StyleDefault)
+
+ licon = case icons of
+ DisablePrefixIcons ->
+ mempty
+ EnablePrefixIcons ->
+ if not covered then
+ WL.annotate CoverageText "⚠ "
+ else
+ " "
+
+ lname =
+ WL.fill (widthName w) (ppLabelName name)
+
+ wminimum =
+ ppLeftPad (widthMinimum w) $
+ ppCoverPercentage minimum_
+
+ wcover i =
+ ppLeftPad (widthPercentage w + length i) $
+ WL.text i <>
+ ppCoverPercentage (coverPercentage tests count)
+
+ lminimum =
+ if widthMinimum w == 0 then
+ mempty
+ else if not covered then
+ " ✗ " <> wminimum
+ else if minimum_ == 0 then
+ " " <> ppLeftPad (widthMinimum w) ""
+ else
+ " ✓ " <> wminimum
+
+ lcover =
+ if widthMinimum w == 0 then
+ wcover ""
+ else if not covered then
+ wcover ""
+ else if minimum_ == 0 then
+ wcover ""
+ else
+ wcover ""
+ in
+ WL.hcat [
+ licon
+ , ltext lname
+ , lborder " "
+ , ltext lcover
+ , lborder " "
+ , ltext $ ppCoverBar (coverPercentage tests count) minimum_
+ , lborder "" -- "│"
+ , ltext lminimum
+ ]
+
+ppLabelName :: LabelName -> Doc a
+ppLabelName (LabelName name) =
+ WL.text name
+
+ppCoverPercentage :: CoverPercentage -> Doc Markup
+ppCoverPercentage =
+ WL.text . renderCoverPercentage
+
+ppCoverBar :: CoverPercentage -> CoverPercentage -> Doc Markup
+ppCoverBar (CoverPercentage percentage) (CoverPercentage minimum_) =
+ let
+ barWidth :: Int
+ barWidth =
+ 20
+
+ coverageRatio :: Double
+ coverageRatio =
+ percentage / 100.0
+
+ coverageWidth_ :: Int
+ coverageWidth_ =
+ floor $
+ coverageRatio * fromIntegral barWidth
+
+ minimumRatio :: Double
+ minimumRatio =
+ minimum_ / 100.0
+
+ minimumWidth :: Int
+ minimumWidth =
+ floor $
+ minimumRatio * fromIntegral barWidth
+
+ index :: [a] -> Int
+ index xs =
+ floor $
+ ((coverageRatio * fromIntegral barWidth) - fromIntegral coverageWidth_) *
+ fromIntegral (length xs)
+
+ part xs =
+ xs !! index xs
+
+ fillWidth =
+ barWidth - coverageWidth_ - 1
+
+ fillErrorWidth =
+ max 0 (minimumWidth - coverageWidth_ - 1)
+
+ fillSurplusWidth =
+ fillWidth - fillErrorWidth
+
+ bar :: (Char, [Char]) -> Doc Markup
+ bar (full, parts) =
+ WL.hcat [
+ WL.text $ replicate coverageWidth_ full
+ , if fillWidth >= 0 then
+ if index parts == 0 then
+ if fillErrorWidth > 0 then
+ WL.annotate FailedText $ WL.text [part parts]
+ else
+ WL.annotate CoverageFill $ WL.text [part parts]
+ else
+ WL.text [part parts]
+ else
+ ""
+ , WL.annotate FailedText . WL.text $
+ replicate fillErrorWidth (head parts)
+ , WL.annotate CoverageFill . WL.text $
+ replicate fillSurplusWidth (head parts)
+ --
+ -- Uncomment when debugging:
+ --
+ -- , WL.annotate CoverageFill . WL.text $
+ -- " " ++ show barWidth
+ -- ++ " " ++ show coverageWidth_
+ -- ++ " " ++ show minimumWidth
+ -- ++ " " ++ "/"
+ -- ++ " " ++ show fillErrorWidth
+ -- ++ " " ++ "+"
+ -- ++ " " ++ show fillSurplusWidth
+ -- ++ " " ++ "="
+ -- ++ " " ++ show fillWidth
+ ]
+ in
+ bar ('█', ['·', '▏', '▎', '▍', '▌', '▋', '▊', '▉'])
+
+ -- FIXME Maybe this should be configurable?
+ -- Alternative histogram bars:
+ --bar ('⣿', ['·', '⡀', '⡄', '⡆', '⡇', '⣇', '⣧', '⣷'])
+ --bar ('⣿', ['⢕', '⡀', '⣀', '⣄', '⣤', '⣦', '⣶', '⣷'])
+ --bar ('⣿', ['⢕', '⡵', '⢗', '⣗', '⣟'])
+ --bar ('⣿', [' ', '⡵', '⢗', '⣗', '⣟'])
+ --bar ('█', ['░','▓'])
+ --bar ('█', ['░'])
+
+renderCoverPercentage :: CoverPercentage -> String
+renderCoverPercentage (CoverPercentage percentage) =
+ printf "%.0f" percentage <> "%"
+
ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)
ppWhenNonZero suffix n =
if n <= 0 then
@@ -734,13 +1136,13 @@
annotateSummary :: Summary -> Doc Markup -> Doc Markup
annotateSummary summary =
if summaryFailed summary > 0 then
- icon FailedIcon '✗' . WL.annotate FailedHeader
+ icon EnablePrefixIcons FailedIcon '✗' . WL.annotate FailedText
else if summaryGaveUp summary > 0 then
- icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader
+ icon EnablePrefixIcons GaveUpIcon '⚐' . WL.annotate GaveUpText
else if summaryWaiting summary > 0 || summaryRunning summary > 0 then
- icon WaitingIcon '○' . WL.annotate WaitingHeader
+ icon EnablePrefixIcons WaitingIcon '○' . WL.annotate WaitingHeader
else
- icon SuccessIcon '✓' . WL.annotate SuccessHeader
+ icon EnablePrefixIcons SuccessIcon '✓' . WL.annotate SuccessText
ppSummary :: MonadIO m => Summary -> m (Doc Markup)
ppSummary summary =
@@ -784,8 +1186,8 @@
Nothing
]
-renderDoc :: MonadIO m => Maybe UseColor -> Doc Markup -> m String
-renderDoc mcolor doc = do
+renderDoc :: MonadIO m => UseColor -> Doc Markup -> m String
+renderDoc color doc = do
let
dull =
SetColor Foreground Dull
@@ -811,16 +1213,22 @@
setSGRCode [vivid Red]
FailedIcon ->
setSGRCode [vivid Red]
- FailedHeader ->
+ FailedText ->
setSGRCode [vivid Red]
GaveUpIcon ->
setSGRCode [dull Yellow]
- GaveUpHeader ->
+ GaveUpText ->
setSGRCode [dull Yellow]
SuccessIcon ->
setSGRCode [dull Green]
- SuccessHeader ->
+ SuccessText ->
setSGRCode [dull Green]
+ CoverageIcon ->
+ setSGRCode [dull Yellow]
+ CoverageText ->
+ setSGRCode [dull Yellow]
+ CoverageFill ->
+ setSGRCode [vivid Black]
DeclarationLocation ->
setSGRCode []
@@ -879,8 +1287,6 @@
end _ =
setSGRCode [Reset]
- color <- resolveColor mcolor
-
let
display =
case color of
@@ -894,19 +1300,44 @@
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
+renderProgress :: MonadIO m => UseColor -> Maybe PropertyName -> Report Progress -> m String
+renderProgress color name x =
+ renderDoc color =<< ppProgress name x
-renderResult :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Result -> m String
-renderResult mcolor name x =
- renderDoc mcolor =<< ppResult name x
+renderResult :: MonadIO m => UseColor -> Maybe PropertyName -> Report Result -> m String
+renderResult = renderResultWith defaultConfig
-renderSummary :: MonadIO m => Maybe UseColor -> Summary -> m String
-renderSummary mcolor x =
- renderDoc mcolor =<< ppSummary x
+data Config =
+ Config {
+ configContext :: Context
+ , configPrintFailedAtLocation :: Bool
+ , configPrintShrinkPath :: Bool
+ , configPrintReproduceMessage :: Bool
+ , configPrintPrefixIcons :: PrintPrefixIcons
+ } deriving (Eq, Show)
+
+-- | Whether to add icons to the start of important output lines or not.
+--
+data PrintPrefixIcons =
+ DisablePrefixIcons
+ -- ^ Do not add icons to the start of important output lines.
+ | EnablePrefixIcons
+ -- ^ Add icons to the start of important output lines.
+ deriving (Eq, Show)
+
+defaultConfig :: Config
+defaultConfig = Config FullContext True True True EnablePrefixIcons
+
+renderResultWith :: MonadIO m => Config -> UseColor -> Maybe PropertyName -> Report Result -> m String
+renderResultWith config color name x =
+ renderDoc color =<< ppResultWith config name x
+
+renderSummary :: MonadIO m => UseColor -> Summary -> m String
+renderSummary color x =
+ renderDoc color =<< ppSummary x
diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs
--- a/src/Hedgehog/Internal/Runner.hs
+++ b/src/Hedgehog/Internal/Runner.hs
@@ -1,15 +1,19 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
+
module Hedgehog.Internal.Runner (
-- * Running Individual Properties
check
, recheck
+ , recheckAt
-- * Running Groups of Properties
, RunnerConfig(..)
@@ -25,26 +29,33 @@
import Control.Concurrent.STM (TVar, atomically)
import qualified Control.Concurrent.STM.TVar as TVar
-import Control.Monad.Catch (MonadCatch(..), catchAll)
+import Control.Exception.Safe (MonadCatch, catchAny)
import Control.Monad.IO.Class (MonadIO(..))
-
-import Data.Semigroup ((<>))
+import Data.Maybe (isJust)
import Hedgehog.Internal.Config
-import Hedgehog.Internal.Gen (runGenT, runDiscardEffect)
+import Hedgehog.Internal.Gen (evalGenT)
+import Hedgehog.Internal.Prelude
+import Hedgehog.Internal.Property (DiscardCount(..), ShrinkCount(..))
import Hedgehog.Internal.Property (Group(..), GroupName(..))
+import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..))
import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..))
-import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests)
-import Hedgehog.Internal.Property (PropertyT(..), Log(..), Failure(..), runTestT)
+import Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT)
+import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests, withSkip)
+import Hedgehog.Internal.Property (TerminationCriteria(..))
+import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..))
+import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure)
+import Hedgehog.Internal.Property (coverageSuccess, journalCoverage)
+import Hedgehog.Internal.Property (defaultMinTests)
+import Hedgehog.Internal.Property (ShrinkPath(..))
import Hedgehog.Internal.Queue
import Hedgehog.Internal.Region
import Hedgehog.Internal.Report
-import Hedgehog.Internal.Seed (Seed)
import qualified Hedgehog.Internal.Seed as Seed
-import Hedgehog.Internal.Tree (Tree(..), Node(..))
+import Hedgehog.Internal.Tree (TreeT(..), NodeT(..))
import Hedgehog.Range (Size)
-import Language.Haskell.TH.Lift (deriveLift)
+import Language.Haskell.TH.Syntax (Lift)
#if mingw32_HOST_OS
import System.IO (hSetEncoding, stdout, stderr, utf8)
@@ -62,10 +73,13 @@
-- the environment.
, runnerColor :: !(Maybe UseColor)
+ -- | The seed to use. 'Nothing' means detect from the environment.
+ , runnerSeed :: !(Maybe Seed)
+
-- | How verbose to be in the runner output. 'Nothing' means detect from
-- the environment.
, runnerVerbosity :: !(Maybe Verbosity)
- } deriving (Eq, Ord, Show)
+ } deriving (Eq, Ord, Show, Lift)
findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b
findM xs0 def p =
@@ -80,24 +94,24 @@
Just x ->
return x
-isFailure :: Node m (Maybe (Either x a, b)) -> Bool
+isFailure :: NodeT m (Maybe (Either x a, b)) -> Bool
isFailure = \case
- Node (Just (Left _, _)) _ ->
+ NodeT (Just (Left _, _)) _ ->
True
_ ->
False
-isSuccess :: Node m (Maybe (Either x a, b)) -> Bool
+isSuccess :: NodeT m (Maybe (Either x a, b)) -> Bool
isSuccess =
not . isFailure
runTreeN ::
Monad m
=> ShrinkRetries
- -> Tree m (Maybe (Either x a, b))
- -> m (Node m (Maybe (Either x a, b)))
+ -> TreeT m (Maybe (Either x a, b))
+ -> m (NodeT m (Maybe (Either x a, b)))
runTreeN n m = do
- o <- runTree m
+ o <- runTreeT m
if n > 0 && isSuccess o then
runTreeN (n - 1) m
else
@@ -105,41 +119,89 @@
takeSmallest ::
MonadIO m
- => Size
- -> Seed
- -> ShrinkCount
+ => ShrinkCount
+ -> ShrinkPath
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
- -> Node m (Maybe (Either Failure (), [Log]))
+ -> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
-takeSmallest size seed shrinks slimit retries updateUI = \case
- Node Nothing _ ->
- pure GaveUp
+takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI =
+ let
+ loop shrinks revShrinkPath = \case
+ NodeT 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)
+ NodeT (Just (x, (Journal logs))) xs ->
+ case x of
+ Left (Failure loc err mdiff) -> do
+ let
+ shrinkPath =
+ ShrinkPath $ reverse revShrinkPath
+ failure =
+ mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse logs)
- updateUI $ Shrinking failure
+ 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
+ if shrinks >= fromIntegral slimit then
+ -- if we've hit the shrink limit, don't shrink any further
+ pure $ Failed failure
else
- return Nothing
+ findM (zip [0..] xs) (Failed failure) $ \(n, m) -> do
+ o <- runTreeN retries m
+ if isFailure o then
+ Just <$> loop (shrinks + 1) (n : revShrinkPath) o
+ else
+ return Nothing
- Right () ->
- return OK
+ Right () ->
+ return OK
+ in
+ loop shrinks0 (reverse shrinkPath0)
+-- | Follow a given shrink path, instead of searching exhaustively. Assume that
+-- the end of the path is minimal, and don't try to shrink any further than
+-- that.
+--
+-- This evaluates the test for all the shrinks on the path, but not ones
+-- off-path. Because the generator is mixed with the test code, it's probably
+-- not possible to avoid this.
+skipToShrink ::
+ MonadIO m
+ => ShrinkPath
+ -> (Progress -> m ())
+ -> NodeT m (Maybe (Either Failure (), Journal))
+ -> m Result
+skipToShrink (ShrinkPath shrinkPath) updateUI =
+ let
+ loop shrinks [] = \case
+ NodeT Nothing _ ->
+ pure GaveUp
+
+ NodeT (Just (x, (Journal logs))) _ ->
+ case x of
+ Left (Failure loc err mdiff) -> do
+ let
+ failure =
+ mkFailure shrinks (ShrinkPath shrinkPath) Nothing loc err mdiff (reverse logs)
+
+ updateUI $ Shrinking failure
+ pure $ Failed failure
+
+ Right () ->
+ return OK
+
+ loop shrinks (s0:ss) = \case
+ NodeT _ xs ->
+ case drop s0 xs of
+ [] ->
+ pure GaveUp
+ (x:_) -> do
+ o <- runTreeT x
+ loop (shrinks + 1) ss o
+ in
+ loop 0 shrinkPath
+
checkReport ::
forall m.
MonadIO m
@@ -150,77 +212,192 @@
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
-checkReport cfg size0 seed0 test0 updateUI =
+checkReport cfg size0 seed0 test0 updateUI = do
+ skip <- liftIO $ resolveSkip $ propertySkip cfg
+
let
+ (mSkipToTest, mSkipToShrink) =
+ case skip of
+ SkipNothing ->
+ (Nothing, Nothing)
+ SkipToTest t d ->
+ (Just (t, d), Nothing)
+ SkipToShrink t d s ->
+ (Just (t, d), Just s)
+
test =
- catchAll test0 (fail . show)
+ catchAny test0 (fail . show)
- loop :: TestCount -> DiscardCount -> Size -> Seed -> m (Report Result)
- loop !tests !discards !size !seed = do
- updateUI $ Report tests discards Running
+ terminationCriteria =
+ propertyTerminationCriteria cfg
+ (confidence, minTests) =
+ case terminationCriteria of
+ EarlyTermination c t -> (Just c, t)
+ NoEarlyTermination c t -> (Just c, t)
+ NoConfidenceTermination t -> (Nothing, t)
+
+ successVerified count coverage =
+ count `mod` 100 == 0 &&
+ -- If the user wants a statistically significant result, this function
+ -- will run a confidence check. Otherwise, it will default to checking
+ -- the percentage of encountered labels
+ maybe False (\c -> confidenceSuccess count c coverage) confidence
+
+ failureVerified count coverage =
+ -- Will be true if we can statistically verify that our coverage was
+ -- inadequate.
+ -- Testing only on 100s to minimise repeated measurement statistical
+ -- errors.
+ count `mod` 100 == 0 &&
+ maybe False (\c -> confidenceFailure count c coverage) confidence
+
+ loop ::
+ TestCount
+ -> DiscardCount
+ -> Size
+ -> Seed
+ -> Coverage CoverCount
+ -> m (Report Result)
+ loop !tests !discards !size !seed !coverage0 = do
+ updateUI $ Report tests discards coverage0 seed0 Running
+
+ let
+ coverageReached =
+ successVerified tests coverage0
+
+ coverageUnreachable =
+ failureVerified tests coverage0
+
+ enoughTestsRun =
+ case terminationCriteria of
+ EarlyTermination _ _ ->
+ tests >= fromIntegral defaultMinTests &&
+ (coverageReached || coverageUnreachable)
+ NoEarlyTermination _ _ ->
+ tests >= fromIntegral minTests
+ NoConfidenceTermination _ ->
+ tests >= fromIntegral minTests
+
+ labelsCovered =
+ coverageSuccess tests coverage0
+
+ successReport =
+ Report tests discards coverage0 seed0 OK
+
+ failureReport message =
+ Report tests discards coverage0 seed0 . Failed $ mkFailure
+ 0
+ (ShrinkPath [])
+ (Just coverage0)
+ Nothing
+ message
+ Nothing
+ []
+
+ confidenceReport =
+ if coverageReached && labelsCovered then
+ successReport
+ else
+ failureReport $
+ "Test coverage cannot be reached after " <> show tests <> " tests"
+
if size > 99 then
-- size has reached limit, reset to 0
- loop tests discards 0 seed
+ loop tests discards 0 seed coverage0
- else if tests >= fromIntegral (propertyTestLimit cfg) then
- -- we've hit the test limit, test was successful
- pure $ Report tests discards OK
+ else if enoughTestsRun then
+ -- at this point, we know that enough tests have been run in order to
+ -- make a decision on if this was a successful run or not
+ --
+ -- If we have early termination, then we need to check coverageReached /
+ -- coverageUnreachable. If we skip tests, we ignore coverage.
+ if isJust mSkipToTest then
+ pure successReport
+ else
+ pure $ case terminationCriteria of
+ EarlyTermination _ _ -> confidenceReport
+ NoEarlyTermination _ _ -> confidenceReport
+ NoConfidenceTermination _ ->
+ if labelsCovered then
+ successReport
+ else
+ failureReport $
+ "Labels not sufficiently covered after " <> show tests <> " tests"
else if discards >= fromIntegral (propertyDiscardLimit cfg) then
-- we've hit the discard limit, give up
- pure $ Report tests discards GaveUp
+ pure $ Report tests discards coverage0 seed0 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
+ (s0, s1) -> case (mSkipToTest, mSkipToShrink) of
+ -- If the report says failed "after 32 tests", the test number that
+ -- failed was 31, but we want the user to be able to skip to 32 and
+ -- start with the one that failed.
+ (Just (n, d), _)
+ | n > tests + 1 ->
+ loop (tests + 1) discards (size + 1) s1 coverage0
+ | d > discards ->
+ loop tests (discards + 1) (size + 1) s1 coverage0
+ (Just _, Just shrinkPath) -> do
+ node <-
+ runTreeT . evalGenT size s0 . runTestT $ unPropertyT test
+ let
+ mkReport =
+ Report (tests + 1) discards coverage0 seed0
+ mkReport <$> skipToShrink shrinkPath (updateUI . mkReport) node
+ _ -> do
+ node@(NodeT x _) <-
+ runTreeT . evalGenT size s0 . runTestT $ unPropertyT test
+ case x of
+ Nothing ->
+ loop tests (discards + 1) (size + 1) s1 coverage0
- Just (Left _, _) ->
- let
- mkReport =
- Report (tests + 1) discards
- in
- fmap mkReport $
- takeSmallest
- size
- seed
- 0
- (propertyShrinkLimit cfg)
- (propertyShrinkRetries cfg)
- (updateUI . mkReport)
- node
+ Just (Left _, _) ->
+ let
+ mkReport =
+ Report (tests + 1) discards coverage0 seed0
+ in
+ fmap mkReport $
+ takeSmallest
+ 0
+ (ShrinkPath [])
+ (propertyShrinkLimit cfg)
+ (propertyShrinkRetries cfg)
+ (updateUI . mkReport)
+ node
- Just (Right (), _) ->
- loop (tests + 1) discards (size + 1) s1
- in
- loop 0 0 size0 seed0
+ Just (Right (), journal) ->
+ let
+ coverage =
+ journalCoverage journal <> coverage0
+ in
+ loop (tests + 1) discards (size + 1) s1 coverage
+ loop 0 0 size0 seed0 mempty
+
checkRegion ::
MonadIO m
=> Region
- -> Maybe UseColor
+ -> UseColor
-> Maybe PropertyName
-> Size
-> Seed
-> Property
-> m (Report Result)
-checkRegion region mcolor name size seed prop =
+checkRegion region color name size seed prop =
liftIO $ do
result <-
checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do
- ppprogress <- renderProgress mcolor name progress
+ ppprogress <- renderProgress color name progress
case reportStatus progress of
Running ->
setRegion region ppprogress
Shrinking _ ->
openRegion region ppprogress
- ppresult <- renderResult mcolor name result
+ ppresult <- renderResult color name result
case reportStatus result of
Failed _ ->
openRegion region ppresult
@@ -234,30 +411,41 @@
checkNamed ::
MonadIO m
=> Region
- -> Maybe UseColor
+ -> UseColor
-> Maybe PropertyName
+ -> Maybe Seed
-> Property
-> m (Report Result)
-checkNamed region mcolor name prop = do
- seed <- liftIO Seed.random
- checkRegion region mcolor name 0 seed prop
+checkNamed region color name mseed prop = do
+ seed <- resolveSeed mseed
+ checkRegion region color name 0 seed prop
-- | Check a property.
--
check :: MonadIO m => Property -> m Bool
-check prop =
+check prop = do
+ color <- detectColor
liftIO . displayRegion $ \region ->
- (== OK) . reportStatus <$> checkNamed region Nothing Nothing prop
+ (== OK) . reportStatus <$> checkNamed region color Nothing Nothing prop
-- | Check a property using a specific size and seed.
--
recheck :: MonadIO m => Size -> Seed -> Property -> m ()
recheck size seed prop0 = do
+ color <- detectColor
let prop = withTests 1 prop0
_ <- liftIO . displayRegion $ \region ->
- checkRegion region Nothing Nothing size seed prop
+ checkRegion region color Nothing size seed prop
pure ()
+recheckAt :: MonadIO m => Seed -> Skip -> Property -> m ()
+recheckAt seed skip prop0 = do
+ color <- detectColor
+ let prop = withSkip skip prop0
+ _ <- liftIO . displayRegion $ \region ->
+ checkRegion region color Nothing 0 seed prop
+ pure ()
+
-- | Check a group of properties using the specified runner config.
--
checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool
@@ -273,34 +461,38 @@
hSetEncoding stdout utf8
hSetEncoding stderr utf8
#endif
+
putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━"
+ seed <- resolveSeed (runnerSeed config)
verbosity <- resolveVerbosity (runnerVerbosity config)
- summary <- checkGroupWith n verbosity (runnerColor config) props
+ color <- resolveColor (runnerColor config)
+ summary <- checkGroupWith n verbosity color seed props
pure $
summaryFailed summary == 0 &&
summaryGaveUp summary == 0
-updateSummary :: Region -> TVar Summary -> Maybe UseColor -> (Summary -> Summary) -> IO ()
-updateSummary sregion svar mcolor f = do
+updateSummary :: Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO ()
+updateSummary sregion svar color f = do
summary <- atomically (TVar.modifyTVar' svar f >> TVar.readTVar svar)
- setRegion sregion =<< renderSummary mcolor summary
+ setRegion sregion =<< renderSummary color summary
checkGroupWith ::
WorkerCount
-> Verbosity
- -> Maybe UseColor
+ -> UseColor
+ -> Seed
-> [(PropertyName, Property)]
-> IO Summary
-checkGroupWith n verbosity mcolor props =
+checkGroupWith n verbosity color seed 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 {
+ updateSummary sregion svar color $ \x -> x {
summaryWaiting =
PropertyCount tasks
, summaryRunning =
@@ -320,7 +512,7 @@
pure (name, prop, region)
finish (_name, _prop, _region) =
- updateSummary sregion svar mcolor $ \x -> x {
+ updateSummary sregion svar color $ \x -> x {
summaryRunning =
summaryRunning x - 1
}
@@ -331,12 +523,12 @@
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
+ result <- checkNamed region color (Just name) (Just seed) prop
+ updateSummary sregion svar color
(<> fromResult (reportStatus result))
pure result
- updateSummary sregion svar mcolor (const summary)
+ updateSummary sregion svar color (const summary)
pure summary
-- | Check a group of properties sequentially.
@@ -364,6 +556,8 @@
Just 1
, runnerColor =
Nothing
+ , runnerSeed =
+ Nothing
, runnerVerbosity =
Nothing
}
@@ -398,11 +592,8 @@
Nothing
, runnerColor =
Nothing
+ , runnerSeed =
+ Nothing
, runnerVerbosity =
Nothing
}
-
-------------------------------------------------------------------------
--- FIXME Replace with DeriveLift when we drop 7.10 support.
-
-$(deriveLift ''RunnerConfig)
diff --git a/src/Hedgehog/Internal/Seed.hs b/src/Hedgehog/Internal/Seed.hs
--- a/src/Hedgehog/Internal/Seed.hs
+++ b/src/Hedgehog/Internal/Seed.hs
@@ -1,5 +1,6 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveLift #-}
-- |
-- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele
-- et. al. [1].
@@ -45,6 +46,7 @@
, mix64variant13
, mix32
, mixGamma
+ , global
) where
import Control.Monad.IO.Class (MonadIO(..))
@@ -61,6 +63,8 @@
import qualified Data.IORef as IORef
import Data.Word (Word32, Word64)
+import Language.Haskell.TH.Syntax (Lift)
+
import System.IO.Unsafe (unsafePerformIO)
import System.Random (RandomGen)
import qualified System.Random as Random
@@ -71,7 +75,7 @@
Seed {
seedValue :: !Word64
, seedGamma :: !Word64 -- ^ must be an odd number
- } deriving (Eq, Ord)
+ } deriving (Eq, Ord, Lift)
instance Show Seed where
showsPrec p (Seed v g) =
diff --git a/src/Hedgehog/Internal/Shrink.hs b/src/Hedgehog/Internal/Shrink.hs
--- a/src/Hedgehog/Internal/Shrink.hs
+++ b/src/Hedgehog/Internal/Shrink.hs
@@ -27,6 +27,9 @@
towards destination x =
if destination == x then
[]
+ -- special case for 1-bit numbers
+ else if destination == 0 && x == 1 then
+ [0]
else
let
-- Halve the operands before subtracting them so they don't overflow.
diff --git a/src/Hedgehog/Internal/Source.hs b/src/Hedgehog/Internal/Source.hs
--- a/src/Hedgehog/Internal/Source.hs
+++ b/src/Hedgehog/Internal/Source.hs
@@ -1,6 +1,5 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
@@ -18,13 +17,10 @@
, withFrozenCallStack
) where
-#if MIN_VERSION_base(4,9,0)
import GHC.Stack (CallStack, HasCallStack, SrcLoc(..))
import GHC.Stack (callStack, getCallStack, withFrozenCallStack)
-#else
-import GHC.Exts (Constraint)
-#endif
+
newtype LineNo =
LineNo {
unLineNo :: Int
@@ -44,25 +40,7 @@
, spanEndColumn :: !ColumnNo
} deriving (Eq, Ord)
-#if !MIN_VERSION_base(4,9,0)
-type family HasCallStack :: Constraint where
- HasCallStack = ()
-
-data CallStack =
- CallStack
- deriving (Show)
-
-callStack :: HasCallStack => CallStack
-callStack =
- CallStack
-
-withFrozenCallStack :: HasCallStack => (HasCallStack => a) -> a
-withFrozenCallStack x =
- x
-#endif
-
getCaller :: CallStack -> Maybe Span
-#if MIN_VERSION_base(4,9,0)
getCaller stack =
case getCallStack stack of
[] ->
@@ -74,10 +52,6 @@
(fromIntegral $ srcLocStartCol x)
(fromIntegral $ srcLocEndLine x)
(fromIntegral $ srcLocEndCol x)
-#else
-getCaller _ =
- Nothing
-#endif
------------------------------------------------------------------------
-- Show instances
diff --git a/src/Hedgehog/Internal/State.hs b/src/Hedgehog/Internal/State.hs
--- a/src/Hedgehog/Internal/State.hs
+++ b/src/Hedgehog/Internal/State.hs
@@ -1,5 +1,4 @@
{-# OPTIONS_HADDOCK not-home #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
@@ -36,7 +35,6 @@
-- * Commands
, Command(..)
, Callback(..)
- , commandGenOK
-- * Actions
, Action(..)
@@ -53,30 +51,31 @@
) where
import qualified Control.Concurrent.Async.Lifted as Async
+import Control.Exception.Safe (MonadCatch)
import Control.Monad (foldM, foldM_)
-import Control.Monad.Catch (MonadCatch)
import Control.Monad.State.Class (MonadState, get, put, modify)
+import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.State (State, runState, execState)
-import Control.Monad.Trans.State (StateT(..), evalStateT)
+import Control.Monad.Trans.State (StateT(..), evalStateT, runStateT)
import Data.Dynamic (Dynamic, toDyn, fromDynamic, dynTypeRep)
import Data.Foldable (traverse_)
import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..))
-#if MIN_VERSION_transformers(0,5,0)
import Data.Functor.Classes (eq1, compare1, showsPrec1)
-#endif
+import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import Data.Typeable (Typeable, TypeRep, Proxy(..), typeRep)
-import Hedgehog.Internal.Gen (MonadGen)
+import Hedgehog.Internal.Barbie (FunctorB(..), TraversableB(..))
+import Hedgehog.Internal.Distributive (distributeT)
+import Hedgehog.Internal.Gen (MonadGen, GenT, GenBase)
import qualified Hedgehog.Internal.Gen as Gen
-import Hedgehog.Internal.HTraversable (HTraversable(..))
import Hedgehog.Internal.Opaque (Opaque(..))
-import Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith)
+import Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith, annotate)
import Hedgehog.Internal.Range (Range)
import Hedgehog.Internal.Show (showPretty)
import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
@@ -92,8 +91,18 @@
showsPrec p (Name x) =
showsPrec p x
--- | Symbolic values.
+-- | Symbolic values: Because hedgehog generates actions in a separate phase
+-- before execution, you will sometimes need to refer to the result of a
+-- previous action in a generator without knowing the value of the result
+-- (e.g., to get the ID of a previously-created user).
--
+-- Symbolic variables provide a token to stand in for the actual variables at
+-- generation time (and in 'Require'/'Update' callbacks). At execution time,
+-- real values are available, so your execute actions work on 'Concrete'
+-- variables.
+--
+-- See also: 'Command', 'Var'
+--
data Symbolic a where
Symbolic :: Typeable a => Name -> Symbolic a
@@ -104,7 +113,6 @@
showsPrec p (Symbolic x) =
showsPrec p x
-#if MIN_VERSION_transformers(0,5,0)
instance Show1 Symbolic where
liftShowsPrec _ _ p (Symbolic x) =
showsPrec p x
@@ -116,21 +124,11 @@
instance Ord1 Symbolic where
liftCompare _ (Symbolic x) (Symbolic y) =
compare x y
-#else
-instance Show1 Symbolic where
- showsPrec1 p (Symbolic x) =
- showsPrec p x
-instance Eq1 Symbolic where
- eq1 (Symbolic x) (Symbolic y) =
- x == y
-
-instance Ord1 Symbolic where
- compare1 (Symbolic x) (Symbolic y) =
- compare x y
-#endif
-
--- | Concrete values.
+-- | Concrete values: At test-execution time, 'Symbolic' values from generation
+-- are replaced with 'Concrete' values from performing actions. This type
+-- gives us something of the same kind as 'Symbolic' to pass as a type
+-- argument to 'Var'.
--
newtype Concrete a where
Concrete :: a -> Concrete a
@@ -140,7 +138,6 @@
showsPrec =
showsPrec1
-#if MIN_VERSION_transformers(0,5,0)
instance Show1 Concrete where
liftShowsPrec sp _ p (Concrete x) =
sp p x
@@ -152,20 +149,7 @@
instance Ord1 Concrete where
liftCompare comp (Concrete x) (Concrete y) =
comp x y
-#else
-instance Show1 Concrete where
- showsPrec1 p (Concrete x) =
- showsPrec p x
-instance Eq1 Concrete where
- eq1 (Concrete x) (Concrete y) =
- x == y
-
-instance Ord1 Concrete where
- compare1 (Concrete x) (Concrete y) =
- compare x y
-#endif
-
------------------------------------------------------------------------
-- | Variables are the potential or actual result of executing an action. They
@@ -185,7 +169,10 @@
-- type of variable because it is used in both the generation and the
-- execution phase.
--
-data Var a v =
+-- The order of arguments makes 'Var' 'FunctorB' and 'TraversableB', which is
+-- how 'Symbolic' values are turned into 'Concrete' ones.
+--
+newtype Var a v =
Var (v a)
-- | Take the value from a concrete variable.
@@ -214,8 +201,12 @@
showString "Var " .
showsPrec1 11 x
-instance HTraversable (Var a) where
- htraverse f (Var v) =
+instance FunctorB (Var a) where
+ bmap f (Var v) =
+ Var (f v)
+
+instance TraversableB (Var a) where
+ btraverse f (Var v) =
fmap Var (f v)
------------------------------------------------------------------------
@@ -241,6 +232,10 @@
emptyEnvironment =
Environment Map.empty
+unionsEnvironment :: [Environment] -> Environment
+unionsEnvironment =
+ Environment . Map.unions . fmap unEnvironment
+
-- | Insert a symbolic / concrete pairing in to the environment.
--
insertConcrete :: Symbolic a -> Concrete a -> Environment -> Environment
@@ -270,9 +265,9 @@
-- | Convert a symbolic structure to a concrete one, using the provided environment.
--
-reify :: HTraversable t => Environment -> t Symbolic -> Either EnvironmentError (t Concrete)
+reify :: TraversableB t => Environment -> t Symbolic -> Either EnvironmentError (t Concrete)
reify vars =
- htraverse (reifyEnvironment vars)
+ btraverse (reifyEnvironment vars)
------------------------------------------------------------------------
-- Callbacks
@@ -375,18 +370,24 @@
------------------------------------------------------------------------
--- | The specification for the expected behaviour of an 'Action'.
+-- | The specification for the expected behaviour of an
+-- 'Action'. These are used to generate sequences of actions to test.
--
-data Command n m (state :: (* -> *) -> *) =
+-- This is the main type you will use when writing state machine
+-- tests. @gen@ is usually an instance of 'MonadGen', and @m@ is usually
+-- an instance of 'MonadTest'. These constraints appear when you pass
+-- your 'Command' list to 'sequential' or 'parallel'.
+--
+data Command gen m (state :: (Type -> Type) -> Type) =
forall input output.
- (HTraversable input, Show (input Symbolic), Typeable output) =>
+ (TraversableB input, Show (input Symbolic), Show output, Typeable output) =>
Command {
-- | A generator which provides random arguments for a command. If the
-- command cannot be executed in the current state, it should return
-- 'Nothing'.
--
commandGen ::
- state Symbolic -> Maybe (n (input Symbolic))
+ state Symbolic -> Maybe (gen (input Symbolic))
-- | Executes a command using the arguments generated by 'commandGen'.
--
@@ -400,18 +401,33 @@
[Callback input output state]
}
--- | Checks that input for a command can be executed in the given state.
+
+-- | An actionable command is a command that can generate an action given
+-- the current symbolic state, that is, its @commandGen@ returns @Just@.
--
-commandGenOK :: Command n m state -> state Symbolic -> Bool
-commandGenOK (Command inputGen _ _) state =
- Maybe.isJust (inputGen state)
+-- This is an internal type required to hold on to the existential
+-- types when building actions.
+--
+data Actionable gen m (state :: (Type -> Type) -> Type) =
+ forall input output.
+ (TraversableB input, Show (input Symbolic), Show output, Typeable output) =>
+ Actionable {
+ _actionableGen ::
+ gen (input Symbolic)
+ , _actionableExecute ::
+ input Concrete -> m output
+
+ , _actionableCallbacks ::
+ [Callback input output state]
+ }
+
-- | An instantiation of a 'Command' which can be executed, and its effect
-- evaluated.
--
-data Action m (state :: (* -> *) -> *) =
+data Action m (state :: (Type -> Type) -> Type) =
forall input output.
- (HTraversable input, Show (input Symbolic)) =>
+ (TraversableB input, Show (input Symbolic), Show output) =>
Action {
actionInput ::
input Symbolic
@@ -459,19 +475,19 @@
-- | 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 :: forall t. TraversableB 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
+ flip execState Map.empty $ btraverse 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 :: TraversableB t => t Symbolic -> Map Name TypeRep -> Bool
variablesOK xs allowed =
let
vars =
@@ -536,29 +552,31 @@
-- | Generates a single action from a set of possible commands.
--
action ::
- (MonadGen n, MonadTest m)
- => [Command n m state]
- -> StateT (Context state) n (Action m state)
+ (MonadGen gen, MonadTest m)
+ => [Command gen m state]
+ -> GenT (StateT (Context state) (GenBase gen)) (Action m state)
action commands =
- Gen.just $ do
+ Gen.justT $ do
Context state0 _ <- get
- Command mgenInput exec callbacks <-
- Gen.element $ filter (\c -> commandGenOK c state0) commands
+ Actionable genInput exec callbacks <-
+ Gen.element_
+ [ Actionable gen exec callbacks
+ | Command inputGen exec callbacks <- commands
+ , Just gen <- [inputGen state0]
+ ]
- input <-
- case mgenInput state0 of
- Nothing ->
- error "genCommand: internal error, tried to use generator with invalid state."
- Just g ->
- lift g
+ -- If we shrink the input, we still want to use the same output. Otherwise
+ -- any actions using this output as part of their input will be dropped. But
+ -- the existing output is still in the context, so `contextNewVar` will
+ -- create a new one. To avoid that, we generate the output before the input.
+ output <- contextNewVar
+ input <- hoist lift $ Gen.toGenT genInput
if not $ callbackRequire callbacks state0 input then
pure Nothing
else do
- output <- contextNewVar
-
contextUpdate $
callbackUpdate callbacks state0 input (Var output)
@@ -569,19 +587,19 @@
(callbackEnsure callbacks)
genActions ::
- (MonadGen n, MonadTest m)
+ (MonadGen gen, MonadTest m)
=> Range Int
- -> [Command n m state]
+ -> [Command gen m state]
-> Context state
- -> n ([Action m state], Context state)
+ -> gen ([Action m state], Context state)
genActions range commands ctx = do
- xs <- Gen.list range (action commands) `evalStateT` ctx
+ xs <- Gen.fromGenT . (`evalStateT` ctx) . distributeT $ Gen.list range (action commands)
pure $
dropInvalid xs `runState` ctx
-- | A sequence of actions to execute.
--
-data Sequential m state =
+newtype Sequential m state =
Sequential {
-- | The sequence of actions.
sequentialActions :: [Action m state]
@@ -603,6 +621,33 @@
(prefix0 ++ x) :
fmap (prefix ++) xs
+renderActionResult :: Environment -> Action m state -> [String]
+renderActionResult env (Action _ output@(Symbolic (Name name)) _ _ _ _) =
+ let
+ prefix0 =
+ "Var " ++ show name ++ " = "
+
+ prefix =
+ replicate (length prefix0) ' '
+
+ unfound = \case
+ EnvironmentValueNotFound _
+ -> "<>"
+ EnvironmentTypeError _ _
+ -> "<>"
+
+ actual =
+ either unfound showPretty
+ $ reifyEnvironment env output
+
+ in
+ case lines actual of
+ [] ->
+ [prefix0 ++ "?"]
+ x : xs ->
+ (prefix0 ++ x) :
+ fmap (prefix ++) xs
+
-- FIXME we should not abuse Show to get nice output for actions
instance Show (Sequential m state) where
show (Sequential xs) =
@@ -611,13 +656,13 @@
-- | Generates a sequence of actions from an initial model state and set of commands.
--
sequential ::
- (MonadGen n, MonadTest m)
+ (MonadGen gen, MonadTest m)
=> Range Int
-> (forall v. state v)
- -> [Command n m state]
- -> n (Sequential m state)
+ -> [Command gen m state]
+ -> gen (Sequential m state)
sequential range initial commands =
- fmap (Sequential . fst) $
+ Sequential . fst <$>
genActions range commands (mkContext initial)
-- | A sequential prefix of actions to execute, with two branches to execute in parallel.
@@ -636,27 +681,32 @@
-- FIXME we should not abuse Show to get nice output for actions
instance Show (Parallel m state) where
- show (Parallel pre xs ys) =
- unlines $ concat [
- ["━━━ Prefix ━━━"]
- , (concatMap renderAction pre)
- , ["", "━━━ Branch 1 ━━━"]
- , (concatMap renderAction xs)
- , ["", "━━━ Branch 2 ━━━"]
- , (concatMap renderAction ys)
- ]
+ show =
+ renderParallel renderAction
+renderParallel :: (Action m state -> [String]) -> Parallel m state -> String
+renderParallel render (Parallel pre xs ys) =
+ unlines $ concat [
+ ["━━━ Prefix ━━━"]
+ , concatMap render pre
+ , ["", "━━━ Branch 1 ━━━"]
+ , concatMap render xs
+ , ["", "━━━ Branch 2 ━━━"]
+ , concatMap render ys
+ ]
+
+
-- | Given the initial model state and set of commands, generates prefix
-- actions to be run sequentially, followed by two branches to be run in
-- parallel.
--
parallel ::
- (MonadGen n, MonadTest m)
+ (MonadGen gen, MonadTest m)
=> Range Int
-> Range Int
-> (forall v. state v)
- -> [Command n m state]
- -> n (Parallel m state)
+ -> [Command gen m state]
+ -> gen (Parallel m state)
parallel prefixN parallelN initial commands = do
(prefix, ctx0) <- genActions prefixN commands (mkContext initial)
(branch1, ctx1) <- genActions parallelN commands ctx0
@@ -770,9 +820,8 @@
withFrozenCallStack $
let
ok =
- any successful .
- fmap (checkActions initial) $
- interleave branch1 branch2
+ any (successful . checkActions initial) $
+ interleave branch1 branch2
in
if ok then
pure ()
@@ -792,13 +841,17 @@
=> (forall v. state v)
-> Parallel m state
-> m ()
-executeParallel initial (Parallel prefix branch1 branch2) =
+executeParallel initial p@(Parallel prefix branch1 branch2) =
withFrozenCallStack $ evalM $ do
(s0, env0) <- foldM executeUpdateEnsure (initial, emptyEnvironment) prefix
- (xs, ys) <-
+ ((xs, env1), (ys, env2)) <-
Async.concurrently
- (evalStateT (traverse execute branch1) env0)
- (evalStateT (traverse execute branch2) env0)
+ (runStateT (traverse execute branch1) env0)
+ (runStateT (traverse execute branch2) env0)
+ let
+ env = unionsEnvironment [env0, env1, env2]
+
+ annotate $ renderParallel (renderActionResult env) p
linearize s0 xs ys
diff --git a/src/Hedgehog/Internal/TH.hs b/src/Hedgehog/Internal/TH.hs
--- a/src/Hedgehog/Internal/TH.hs
+++ b/src/Hedgehog/Internal/TH.hs
@@ -1,9 +1,11 @@
{-# OPTIONS_HADDOCK not-home #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Hedgehog.Internal.TH (
TExpQ
, discover
+ , discoverPrefix
) where
import qualified Data.List as List
@@ -13,20 +15,42 @@
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)
+import Language.Haskell.TH (Exp(..), Q, location, runIO
+#if MIN_VERSION_template_haskell(2,17,0)
+ , CodeQ, joinCode, unTypeCode, unsafeCodeCoerce
+#endif
+ )
+import Language.Haskell.TH.Syntax (Loc(..), mkName
+#if !MIN_VERSION_template_haskell(2,17,0)
+ , TExp, unsafeTExpCoerce, unTypeQ
+#endif
+ )
-type TExpQ a =
- Q (TExp a)
+#if MIN_VERSION_template_haskell(2,17,0)
+type TExpQ a = CodeQ a
+#else
+-- Originally `Code` is a more polymorphic newtype wrapper, but for this module
+-- we can get away with just making it a type alias.
+type TExpQ a = Q (TExp a)
+joinCode :: Q (TExpQ a) -> TExpQ a
+joinCode = (>>= id)
+unsafeCodeCoerce :: Q Exp -> TExpQ a
+unsafeCodeCoerce = unsafeTExpCoerce
+unTypeCode :: TExpQ a -> Q Exp
+unTypeCode = unTypeQ
+#endif
-- | Discover all the properties in a module.
--
-- Functions starting with `prop_` are assumed to be properties.
--
discover :: TExpQ Group
-discover = do
+discover = discoverPrefix "prop_"
+
+discoverPrefix :: String -> TExpQ Group
+discoverPrefix prefix = joinCode $ do
file <- getCurrentFile
- properties <- Map.toList <$> runIO (readProperties file)
+ properties <- Map.toList <$> runIO (readProperties prefix file)
let
startLine =
@@ -40,24 +64,24 @@
fmap (mkNamedProperty . fst) $
List.sortBy startLine properties
- [|| Group $$(moduleName) $$(listTE names) ||]
+ return [|| Group $$(moduleName) $$(listTE names) ||]
mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property)
-mkNamedProperty name = do
+mkNamedProperty name =
[|| (name, $$(unsafeProperty name)) ||]
unsafeProperty :: PropertyName -> TExpQ Property
unsafeProperty =
- unsafeTExpCoerce . pure . VarE . mkName . unPropertyName
+ unsafeCodeCoerce . pure . VarE . mkName . unPropertyName
listTE :: [TExpQ a] -> TExpQ [a]
-listTE xs = do
- unsafeTExpCoerce . pure . ListE =<< traverse unTypeQ xs
+listTE xs =
+ unsafeCodeCoerce $ pure . ListE =<< traverse unTypeCode xs
moduleName :: TExpQ GroupName
-moduleName = do
+moduleName = joinCode $ do
loc <- GroupName . loc_module <$> location
- [|| loc ||]
+ return [|| loc ||]
getCurrentFile :: Q FilePath
getCurrentFile =
diff --git a/src/Hedgehog/Internal/Tree.hs b/src/Hedgehog/Internal/Tree.hs
--- a/src/Hedgehog/Internal/Tree.hs
+++ b/src/Hedgehog/Internal/Tree.hs
@@ -1,16 +1,32 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- MonadBase
+#if __GLASGOW_HASKELL__ < 802
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+#endif
module Hedgehog.Internal.Tree (
- Tree(..)
- , Node(..)
+ Tree
+ , pattern Tree
+ , TreeT(..)
+ , runTree
+ , mapTreeT
+ , treeValue
+ , treeChildren
- , fromNode
+ , Node
+ , pattern Node
+ , NodeT(..)
+ , fromNodeT
, unfold
, unfoldForest
@@ -18,228 +34,549 @@
, expand
, prune
+ , catMaybes
+ , filter
+ , mapMaybe
+ , filterMaybeT
+ , mapMaybeMaybeT
+ , filterT
+ , consChild
+ , mapMaybeT
+ , depth
+ , interleave
+
, render
+ , renderT
) where
+#if !MIN_VERSION_base(4,18,0)
+import Control.Applicative (liftA2)
+#endif
import Control.Applicative (Alternative(..))
-import Control.Monad (MonadPlus(..), ap, join)
+import Control.Exception.Safe (Exception)
+import Control.Monad (MonadPlus(..), guard, join)
import Control.Monad.Base (MonadBase(..))
-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception)
+import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch))
+import Control.Monad.Trans.Control ()
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Morph (MFunctor(..), MMonad(..))
+import Control.Monad.Morph (MFunctor(..), MMonad(..), generalize)
import Control.Monad.Primitive (PrimMonad(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Resource (MonadResource(..))
import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Zip (MonadZip(..))
-#if MIN_VERSION_base(4,9,0)
+import Data.Functor.Identity (Identity(..))
+import Data.Functor.Classes (Eq1(..))
import Data.Functor.Classes (Show1(..), showsPrec1)
import Data.Functor.Classes (showsUnaryWith, showsBinaryWith)
-#endif
+import qualified Data.List as List
+import qualified Data.Maybe as Maybe
import Hedgehog.Internal.Distributive
+import Control.Monad.Trans.Control (MonadBaseControl (..))
+import Prelude hiding (filter)
+
------------------------------------------------------------------------
+-- | A rose tree.
+--
+type Tree =
+ TreeT Identity
+
+-- | Pattern to ease construction / deconstruction of pure trees.
+--
+pattern Tree :: NodeT Identity a -> Tree a
+pattern Tree node =
+ TreeT (Identity node)
+#if __GLASGOW_HASKELL__ >= 802
+{-# COMPLETE Tree #-}
+#endif
+
-- | An effectful tree, each node in the tree can have an effect before it is
-- produced.
--
-newtype Tree m a =
- Tree {
- runTree :: m (Node m a)
+newtype TreeT m a =
+ TreeT {
+ runTreeT :: m (NodeT m a)
}
+instance MonadBaseControl b m => MonadBaseControl b (TreeT m) where
+ type StM (TreeT m) a = StM m (NodeT m a)
+ liftBaseWith f = TreeT $ liftBaseWith (\g -> pure <$> f (g . runTreeT))
+ restoreM = TreeT . restoreM
+
+-- | A node in a rose tree.
+--
+type Node =
+ NodeT Identity
+#if __GLASGOW_HASKELL__ >= 802
+{-# COMPLETE Node #-}
+#endif
+
+-- | Pattern to ease construction / deconstruction of pure nodes.
+--
+pattern Node :: a -> [Tree a] -> Node a
+pattern Node x xs =
+ NodeT x xs
+
-- | A node in an effectful tree, as well as its unevaluated children.
--
-data Node m a =
- Node {
+data NodeT m a =
+ NodeT {
+ -- | The value at this 'NodeT' in the 'TreeT'.
nodeValue :: a
- , nodeChildren :: [Tree m a]
- }
--- | Create a 'Tree' from a 'Node'
+ -- | The children of this 'NodeT'.
+ , nodeChildren :: [TreeT m a]
+ } deriving (Eq)
+
+-- | Extracts the 'Node' from a 'Tree'.
--
-fromNode :: Applicative m => Node m a -> Tree m a
-fromNode =
- Tree . pure
+runTree :: Tree a -> Node a
+runTree =
+ runIdentity . runTreeT
+-- | Map between 'TreeT' computations.
+--
+mapTreeT :: (m (NodeT m a) -> m (NodeT m a)) -> TreeT m a -> TreeT m a
+mapTreeT f =
+ TreeT . f . runTreeT
+
+-- | Create a 'TreeT' from a 'NodeT'
+--
+fromNodeT :: Applicative m => NodeT m a -> TreeT m a
+fromNodeT =
+ TreeT . pure
+
+-- | The value at the root of the 'Tree'.
+--
+treeValue :: Tree a -> a
+treeValue =
+ nodeValue . runTree
+
+-- | The children of the 'Tree'.
+--
+treeChildren :: Tree a -> [Tree a]
+treeChildren =
+ nodeChildren . runTree
+
-- | Create a tree from a value and an unfolding function.
--
-unfold :: Monad m => (a -> [a]) -> a -> Tree m a
+unfold :: Monad m => (a -> [a]) -> a -> TreeT m a
unfold f x =
- Tree . pure $
- Node x (unfoldForest f x)
+ TreeT . pure $
+ NodeT x (unfoldForest f x)
-- | Create a forest from a value and an unfolding function.
--
-unfoldForest :: Monad m => (a -> [a]) -> a -> [Tree m a]
+unfoldForest :: Monad m => (a -> [a]) -> a -> [TreeT m a]
unfoldForest f =
fmap (unfold f) . f
-- | Expand a tree using an unfolding function.
--
-expand :: Monad m => (a -> [a]) -> Tree m a -> Tree m a
+expand :: Monad m => (a -> [a]) -> TreeT m a -> TreeT m a
expand f m =
- Tree $ do
- Node x xs <- runTree m
- pure . Node x $
+ TreeT $ do
+ NodeT x xs <- runTreeT m
+ pure . NodeT x $
fmap (expand f) xs ++ unfoldForest f x
--- | Throw away a tree's children.
+-- | Throw away all but the top @n@ levels of a tree's children.
--
-prune :: Monad m => Tree m a -> Tree m a
-prune m =
- Tree $ do
- Node x _ <- runTree m
- pure $ Node x []
+-- /@prune 0@ will throw away all of a tree's children./
+--
+prune :: Monad m => Int -> TreeT m a -> TreeT m a
+prune n m =
+ if n <= 0 then
+ TreeT $ do
+ NodeT x _ <- runTreeT m
+ pure $ NodeT x []
+ else
+ TreeT $ do
+ NodeT x xs0 <- runTreeT m
+ pure . NodeT x $
+ fmap (prune (n - 1)) xs0
+-- | Returns the depth of the deepest leaf node in the tree.
+--
+depth :: Tree a -> Int
+depth m =
+ let
+ NodeT _ xs =
+ runTree m
+
+ n =
+ if null xs then
+ 0
+ else
+ maximum (fmap depth xs)
+ in
+ 1 + n
+
+-- | Takes a tree of 'Maybe's and returns a tree of all the 'Just' values.
+--
+-- If the root of the tree is 'Nothing' then 'Nothing' is returned.
+--
+catMaybes :: Tree (Maybe a) -> Maybe (Tree a)
+catMaybes m =
+ let
+ NodeT mx mxs =
+ runTree m
+ in
+ case mx of
+ Nothing -> do
+ case Maybe.mapMaybe catMaybes mxs of
+ [] ->
+ Nothing
+ Tree (NodeT x xs0) : xs1 ->
+ Just . Tree $
+ Node x (xs0 ++ xs1)
+ Just x ->
+ Just . Tree $
+ Node x (Maybe.mapMaybe catMaybes mxs)
+
+fromPred :: (a -> Bool) -> a -> Maybe a
+fromPred p a = a <$ guard (p a)
+
+-- | Returns a tree containing only elements that match the predicate.
+--
+-- If the root of the tree does not match the predicate then 'Nothing' is
+-- returned.
+--
+filter :: (a -> Bool) -> Tree a -> Maybe (Tree a)
+filter p = mapMaybe (fromPred p)
+
+mapMaybe :: (a -> Maybe b) -> Tree a -> Maybe (Tree b)
+mapMaybe p =
+ catMaybes .
+ runTreeMaybeT .
+ mapMaybeMaybeT p .
+ hoist lift
+
+runTreeMaybeT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a)
+runTreeMaybeT =
+ runMaybeT .
+ distributeT
+
+-- | Returns a tree containing only elements that match the predicate.
+--
+-- If the root of the tree does not match the predicate then 'Nothing' is
+-- returned.
+--
+filterMaybeT :: (a -> Bool) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a
+filterMaybeT p = mapMaybeMaybeT (fromPred p)
+
+mapMaybeMaybeT :: (a -> Maybe b) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) b
+mapMaybeMaybeT p t =
+ case runTreeMaybeT t of
+ Tree (Node Nothing _) ->
+ TreeT . MaybeT . Identity $ Nothing
+ Tree (Node (Just x) xs) ->
+ case p x of
+ Nothing -> TreeT . MaybeT . Identity $ Nothing
+ Just x' ->
+ hoist generalize $
+ Tree . Node x' $
+ concatMap (flattenTree p) xs
+
+flattenTree :: (a -> Maybe b) -> Tree (Maybe a) -> [Tree b]
+flattenTree p (Tree (Node mx mxs0)) =
+ let
+ mxs =
+ concatMap (flattenTree p) mxs0
+ in
+ case mx of
+ Nothing -> mxs
+ Just x ->
+ case p x of
+ Just x' ->
+ [Tree (Node x' mxs)]
+ Nothing ->
+ mxs
+
+-- | Returns a tree containing only elements that match the predicate.
+--
+-- When an element does not match the predicate its node is replaced with
+-- 'empty'.
+--
+filterT :: (Monad m, Alternative m) => (a -> Bool) -> TreeT m a -> TreeT m a
+filterT p =
+ mapMaybeT (fromPred p)
+
+mapMaybeT :: (Monad m, Alternative m) => (a -> Maybe b) -> TreeT m a -> TreeT m b
+mapMaybeT p m =
+ TreeT $ do
+ NodeT x xs <- runTreeT m
+ case p x of
+ Just x' ->
+ pure $
+ NodeT x' (fmap (mapMaybeT p) xs)
+ Nothing ->
+ empty
+
+consChild :: (Monad m) => a -> TreeT m a -> TreeT m a
+consChild a m =
+ TreeT $ do
+ NodeT x xs <- runTreeT m
+ pure $
+ NodeT x $
+ pure a : xs
+
------------------------------------------------------------------------
--- Node/Tree instances
-instance Functor m => Functor (Node m) where
- fmap f (Node x xs) =
- Node (f x) (fmap (fmap f) xs)
+-- | All ways a list can be split
+--
+-- > splits [1,2,3]
+-- > ==
+-- > [ ([], 1, [2, 3])
+-- , ([1], 2, [3])
+-- , ([1, 2], 3, [])
+-- ]
+--
+splits :: [a] -> [([a], a, [a])]
+splits xs0 =
+ let
+ go (front : fronts) (x : xs) =
+ (front, x, xs) : go fronts xs
+ go _ _ =
+ []
+ in
+ go (List.inits xs0) xs0
-instance Functor m => Functor (Tree m) where
+-- | @removes n@ computes all ways we can remove chunks of size @n@ from a list
+--
+-- Examples
+--
+-- > removes 1 [1..3] == [[2,3],[1,3],[1,2]]
+-- > removes 2 [1..4] == [[3,4],[1,2]]
+-- > removes 2 [1..5] == [[3,4,5],[1,2,5],[1,2,3,4]]
+-- > removes 3 [1..5] == [[4,5],[1,2,3]]
+--
+-- Note that the last chunk we delete might have fewer elements than @n@.
+removes :: forall a. Int -> [a] -> [[a]]
+removes k = \xs -> go xs
+ where
+ go :: [a] -> [[a]]
+ go [] = []
+ go xs = xs2 : map (xs1 ++) (go xs2)
+ where
+ (xs1, xs2) = splitAt k xs
+
+dropSome :: Monad m => [NodeT m a] -> [TreeT m [a]]
+dropSome ts = do
+ n <- takeWhile (> 0) $ iterate (`div` 2) (length ts)
+ ts' <- removes n ts
+ pure . TreeT . pure $ interleave ts'
+
+shrinkOne :: Monad m => [NodeT m a] -> [TreeT m [a]]
+shrinkOne ts = do
+ (xs, y0, zs) <- splits ts
+ y1 <- nodeChildren y0
+ pure . TreeT $ do
+ y2 <- runTreeT y1
+ pure $
+ interleave (xs ++ [y2] ++ zs)
+
+interleave :: forall m a. Monad m => [NodeT m a] -> NodeT m [a]
+interleave ts =
+ NodeT (fmap nodeValue ts) $
+ concat [
+ dropSome ts
+ , shrinkOne ts
+ ]
+
+------------------------------------------------------------------------
+
+instance Foldable Tree where
+ foldMap f (TreeT mx) =
+ foldMap f (runIdentity mx)
+
+instance Foldable Node where
+ foldMap f (NodeT x xs) =
+ f x `mappend` mconcat (fmap (foldMap f) xs)
+
+instance Traversable Tree where
+ traverse f (TreeT mx) =
+ TreeT <$> traverse (traverse f) mx
+
+instance Traversable Node where
+ traverse f (NodeT x xs) =
+ NodeT <$> f x <*> traverse (traverse f) xs
+
+------------------------------------------------------------------------
+-- NodeT/TreeT instances
+
+instance (Eq1 m, Eq a) => Eq (TreeT m a) where
+ TreeT m0 == TreeT m1 =
+ liftEq (==) m0 m1
+
+instance Functor m => Functor (NodeT m) where
+ fmap f (NodeT x xs) =
+ NodeT (f x) (fmap (fmap f) xs)
+
+instance Functor m => Functor (TreeT m) where
fmap f =
- Tree . fmap (fmap f) . runTree
+ TreeT . fmap (fmap f) . runTreeT
-instance Monad m => Applicative (Node m) where
- pure =
- return
- (<*>) =
- ap
+instance Applicative m => Applicative (NodeT m) where
+ pure x =
+ NodeT x []
+ (<*>) (NodeT ab tabs) na@(NodeT a tas) =
+ NodeT (ab a) $
+ map (<*> (fromNodeT na)) tabs ++ map (fmap ab) tas
-instance Monad m => Applicative (Tree m) where
+instance Applicative m => Applicative (TreeT m) where
pure =
- return
- (<*>) =
- ap
+ TreeT . pure . pure
+ (<*>) (TreeT mab) (TreeT ma) =
+ TreeT $
+ liftA2 (<*>) mab ma
-instance Monad m => Monad (Node m) where
- return x =
- Node x []
+instance Monad m => Monad (NodeT m) where
+ return =
+ pure
- (>>=) (Node x xs) k =
+ (>>=) (NodeT x xs) k =
case k x of
- Node y ys ->
- Node y $
- fmap (Tree . fmap (>>= k) . runTree) xs ++ ys
+ NodeT y ys ->
+ NodeT y $
+ fmap (TreeT . fmap (>>= k) . runTreeT) xs ++ ys
-instance Monad m => Monad (Tree m) where
- return x =
- Tree . pure $ Node x []
+instance Monad m => Monad (TreeT m) where
+ return =
+ pure
(>>=) m k =
- Tree $ do
- Node x xs <- runTree m
- Node y ys <- runTree (k x)
- pure . Node y $
+ TreeT $ do
+ NodeT x xs <- runTreeT m
+ NodeT y ys <- runTreeT (k x)
+ pure . NodeT y $
fmap (>>= k) xs ++ ys
-instance MonadPlus m => Alternative (Tree m) where
+instance Alternative m => Alternative (TreeT m) where
empty =
- mzero
- (<|>) =
- mplus
+ TreeT empty
+ (<|>) x y =
+ TreeT (runTreeT x <|> runTreeT y)
-instance MonadPlus m => MonadPlus (Tree m) where
+instance MonadPlus m => MonadPlus (TreeT m) where
mzero =
- Tree mzero
+ TreeT mzero
mplus x y =
- Tree (runTree x `mplus` runTree y)
+ TreeT (runTreeT x `mplus` runTreeT y)
-instance MonadTrans Tree where
- lift m =
- Tree $ do
- x <- m
- pure (Node x [])
+zipTreeT :: forall f a b. Applicative f => TreeT f a -> TreeT f b -> TreeT f (a, b)
+zipTreeT l0@(TreeT left) r0@(TreeT right) =
+ TreeT $
+ let
+ zipNodeT :: NodeT f a -> NodeT f b -> NodeT f (a, b)
+ zipNodeT (NodeT a ls) (NodeT b rs) =
+ NodeT (a, b) $
+ concat [
+ [zipTreeT l1 r0 | l1 <- ls]
+ , [zipTreeT l0 r1 | r1 <- rs]
+ ]
+ in
+ zipNodeT <$> left <*> right
-instance MFunctor Node where
- hoist f (Node x xs) =
- Node x (fmap (hoist f) xs)
+instance Monad m => MonadZip (TreeT m) where
+ mzip =
+ zipTreeT
-instance MFunctor Tree where
- hoist f (Tree m) =
- Tree . f $ fmap (hoist f) m
+instance MonadTrans TreeT where
+ lift f =
+ TreeT $
+ fmap (\x -> NodeT x []) f
-embedNode :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Node t b -> Node m b
-embedNode f (Node x xs) =
- Node x (fmap (embedTree f) xs)
+instance MFunctor NodeT where
+ hoist f (NodeT x xs) =
+ NodeT x (fmap (hoist f) xs)
-embedTree :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Tree t b -> Tree m b
-embedTree f (Tree m) =
- Tree . pure . embedNode f =<< f m
+instance MFunctor TreeT where
+ hoist f (TreeT m) =
+ TreeT . f $ fmap (hoist f) m
-instance MMonad Tree where
+embedNodeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> NodeT t b -> NodeT m b
+embedNodeT f (NodeT x xs) =
+ NodeT x (fmap (embedTreeT f) xs)
+
+embedTreeT :: Monad m => (t (NodeT t b) -> TreeT m (NodeT t b)) -> TreeT t b -> TreeT m b
+embedTreeT f (TreeT m) =
+ TreeT . pure . embedNodeT f =<< f m
+
+instance MMonad TreeT where
embed f m =
- embedTree f m
+ embedTreeT f m
-distributeNode :: Transformer t Tree m => Node (t m) a -> t (Tree m) a
-distributeNode (Node x xs) =
- join . lift . fromNode . Node (pure x) $
- fmap (pure . distributeTree) xs
+distributeNodeT :: Transformer t TreeT m => NodeT (t m) a -> t (TreeT m) a
+distributeNodeT (NodeT x xs) =
+ join . lift . fromNodeT . NodeT (pure x) $
+ fmap (pure . distributeTreeT) xs
-distributeTree :: Transformer t Tree m => Tree (t m) a -> t (Tree m) a
-distributeTree x =
- distributeNode =<< hoist lift (runTree x)
+distributeTreeT :: Transformer t TreeT m => TreeT (t m) a -> t (TreeT m) a
+distributeTreeT x =
+ distributeNodeT =<< hoist lift (runTreeT x)
-instance Distributive Tree where
- distribute =
- distributeTree
+instance MonadTransDistributive TreeT where
+ distributeT =
+ distributeTreeT
-instance PrimMonad m => PrimMonad (Tree m) where
- type PrimState (Tree m) =
+instance PrimMonad m => PrimMonad (TreeT m) where
+ type PrimState (TreeT m) =
PrimState m
primitive =
lift . primitive
-instance MonadIO m => MonadIO (Tree m) where
+instance MonadIO m => MonadIO (TreeT m) where
liftIO =
lift . liftIO
-instance MonadBase b m => MonadBase b (Tree m) where
+instance MonadBase b m => MonadBase b (TreeT m) where
liftBase =
lift . liftBase
-instance MonadThrow m => MonadThrow (Tree m) where
+instance MonadThrow m => MonadThrow (TreeT m) where
throwM =
lift . throwM
-handleNode :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Node m a -> Node m a
-handleNode onErr (Node x xs) =
- Node x $
- fmap (handleTree onErr) xs
+handleNodeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> NodeT m a -> NodeT m a
+handleNodeT onErr (NodeT x xs) =
+ NodeT x $
+ fmap (handleTreeT onErr) xs
-handleTree :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Tree m a -> Tree m a
-handleTree onErr m =
- Tree . fmap (handleNode onErr) $
- catch (runTree m) (runTree . onErr)
+handleTreeT :: (Exception e, MonadCatch m) => (e -> TreeT m a) -> TreeT m a -> TreeT m a
+handleTreeT onErr m =
+ TreeT . fmap (handleNodeT onErr) $
+ catch (runTreeT m) (runTreeT . onErr)
-instance MonadCatch m => MonadCatch (Tree m) where
+instance MonadCatch m => MonadCatch (TreeT m) where
catch =
- flip handleTree
+ flip handleTreeT
-localNode :: MonadReader r m => (r -> r) -> Node m a -> Node m a
-localNode f (Node x xs) =
- Node x $
- fmap (localTree f) xs
+localNodeT :: MonadReader r m => (r -> r) -> NodeT m a -> NodeT m a
+localNodeT f (NodeT x xs) =
+ NodeT x $
+ fmap (localTreeT f) xs
-localTree :: MonadReader r m => (r -> r) -> Tree m a -> Tree m a
-localTree f (Tree m) =
- Tree $
- pure . localNode f =<< local f m
+localTreeT :: MonadReader r m => (r -> r) -> TreeT m a -> TreeT m a
+localTreeT f (TreeT m) =
+ TreeT $
+ pure . localNodeT f =<< local f m
-instance MonadReader r m => MonadReader r (Tree m) where
+instance MonadReader r m => MonadReader r (TreeT m) where
ask =
lift ask
local =
- localTree
+ localTreeT
-instance MonadState s m => MonadState s (Tree m) where
+instance MonadState s m => MonadState s (TreeT m) where
get =
lift get
put =
@@ -247,72 +584,71 @@
state =
lift . state
-listenNode :: MonadWriter w m => w -> Node m a -> Node m (a, w)
-listenNode w (Node x xs) =
- Node (x, w) $
- fmap (listenTree w) xs
+listenNodeT :: MonadWriter w m => w -> NodeT m a -> NodeT m (a, w)
+listenNodeT w (NodeT x xs) =
+ NodeT (x, w) $
+ fmap (listenTreeT w) xs
-listenTree :: MonadWriter w m => w -> Tree m a -> Tree m (a, w)
-listenTree w0 (Tree m) =
- Tree $ do
+listenTreeT :: MonadWriter w m => w -> TreeT m a -> TreeT m (a, w)
+listenTreeT w0 (TreeT m) =
+ TreeT $ do
(x, w) <- listen m
- pure $ listenNode (mappend w0 w) x
+ pure $ listenNodeT (mappend w0 w) x
-- FIXME This just throws away the writer modification function.
-passNode :: MonadWriter w m => Node m (a, w -> w) -> Node m a
-passNode (Node (x, _) xs) =
- Node x $
- fmap passTree xs
+passNodeT :: MonadWriter w m => NodeT m (a, w -> w) -> NodeT m a
+passNodeT (NodeT (x, _) xs) =
+ NodeT x $
+ fmap passTreeT xs
-passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a
-passTree (Tree m) =
- Tree $
- pure . passNode =<< m
+passTreeT :: MonadWriter w m => TreeT m (a, w -> w) -> TreeT m a
+passTreeT (TreeT m) =
+ TreeT $
+ pure . passNodeT =<< m
-instance MonadWriter w m => MonadWriter w (Tree m) where
+instance MonadWriter w m => MonadWriter w (TreeT m) where
writer =
lift . writer
tell =
lift . tell
listen =
- listenTree mempty
+ listenTreeT mempty
pass =
- passTree
+ passTreeT
-handleErrorNode :: MonadError e m => (e -> Tree m a) -> Node m a -> Node m a
-handleErrorNode onErr (Node x xs) =
- Node x $
- fmap (handleErrorTree onErr) xs
+handleErrorNodeT :: MonadError e m => (e -> TreeT m a) -> NodeT m a -> NodeT m a
+handleErrorNodeT onErr (NodeT x xs) =
+ NodeT x $
+ fmap (handleErrorTreeT onErr) xs
-handleErrorTree :: MonadError e m => (e -> Tree m a) -> Tree m a -> Tree m a
-handleErrorTree onErr m =
- Tree . fmap (handleErrorNode onErr) $
- catchError (runTree m) (runTree . onErr)
+handleErrorTreeT :: MonadError e m => (e -> TreeT m a) -> TreeT m a -> TreeT m a
+handleErrorTreeT onErr m =
+ TreeT . fmap (handleErrorNodeT onErr) $
+ catchError (runTreeT m) (runTreeT . onErr)
-instance MonadError e m => MonadError e (Tree m) where
+instance MonadError e m => MonadError e (TreeT m) where
throwError =
lift . throwError
catchError =
- flip handleErrorTree
+ flip handleErrorTreeT
-instance MonadResource m => MonadResource (Tree m) where
+instance MonadResource m => MonadResource (TreeT m) where
liftResourceT =
lift . liftResourceT
------------------------------------------------------------------------
-- Show/Show1 instances
-#if MIN_VERSION_base(4,9,0)
-instance (Show1 m, Show a) => Show (Node m a) where
+instance (Show1 m, Show a) => Show (NodeT m a) where
showsPrec =
showsPrec1
-instance (Show1 m, Show a) => Show (Tree m a) where
+instance (Show1 m, Show a) => Show (TreeT m a) where
showsPrec =
showsPrec1
-instance Show1 m => Show1 (Node m) where
- liftShowsPrec sp sl d (Node x xs) =
+instance Show1 m => Show1 (NodeT m) where
+ liftShowsPrec sp sl d (NodeT x xs) =
let
sp1 =
liftShowsPrec sp sl
@@ -323,10 +659,10 @@
sp2 =
liftShowsPrec sp1 sl1
in
- showsBinaryWith sp sp2 "Node" d x xs
+ showsBinaryWith sp sp2 "NodeT" d x xs
-instance Show1 m => Show1 (Tree m) where
- liftShowsPrec sp sl d (Tree m) =
+instance Show1 m => Show1 (TreeT m) where
+ liftShowsPrec sp sl d (TreeT m) =
let
sp1 =
liftShowsPrec sp sl
@@ -337,8 +673,7 @@
sp2 =
liftShowsPrec sp1 sl1
in
- showsUnaryWith sp2 "Tree" d m
-#endif
+ showsUnaryWith sp2 "TreeT" d m
------------------------------------------------------------------------
-- Pretty Printing
@@ -347,22 +682,22 @@
-- Rendering implementation based on the one from containers/Data.Tree
--
-renderTreeLines :: Monad m => Tree m String -> m [String]
-renderTreeLines (Tree m) = do
- Node x xs0 <- m
+renderTreeTLines :: Monad m => TreeT m String -> m [String]
+renderTreeTLines (TreeT m) = do
+ NodeT x xs0 <- m
xs <- renderForestLines xs0
pure $
- lines (renderNode x) ++ xs
+ lines (renderNodeT x) ++ xs
-renderNode :: String -> String
-renderNode xs =
+renderNodeT :: String -> String
+renderNodeT xs =
case xs of
[_] ->
' ' : xs
_ ->
xs
-renderForestLines :: Monad m => [Tree m String] -> m [String]
+renderForestLines :: Monad m => [TreeT m String] -> m [String]
renderForestLines xs0 =
let
shift hd other =
@@ -373,18 +708,25 @@
pure []
[x] -> do
- s <- renderTreeLines x
+ s <- renderTreeTLines x
pure $
shift " └╼" " " s
x : xs -> do
- s <- renderTreeLines x
+ s <- renderTreeTLines x
ss <- renderForestLines xs
pure $
shift " ├╼" " │ " s ++ ss
+-- | Render a tree of strings.
+--
+render :: Tree String -> String
+render =
+ runIdentity . renderT
+
-- | Render a tree of strings, note that this forces all the delayed effects in
-- the tree.
-render :: Monad m => Tree m String -> m String
-render =
- fmap unlines . renderTreeLines
+--
+renderT :: Monad m => TreeT m String -> m String
+renderT =
+ fmap unlines . renderTreeTLines
diff --git a/src/Hedgehog/Internal/Tripping.hs b/src/Hedgehog/Internal/Tripping.hs
--- a/src/Hedgehog/Internal/Tripping.hs
+++ b/src/Hedgehog/Internal/Tripping.hs
@@ -3,13 +3,24 @@
tripping
) where
-import Hedgehog.Internal.Property
-import Hedgehog.Internal.Show
-import Hedgehog.Internal.Source
+import Hedgehog.Internal.Property (MonadTest, Diff(..), success, failWith)
+import Hedgehog.Internal.Show (valueDiff, mkValue, showPretty)
+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
-- | Test that a pair of encode / decode functions are compatible.
--
+-- Given a printer from some type @a -> b@, and a parser with a
+-- potential failure case @b -> f a@. Ensure that a valid @a@ round
+-- trips through the "print" and "parse" to yield the same @a@.
+--
+-- For example, types /should/ have tripping 'Read' and 'Show'
+-- instances:
+--
+-- @
+-- trippingShowRead :: (Show a, Read a, Eq a, MonadTest m) => a -> m ()
+-- trippingShowRead a = tripping a show readEither
+-- @
tripping ::
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a), HasCallStack)
=> a
@@ -45,7 +56,8 @@
Just diff ->
withFrozenCallStack $
failWith
- (Just $ Diff "━━━ " "- Original" "/" "+ Roundtrip" " ━━━" diff) $
+ (Just $
+ Diff "━━━ " "- Original" ") (" "+ Roundtrip" " ━━━" diff) $
unlines [
"━━━ Intermediate ━━━"
, showPretty i
diff --git a/src/Hedgehog/Main.hs b/src/Hedgehog/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Main.hs
@@ -0,0 +1,19 @@
+module Hedgehog.Main (
+ -- * Running tests
+ defaultMain
+ ) where
+
+import Control.Monad (unless)
+
+import System.Exit (exitFailure)
+import System.IO (BufferMode (LineBuffering), hSetBuffering, stderr, stdout)
+
+-- | An entry point that can be used as a main function.
+--
+defaultMain :: [IO Bool] -> IO ()
+defaultMain tests = do
+ hSetBuffering stdout LineBuffering
+ hSetBuffering stderr LineBuffering
+ result <- and <$> sequence tests
+ unless result
+ exitFailure
diff --git a/test/Test/Hedgehog/Applicative.hs b/test/Test/Hedgehog/Applicative.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Hedgehog/Applicative.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+module Test.Hedgehog.Applicative where
+
+import Control.Monad.Morph (hoist)
+import Control.Monad.State.Class (MonadState(..), modify)
+import qualified Control.Monad.Trans.State.Lazy as Lazy
+
+import Data.Foldable (traverse_)
+import qualified Data.List as List
+import qualified Data.Map as Map
+
+import Hedgehog hiding (Command, Var)
+import qualified Hedgehog.Range as Range
+
+import qualified Hedgehog.Internal.Gen as Gen
+import qualified Hedgehog.Internal.Tree as Tree
+
+
+newtype Var =
+ Var Int
+ deriving (Eq, Ord, Show)
+
+data Command =
+ Add
+ | Remove
+ deriving (Eq, Ord, Show)
+
+data a :<- b =
+ a :<- b
+ deriving (Eq, Ord, Show)
+
+takeVar :: a :<- b -> a
+takeVar (var :<- _) =
+ var
+
+genVar :: (MonadState Int m, MonadGen m) => m Var
+genVar = do
+ modify (+1)
+ Var <$> get
+
+genCommand :: MonadGen m => m Command
+genCommand =
+ Gen.element [Add, Remove]
+
+genCommands :: (MonadState Int m, MonadGen m) => m [Var :<- Command]
+genCommands =
+ Gen.list (Range.constant 0 3) $ do
+ var <- genVar
+ cmd <- genCommand
+ pure $
+ var :<- cmd
+
+-- | Uncomment to observe invalid Applicative behaviour
+--
+-- /This actually also works, if you comment out the ApplicativeDo above./
+--
+xprop_StateT_inside :: Property
+xprop_StateT_inside =
+ propVars $ hoist (`Lazy.evalStateT` 0) genCommands
+
+prop_StateT_outside :: Property
+prop_StateT_outside =
+ propVars . (`Lazy.evalStateT` 0) $ distributeT genCommands
+
+propVars :: Gen [Var :<- Command] -> Property
+propVars gen =
+ property $ do
+ let
+
+ tree <-
+ forAllWith (Tree.render . fmap show . Tree.prune 3) $
+ Gen.toTree gen
+
+ let
+ noDuplicates xs =
+ let
+ sorted =
+ List.sort xs
+
+ unique =
+ Map.elems (Map.fromList (fmap (\x -> (takeVar x, x)) xs))
+
+ varsEq ys zs =
+ fmap takeVar ys ==
+ fmap takeVar zs
+ in
+ diff sorted varsEq unique
+
+ traverse_ noDuplicates tree
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
diff --git a/test/Test/Hedgehog/Confidence.hs b/test/Test/Hedgehog/Confidence.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Hedgehog/Confidence.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Test.Hedgehog.Confidence where
+
+import Hedgehog
+import qualified Hedgehog.Range as Range
+import qualified Hedgehog.Internal.Gen as Gen
+
+confidence :: Confidence
+confidence = 10 ^ (9 :: Int)
+
+prop_with_confidence :: Property
+prop_with_confidence =
+ verifiedTermination . withConfidence confidence . property $ do
+ number <- forAll (Gen.int $ Range.linear 1 10)
+ cover 20 "number == 1" $ number == 1
+
+-- This tests that at least 1000 tests are run for the property
+prop_with_confidence_and_min_tests :: Property
+prop_with_confidence_and_min_tests =
+ withConfidence confidence . withTests 1000 . property $ do
+ number <- forAll (Gen.int $ Range.linear 1 10)
+ cover 10 "number == 2" $ number == 2
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
diff --git a/test/Test/Hedgehog/Filter.hs b/test/Test/Hedgehog/Filter.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Hedgehog/Filter.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Test.Hedgehog.Filter where
+
+import Data.Foldable (toList)
+import qualified Data.Set as Set
+
+import Hedgehog
+import qualified Hedgehog.Range as Range
+
+import qualified Hedgehog.Internal.Gen as Gen
+import Hedgehog.Internal.Tree (NodeT(..))
+import qualified Hedgehog.Internal.Tree as Tree
+
+-- | Prevent this bug from returning:
+--
+-- https://stackoverflow.com/questions/54412108/why-the-does-this-shrink-tree-looks-the-way-it-does-when-using-filter
+--
+-- I'm trying to understand what is the effect that filter has in the shrink
+-- tree of a generator when using _integrated shrinking_.
+--
+-- Consider the following function:
+--
+-- @
+-- {-# LANGUAGE OverloadedStrings #-}
+--
+-- import Hedgehog
+-- import qualified Hedgehog.Gen as Gen
+--
+-- genChar:: Gen Char
+-- genChar =
+-- Gen.filter (`elem` ("x" :: String)) (Gen.element "yx")
+--
+-- @
+--
+-- When a print the shrink tree:
+--
+-- @
+-- >>> Gen.printTree genChar
+-- @
+--
+-- I'd get shrink trees that look as follow:
+--
+-- @
+-- 'x'
+-- └╼'x'
+-- └╼'x'
+-- └╼'x'
+-- ...
+--
+-- └╼
+-- @
+--
+-- This is, a very deep tree containing only @x@'s, and a @discard@ at the
+-- end.
+--
+prop_filter_repetition :: Property
+prop_filter_repetition =
+ property $ do
+ let
+ genChar:: Gen Char
+ genChar =
+ Gen.filter (`elem` ("x" :: String)) (Gen.element "yx")
+
+ tree <- forAllWith (Tree.render . fmap show . Tree.prune 10) (Gen.toTree genChar)
+ Tree.depth tree === 1
+
+prop_filter_even :: Property
+prop_filter_even =
+ property $ do
+ let
+ genEven :: Gen Int
+ genEven =
+ Gen.filter even (Gen.int (Range.constant 0 8))
+
+ tree <- forAllWith (Tree.render . fmap show . Tree.prune 5) (Gen.toTree genEven)
+
+ let
+ NodeT x _ =
+ Tree.runTree tree
+
+ required =
+ Set.fromList (filter even [0..x])
+
+ actual =
+ Set.fromList (toList tree)
+
+ missing =
+ required `Set.difference` actual
+
+ annotateShow missing
+ required === actual
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
diff --git a/test/Test/Hedgehog/Maybe.hs b/test/Test/Hedgehog/Maybe.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Hedgehog/Maybe.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Test.Hedgehog.Maybe where
+
+import Data.Foldable (toList)
+
+import Hedgehog
+
+import qualified Hedgehog.Internal.Shrink as Shrink
+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
+import Hedgehog.Internal.Tree (Tree)
+import qualified Hedgehog.Internal.Tree as Tree
+
+
+mkTree :: Int -> Tree Int
+mkTree n =
+ Tree.expand (Shrink.towards 0) (pure n)
+
+showOdd :: Int -> Maybe String
+showOdd n =
+ if n `mod` 2 == 0 then
+ Nothing
+ else
+ Just (show n)
+
+render :: (HasCallStack, Show a) => Tree a -> PropertyT IO ()
+render x =
+ withFrozenCallStack $ do
+ annotate . Tree.render $ fmap show x
+
+prop_mapMaybe :: Property
+prop_mapMaybe =
+ withTests 1 . property $ do
+ let original = mkTree 5
+ case Tree.mapMaybe showOdd original of
+ Nothing ->
+ failure
+ Just mapped -> do
+ render original
+ render mapped
+ ["5" , "3" , "1" , "1" , "3" , "1"] === toList mapped
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
diff --git a/test/Test/Hedgehog/Skip.hs b/test/Test/Hedgehog/Skip.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Hedgehog/Skip.hs
@@ -0,0 +1,286 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+module Test.Hedgehog.Skip where
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (MonadIO(..))
+
+import Data.Foldable (for_)
+import Data.IORef (IORef)
+import qualified Data.IORef as IORef
+
+import Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import qualified Hedgehog.Internal.Config as Config
+import Hedgehog.Internal.Property (Skip(..), ShrinkPath(..), skipCompress, skipDecompress)
+import qualified Hedgehog.Internal.Property as Property
+import qualified Hedgehog.Internal.Runner as Runner
+import Hedgehog.Internal.Report (Report(..), Result(..), FailureReport(..))
+
+-- | We use this property to help test skipping. It keeps a log of every time it
+-- runs in the 'IORef' it's passed.
+--
+-- It ignores its seed. It discards at size 1 and fails at size 2. When it
+-- shrinks, it initially shrinks to something that will pass, and then to
+-- something that will fail.
+--
+skipTestProperty :: IORef [(Size, Int, Bool, Bool)] -> Property
+skipTestProperty logRef =
+ withTests 5 . property $ do
+ val@(curSize, _, shouldDiscard, shouldPass) <- forAll $ do
+ curSize <- Gen.sized pure
+ (shouldDiscard, shouldPass, nShrinks) <-
+ (,,)
+ <$> pure (curSize == 1)
+ <*> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2)
+ <*> Gen.shrink (\n -> reverse [0 .. n-1]) (pure 3)
+ pure (curSize, nShrinks, shouldDiscard, shouldPass)
+
+ -- Fail coverage to make sure we disable it when shrinking.
+ cover 100 "Not 4" (curSize /= 4)
+
+ liftIO $ IORef.modifyIORef' logRef (val :)
+ when shouldDiscard discard
+ assert shouldPass
+
+checkProp :: MonadIO m => Property -> m (Report Result)
+checkProp prop = do
+ seed <- Config.resolveSeed Nothing
+ liftIO $ Runner.checkReport
+ (Property.propertyConfig prop)
+ 0
+ seed
+ (Property.propertyTest prop)
+ (const $ pure ())
+
+prop_SkipNothing :: Property
+prop_SkipNothing =
+ withTests 1 . property $ do
+ logRef <- liftIO $ IORef.newIORef []
+ let
+ prop =
+ withSkip "" $ skipTestProperty logRef
+
+ report <- checkProp prop
+ case reportStatus report of
+ Failed f -> do
+ failureShrinks f === 3
+ failureShrinkPath f === ShrinkPath [1, 1, 1]
+
+ _ -> do
+ annotateShow report
+ failure
+
+ logs <- liftIO $ reverse <$> IORef.readIORef logRef
+ logs ===
+ [ (0, 3, False, True)
+ , (1, 3, True, True)
+ , (2, 3, False, False)
+ , (2, 3, False, True)
+ , (2, 2, False, False)
+ , (2, 2, False, True)
+ , (2, 1, False, False)
+ , (2, 1, False, True)
+ , (2, 0, False, False)
+ , (2, 0, False, True)
+ ]
+
+prop_SkipToFailingTest :: Property
+prop_SkipToFailingTest =
+ withTests 1 . property $ do
+ logRef <- liftIO $ IORef.newIORef []
+ let
+ prop =
+ withSkip "3" $ skipTestProperty logRef
+
+ report <- checkProp prop
+ case reportStatus report of
+ Failed f -> do
+ failureShrinks f === 3
+ failureShrinkPath f === ShrinkPath [1, 1, 1]
+
+ _ ->
+ failure
+
+ logs <- liftIO $ reverse <$> IORef.readIORef logRef
+ logs ===
+ [ (2, 3, False, False)
+ , (2, 3, False, True)
+ , (2, 2, False, False)
+ , (2, 2, False, True)
+ , (2, 1, False, False)
+ , (2, 1, False, True)
+ , (2, 0, False, False)
+ , (2, 0, False, True)
+ ]
+
+prop_SkipPastFailingTest :: Property
+prop_SkipPastFailingTest =
+ withTests 1 . property $ do
+ logRef <- liftIO $ IORef.newIORef []
+ let
+ prop =
+ withSkip "4" $ skipTestProperty logRef
+
+ report <- checkProp prop
+ reportStatus report === OK
+
+ logs <- liftIO $ reverse <$> IORef.readIORef logRef
+ logs === [(3, 3, False, True), (4, 3, False, True)]
+
+prop_SkipToNoShrink :: Property
+prop_SkipToNoShrink =
+ withTests 1 . property $ do
+ logRef <- liftIO $ IORef.newIORef []
+ let
+ prop =
+ withSkip "3:" $ skipTestProperty logRef
+
+ report <- checkProp prop
+ case reportStatus report of
+ Failed f -> do
+ failureShrinks f === 0
+ failureShrinkPath f === Property.ShrinkPath []
+
+ _ ->
+ failure
+
+ logs <- liftIO $ reverse <$> IORef.readIORef logRef
+ logs === [(2, 3, False, False)]
+
+prop_SkipToFailingShrink :: Property
+prop_SkipToFailingShrink =
+ withTests 1 . property $ do
+ logRef <- liftIO $ IORef.newIORef []
+ let
+ prop =
+ withSkip "3:b2" $ skipTestProperty logRef
+
+ report <- checkProp prop
+ case reportStatus report of
+ Failed f -> do
+ failureShrinks f === 2
+ failureShrinkPath f === Property.ShrinkPath [1, 1]
+
+ _ ->
+ failure
+
+ logs <- liftIO $ reverse <$> IORef.readIORef logRef
+ logs === [(2, 3, False, False), (2, 2, False, False), (2, 1, False, False)]
+
+prop_SkipToPassingShrink :: Property
+prop_SkipToPassingShrink =
+ withTests 1 . property $ do
+ logRef <- liftIO $ IORef.newIORef []
+ let
+ prop =
+ withSkip "3:bA" $ skipTestProperty logRef
+
+ report <- checkProp prop
+ reportStatus report === OK
+
+ logs <- liftIO $ reverse <$> IORef.readIORef logRef
+ logs === [(2, 3, False, False), (2, 2, False, False), (2, 2, False, True)]
+
+prop_SkipToReportedShrink :: Property
+prop_SkipToReportedShrink =
+ withTests 1 . property $ do
+ logRef <- liftIO $ IORef.newIORef []
+
+ report1 <- checkProp $ skipTestProperty logRef
+ failure1 <- case reportStatus report1 of
+ Failed f -> pure f
+ _ -> do
+ annotateShow report1
+ failure
+
+ let
+ skip = SkipToShrink (reportTests report1)
+ (reportDiscards report1)
+ (failureShrinkPath failure1)
+
+
+ report2 <- checkProp $ withSkip skip $ skipTestProperty logRef
+ failure2 <- case reportStatus report2 of
+ Failed f -> pure f
+ _ -> do
+ annotateShow report2
+ failure
+
+ failure1 === failure2
+
+ reportTests report1 === 2
+ reportTests report2 === 2
+ reportDiscards report1 === 1
+ reportDiscards report2 === 1
+
+genSkip :: Gen Skip
+genSkip =
+ let
+ range =
+ Range.linear 0 100
+
+ genTestCount =
+ Property.TestCount <$> Gen.int range
+
+ genDiscardCount =
+ Property.DiscardCount <$> Gen.int range
+
+ genShrinkPath =
+ Property.ShrinkPath <$> Gen.list range (Gen.int range)
+ in
+ Gen.choice
+ [ pure SkipNothing
+ , SkipToTest <$> genTestCount <*> genDiscardCount
+ , SkipToShrink <$> genTestCount <*> genDiscardCount <*> genShrinkPath
+ ]
+
+-- | Test that `skipCompress` and `skipDecompress` roundtrip.
+prop_compressSkip :: Property
+prop_compressSkip =
+ property $ do
+ skip <- forAll genSkip
+ tripping skip Property.skipCompress Property.skipDecompress
+
+-- | Demonstrate some example compressions.
+--
+-- In general it's probably fine for compressions to change between hedgehog
+-- versions. There's not much reason to share them or save them long-term. So
+-- breaking this test isn't necessarily a problem, if it's done deliberately.
+--
+-- But it's useful to have examples, to avoid accidentally changing the
+-- compression format and to demonstrate edge cases.
+prop_compressDecompressExamples :: Property
+prop_compressDecompressExamples =
+ withTests 1 . property $ do
+ let
+ -- Each test case has a Skip, the result of compressing it, and some other
+ -- strings that would decompress to the same Skip.
+ testCases =
+ [ (SkipNothing, "", [])
+ , (SkipToTest 3 0, "3", ["03", "003", "3/0", "03/00"])
+ , (SkipToTest 197 1, "197/1", ["0197/1", "00197/01"])
+ , ( SkipToShrink 5 0 $ Property.ShrinkPath [2, 3, 0]
+ , "5:cDa"
+ , ["5:CdA", "05:c1b0D1A1"]
+ )
+ , ( SkipToShrink 21 3 $ Property.ShrinkPath [5, 3, 27, 27, 26]
+ , "21/3:fDbb2BA"
+ , ["21/3:fDbbBBba"]
+ )
+ ]
+
+ for_ testCases $ \(skip, compressed, otherCompressions) -> do
+ skipCompress skip === compressed
+ for_ (compressed : otherCompressions) $ \c ->
+ skipDecompress c === Just skip
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
diff --git a/test/Test/Hedgehog/Zip.hs b/test/Test/Hedgehog/Zip.hs
new file mode 100644
--- /dev/null
+++ b/test/Test/Hedgehog/Zip.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Test.Hedgehog.Zip where
+
+import Control.Monad.Zip (mzip)
+
+import Data.Maybe (fromJust)
+
+import Hedgehog
+import qualified Hedgehog.Range as Range
+
+import qualified Hedgehog.Internal.Gen as Gen
+import qualified Hedgehog.Internal.Shrink as Shrink
+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)
+import Hedgehog.Internal.Tree (Tree)
+import qualified Hedgehog.Internal.Tree as Tree
+
+
+mkTree :: Int -> Tree Int
+mkTree n =
+ Tree.expand (Shrink.towards 0) (pure n)
+
+mkGen :: Int -> Gen Int
+mkGen =
+ Gen.fromTree . mkTree
+
+render :: Show a => HasCallStack => Tree a -> PropertyT IO ()
+render x =
+ withFrozenCallStack $ do
+ annotate . Tree.render $ fmap show x
+
+prop_gen_applicative :: Property
+prop_gen_applicative =
+ property $ do
+ let
+ treeApplicative n m =
+ (,) <$> mkTree n <*> mkTree m
+
+ treeZip n m =
+ mzip (mkTree n) (mkTree m)
+
+ genApplicative n m =
+ fromJust .
+ Gen.evalGen 0 (Seed 0 0) $
+ (,) <$> mkGen n <*> mkGen m
+
+ n <- forAll $ Gen.int (Range.constant 1 5)
+ m <- forAll $ Gen.int (Range.constant 1 5)
+
+ render $ genApplicative n m
+ render $ treeZip n m
+ render $ treeApplicative n m
+
+ genApplicative n m === treeZip n m
+ genApplicative n m /== treeApplicative n m
+
+ success
+
+tests :: IO Bool
+tests =
+ checkParallel $$(discover)
diff --git a/test/test.hs b/test/test.hs
--- a/test/test.hs
+++ b/test/test.hs
@@ -1,20 +1,24 @@
-import Control.Monad (unless)
-import System.IO (BufferMode(..), hSetBuffering, stdout, stderr)
-import System.Exit (exitFailure)
+import Hedgehog.Main (defaultMain)
+import qualified Test.Hedgehog.Applicative
+import qualified Test.Hedgehog.Confidence
+import qualified Test.Hedgehog.Filter
+import qualified Test.Hedgehog.Maybe
import qualified Test.Hedgehog.Seed
+import qualified Test.Hedgehog.Skip
import qualified Test.Hedgehog.Text
+import qualified Test.Hedgehog.Zip
main :: IO ()
-main = do
- hSetBuffering stdout LineBuffering
- hSetBuffering stderr LineBuffering
-
- results <- sequence [
- Test.Hedgehog.Text.tests
+main =
+ defaultMain [
+ Test.Hedgehog.Applicative.tests
+ , Test.Hedgehog.Confidence.tests
+ , Test.Hedgehog.Filter.tests
+ , Test.Hedgehog.Maybe.tests
, Test.Hedgehog.Seed.tests
+ , Test.Hedgehog.Skip.tests
+ , Test.Hedgehog.Text.tests
+ , Test.Hedgehog.Zip.tests
]
-
- unless (and results) $
- exitFailure
+
+
+## Contributors
+
+
+