diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2026 Carl Wernhoff
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,34 @@
+# `hedgehog-utils`
+
+_Utilities for [Hedgehog]_
+
+[![License]](./LICENSE)
+[![Hackage Version]](https://hackage.haskell.org/package/hedgehog-utils)
+[![Stackage Nightly]](https://stackage.org/nightly/package/hedgehog-utils)
+
+[License]: https://img.shields.io/badge/license-MIT-green
+[Hackage Version]: https://img.shields.io/hackage/v/hedgehog-utils
+[Stackage Nightly]: https://stackage.org/package/hedgehog-utils/badge/nightly
+
+
+
+Links:
+* [Hackage page](https://hackage.haskell.org/package/hedgehog-utils)
+* [API documentation](https://hackage.haskell.org/package/hedgehog-utils/docs/Hedgehog-Utils.html)
+* [github.com/carlwr/hedgehog-utils](https://github.com/carlwr/hedgehog-utils)
+
+---
+
+
+
+# Written by a human
+
+During the development of this package, AI models were used extensively for discussions and feedback. All code and documentation however is authored by me (Carl), a human developer: no text (code; natural language) within this package/repo is direct output from an AI model.
+
+Since I am not a native English speaker, any natural language is likely to feature language quirks. AI models were not asked to identify or rectify such.
+
+The above should not be understood as any opinion or preference of mine - it is just a description of how the code in this particular package/repo was authored.
+
+
+[Hedgehog]: https://hackage.haskell.org/package/hedgehog
+[`hspec`]: http://hspec.github.io
diff --git a/hedgehog-utils.cabal b/hedgehog-utils.cabal
new file mode 100644
--- /dev/null
+++ b/hedgehog-utils.cabal
@@ -0,0 +1,165 @@
+cabal-version: 3.0
+
+name: hedgehog-utils
+version: 0.1.0.0
+stability: experimental
+category: Testing
+synopsis: Utilities for Hedgehog
+homepage: https://github.com/carlwr/hedgehog-utils#readme
+bug-reports: https://github.com/carlwr/hedgehog-utils/issues
+author: Carl W
+maintainer: Carl W
+copyright: none
+license: MIT
+license-file: LICENSE
+build-type: Simple
+tested-with:
+ GHC == 9.12.2
+extra-doc-files:
+ README.md
+description:
+ Various extra utilities for Hedgehog, the property-testing framework.
+
+source-repository head
+ type: git
+ location: https://github.com/carlwr/hedgehog-utils
+
+flag doctest
+ description: enable doctests
+ default: False
+ manual: True
+
+flag isDev
+ description: development conveniences
+ default: False
+ manual: True
+
+
+-- dependencies
+-- ------------
+
+-- library:
+
+common dep_base { build-depends: base >= 4.19.2 && < 5 }
+common dep_containers { build-depends: containers >= 0.7 && < 0.8 }
+common dep_hh { build-depends: hedgehog >= 1.5 && < 1.8 }
+common dep_deepseq { build-depends: deepseq >= 1.5.0 && < 1.6 }
+
+-- test components:
+
+common dep_hspec { build-depends: hspec >= 2.11.8 && < 2.12 }
+common dep_hspec-core { build-depends: hspec-core >= 2.11.8 && < 2.12 }
+common dep_hspec-hh { build-depends: hspec-hedgehog >= 0.3.0.0 && < 0.4 }
+
+common tooldep_hspec-discover
+ build-tool-depends:
+ hspec-discover:hspec-discover >= 2.11.8 && < 2.12
+
+
+-- components
+-- ----------
+
+common defaults
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Widentities
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wredundant-constraints
+ -Wno-type-defaults
+ -Wno-partial-type-signatures
+ -Wnoncanonical-monad-instances
+ -Wpartial-fields
+ -Winvalid-haddock
+ -Wredundant-bang-patterns
+ -Wredundant-strictness-flags
+ if impl(ghc >= 9.8)
+ ghc-options:
+ -Winconsistent-flags
+ if flag(isDev)
+ ghc-options:
+ -freverse-errors
+ -fshow-hole-matches-of-hole-fits
+ -fmax-valid-hole-fits=30
+ -fhide-source-paths
+ -fwrite-ide-info
+ -dsuppress-module-prefixes
+ default-language: GHC2021
+ default-extensions:
+ UnicodeSyntax
+ LambdaCase
+ MultiWayIf
+ RecordWildCards
+ ViewPatterns
+ PatternSynonyms
+ PartialTypeSignatures
+ ExtendedDefaultRules
+
+library
+ import:
+ , defaults
+ , dep_base
+ , dep_containers
+ , dep_hh
+ , dep_deepseq
+ hs-source-dirs: src
+ autogen-modules: Paths_hedgehog_utils
+ other-modules: Paths_hedgehog_utils
+ exposed-modules:
+ Hedgehog.Utils
+ Hedgehog.Utils.MetaTesting
+ Hedgehog.Utils.Bottoms
+ Hedgehog.Utils.Gen
+ Hedgehog.Utils.Internal
+
+test-suite hspec
+ import:
+ , defaults
+ , dep_base
+ , dep_containers
+ , dep_hh
+ , dep_hspec
+ , dep_hspec-core
+ , dep_hspec-hh
+ , tooldep_hspec-discover
+ hs-source-dirs:
+ , test/hspec
+ type:
+ exitcode-stdio-1.0
+ main-is:
+ Spec.hs
+ other-modules:
+ SpecHook
+ TestsPrelude
+ Hedgehog.UtilsSpec
+ Hedgehog.Utils.MetaTestingSpec
+ Hedgehog.Utils.BottomsSpec
+ Hedgehog.Utils.GenSpec
+ ghc-options:
+ -threaded
+ -rtsopts
+ -with-rtsopts=-N
+ -main-is Spec
+ default-extensions:
+ , OverloadedStrings
+ build-depends:
+ , hedgehog-utils
+ , hspec-tidy-formatter >= 0.2.0.0 && < 1
+
+test-suite doctest
+ import:
+ , defaults
+ , dep_base
+ -- no solution for 9.14 due to doctest-parallell
+ -- (forcing with --alow-newer causes compilation error)
+ if !flag(doctest) || impl(ghc >= 9.14)
+ buildable: False
+ hs-source-dirs: test/doctests
+ type: exitcode-stdio-1.0
+ main-is: doctests.hs
+ ghc-options:
+ -threaded
+ build-depends:
+ , hedgehog-utils
+ , doctest-parallel >= 0.3 && < 1.0
diff --git a/src/Hedgehog/Utils.hs b/src/Hedgehog/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Utils.hs
@@ -0,0 +1,302 @@
+module Hedgehog.Utils
+(
+ -- * Assertions
+ assertWith
+, noneUnequal
+, allEqual
+, FuncTest
+, (===.)
+, (===..)
+, (===...)
+, MaterialTest
+, (<==>)
+, (<==>.)
+, (<==>..)
+, deterministic
+, deterministicF
+, constF_M
+, notConstF_M
+
+ -- * Meta-testing
+, module Hedgehog.Utils.MetaTesting
+
+ -- * Bottoms
+, module Hedgehog.Utils.Bottoms
+
+ -- * Annotations
+, maybeCollect
+, maybeLabelS
+, labelS
+
+ -- * Misc.
+, failWith
+, checkOnce
+
+)
+where
+
+import Hedgehog.Utils.Internal
+
+import Hedgehog.Utils.MetaTesting
+import Hedgehog.Utils.Bottoms
+
+import Hedgehog
+import Hedgehog.Internal.Show qualified as Shw
+
+import Data.Foldable
+import Data.List qualified as L
+import Data.String
+import Control.Monad.IO.Class
+import Control.Monad
+import GHC.Stack
+
+
+{- $setup
+>>> import Hedgehog
+-}
+
+
+--- Assertions ---
+
+assertWith :: (MonadTest m, Show a, HasCallStack) => (a -> Bool) -> a -> m ()
+assertWith f x =
+ withFrozenCallStack $
+ when (not (f x)) $
+ fail_with
+ "The assertion returned False when applied to the value."
+ [Shw.showPretty x]
+
+
+{-| Fail the test if, for a 'Foldable' with at least two elements, not all elements are equal.
+
+The 'Foldable' is tested by comparing the first element to each subsequent element.
+
+Note: This function trades performance for some other potential benefits (laziness, no 'Ord' requirement). It may be slow on large inputs.
+
+== Examples
+
+>>> checkOnce (noneUnequal [1,1,1])
+...
+True
+
+>>> checkOnce (noneUnequal [1,1,99])
+...
+False
+
+The traversal short-circuits if a non-equal element is encountered:
+
+>>> checkOnce (noneUnequal [1,1,99,error "boom"])
+...
+False
+
+If <= 1 element, the test will always pass:
+
+>>> checkOnce (noneUnequal [1])
+...
+True
+-}
+noneUnequal
+ :: (MonadTest m, Foldable t, Eq a, Show a, HasCallStack)
+ => t a
+ -> m ()
+noneUnequal ys =
+ withFrozenCallStack $
+ case toList ys of
+ x0:xs -> should_eq x0 `traverse_` xs
+ _ -> pure ()
+ where
+ should_eq x0 x
+ |x==x0 = pure ()
+ |otherwise =
+ withFrozenCallStack $
+ fail_with
+ "some are unequal"
+ ["element " ++ showq x ++ " not equal to first element " ++ showq x0
+ ]
+
+
+{- | Fail the test if, for a 'Foldable' with at least two elements, not all elements are equal. With no or one element, the test is discarded.
+
+>>> checkOnce (allEqual [1,1,1])
+...
+True
+
+>>> checkOnce (allEqual [1,1,99])
+...
+False
+
+>>> check . withDiscards 10 . property $ (allEqual [1])
+...gave up...
+False
+
+-}
+allEqual :: (Monad m, Foldable t, Eq a, Show a, HasCallStack) =>
+ t a -> PropertyT m ()
+allEqual ys
+ | x0:x1:xs <- toList ys = (x1===x0) >> (=== x0) `traverse_` xs
+ | otherwise = discard
+
+
+type FuncTest m r = (MonadTest m, Show r, Eq r, HasCallStack)
+
+{- | Fail the test if the two functions, after each having been applied to the value, do not return equal results.
+
+'===..' and '===...' are similar, but for functions taking two and three arguments, respectively.
+-}
+(===.) ::FuncTest m r => (a->r) -> (a->r) -> a -> m ()
+(===..) ::FuncTest m r => (b->a->r) -> (b->a->r) -> b -> a -> m ()
+(===...)::FuncTest m r => (c->b->a->r) -> (c->b->a->r) -> c -> b -> a -> m ()
+
+lhs ===. rhs = withFrozenCallStack $ \ a -> lhs a === rhs a
+lhs ===.. rhs = withFrozenCallStack $ \ b a -> lhs b a === rhs b a
+lhs ===... rhs = withFrozenCallStack $ \c b a -> lhs c b a === rhs c b a
+
+infix 4 ===.
+infix 4 ===..
+infix 4 ===...
+
+
+type MaterialTest m a t u = (MonadTest m, Show a, Ord a, Foldable t, Foldable u, HasCallStack)
+
+-- | Fail the test if the two 'Foldable's are not equal up to ordering.
+(<==>) :: MaterialTest m a t u => t a -> u a -> m ()
+(<==>) xs ys = L.sort (toList xs) ===
+ L.sort (toList ys)
+
+-- | Fail the test if the two 'Foldable's obtained by applying each function to the value do not return results that are equal up to ordering.
+(<==>.) :: MaterialTest m r t u => ( a->t r) -> ( a->u r) ->a->m ()
+(<==>..) :: MaterialTest m r t u => (b->a->t r) -> (b->a->u r) -> b->a->m ()
+
+lhs <==>. rhs = withFrozenCallStack $ \ a -> lhs a <==> rhs a
+lhs <==>.. rhs = withFrozenCallStack $ \b a -> lhs b a <==> rhs b a
+
+infix 4 <==>.
+infix 4 <==>..
+
+{- | Fail the test if an action does not produce the same value when evaluated twice.
+-}
+deterministic :: (MonadTest m, MonadIO m, Eq a, Show a, HasCallStack) => IO a -> m ()
+deterministic m =
+ withFrozenCallStack $
+ do
+ res0 <- liftIO m
+ res1 <- liftIO m
+ res0===res1
+
+{- | Fail the test if an effectful function does not return the same value when evaluated twice on the same point of the domain.
+
+The function is evaluated at two different points (provided by the caller). Both are evaluated a first time, before they are then evaluated a second time.
+-}
+deterministicF :: (MonadTest m, MonadIO m, Show a, Eq b, Show b, HasCallStack) =>
+ (a -> IO b) -> (a,a) -> m ()
+deterministicF f (x0,x1) =
+ withFrozenCallStack $
+ do
+ annotate $ "(x0,x1) is " ++ show (x0,x1)
+
+ f_x0_first <- f_x0
+ f_x1_first <- f_x1
+ f_x0_second <- f_x0
+ f_x0_first === f_x0_second
+
+ f_x1_second <- f_x1
+ f_x1_first === f_x1_second
+
+ where
+ f_x0 = liftIO (f x0)
+ f_x1 = liftIO (f x1)
+
+{-| /Constancy of effectful function./
+
+__Fail__ the test if evaluating the function at the two given points results in two values that are __equal__, i.e. if results are not consistent with @f@ being a constant function.
+
+If @x0 == x1@, the test is discarded (@f@ is never evaluated).
+-}
+constF_M :: (MonadIO m, Eq a, Show a, Show b, Eq b, HasCallStack) =>
+ (a -> IO b) -- ^ @f@
+ -> (a,a) -- ^ @(x0,x1)@
+ -> PropertyT m ()
+constF_M f (x0,x1) =
+ withFrozenCallStack $ do
+ when (x0==x1) discard
+ y0 <- liftIO (f x0)
+ y1 <- liftIO (f x1)
+ annotate $ "not constant: " ++ show (x0,x1) ++ " --> " ++ show (y0,y1)
+ y0 === y1
+
+
+{- | /Non-constancy of effectful function./
+
+__Succeed__ the test if evaluating the function at the two given points results in two values that are __/un/equal__, i.e. if results are proof that @f@ is a non-constant function. Otherwise, __discard__ the test.
+
+=== Details
+
+If, with @y0@ as the effectful result of @f x0@ and similar for @y1@,
+
+- @y0 /= y1@, __succeed__ the test
+
+ - @f@ has been proven non-constant over @a@
+
+- @y0 == y1@, __discard__ the test
+
+ - constancy of @f@ over @a@ is not yet proven; further points should be tried
+
+Further, if
+
+- @x0 == x1@, __discard__ the test
+
+ - non-constancy cannot be proven with these inputs
+ - note: @f@ is not evaluated in this case
+
+The returned property will __fail__ only if it throws an exception.
+
+The test runner will __give up__ if it is unable to prove non-constancy within the discard limit ('withDiscards').
+
+It is likely suitable to let tests running this property succeed the test on the first succeeding property (@'withTests' 1@).
+-}
+notConstF_M :: (MonadIO m, Eq a, Eq b) =>
+ (a -> IO b) -- ^ @f@
+ -> (a,a) -- ^ @(x0,x1)@
+ -> PropertyT m ()
+notConstF_M f (x0,x1) =
+ withFrozenCallStack
+ $ do
+ when (x0==x1) discard
+ y0 <- liftIO $ (f x0)
+ y1 <- liftIO $ (f x1)
+ if (y0 /= y1)
+ then success -- non-constancy proved, done
+ else discard -- non-constancy still unknown, caller should keep trying
+
+
+--- Annotations ---
+
+maybeCollect :: (MonadTest m, Show a, HasCallStack) => Maybe a -> m ()
+maybeCollect = (`whenJust` collect)
+
+maybeLabelS :: (MonadTest m, HasCallStack) => Maybe String -> m ()
+maybeLabelS = (`whenJust` label . fromString)
+
+labelS :: (MonadTest m, HasCallStack) => String -> m ()
+labelS = label . fromString
+
+
+--- Misc. ---
+
+failWith
+ :: (MonadTest m, HasCallStack)
+ => String -- ^ heading
+ -> [String] -- ^ body
+ -> m a
+failWith heading body =
+ withFrozenCallStack $
+ fail_with heading body
+
+{-| Run a property test once using "Hedgehog"s 'check'.
+
+If the test succeeds, 'True' is returned.
+
+This function does not suppress output to stdout. If that is desired, functions from "Hedgehog.Utils.MetaTesting" should be used instead.
+-}
+checkOnce :: MonadIO m => PropertyT IO () -> m Bool
+checkOnce x = check . withTests 1 . property $ x
diff --git a/src/Hedgehog/Utils/Bottoms.hs b/src/Hedgehog/Utils/Bottoms.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Utils/Bottoms.hs
@@ -0,0 +1,77 @@
+{- | Description: Hedgehog bottom assertions
+
+These helpers classify “bottom” by catching t'SomeException'. This includes asynchronous exceptions (e.g. runner interrupts/timeouts), so results can be affected by external cancellation and do not always imply a defect in the pure expression.
+
+-}
+
+module Hedgehog.Utils.Bottoms
+(
+ assertBottom
+, assertNotBottom
+, assertBottomNF
+, assertNotBottomNF
+) where
+
+import Hedgehog.Utils.Internal
+import Hedgehog
+
+import Control.Monad.IO.Class
+import Control.Exception
+import Control.DeepSeq
+import GHC.Stack
+
+
+-- | Expect evaluating to WHNF to throw.
+assertBottom
+ :: (MonadTest m, MonadIO m, HasCallStack)
+ => a
+ -> m ()
+assertBottom x = do
+ r <- evalIO $ try (evaluate x)
+ case r :: Either SomeException _ of
+ Left _ -> success
+ Right _ ->
+ withFrozenCallStack $
+ fail_with
+ "Expected non-bottom"
+ [ "(instead got some value)"
+ ]
+
+
+
+-- | Expect evaluating to WHNF __not__ to throw.
+assertNotBottom
+ :: (MonadTest m, MonadIO m, HasCallStack)
+ => a
+ -> m ()
+assertNotBottom x = do
+ r <- evalIO $ try (evaluate x)
+ case r :: Either SomeException _ of
+ Right _ -> footnote "assertNotBottom: passed." >> success
+ Left e ->
+ withFrozenCallStack $
+ fail_with
+ "Expected non-bottom"
+ [ "Got exception:"
+ , "\"" ++ show e ++ "\""
+ ]
+
+
+-- | Expect evaluating to NF (deep) to throw.
+assertBottomNF
+ :: (MonadTest m, MonadIO m, NFData a, HasCallStack)
+ => a
+ -> m ()
+assertBottomNF x =
+ withFrozenCallStack $
+ assertBottom (force x)
+
+
+-- | Expect evaluating to NF (deep) __not__ to throw.
+assertNotBottomNF
+ :: (MonadTest m, MonadIO m, NFData a, HasCallStack)
+ => a
+ -> m ()
+assertNotBottomNF x =
+ withFrozenCallStack $
+ assertNotBottom (force x)
diff --git a/src/Hedgehog/Utils/Gen.hs b/src/Hedgehog/Utils/Gen.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Utils/Gen.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hedgehog.Utils.Gen
+(
+ -- * Generators
+ boolSeq
+, nat
+, str
+, elementFrequency
+
+ -- * Utilities
+, includeSize
+, includeSize'
+, shrinkFirst
+, trace
+
+-- * "Hedgehog.Gen" re-export
+, module Hedgehog.Gen
+)
+where
+
+import Hedgehog.Utils.Internal
+
+import Hedgehog
+import Hedgehog.Gen -- for re-export
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+
+import Hedgehog.Internal.Gen qualified as I_Gen
+import Hedgehog.Internal.Tree qualified as Tree
+
+import Data.Sequence qualified as Seq
+import Debug.Trace qualified as Debug
+import GHC.Stack
+
+
+boolSeq :: MonadGen m => Int -> m (Seq.Seq Bool)
+boolSeq n = Gen.seq (Range.linear 0 n) Gen.bool
+
+nat :: MonadGen m => m Int
+nat = Gen.int (Range.linear 0 100)
+
+str :: MonadGen m => m String
+str = Gen.string (Range.linear 0 4) Gen.alpha
+
+
+{- | Uses a weighted distribution to randomly select one of the elements in the list.
+
+The generator shrinks towards the first element in the list.
+
+/The input list must be non-empty./
+-}
+elementFrequency :: (MonadGen m, HasCallStack) => [(Int,a)] -> m a
+elementFrequency xs =
+ withFrozenCallStack $
+ Gen.frequency [(w,Gen.constant a) | (w,a) <- xs]
+
+
+includeSize :: MonadGen m => m a -> m (Size, a)
+includeSize gen = Gen.sized $ \sz -> (sz,)<$>gen
+
+
+includeSize' :: MonadGen m => m a -> m (String,a)
+includeSize' = fmap f . includeSize
+ where
+ f (Size i,x) = (padLeft ' ' 3 (show i),x)
+
+
+-- | Make a generator print any generated values using 'Debug.Trace.trace'. A custom string is prepended to each trace message.
+trace :: (MonadGen m, Show a) => String -> m a -> m a
+trace desc g = Gen.sized $ \(Size _sz) -> do
+ x <- g
+ Debug.trace (desc++" "++show x) (pure x)
+
+
+{- | Give the generator additional shrinking options, while keeping the
+ existing shrinks intact.
+
+The new shrinks will be tried before existing shrinks. This is different from 'Gen.shrink', which is otherwise similar.
+-}
+shrinkFirst :: MonadGen m => (a -> [a]) -> m a -> m a
+shrinkFirst f = withGenT $ I_Gen.mapGenT (expand' f)
+ where
+
+ -- "Expand a tree using an unfolding function."
+ -- (adjusted version of expand' from Hedgehog.Internal.Tree)
+ expand' :: Monad m => (a -> [a]) -> Tree.TreeT m a -> Tree.TreeT m a
+ expand' f' m =
+ Tree.TreeT $ do
+ Tree.NodeT x xs <- Tree.runTreeT m
+ pure . Tree.NodeT x $
+ Tree.unfoldForest f' x ++ fmap (expand' f') xs
+ -- orig.: fmap (expand' f) xs ++ Tree.unfoldForest f x
+
+ withGenT g = fromGenT . g . toGenT
diff --git a/src/Hedgehog/Utils/Internal.hs b/src/Hedgehog/Utils/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Utils/Internal.hs
@@ -0,0 +1,31 @@
+module Hedgehog.Utils.Internal
+(
+ fail_with
+, showq
+, padLeft
+, whenJust
+) where
+
+import Hedgehog
+import GHC.Stack
+import Hedgehog.Internal.Property qualified as Prop
+
+
+fail_with :: (MonadTest m, HasCallStack) => String -> [String] -> m a
+fail_with heading body =
+ withFrozenCallStack $
+ Prop.failWith Nothing str
+ where
+ str = unlines ([ "━━ " ++ heading ++ " ━━" ] ++ body)
+
+showq :: Show a => a -> String
+showq x = "\"" ++ show x ++ "\""
+
+padLeft :: a -> Int -> [a] -> [a]
+padLeft x n xs = take k (repeat x) ++ xs
+ where k = n - length xs
+
+whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
+whenJust = \case
+ Just x -> \f -> f x
+ _ -> const (pure ())
diff --git a/src/Hedgehog/Utils/MetaTesting.hs b/src/Hedgehog/Utils/MetaTesting.hs
new file mode 100644
--- /dev/null
+++ b/src/Hedgehog/Utils/MetaTesting.hs
@@ -0,0 +1,485 @@
+{- | Description: Hedgehog meta-testing
+
+/"Hedgehog" meta-testing with a focus on reproducibility./
+
+The property-running functions of this module:
+
+- run the inner property using a t'Seed' that is either the module-hardcoded 'defaultSeed' or an explicitly passed t'Seed'
+
+ - i.e.: the t'Seed' that is used when runing user tests never affects the running of inner properties
+
+- do not produce terminal output in the form of run progress, failure reports/diffs and summaries
+
+ - they do not however redirect stdout/stderr, meaning that e.g. @'liftIO' . 'putStr' . ...@ still writes to stdout
+
+- will report inner properties that throw uncaught exceptions as __failing__
+
+ - since "Hedgehog"s internal test runner catches exceptions, considering such properties as test failures
+
+- are similar in spirit to "Hedgehog"'s 'check', however:
+
+ - 'check' has the side effect of producing terminal output, in a way that can't be easily silenced
+ - 'check' returns an @'IO' 'Bool'@ which does not distinguish between a test failure and giving up trying to generate input values
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hedgehog.Utils.MetaTesting
+(
+ -- * Running properties
+ evalCheck
+, evalCheckWith
+, evalCheckProperty
+, evalCheckPropertyWith
+
+ -- * Asserting on the result of running properties
+, MetaAssertion
+, assertPassing
+, assertGivingUp
+, assertFailing
+, assertFailingReport
+, assertFailsWithReport
+, checkSilently
+
+ -- * Convenience functions
+, isFailed
+, Outcome(..)
+, outcomeOf
+, outcomeOf'
+
+ -- * Utilities
+, randomOutcomeProp
+, TestException
+, genSeed
+, forAllProps
+, forAllPropsWith
+
+ -- * Default values reference
+, defaultMetaConfig
+, Size0
+, defaultSize0
+, defaultSeed
+
+) where
+
+import Hedgehog.Utils.Internal
+
+import Hedgehog
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+
+import Hedgehog.Internal.Runner qualified as Runner
+import Hedgehog.Internal.Report qualified as Report
+import Hedgehog.Internal.Config qualified as Cfg
+import Hedgehog.Internal.Property qualified as Prop
+import Hedgehog.Internal.Show qualified as Shw
+import Hedgehog.Internal.Seed qualified as Seed
+
+import Hedgehog.Internal.Report (Result, Report, FailureReport)
+
+import Control.Monad.IO.Class
+import Control.Exception
+import GHC.Stack
+import Data.Word
+import Control.Monad
+
+
+{- $setup
+>>> import Hedgehog
+>>> import Hedgehog.Gen qualified as Gen
+>>> import Control.Monad.IO.Class
+-}
+
+
+{- | The action of running a property test on the given @'PropertyT' 'IO' ()@.
+
+'defaultSeed' is used as t'Seed'.
+
+'defaultSize0' is used as the initial t'Size'.
+
+=== Example
+
+>>> :{
+ innerProp = do
+ char <- forAll Gen.lower
+ char /== 'b' -- SOMETIMES FAILS!
+:}
+
+>>> :{
+ myTest :: (MonadTest m, MonadIO m) => m ()
+ myTest = do
+ res <- evalCheck innerProp
+ outcomeOf res === Failing
+:}
+
+Here we use "Hedgehog"s 'check' to run the test. 'check' prints some output to stdout, and returns a 'True' IO action:
+
+>>> check (property myTest) :: IO Bool
+...
+True
+
+The omitted stdout output would be something like:
+
+> ✓ passed 100 tests.
+
+Our own test (outer property) passes, because it asserts that the inner property should fail when it is run - which it does.
+-}
+evalCheck
+ :: (MonadIO m, HasCallStack)
+
+ {- | An __inner property__ to run as a property test.
+ -}
+ => PropertyT IO ()
+
+ {- | The result of running a property test on the inner property.
+
+ In our test code, we typically put this value in some 'MonadTest' context which allows making assertions on the 'Result'. We then refer to this @m 'Result'@ as the __outer property__.
+ -}
+ -> m Result
+
+evalCheck prop =
+ Report.reportStatus <$>
+ ( withFrozenCallStack
+ evalCheckWith
+ defaultMetaConfig
+ defaultSize0
+ defaultSeed
+ prop
+ )
+
+_evalCheck_doctest :: a
+_evalCheck_doctest = undefined
+ where
+
+ innerProp = do
+ char <- forAll Gen.lower
+ char /== 'b'
+
+ myTest :: (MonadTest m, MonadIO m) => m ()
+ myTest = do
+ res <- evalCheck innerProp
+ outcomeOf res === Failing
+
+ _res = check (property myTest) :: IO Bool
+
+
+{- | The action of running a property test on the given @'PropertyT' 'IO' ()@.
+
+Compared to 'evalCheck', this function takes explicit run parameters and has a richer return type.
+
+This function plays a role similar to that of @checkReport@ in "Hedgehog.Internal.Runner".
+-}
+evalCheckWith
+ :: ∀ m. (MonadIO m, HasCallStack)
+ => Prop.PropertyConfig -- ^ limits etc. to use when running the property test
+ -> Size0
+ -> Seed
+ -> PropertyT IO () -- ^ the inner property to run
+ -> m (Report Result)
+evalCheckWith propCfg size0 seed prop =
+ withFrozenCallStack $
+ liftIO (runInner prop)
+ where
+ runInner :: PropertyT IO () -> IO (Report Result)
+ runInner prop' = Runner.checkReport propCfg size0 seed prop' silentReporter
+
+ silentReporter :: (Report Report.Progress -> IO ())
+ silentReporter _ = pure ()
+
+
+{- | The action of running a property test on the given 'Property'.
+-}
+evalCheckProperty
+ :: ∀ m. (MonadIO m, HasCallStack)
+ => Property -- ^ the inner 'Property' to run
+ -> m Result
+evalCheckProperty propty =
+ Report.reportStatus <$>
+ ( withFrozenCallStack $
+ evalCheckPropertyWith
+ defaultSize0
+ defaultSeed
+ propty
+ )
+
+
+evalCheckPropertyWith
+ :: ∀ m. (MonadIO m, HasCallStack)
+ => Size0
+ -> Seed
+ -> Property -- ^ the inner 'Property' to run
+ -> m (Report Result)
+evalCheckPropertyWith size0 seed (Prop.Property propCfg prop) =
+ withFrozenCallStack $
+ evalCheckWith propCfg size0 seed prop
+
+
+-- --- assertions ---
+
+type MetaAssertion m
+ = (MonadTest m, MonadIO m, HasCallStack)
+ => PropertyT IO () -> m ()
+
+assertPassing :: MetaAssertion m
+assertFailing :: MetaAssertion m
+assertGivingUp :: MetaAssertion m
+
+assertPassing = withFrozenCallStack $ asrt_impl "succeed" (==Report.OK)
+assertFailing = withFrozenCallStack $ asrt_impl "fail" isFailed
+assertGivingUp = withFrozenCallStack $ asrt_impl "give up" (==Report.GaveUp)
+
+asrt_impl
+ :: (MonadIO m, MonadTest m, HasCallStack)
+ => String
+ -> (Result->Bool)
+ -> PropertyT IO ()
+ -> m ()
+asrt_impl didNot p prop =
+ withFrozenCallStack $ do
+ r <- evalCheck prop
+ when (not (p r)) $ fail_with_didNotMsg r didNot
+
+assertFailingReport
+ :: (MonadIO m, MonadTest m, HasCallStack)
+ => (FailureReport -> Bool) -- ^ assertion on the failure report
+ -> PropertyT IO ()
+ -> m ()
+assertFailingReport f p =
+ withFrozenCallStack $ do
+ res <- evalCheck p
+ case res of
+ Report.OK -> fail_with_didNotMsg res "fail"
+ Report.GaveUp -> fail_with_didNotMsg res "fail"
+ Report.Failed fReport
+ |f fReport -> success
+ |otherwise ->
+ fail_with
+ "Property test failed, but not with the expected FailureReport."
+ [Shw.showPretty res]
+
+{- | @'assertFailsWithReport' == 'flip' 'assertFailingReport'@
+-}
+assertFailsWithReport
+ :: (MonadIO m, MonadTest m, HasCallStack)
+ => PropertyT IO ()
+ -> (FailureReport -> Bool) -- ^ assertion on the failure report
+ -> m ()
+assertFailsWithReport =
+ withFrozenCallStack $
+ flip assertFailingReport
+
+
+fail_with_didNotMsg :: (MonadTest m, HasCallStack) => Result -> String -> m a
+fail_with_didNotMsg res didNot =
+ withFrozenCallStack $
+ fail_with
+ ( "Assertion failed: property test did not " ++ didNot)
+ [ "actual (unexpected) result:"
+ , Shw.showPretty res
+ , ":: Hedgehog.Internal.Report.Result"
+ ]
+
+
+{- | Check a property and return 'True' if running it is a successful test. If it is a failing test or gives up generating input values, return 'False'.
+
+Similar to "Hedgehog"s 'check', but this function does not write to stdout. It also uses the defaults defined by this module.
+-}
+checkSilently :: (MonadIO m, HasCallStack) => Property -> m Bool
+checkSilently prop =
+ withFrozenCallStack $ do
+ res <- evalCheckProperty prop
+ pure $ case outcomeOf res of
+ Passing -> True
+ GivinUp -> False
+ Failing -> False
+
+
+-- --- convenience functions ---
+
+isFailed :: Result -> Bool
+isFailed = \case
+ Report.Failed _ -> True
+ _ -> False
+
+{- | The outcome of running a property test for a property.
+
+This type is similar to "Hedgehog"s type 'Result', but it omits the failure report field for failing tests.
+-}
+data Outcome =
+ Passing -- ^ the test was successful
+ | GivinUp -- ^ the test gave up generating input values
+ | Failing -- ^ there was a test failure
+ deriving (Eq, Ord, Show, Read, Enum, Bounded)
+
+outcomeOf :: Result -> Outcome
+outcomeOf = \case
+ Report.OK -> Passing
+ Report.GaveUp -> GivinUp
+ Report.Failed _ -> Failing
+
+outcomeOf' :: Report Result -> Outcome
+outcomeOf' = outcomeOf . Report.reportStatus
+
+
+-- --- defaults references ---
+
+{- | A default 'Prop.PropertyConfig' suitable for meta-properties.
+
+It is almost the same as "Hedgehog"'s 'Prop.defaultConfig'. It differs only by not taking the /skip/ value from environment variable @HEDGEHOG_SKIP@ in case there is one. This is a small tweak for improved determinism.
+-}
+defaultMetaConfig :: Prop.PropertyConfig
+defaultMetaConfig =
+ Prop.defaultConfig{ Prop.propertySkip = Just Cfg.SkipNothing }
+
+-- | An initial size when running a property test.
+type Size0 = Size
+
+{- | A default initial t'Size' when running property test.
+
+It is set to the same value that "Hedgehog" uses internally by default.
+-}
+defaultSize0 :: Size0
+defaultSize0 = 0
+
+{- | A default t'Seed' whose value is hard-coded by this module.
+
+@
+import "Hedgehog.Internal.Seed" ('Seed.from')
+
+'defaultSeed' == 'Seed.from' (1 :: 'Word64')
+@
+-}
+defaultSeed :: Seed
+defaultSeed = Seed.from default_seed_arg
+
+default_seed_arg :: Word64
+default_seed_arg = 1
+
+
+-- --- utilities ---
+
+{- | A property that when evaluated has roughly equal probability to succeed, fail or give up. (As long as the property config parameters are left unchanged.)
+-}
+randomOutcomeProp :: HasCallStack => Property
+randomOutcomeProp =
+ withTests 1
+ . withDiscards 1
+ . withShrinks 0
+ $ Prop.Property defaultMetaConfig propT
+ where
+ propT = do
+ (tag,innerProp) <- forAllWith fst gen
+ footnote $ "this property is " ++ show tag
+ innerProp
+
+ gen = Gen.frequency $
+ [ (10,Gen.constant ("succeeding" ,success ))
+ , ( 5,Gen.constant ("failing" ,failure ))
+ , ( 5,Gen.constant ("failing (IO-exc.)",ioException))
+ , (10,Gen.constant ("discarding" ,discard ))
+ ]
+
+ ioException = evalIO (throwIO TestException)
+
+
+data TestException = TestException deriving Show
+instance Exception TestException
+
+
+{- | Random t'Seed' values, properly constructed.
+
+Generated seeds have one shrink: 'defaultSeed'.
+-}
+genSeed :: Gen Seed
+genSeed =
+ Gen.frequency
+ [ ( 1,Gen.constant defaultSeed)
+ , (20,Seed.from <$> Gen.prune (Gen.word64 range))
+ ]
+ where
+ range = Range.constant r_0 (r_0 + r_width)
+
+ r_0 = default_seed_arg + 1
+ r_width = 0xffff_ffff
+
+
+{- | Use a generator of random properties to draw a random property. Run a property test on it and return the outcome of doing so.
+
+If the outer property fails, the failure report will show the inner property using its 'Prop.PropertyConfig' and a footnote will show the size, seed and 'Outcome'.
+-}
+forAllProps :: (MonadIO m,HasCallStack) =>
+ Gen Property -- ^ a generator of properties
+ -> Size0 -- ^ (for the inner property - not the generator)
+ -> Seed -- ^ (for the inner property - not the generator)
+ -> PropertyT m Outcome -- ^ the outcome of running the generated property
+forAllProps = forAllProps_impl id shw
+ where
+ shw = Shw.showPretty . Prop.propertyConfig
+
+
+{- | Like 'forAllProps', but with a generator that also generates a 'String' for each property.
+
+If the user test fails, the failure report will use the 'String' to show the inner property.
+-}
+forAllPropsWith :: (MonadIO m,HasCallStack) =>
+ Gen (String,Property) -- ^ a generator of properties
+ -> Size0
+ -> Seed
+ -> PropertyT m Outcome
+forAllPropsWith = forAllProps_impl snd fst
+
+
+forAllProps_impl :: (MonadIO m,HasCallStack) =>
+ (a -> Property)
+ -> (a -> String)
+ -> Gen a
+ -> Size0
+ -> Seed
+ -> PropertyT m Outcome
+forAllProps_impl f shw gen sz sd = do
+ prop <- forAllWith shw gen
+ outcome <- outcomeOf' <$> evalCheckPropertyWith sz sd (f prop)
+ footnote (footMsg outcome)
+ pure outcome
+ where
+ footMsg outcome = unlines
+ [ "running the inner property"
+ , " - used size" ++ show sz ++ ", seed " ++ show sd
+ , " - resulted in the outcome " ++ show outcome
+ ]
+
+
+-- --- misc ---
+
+{- dev notes:
+
+my understanding: Runner.checkReport catches exceptions in the properties it runs, considering such properties test failures. That would mean that the IO that Runner.checkReport returns is only expected to throw (uncaught) exceptions in case of some unexpected problem with actually running the test at all.
+ -> choose to evaluate Runner.checkReport with liftIO, not evalIO
+ -> allows our functions to return values in MonadIO, rather than the stronger MonadTest
+ -> MonadIO rather than MonadTest here has the further benefit of being more intuitive (clearer distinction in signatures between inner properties and the outer MonadIO)
+
+Hedgehog.Internal.Runner:
+ call chain:
+ check --> checkNamed --> checkRegion --> checkReport
+
+test/Test/Hedgehog/Skip.hs
+ their checkProp is similar to our checkSilently
+ https://github.com/hedgehogqa/haskell-hedgehog/blob/master/hedgehog/test/Test/Hedgehog/Skip.hs
+-}
+
+
+{- some dead code; keep for now
+
+hoistMb :: MonadTest m => Maybe b -> MaybeT m b
+hoistMb mb = hoistMaybe mb
+
+generalizePropToMonadIO :: (MonadIO m) => PropertyT IO a -> PropertyT m a
+generalizePropToMonadIO = hoist liftIO
+
+-- | Lift a 'PropertyT' in IO to a 'PropertyT' in MonadTest.
+--
+-- If the 'IO' action throws an exception, the test is failed.
+generalizePropToMonadTest :: (MonadTest m, MonadIO m) => PropertyT IO a -> PropertyT m a
+generalizePropToMonadTest = hoist evalIO
+
+-}
diff --git a/test/doctests/doctests.hs b/test/doctests/doctests.hs
new file mode 100644
--- /dev/null
+++ b/test/doctests/doctests.hs
@@ -0,0 +1,13 @@
+module Main where
+
+import System.Environment (getArgs)
+
+import Test.DocTest
+ ( mainFromCabal
+ )
+
+main :: IO ()
+main = do
+ mainFromCabal
+ "hedgehog-utils"
+ =<< getArgs
diff --git a/test/hspec/Hedgehog/Utils/BottomsSpec.hs b/test/hspec/Hedgehog/Utils/BottomsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/hspec/Hedgehog/Utils/BottomsSpec.hs
@@ -0,0 +1,49 @@
+
+module Hedgehog.Utils.BottomsSpec
+( spec
+) where
+
+import Hedgehog.Utils.Bottoms qualified as UUT
+import TestsPrelude
+
+
+-- | Option to temporarily enable tests that will fail.
+--
+-- Useful for meta-testing the tests, and to be able to inspect failure reports.
+--
+-- default: False
+enableFailingTests :: Bool
+enableFailingTests = False
+
+
+spec :: Spec
+spec = do
+
+ describe "*Bottom" $ do
+ it "not bottom" $ UUT.assertNotBottom fine
+ it "is bottom" $ UUT.assertBottom crash
+
+ describe "*BottomNF" $ do
+ it "not bottom" $ UUT.assertNotBottomNF fine
+ it "is bottom" $ UUT.assertBottomNF crash
+
+ when enableFailingTests $
+ describe "SHOULD FAIL: assert that..." $ do
+
+ describe "(*Bottom:)" $ do
+ it "...a non-bottom is bottom " $ UUT.assertBottom fine
+ it "...a bottom is non-bottom" $ UUT.assertNotBottom crash
+ describe "(*BottomNF:)" $ do
+ it "...a non-bottom is bottom " $ UUT.assertBottomNF fine
+ it "...a bottom is non-bottom" $ UUT.assertNotBottomNF crash
+
+
+fine :: HasCallStack => Int
+fine = length $ take 1 (1:error "fine boom")
+
+crash :: HasCallStack => Int
+crash = length $ take 2 (1:error "crash boom")
+
+-- (not sure if sharing can be an issue)
+{-# INLINE fine #-}
+{-# INLINE crash #-}
diff --git a/test/hspec/Hedgehog/Utils/GenSpec.hs b/test/hspec/Hedgehog/Utils/GenSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/hspec/Hedgehog/Utils/GenSpec.hs
@@ -0,0 +1,24 @@
+module Hedgehog.Utils.GenSpec
+( spec
+) where
+
+import Hedgehog.Utils.Gen qualified as UUT
+import TestsPrelude
+
+
+spec :: Spec
+spec = do
+ describe "elementFrequency" spec_elementFrequency
+
+spec_elementFrequency :: Spec
+spec_elementFrequency =
+ modifyMaxSuccess (const 1_000) $ do
+ it "covers" $ do
+ let
+ gen = UUT.elementFrequency
+ [(1,'a')
+ ,(9,'b')
+ ]
+ x <- forAll gen
+ cover 5 "a" (x=='a')
+ cover 80 "b" (x=='b')
diff --git a/test/hspec/Hedgehog/Utils/MetaTestingSpec.hs b/test/hspec/Hedgehog/Utils/MetaTestingSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/hspec/Hedgehog/Utils/MetaTestingSpec.hs
@@ -0,0 +1,446 @@
+module Hedgehog.Utils.MetaTestingSpec
+( spec
+) where
+
+import Hedgehog.Utils.MetaTesting qualified as UUT
+
+import TestsPrelude hiding (withFrozenCallStack)
+
+import Hedgehog.Utils.MetaTesting (Outcome)
+import Hedgehog.Utils qualified as Utils
+
+import Hedgehog.Gen qualified as Gen
+
+import Hedgehog.Internal.Report qualified as Report
+import Hedgehog.Internal.Show qualified as Shw
+import Hedgehog.Internal.Source qualified as Src
+
+import Data.List qualified as L
+
+
+
+-- --- preamble, documentation ---
+
+{-| Enable tests that will deliberately fail.
+
+Useful for meta-testing the tests, and to be able to inspect failure reports.
+
+Always checked in as 'False'.
+-}
+enableFailingTests :: Bool
+enableFailingTests = False
+
+{-| Enable tests on the source locations in failure reports.
+
+Not overly refactor- or future-proof, but very helpful to at least have at hand.
+
+=== Debugging hints
+
+Likely causes to source locations...
+ ...missing:
+ -> missing HasCallStack
+ ...wrong/pointing into MetaTesting.hs:
+ -> missing withFrozenCallStack
+
+-}
+enableCheckSourceLocationFilename :: Bool
+enableCheckSourceLocationFilename = True
+
+-- | Name of this filename; used in source location tests
+fname_self :: FilePath
+fname_self = "MetaTestingSpec.hs"
+
+-- | Don't import/use 'GHC.Stack.withFrozenCallStack' in this file.
+--
+-- For tests, the withFrozenCallStack highest in the call chain should be one _in the code under test_, so proper callstack freezing in code under test is observable in testing.
+withFrozenCallStack :: don't use me
+withFrozenCallStack =
+ error ""
+
+-- | If this is not an ambiguous definition error, withFrozenCallStack is not imported (good).
+_shouldn't_be_ambiguous :: a
+_shouldn't_be_ambiguous = undefined withFrozenCallStack
+
+
+-- --- specs ---
+
+spec :: Spec
+spec = do
+ describe "smoke tests" spec_smoke
+ describe "main" spec_main
+ describe "source locations" spec_sourceLocations
+ describe "main, provoke failing" spec_mainFailing
+ describe "inner bottoms" spec_innerBottoms
+ describe "genSeed" spec_genSeed
+ describe "randomOutcomeProp" spec_randomOutcomeProp
+ describe "seed integrity (nested props)" spec_seedIntegrity
+
+
+-- --- example properties ---
+
+bottomIO :: (MonadTest m, MonadIO m) => m a
+bottomIO = do
+ footnote "inner is bottomIO"
+ evalIO (error "error: bottomIO")
+
+bottom :: a
+bottom = error "I am a bottom"
+
+data SpecTestException = SpecTestException deriving Show
+instance Exception SpecTestException
+
+throwin :: (MonadTest m, MonadIO m) => m a
+throwin = do
+ footnote "inner is throwin"
+ evalIO (throwIO SpecTestException)
+
+
+-- --- smoke tests ---
+
+spec_smoke :: Spec
+spec_smoke = unitTests $ do
+ it "assertPassing " $ UUT.assertPassing success
+ it "assertFailing " $ UUT.assertFailing failure
+ it "evalCheck: pass " $ (UUT.evalCheck success) >>= (===Report.OK)
+ it "evalCheck: fail " $ (UUT.evalCheck failure) >>= (assert . UUT.isFailed)
+ it "evalCheck: throw" $ (UUT.evalCheck throwin) >>= (assert . UUT.isFailed)
+
+
+-- --- main spec ---
+
+type WithInner =
+ ( Prop -> Prop
+ , Prop -> Prop
+ , Prop -> Prop
+ )
+
+type WithInnerP =
+ ( Property -> Prop
+ , Property -> Prop
+ , Property -> Prop
+ )
+
+spec_main :: Spec
+spec_main = unitTests $ do
+
+ mkSpec "evalCheck " evalChecks
+ mkSpec "evalCheck + outcomeOf" outcomeOf
+ mkSpec "UUT.assert* " uut_asserts
+ mkSpecP "checkSilently " checkSilentlies
+
+ where
+
+ evalChecks =
+ ( \p -> do res <- UUT.evalCheck p; res===Report.OK
+ , \p -> do res <- UUT.evalCheck p; assert (UUT.isFailed res)
+ , \p -> do res <- UUT.evalCheck p; res===Report.GaveUp
+ )
+
+ outcomeOf =
+ ( \p -> do res <- UUT.evalCheck p; UUT.outcomeOf res===UUT.Passing
+ , \p -> do res <- UUT.evalCheck p; UUT.outcomeOf res===UUT.Failing
+ , \p -> do res <- UUT.evalCheck p; UUT.outcomeOf res===UUT.GivinUp
+ )
+
+ checkSilentlies =
+ ( \p -> do res <- UUT.checkSilently p; assert res
+ , \p -> do res <- UUT.checkSilently p; assert (not res)
+ , \p -> do res <- UUT.checkSilently p; assert (not res)
+ )
+
+ uut_asserts =
+ ( UUT.assertPassing
+ , UUT.assertFailing
+ , UUT.assertGivingUp
+ )
+
+ mkSpec :: String -> WithInner -> Spec
+ mkSpec s (asrtSucc,asrtFail,asrtGU) =
+ describe s $ do
+ it "inner succeeds " $ asrtSucc success
+ it "inner fails " $ asrtFail failure
+ it "inner IO-throws" $ asrtFail throwin
+ it "inner gives up " $ asrtGU discard
+
+ mkSpecP :: String -> WithInnerP -> Spec
+ mkSpecP s = mkSpec s . map3 (. property)
+
+
+-- --- source locations ---
+
+spec_sourceLocations :: Spec
+spec_sourceLocations = unitTests $ do
+ let
+
+ fReportOf = \case
+ Report.Failed fReport -> pure fReport
+ Report.OK -> annotate "did not fail" >> failure
+ Report.GaveUp -> annotate "did not fail" >> failure
+
+ checkFailureLocation :: MonadTest m => Report.FailureReport -> m ()
+ checkFailureLocation rep = do
+ annotate (Shw.showPretty rep)
+ case Report.failureLocation rep of
+ Nothing -> annotate "source location is missing" >> failure
+ Just span' ->
+ when enableCheckSourceLocationFilename $
+ let (Src.Span fpath _ _ _ _) = span' in
+ diff fname_self L.isSuffixOf fpath
+
+ describe "assert*" $ do
+
+ let
+ checkIsFromAssertion =
+ diff "Assertion failed:" L.isInfixOf . Report.failureMessage
+
+ it "assertFailing" $ do
+ result <- UUT.evalCheck (UUT.assertFailing success)
+ fReport <- fReportOf result
+ checkIsFromAssertion fReport
+ checkFailureLocation fReport
+
+ it "assertPassing" $ do
+ result <- UUT.evalCheck (UUT.assertPassing failure)
+ fReport <- fReportOf result
+ checkIsFromAssertion fReport
+ checkFailureLocation fReport
+
+ describe "evalCheck*" $ do
+
+ it "evalCheck" $ do
+ result <- UUT.evalCheck failure
+ fReport <- fReportOf result
+ checkFailureLocation fReport
+
+ it "evalCheckWith" $ do
+ let
+ uut_evalCheckWith =
+ UUT.evalCheckWith
+ UUT.defaultMetaConfig
+ UUT.defaultSize0
+ UUT.defaultSeed
+
+ rResult <- uut_evalCheckWith failure
+ fReport <- fReportOf (Report.reportStatus rResult)
+ checkFailureLocation fReport
+
+
+-- --- main - failing ---
+
+spec_mainFailing :: Spec
+spec_mainFailing =
+ unitTests
+ $ whenEnableFailing "(inner is,assert that)..."
+ $ do
+
+ describe "UUT.assert*, non-bottom inners" $ do
+
+ it "succ ,Fail " $ UUT.assertFailing success
+ xt "succ ,GaveUp" $ UUT.assertGivingUp success
+ xt "fail ,Succ " $ UUT.assertPassing failure
+ xt "fail ,GaveUp" $ UUT.assertGivingUp failure
+ xt "g.up ,Succ " $ UUT.assertPassing discard
+ xt "g.up ,Fail " $ UUT.assertFailing discard
+ xt "pThrw,GaveUp" $ UUT.assertGivingUp throwin
+ xt "pThrw,succ " $ UUT.assertPassing throwin
+ -- (not necessarily exhaustive)
+
+ describe "evalCheck" $ do
+ xt "fail ,OK " $ UUT.evalCheck failure >>= (=== Report.OK)
+ xt "g.up ,OK " $ UUT.evalCheck discard >>= (=== Report.OK)
+ xt "IOerr,GaveUp" $ UUT.evalCheck bottomIO >>= (=== Report.GaveUp)
+ xt "succ ,Failed" $ UUT.evalCheck success >>= (assert . UUT.isFailed)
+
+
+-- --- inner bottoms ---
+
+-- documentation of the current behaviour; possibly, other behaviours could be defensible as well
+
+spec_innerBottoms :: Spec
+spec_innerBottoms = unitTests $ do
+
+ describe "(inner-is,assert-that):" $ do
+ it "bottom ,fail" $ UUT.assertFailing bottom
+ it "bottomIO,fail" $ UUT.assertFailing bottomIO
+
+ whenEnableFailing "(inner is,assert that)..." $ do
+ xt "bottom ,succ" $ UUT.assertPassing bottom
+ xt "bottomIO,succ" $ UUT.assertPassing bottomIO
+ xt "bottom ,g.up" $ UUT.assertGivingUp bottom
+ xt "bottomIO,g.up" $ UUT.assertGivingUp bottomIO
+
+
+-- --- genSeed ---
+
+spec_genSeed :: Spec
+spec_genSeed =
+ modifyMaxSuccess (const 1000) $
+ it "coverage" $ do
+ s <- forAll genSeed
+ cover 1 "defaultSeed" (s==UUT.defaultSeed)
+
+
+-- --- randomOutcomeProp ---
+
+-- | convenience helper
+chk :: MonadIO m => Seed -> Property -> m Outcome
+chk seed pr =
+ UUT.outcomeOf' <$> UUT.evalCheckPropertyWith UUT.defaultSize0 seed pr
+
+spec_randomOutcomeProp :: Spec
+spec_randomOutcomeProp = do
+
+ let
+ f :: MonadIO m => Seed -> m Outcome
+ f s = chk s UUT.randomOutcomeProp
+
+ modifyMaxSuccess (const 1000) $ do
+
+ it "coverage (outcome)" $ do
+ s <- forAll genSeed
+ x <- f s
+ cover 15 "Failing" (x==UUT.Failing)
+ cover 15 "GivinUp" (x==UUT.GivinUp)
+ cover 15 "Passing" (x==UUT.Passing)
+
+ ( modifyMaxSuccess (const 100) .
+ modifyMaxDiscardRatio (const 1) ) $
+
+ describe "property is" $ do
+
+ it "deterministic" $ do
+ s <- forAll genSeed
+ Utils.deterministic (f s)
+
+ it "deterministic (interleaved)" $ do
+ (s0,s1) <- forAll genSeeds
+ Utils.deterministicF f (s0,s1)
+
+ it "seed-sensitive" $ do
+ (s0,s1) <- forAll genSeeds
+ Utils.notConstF_M f (s0,s1)
+
+
+-- --- seed integrity ---
+
+-- to be able to vary an outer and an inner seed in a controlled way, use a meta-property nested inside another meta-property
+
+-- use tagged phantom types to enforce correct pairing of seed<->outcome for each of the inner and outer properties
+
+data I -- (I)nner
+data O -- (O)uter
+
+type Outcome' :: Type -> Type
+type Seed' :: Type -> Type
+
+newtype Outcome' b = Outcome' Outcome deriving (Eq,Show,Enum,Bounded)
+newtype Seed' b = Seed' Seed deriving (Eq,Show)
+
+-- | tagged version of 'chk'; using this to run properties enforces that the same tag is used for the seed and the outcome
+chk' :: ∀ b m. MonadIO m
+ => Seed' b
+ -> Property
+ -> m (Outcome' b)
+chk' (Seed' seed) pr = Outcome' <$> chk seed pr
+
+-- | two nested property tests
+nested_ :: MonadIO m
+ => Property -- ^ inner property to run
+ -> (Outcome' I -> Prop) -- ^ assertion for the outcome of the inner property
+ -> Seed' I
+ -> Seed' O
+ -> m (Outcome' O)
+nested_ innerProp asrt i o = chk' o outerProp
+ where
+ outerProp = property $ do
+ r <- chk' i innerProp
+ asrt r
+
+spec_seedIntegrity :: Spec
+spec_seedIntegrity =
+ let
+
+ f :: MonadIO m
+ => (Outcome' I -> Prop)
+ -> Seed' I
+ -> Seed' O
+ -> m (Outcome' O)
+ f = nested_ UUT.randomOutcomeProp
+
+ gen_i = Seed' @I <$> genSeed
+ gen_o = Seed' @O <$> genSeed
+ gen_asrt = Gen.enumBounded :: Gen (Outcome' I)
+
+ gen =
+ (,,,,)
+ <$> gen_asrt
+ <*> gen_i
+ <*> gen_i
+ <*> gen_o
+ <*> gen_o
+
+ in
+ modifyMaxSuccess (const 50) $ do
+
+ describe "pre-conditions" $ do
+
+ modifyMaxSuccess (const 200) $
+ it "coverage (outer outcome)" $ do
+ (asrt,i,_,o,_) <- forAll gen
+ res <- f (===asrt) i o
+ cover 20 "Passing" (res == Outcome' UUT.Passing)
+ cover 40 "Failing" (res == Outcome' UUT.Failing)
+
+ it "outer not giving up" $ do
+ (asrt,i,_,o,_) <- forAll gen
+ res <- f (===asrt) i o
+ res /== Outcome' UUT.GivinUp
+
+ describe "outer outcome is" $ do
+
+ it "deterministic" $ do
+ (asrt,i,_,o,_) <- forAll gen
+ Utils.deterministic $ f (===asrt) i o
+
+ it "deterministic (interleaved)" $ do
+ (asrt,o0,o1,i0,i1) <- forAll gen
+ let f' = uncurry (f (===asrt))
+ Utils.deterministicF f' ((o0,i0),(o1,i1))
+
+ let
+ notConstF_M = Utils.notConstF_M
+ constF_M = Utils.constF_M
+
+ notConst (asrt,i0,i1,o ,_ ) = notConstF_M (\i -> f (===asrt) i o) (i0,i1)
+ isConst (asrt,i ,_ ,o0,o1) = constF_M (\o -> f (===asrt) i o) (o0,o1)
+
+ it "provedly non-constant w.r.t. inner seed" $ forAll gen >>= notConst
+ it "seemingly constant w.r.t. outer seed" $ forAll gen >>= isConst
+
+
+-- --- general helpers ---
+
+whenEnableFailing :: HasCallStack => String -> Spec -> Spec
+xwhenEnableFailing :: HasCallStack => String -> Spec -> Spec
+
+whenEnableFailing t = when enableFailingTests . describe (failDesc t)
+xwhenEnableFailing t = when enableFailingTests . xdescribe (failDesc t)
+
+failDesc :: String -> String
+failDesc = \case
+ "" -> "SHOULD FAIL"
+ t -> "SHOULD FAIL: " ++ t
+
+
+genSeed :: Gen Seed
+genSeed = UUT.genSeed
+
+genSeeds :: Gen (Seed,Seed)
+genSeeds = (,) <$> UUT.genSeed <*> UUT.genSeed
+
+map3 :: (a -> b) -> (a,a,a) -> (b,b,b)
+map3 f (x,y,z) = (f x,f y,f z)
+
+
+_silence_unusedWarnings :: _
+_silence_unusedWarnings = undefined xwhenEnableFailing
diff --git a/test/hspec/Hedgehog/UtilsSpec.hs b/test/hspec/Hedgehog/UtilsSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/hspec/Hedgehog/UtilsSpec.hs
@@ -0,0 +1,80 @@
+module Hedgehog.UtilsSpec
+( spec
+) where
+
+import Hedgehog.Utils qualified as UUT
+
+import TestsPrelude
+
+import Hedgehog.Utils.MetaTesting qualified as Meta
+
+import Hedgehog.Gen qualified as Gen
+import Hedgehog.Range qualified as Range
+
+
+
+spec :: Spec
+spec = do
+
+ it "deterministic" $ do
+ x <- forAll $ Gen.int (Range.linear 0 100)
+ UUT.deterministic (pure x)
+
+ it "deterministicF" $ do
+ let gen = Gen.int (Range.linear 0 100)
+ (x,y) <- forAll $ (,) <$> gen <*> gen
+ UUT.deterministicF pure (x,y)
+
+ it "constF_M" $ do
+ let gen_x = Gen.int (Range.linear 0 100)
+ gen_y = Gen.alpha
+ (x0,x1,y) <- forAll $ (,,) <$> gen_x <*> gen_x <*> gen_y
+ let f _ = pure y
+ UUT.constF_M f (x0,x1)
+
+ describe "notConstF_M" $ do
+ it "can prove non-constancy" $ do
+ (_,(f,(x0,x1))) <- forAllWith fst (genF 30 30)
+ UUT.notConstF_M f (x0,x1)
+ it "gives up if function is constant" $ do
+ (_,(f,(x0,x1))) <- forAllWith fst (genF 30 0)
+ Meta.assertGivingUp $ UUT.notConstF_M f (x0,x1)
+ it "gives up if only equal evaluation points" $ do
+ (_,(f,(x0,x1))) <- forAllWith fst (genF 0 30)
+ Meta.assertGivingUp $ UUT.notConstF_M f (x0,x1)
+
+
+newtype X = X Int deriving (Eq,Show)
+newtype Y = Y Int deriving (Eq,Show)
+
+type RandomFunction a b =
+ ( String -- some String representation of the function
+ , ( a -> IO b -- the function
+ , (a,a) -- supported points of evaluation
+ )
+ )
+
+-- | a generator of random functions
+genF
+ :: Int -- ^ number of 'X' values to draw from for random 'X' values
+ -> Int -- ^ (the same, for 'Y')
+ -> Gen (RandomFunction X Y)
+genF w_x w_y = do
+ (x0,x1,y0,y1) <- gen
+ let
+ f x|x==x0 = pure y0
+ |x==x1 = pure y1
+ |otherwise = error "unsupported evaluation point"
+ f_show = "" ++ show (y0,y1) ++ ">"
+ pure (f_show,(f,(x0,x1)))
+ where
+ gen_x = X <$> Gen.int (Range.linear 0 w_x)
+ gen_y = Y <$> Gen.int (Range.linear 0 w_y)
+ gen =
+ (,,,)
+ <$> gen_x
+ <*> gen_x
+ <*> gen_y
+ <*> gen_y
+
+
diff --git a/test/hspec/Spec.hs b/test/hspec/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/hspec/Spec.hs
@@ -0,0 +1,1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
diff --git a/test/hspec/SpecHook.hs b/test/hspec/SpecHook.hs
new file mode 100644
--- /dev/null
+++ b/test/hspec/SpecHook.hs
@@ -0,0 +1,22 @@
+module SpecHook
+( hook
+) where
+
+import Test.Hspec.TidyFormatter qualified as TidyFormatter
+
+import Test.Hspec
+import Test.Hspec.Core.Spec (modifyConfig)
+import Test.Hspec.Runner (Config(..), ColorMode(ColorAlways))
+
+
+hook :: Spec -> Spec
+hook = (setupSpec >>) . TidyFormatter.use
+
+setupSpec :: Spec
+setupSpec = modifyConfig $
+ (\c -> c { configSeed = Just seed })
+ . (\c -> c { configColorMode = ColorAlways })
+ . (\c -> c { configConcurrentJobs = Just 1 })
+ . (\c -> c { configRandomize = False })
+ where
+ seed = 1
diff --git a/test/hspec/TestsPrelude.hs b/test/hspec/TestsPrelude.hs
new file mode 100644
--- /dev/null
+++ b/test/hspec/TestsPrelude.hs
@@ -0,0 +1,50 @@
+module TestsPrelude
+(
+ Prop
+, unitTests
+, it
+, xt
+
+ -- * re-exports
+, module Test.Hspec
+, module Test.Hspec.Hedgehog
+, module Data.Kind
+, module Control.Monad.IO.Class
+, module Control.Monad
+, module Control.Exception
+, module GHC.Stack
+
+) where
+
+
+--- for re-export ---
+
+import Test.Hspec hiding (it)
+import Test.Hspec.Hedgehog
+
+import Data.Kind
+import Control.Monad.IO.Class
+import Control.Monad
+import Control.Exception hiding (assert)
+import GHC.Stack
+
+
+--- for internal use ---
+
+import Test.Hspec qualified as Hspec
+
+
+--- identifiers ---
+
+type Prop = PropertyT IO ()
+
+unitTests :: Spec -> Spec
+unitTests =
+ modifyMaxShrinks (const 0)
+ . modifyMaxSuccess (const 1)
+
+it :: HasCallStack => String -> Prop -> Spec
+it desc = Hspec.it desc . hedgehog
+
+xt :: HasCallStack => String -> Prop -> Spec
+xt desc = Hspec.xit desc . hedgehog