hedgehog 1.0.1 → 1.0.2

raw patch · 16 files changed

+616/−341 lines, 16 filesdep +erfdep ~pretty-showdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: erf

Dependency ranges changed: pretty-show, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−0
• README.md +1/−1
• hedgehog.cabal +5/−2
• src/Hedgehog.hs +5/−0
• src/Hedgehog/Gen.hs +1/−0
• src/Hedgehog/Internal/Distributive.hs +22/−203
• src/Hedgehog/Internal/Gen.hs +120/−32
• src/Hedgehog/Internal/Property.hs +166/−16
• src/Hedgehog/Internal/Range.hs +7/−6
• src/Hedgehog/Internal/Report.hs +11/−13
• src/Hedgehog/Internal/Runner.hs +106/−39
• src/Hedgehog/Internal/State.hs +1/−1
• src/Hedgehog/Internal/Tree.hs +57/−28
• test/Test/Hedgehog/Confidence.hs +27/−0
• test/Test/Hedgehog/Maybe.hs +45/−0
• test/test.hs +4/−0

@@ -1,3 +1,13 @@+## Version 1.0.2 (2020-01-10)+- Speed up `Tree.splits` ([#349][349], [@treeowl][treeowl])+- Speed up `Gen.shuffle` ([#348][348], [@treeowl][treeowl])+- Add docs on the bounds of `Size` ([#346][346], [@chris-martin][chris-martin])+- Fix performance issues with color handling ([#345][345], [@stolyaroleh][stolyaroleh])+- Add `mapMaybe`, `mapMaybeT`, in `Tree` and `Gen` ([#339][339], [@treeowl][treeowl])+- Fix some formatting bugs in Haddock ([#332][332], [@sshine][sshine])+- Add `MonadGen` instances for `StateT` ([#321][321], [#330][330], [@HuwCampbell][HuwCampbell] / [@tomjaguarpaw][tomjaguarpaw] / [@symbiont-sam-halliday][symbiont-sam-halliday])+- Add `MonadBaseControl` instance for `PropertyT` ([#328][328], [@treeowl][treeowl])+ ## Version 1.0.1 (2019-09-16) - Add compatibility with GHC 8.8 ([#319][319], [@erikd][erikd]) - Include location of failed assertion in report. This enables editors to more easily parse the location of failed test assertions, and provide links/jump functionality ([#308][308], [@owickstrom][owickstrom])@@ -155,7 +165,35 @@   https://github.com/ajmcmiddlin [owickstrom]:   https://github.com/owickstrom+[treeowl]:+  https://github.com/treeowl+[tomjaguarpaw]:+  https://github.com/tomjaguarpaw +[symbiont-sam-halliday]:+  https://github.com/symbiont-sam-halliday+[sshine]:+  https://github.com/sshine+[stolyaroleh]:+  https://github.com/stolyaroleh +[349]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/349+[348]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/348+[346]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/346+[345]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/345+[339]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/339+[332]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/332+[330]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/330+[328]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/328+[321]:+  https://github.com/hedgehogqa/haskell-hedgehog/pull/321 [319]:   https://github.com/hedgehogqa/haskell-hedgehog/pull/319 [308]:

@@ -92,7 +92,7 @@ <img width="307" src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo-grey.png" />   [hackage]: http://hackage.haskell.org/package/hedgehog- [hackage-shield]: https://img.shields.io/badge/hackage-v1.0-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

@@ -1,4 +1,4 @@-version: 1.0.1+version: 1.0.2  name:   hedgehog@@ -49,12 +49,13 @@   build-depends:    -- GHC 8.0.1 / base-4.9.0.0 (May 2016)       base                            >= 4.9        && < 5-    , ansi-terminal                   >= 0.6        && < 0.10+    , ansi-terminal                   >= 0.6        && < 0.11     , async                           >= 2.0        && < 2.3     , bytestring                      >= 0.10       && < 0.11     , concurrent-output               >= 1.7        && < 1.11     , containers                      >= 0.4        && < 0.7     , directory                       >= 1.2        && < 1.4+    , erf                             >= 2.0        && < 2.1     , exceptions                      >= 0.7        && < 0.11     , fail                            >= 4.9        && < 5     , lifted-async                    >= 0.7        && < 0.11@@ -126,7 +127,9 @@    other-modules:     Test.Hedgehog.Applicative+    Test.Hedgehog.Confidence     Test.Hedgehog.Filter+    Test.Hedgehog.Maybe     Test.Hedgehog.Seed     Test.Hedgehog.Text     Test.Hedgehog.Zip

@@ -66,6 +66,10 @@   , checkParallel   , checkSequential +  , Confidence+  , verifiedTermination+  , withConfidence+   , withTests   , TestLimit @@ -167,6 +171,7 @@ 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 (Test, TestT, property, test)

@@ -67,6 +67,7 @@   -- ** Conditional   , discard   , filter+  , mapMaybe   , just    -- ** Collections

@@ -7,13 +7,11 @@ {-# LANGUAGE TypeFamilies #-} module Hedgehog.Internal.Distributive (     MonadTransDistributive(..)-  , MonadTransJuggle(..)   ) where  import           Control.Monad (join) import           Control.Monad.Morph (MFunctor(..)) import           Control.Monad.Trans.Class (MonadTrans(..))-import           Control.Monad.Trans.Control (MonadTransControl(..)) import           Control.Monad.Trans.Identity (IdentityT(..)) import           Control.Monad.Trans.Except (ExceptT(..), runExceptT) import           Control.Monad.Trans.Maybe (MaybeT(..))@@ -25,13 +23,8 @@ import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict -import           Data.Proxy (Proxy(..))-import           Data.Bifunctor (Bifunctor(..))- import           GHC.Exts (Constraint) --- NOTE: Replace use of Proxy with TypeApplications when we drop 7.10 support.- ------------------------------------------------------------------------ -- * MonadTransDistributive @@ -80,205 +73,31 @@     lift . Strict.WriterT . pure =<< hoist lift (Strict.runWriterT m)  instance MonadTransDistributive (Lazy.StateT s) where-  type Transformer f (Lazy.StateT s) m = (-      Monad m-    , Monad (f m)-    , Monad (Lazy.StateT s m)-    , Monad (f (Lazy.StateT s m))-    , MonadTrans f-    , MonadTransControl f-    , MonadTransJuggle f-    , MFunctor f-    )--  distributeT :: forall f m a.-       Transformer f (Lazy.StateT s) m-    => Lazy.StateT s (f m) a-    -> f (Lazy.StateT s m) a-  distributeT m =-    join $ liftWith $ \run ->-      let-        restoreStateT :: s -> StT f (a, s) -> (f (Lazy.StateT s m) a, s)-        restoreStateT s = do-          first (restoreT . pure) . juggleState @f @a Proxy Proxy s-      in-        Lazy.StateT $ \s -> do-          fmap (restoreStateT s) . run $ Lazy.runStateT m s+  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-  type Transformer f (Strict.StateT s) m = (-      Monad m-    , Monad (f m)-    , Monad (Strict.StateT s m)-    , Monad (f (Strict.StateT s m))-    , MonadTrans f-    , MonadTransControl f-    , MonadTransJuggle f-    , MFunctor f-    )--  distributeT :: forall f m a.-       Transformer f (Strict.StateT s) m-    => Strict.StateT s (f m) a-    -> f (Strict.StateT s m) a-  distributeT m =-    join $ liftWith $ \run ->-      let-        restoreStateT :: s -> StT f (a, s) -> (f (Strict.StateT s m) a, s)-        restoreStateT s = do-          first (restoreT . pure) . juggleState @f @a Proxy Proxy s-      in-        Strict.StateT $ \s -> do-          fmap (restoreStateT s) . run $ Strict.runStateT m s+  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-  type Transformer f (Lazy.RWST r w s) m = (-      Monad m-    , Monad (f m)-    , Monad (Lazy.RWST r w s m)-    , Monad (f (Lazy.RWST r w s m))-    , MonadTrans f-    , MonadTransControl f-    , MonadTransJuggle f-    , MFunctor f-    )--  distributeT :: forall f m a.-       Transformer f (Lazy.RWST r w s) m-    => Lazy.RWST r w s (f m) a-    -> f (Lazy.RWST r w s m) a-  distributeT m =-    join $ liftWith $ \run ->-      let-        restoreRWST :: s -> StT f (a, s, w) -> (f (Lazy.RWST r w s m) a, s, w)-        restoreRWST s = do-          first3 (restoreT . pure) . juggleRWS @f @w @a Proxy Proxy Proxy s-      in-        Lazy.RWST $ \r s -> do-          fmap (restoreRWST s) . run $ Lazy.runRWST m r s+  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-  type Transformer f (Strict.RWST r w s) m = (-      Monad m-    , Monad (f m)-    , Monad (Strict.RWST r w s m)-    , Monad (f (Strict.RWST r w s m))-    , MonadTrans f-    , MonadTransControl f-    , MonadTransJuggle f-    , MFunctor f-    )--  distributeT :: forall f m a.-       Transformer f (Strict.RWST r w s) m-    => Strict.RWST r w s (f m) a-    -> f (Strict.RWST r w s m) a-  distributeT m =-    join $ liftWith $ \run ->-      let-        restoreRWST :: s -> StT f (a, s, w) -> (f (Strict.RWST r w s m) a, s, w)-        restoreRWST s = do-          first3 (restoreT . pure) . juggleRWS @f @w @a Proxy Proxy Proxy s-      in-        Strict.RWST $ \r s -> do-          fmap (restoreRWST s) . run $ Strict.runRWST m r s----------------------------------------------------------------------------- * MonadTransJuggle--first3 :: (a -> b) -> (a, s, w) -> (b, s, w)-first3 f (a, s, w) =-  (f a, s, w)--unpack3 :: (a, s, w) -> (a, (s, w))-unpack3 (a, s, w) =-  (a, (s, w))--juggleRWS :: forall t w a s.-     (MonadTransJuggle t, Monoid w)-  => Proxy t-  -> Proxy w-  -> Proxy a-  -> s-  -> StT t (a, s, w)-  -> (StT t a, s, w)-juggleRWS _ _ _ s0 st0 =-  let-    (st, (s, w)) =-      juggleState @t @a Proxy Proxy (s0, mempty) $-        mapStT @t @(a, s, w) Proxy Proxy unpack3 st0-  in-    (st, s, w)--class MonadTransControl t => MonadTransJuggle (t :: (* -> *) -> * -> *) where-  mapStT :: Proxy t -> Proxy a -> (a -> b) -> StT t a -> StT t b-  juggleState :: Proxy t -> Proxy a -> s -> StT t (a, s) -> (StT t a, s)--instance MonadTransJuggle MaybeT where-  mapStT _ _ =-    fmap--  juggleState _ _ s0 = \case-    Nothing ->-      (Nothing, s0)-    Just (x, s) ->-      (Just x, s)--instance MonadTransJuggle (ExceptT x) where-  mapStT _ _ =-    fmap--  juggleState _ _ s0 = \case-    Left x ->-      (Left x, s0)-    Right (x, s) ->-      (Right x, s)--instance MonadTransJuggle (ReaderT r) where-  mapStT _ _ =-    id--  juggleState _ _ _ (x, s) =-    (x, s)--instance Monoid w => MonadTransJuggle (Lazy.WriterT w) where-  mapStT _ _ =-    first--  juggleState _ _ _ ((x, s), w) =-    ((x, w), s)--instance Monoid w => MonadTransJuggle (Strict.WriterT w) where-  mapStT _ _ =-    first--  juggleState _ _ _ ((x, s), w) =-    ((x, w), s)--instance MonadTransJuggle (Lazy.StateT s) where-  mapStT _ _ =-    first--  juggleState _ _ _ ((x, s0), s1) =-    ((x, s1), s0)--instance MonadTransJuggle (Strict.StateT s) where-  mapStT _ _ =-    first--  juggleState _ _ _ ((x, s0), s1) =-    ((x, s1), s0)--instance Monoid w => MonadTransJuggle (Lazy.RWST r w s) where-  mapStT _ _ =-    first3--  juggleState _ _ _ ((x, s0), s1, w) =-    ((x, s1, w), s0)--instance Monoid w => MonadTransJuggle (Strict.RWST r w s) where-  mapStT _ _ =-    first3--  juggleState _ _ _ ((x, s0), s1, w) =-    ((x, s1, w), s0)+  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)

@@ -18,6 +18,9 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- MonadBase+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE DerivingVia #-}+#endif module Hedgehog.Internal.Gen (   -- * Transformer     Gen@@ -96,7 +99,9 @@   , discard   , ensure   , filter+  , mapMaybe   , filterT+  , mapMaybeT   , just   , justT @@ -120,6 +125,7 @@   -- ** Combinations & Permutations   , subsequence   , shuffle+  , shuffleSeq    -- * Sampling Generators   , sample@@ -163,8 +169,9 @@   ) where  import           Control.Applicative (Alternative(..),liftA2)-import           Control.Monad (MonadPlus(..), filterM, replicateM, join)+import           Control.Monad (MonadPlus(..), filterM, guard, replicateM, join) import           Control.Monad.Base (MonadBase(..))+import           Control.Monad.Trans.Control (MonadBaseControl(..)) import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import           Control.Monad.Error.Class (MonadError(..)) import           Control.Monad.Fail (MonadFail (..))@@ -181,6 +188,8 @@ 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(..))@@ -190,6 +199,9 @@ import           Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Char as Char+#if __GLASGOW_HASKELL__ < 806+import           Data.Coerce (coerce)+#endif import           Data.Foldable (for_, toList) import           Data.Functor.Identity (Identity(..)) import           Data.Int (Int8, Int16, Int32, Int64)@@ -247,8 +259,7 @@ -- evalGen :: Size -> Seed -> Gen a -> Maybe (Tree a) evalGen size seed =-  fmap (fmap Maybe.fromJust) .-  Tree.filter Maybe.isJust .+  Tree.mapMaybe id .   evalGenT size seed  -- | Runs a generator, producing its shrink tree.@@ -311,8 +322,7 @@ -- runDiscardEffect :: TreeT (MaybeT Identity) a -> Maybe (Tree a) runDiscardEffect =-  fmap (fmap Maybe.fromJust) .-  Tree.filter Maybe.isJust .+  Tree.mapMaybe id .   runDiscardEffectT  -- | Run the discard effects through the tree and reify them as 'Maybe' values@@ -409,6 +419,26 @@   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)@@ -587,6 +617,24 @@   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@@ -852,7 +900,7 @@  -- | Generates a random floating-point number in the @[inclusive,exclusive)@ range. -----   This generator works the same as 'integral', but for floating point numbers.+--   /This generator works the same as 'integral', but for floating point numbers./ -- realFloat :: (MonadGen m, RealFloat a) => Range a -> m a realFloat range =@@ -916,8 +964,8 @@ -- enumBounded :: 'Gen' 'Bool' -- @ -----   /This is implemented in terms of the 'Enum' class, and thus may be---    partial for integral types larger than 'Int', e.g. 'Word64'./+--   /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@@ -1211,6 +1259,9 @@   else     discard +fromPred :: (a -> Bool) -> a -> Maybe a+fromPred p a = a <$ guard (p a)+ -- | Generates a value that satisfies a predicate. -- --   This is essentially:@@ -1223,7 +1274,11 @@ --   forever. If we trigger these limits then the whole generator is discarded. -- filter :: (MonadGen m, GenBase m ~ Identity) => (a -> Bool) -> m a -> m a-filter p gen0 =+filter p =+  mapMaybe (fromPred p)++mapMaybe :: (MonadGen m, GenBase m ~ Identity) => (a -> Maybe b) -> m a -> m b+mapMaybe p gen0 =   let     try k =       if k > 100 then@@ -1231,15 +1286,20 @@       else do         (x, gen) <- freeze $ scale (2 * k +) gen0 -        if p x then-          withGenT (mapGenT (Tree.filterMaybeT p)) gen-        else-          try (k + 1)+        case p x of+          Just _ ->+            withGenT (mapGenT (Tree.mapMaybeMaybeT p)) gen+          Nothing ->+            try (k + 1)   in     try 0  filterT :: MonadGen m => (a -> Bool) -> m a -> m a-filterT p gen0 =+filterT p =+  mapMaybeT (fromPred p)++mapMaybeT :: MonadGen m => (a -> Maybe b) -> m a -> m b+mapMaybeT p gen0 =   let     try k =       if k > 100 then@@ -1247,16 +1307,17 @@       else do         (x, gen) <- freeze $ scale (2 * k +) gen0 -        if p x then-          withGenT (mapGenT (Tree.filterT p)) gen-        else-          try (k + 1)+        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.+--   /This is implemented using 'filter' and has the same caveats./ -- just :: (MonadGen m, GenBase m ~ Identity) => m (Maybe a) -> m a just g = do@@ -1269,7 +1330,7 @@  -- | Runs a 'Maybe' generator until it produces a 'Just'. -----   This is implemented using 'filter' and has the same caveats.+--   /This is implemented using 'filter' and has the same caveats./ -- justT :: MonadGen m => m (Maybe a) -> m a justT g = do@@ -1525,20 +1586,47 @@  -- | Generates a random permutation of a list. -----   This shrinks towards the order of the list being identical to the input---   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"+-- 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

@@ -1,6 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveLift #-}@@ -12,6 +13,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}@@ -41,6 +43,7 @@   , forAllT   , forAllWith   , forAllWithT+  , defaultMinTests   , discard    -- * Group@@ -92,6 +95,15 @@   , CoverPercentage(..)   , toCoverCount +  -- * Confidence+  , Confidence(..)+  , TerminationCriteria(..)+  , confidenceSuccess+  , confidenceFailure+  , withConfidence+  , verifiedTermination+  , defaultConfidence+   -- * Internal   -- $internal   , defaultConfig@@ -105,6 +117,8 @@   , mkTestT   , runTest   , runTestT++  , wilsonBounds   ) where  import           Control.Applicative (Alternative(..))@@ -139,11 +153,14 @@  import qualified Data.Char as Char 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.Ratio ((%)) import           Data.Typeable (typeOf)  import           Hedgehog.Internal.Distributive@@ -187,6 +204,16 @@ -- 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 =@@ -221,14 +248,23 @@       unPropertyName :: String     } 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+    , propertyTerminationCriteria :: !TerminationCriteria     } deriving (Eq, Ord, Show, Lift)  -- | The number of successful tests that need to be run before a property test@@ -333,6 +369,12 @@   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@@ -403,7 +445,7 @@ newtype CoverPercentage =   CoverPercentage {       unCoverPercentage :: Double-    } deriving (Eq, Ord, Show, Num)+    } deriving (Eq, Ord, Show, Num, Fractional)  -- | The name of a classifier. --@@ -420,8 +462,8 @@  -- | 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./+--   /When a classifier's coverage does not exceed the required minimum, the/+--   /test will be failed./ -- data Label a =   MkLabel {@@ -433,8 +475,8 @@  -- | 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./+--   /When a given classification's coverage does not exceed the required/+--   /minimum, the test will be failed./ -- newtype Coverage a =   Coverage {@@ -699,10 +741,10 @@ --   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./+--   /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@@ -890,22 +932,60 @@ defaultConfig :: PropertyConfig defaultConfig =   PropertyConfig {-      propertyTestLimit =-        100-    , propertyDiscardLimit =+      propertyDiscardLimit =         100     , propertyShrinkLimit =         1000     , propertyShrinkRetries =         0+    , propertyTerminationCriteria =+        NoConfidenceTermination defaultMinTests     } +-- | 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. --@@ -915,7 +995,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.@@ -1013,6 +1100,7 @@ labelCovered tests (MkLabel _ _ minimum_ population) =   coverPercentage tests population >= minimum_ +-- | All labels are covered coverageSuccess :: TestCount -> Coverage CoverCount -> Bool coverageSuccess tests =   null . coverageFailures tests@@ -1021,6 +1109,68 @@ coverageFailures tests (Coverage kvs) =   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+-- (<https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval+-- wikipedia>) 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 $@@ -1073,7 +1223,7 @@ --    prop_with_classifier = --      property $ do --        xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha---        for_ xs $ \x -> do+--        for_ xs $ \\x -> do --          classify "newborns" $ x == 0 --          classify "children" $ x > 0 && x < 13 --          classify "teens" $ x > 12 && x < 20

@@ -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 =@@ -400,7 +401,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 +419,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)

@@ -1069,8 +1069,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@@ -1170,8 +1170,6 @@     end _ =       setSGRCode [Reset] -  color <- resolveColor mcolor-   let     display =       case color of@@ -1191,14 +1189,14 @@     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 color name x =+  renderDoc color =<< ppResult name x -renderSummary :: MonadIO m => Maybe UseColor -> Summary -> m String-renderSummary mcolor x =-  renderDoc mcolor =<< ppSummary x+renderSummary :: MonadIO m => UseColor -> Summary -> m String+renderSummary color x =+  renderDoc color =<< ppSummary x

@@ -40,7 +40,10 @@ import           Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT) import           Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests) import           Hedgehog.Internal.Property (TestCount(..), PropertyCount(..))+import           Hedgehog.Internal.Property (TerminationCriteria(..)) import           Hedgehog.Internal.Property (coverageSuccess, journalCoverage)+import           Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure)+import           Hedgehog.Internal.Property (defaultMinTests) import           Hedgehog.Internal.Queue import           Hedgehog.Internal.Region import           Hedgehog.Internal.Report@@ -160,6 +163,30 @@     test =       catchAll test0 (fail . show) +    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@@ -170,28 +197,65 @@     loop !tests !discards !size !seed !coverage0 = do       updateUI $ Report tests discards coverage0 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 OK++        failureReport message =+          Report tests discards coverage0 . Failed $ mkFailure+            size+            seed+            0+            (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 coverage0 -      else if tests >= fromIntegral (propertyTestLimit cfg) then-        -- we've hit the test limit-        if coverageSuccess tests coverage0 then-          -- all classifiers satisfied, test was successful-          pure $ Report tests discards coverage0 OK--        else-          -- some classifiers unsatisfied, test was successful-          pure . Report tests discards coverage0 . Failed $-            mkFailure-              size-              seed-              0-              (Just coverage0)-              Nothing-              "Insufficient coverage."-              Nothing-              []+      else if 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+        pure $ case terminationCriteria of+          EarlyTermination _ _ -> confidenceReport+          NoEarlyTermination _ _ -> confidenceReport+          NoConfidenceTermination _ ->+            if labelsCovered then+              successReport+            else+              failureReport $+                "Labels not sufficently covered after " <> show tests <> " tests"        else if discards >= fromIntegral (propertyDiscardLimit cfg) then         -- we've hit the discard limit, give up@@ -233,24 +297,24 @@ 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@@ -264,28 +328,30 @@ checkNamed ::      MonadIO m   => Region-  -> Maybe UseColor+  -> UseColor   -> Maybe PropertyName   -> Property   -> m (Report Result)-checkNamed region mcolor name prop = do+checkNamed region color name prop = do   seed <- liftIO Seed.random-  checkRegion region mcolor name 0 seed prop+  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 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 ()  -- | Check a group of properties using the specified runner config.@@ -307,31 +373,32 @@     putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━"      verbosity <- resolveVerbosity (runnerVerbosity config)-    summary <- checkGroupWith n verbosity (runnerColor config) props+    color <- resolveColor (runnerColor config)+    summary <- checkGroupWith n verbosity color 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   -> [(PropertyName, Property)]   -> IO Summary-checkGroupWith n verbosity mcolor props =+checkGroupWith n verbosity color 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 =@@ -351,7 +418,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           }@@ -362,12 +429,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) 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.

@@ -97,7 +97,7 @@ --   previous action in a generator without knowing the value of the result --   (e.g., to get the ID of a previously-created user). -----   Symmbolic variables provide a token to stand in for the actual variables at+--   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.

@@ -33,8 +33,11 @@    , catMaybes   , filter+  , mapMaybe   , filterMaybeT+  , mapMaybeMaybeT   , filterT+  , mapMaybeT   , depth   , interleave @@ -43,7 +46,7 @@   ) where  import           Control.Applicative (Alternative(..), liftA2)-import           Control.Monad (MonadPlus(..), join)+import           Control.Monad (MonadPlus(..), guard, join) import           Control.Monad.Base (MonadBase(..)) import           Control.Monad.Trans.Control () import           Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception)@@ -63,9 +66,11 @@ import           Data.Functor.Classes (Eq1(..)) import           Data.Functor.Classes (Show1(..), showsPrec1) import           Data.Functor.Classes (showsUnaryWith, showsBinaryWith)+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) @@ -91,6 +96,11 @@       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 =@@ -220,16 +230,22 @@         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 =+filter p = mapMaybe (fromPred p)++mapMaybe :: (a -> Maybe b) -> Tree a -> Maybe (Tree b)+mapMaybe p =   catMaybes .   runTreeMaybeT .-  filterMaybeT p .+  mapMaybeMaybeT p .   hoist lift  runTreeMaybeT :: Monad m => TreeT (MaybeT m) a -> TreeT m (Maybe a)@@ -243,29 +259,35 @@ --   returned. -- filterMaybeT :: (a -> Bool) -> TreeT (MaybeT Identity) a -> TreeT (MaybeT Identity) a-filterMaybeT p t =+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) ->-      hoist generalize $-        Tree . Node x $-          concatMap (flattenTree (maybe False p)) xs+      case p x of+        Nothing -> TreeT . MaybeT . Identity $ Nothing+        Just x' ->+          hoist generalize $+            Tree . Node x' $+              concatMap (flattenTree p) xs -flattenTree :: (Maybe a -> Bool) -> Tree (Maybe a) -> [Tree a]+flattenTree :: (a -> Maybe b) -> Tree (Maybe a) -> [Tree b] flattenTree p (Tree (Node mx mxs0)) =   let     mxs =       concatMap (flattenTree p) mxs0   in-    if p mx then-      case mx of-        Nothing ->-          []-        Just x ->-          [Tree (Node x mxs)]-    else-      mxs+    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. --@@ -273,14 +295,19 @@ --   'empty'. -- filterT :: (Monad m, Alternative m) => (a -> Bool) -> TreeT m a -> TreeT m a-filterT p m =+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-    if p x then-      pure $-        NodeT x (fmap (filterT p) xs)-    else-      empty+    case p x of+      Just x' ->+        pure $+          NodeT x' (fmap (mapMaybeT p) xs)+      Nothing ->+        empty  ------------------------------------------------------------------------ @@ -294,12 +321,14 @@ --   ] -- splits :: [a] -> [([a], a, [a])]-splits = \case-  [] ->-    []-  x : xs ->-    ([], x, xs) :-    fmap (\(as, b, cs) -> (x : as, b, cs)) (splits xs)+splits xs0 =+  let+    go (front : fronts) (x : xs) =+      (front, x, xs) : go fronts xs+    go _ _ =+      []+  in+    go (List.inits xs0) xs0  dropOne :: Monad m => [NodeT m a] -> [TreeT m [a]] dropOne ts = do

@@ -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)

@@ -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)

@@ -1,7 +1,9 @@ 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.Text import qualified Test.Hedgehog.Zip@@ -11,7 +13,9 @@ main =   defaultMain [       Test.Hedgehog.Applicative.tests+    , Test.Hedgehog.Confidence.tests     , Test.Hedgehog.Filter.tests+    , Test.Hedgehog.Maybe.tests     , Test.Hedgehog.Seed.tests     , Test.Hedgehog.Text.tests     , Test.Hedgehog.Zip.tests