summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormoodmosaic <>2020-06-29 04:34:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-06-29 04:34:00 (GMT)
commita4990ff4903694da2d54e4547682bb0408271939 (patch)
treec5d7fca27efa39a754d1b7b39e48d669fe434289
parent0b4ccc6d118257883429ceb8044ebd0eeaa40cb5 (diff)
version 1.0.3HEAD1.0.3master
-rw-r--r--CHANGELOG.md33
-rw-r--r--hedgehog.cabal22
-rw-r--r--src/Hedgehog.hs3
-rw-r--r--src/Hedgehog/Gen.hs7
-rw-r--r--src/Hedgehog/Internal/Discovery.hs6
-rw-r--r--src/Hedgehog/Internal/Distributive.hs1
-rw-r--r--src/Hedgehog/Internal/Gen.hs57
-rw-r--r--src/Hedgehog/Internal/Prelude.hs17
-rw-r--r--src/Hedgehog/Internal/Property.hs34
-rw-r--r--src/Hedgehog/Internal/Report.hs46
-rw-r--r--src/Hedgehog/Internal/Runner.hs9
-rw-r--r--src/Hedgehog/Internal/Source.hs1
-rw-r--r--src/Hedgehog/Internal/State.hs1
-rw-r--r--src/Hedgehog/Internal/Tree.hs38
-rw-r--r--src/Hedgehog/Main.hs1
15 files changed, 213 insertions, 63 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index a9ec4ce..757f997 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,4 +1,15 @@
+## Version 1.0.3 (2020-06-26)
+
+- Don't swallow errors if we can't find the source file ([#387][387], [@HuwCampbell][HuwCampbell])
+- Add `Property.evalNF` ([#384][384], [@dcastro][dcastro])
+- Add `Gen.either` and `Gen.either_` ([#382][382], [@dcastro][dcastro])
+- Add `filterT`, `justT`, and `mapMaybeT` to `Gen` exports ([#366][366], [@kquick][kquick])
+- Bump pretty-show to 1.10 which supports quasi-quotes ([#365][365], [@jacobstanley][jacobstanley])
+- Remove `undefined` in `GenT`'s `MonadWriter` instance ([#344][344], [@HuwCampbell][HuwCampbell])
+- Make `Tree.interleave` logarithmtic rather than linear ([#313][313], [@edsko][edsko])
+
## Version 1.0.2 (2020-01-10)
+- Support GHC 8.10 ([#376][376], [@sjakobi][sjakobi])
- 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])
@@ -168,14 +179,30 @@
[treeowl]:
https://github.com/treeowl
[tomjaguarpaw]:
- https://github.com/tomjaguarpaw
+ https://github.com/tomjaguarpaw
[symbiont-sam-halliday]:
https://github.com/symbiont-sam-halliday
[sshine]:
https://github.com/sshine
[stolyaroleh]:
https://github.com/stolyaroleh
+[kquick]:
+ https://github.com/kquick
+[dcastro]:
+ https://github.com/dcastro
+[387]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/387
+[384]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/384
+[382]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/382
+[376]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/376
+[366]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/366
+[365]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/365
[349]:
https://github.com/hedgehogqa/haskell-hedgehog/pull/349
[348]:
@@ -184,6 +211,8 @@
https://github.com/hedgehogqa/haskell-hedgehog/pull/346
[345]:
https://github.com/hedgehogqa/haskell-hedgehog/pull/345
+[344]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/344
[339]:
https://github.com/hedgehogqa/haskell-hedgehog/pull/339
[332]:
@@ -196,6 +225,8 @@
https://github.com/hedgehogqa/haskell-hedgehog/pull/321
[319]:
https://github.com/hedgehogqa/haskell-hedgehog/pull/319
+[313]:
+ https://github.com/hedgehogqa/haskell-hedgehog/pull/313
[308]:
https://github.com/hedgehogqa/haskell-hedgehog/pull/308
[303]:
diff --git a/hedgehog.cabal b/hedgehog.cabal
index 6c06676..d45714d 100644
--- a/hedgehog.cabal
+++ b/hedgehog.cabal
@@ -1,4 +1,4 @@
-version: 1.0.2
+version: 1.0.3
name:
hedgehog
@@ -29,14 +29,16 @@ license:
license-file:
LICENSE
cabal-version:
- >= 1.8
+ >= 1.10
build-type:
Simple
tested-with:
GHC == 8.0.2
, GHC == 8.2.2
, GHC == 8.4.4
- , GHC == 8.6.4
+ , GHC == 8.6.5
+ , GHC == 8.8.3
+ , GHC == 8.10.1
extra-source-files:
README.md
CHANGELOG.md
@@ -54,6 +56,7 @@ library
, bytestring >= 0.10 && < 0.11
, concurrent-output >= 1.7 && < 1.11
, containers >= 0.4 && < 0.7
+ , deepseq >= 1.1.0.0 && < 1.5
, directory >= 1.2 && < 1.4
, erf >= 2.0 && < 2.1
, exceptions >= 0.7 && < 0.11
@@ -62,13 +65,13 @@ library
, mmorph >= 1.0 && < 1.2
, monad-control >= 1.0 && < 1.1
, mtl >= 2.1 && < 2.3
- , pretty-show >= 1.6 && < 1.10
+ , pretty-show >= 1.6 && < 1.11
, primitive >= 0.6 && < 0.8
, random >= 1.1 && < 1.2
, resourcet >= 1.1 && < 1.3
, semigroups >= 0.16 && < 0.20
, stm >= 2.4 && < 2.6
- , template-haskell >= 2.10 && < 2.16
+ , template-haskell >= 2.10 && < 2.17
, text >= 1.1 && < 1.3
, time >= 1.4 && < 1.10
, transformers >= 0.5 && < 0.6
@@ -97,6 +100,7 @@ library
Hedgehog.Internal.Gen
Hedgehog.Internal.HTraversable
Hedgehog.Internal.Opaque
+ Hedgehog.Internal.Prelude
Hedgehog.Internal.Property
Hedgehog.Internal.Queue
Hedgehog.Internal.Range
@@ -112,6 +116,9 @@ library
Hedgehog.Internal.Tree
Hedgehog.Internal.Tripping
+ default-language:
+ Haskell2010
+
test-suite test
type:
exitcode-stdio-1.0
@@ -140,7 +147,10 @@ test-suite test
, containers >= 0.4 && < 0.7
, mmorph >= 1.0 && < 1.2
, mtl >= 2.1 && < 2.3
- , pretty-show >= 1.6 && < 1.10
+ , pretty-show >= 1.6 && < 1.11
, semigroups >= 0.16 && < 0.20
, text >= 1.1 && < 1.3
, transformers >= 0.3 && < 0.6
+
+ default-language:
+ Haskell2010
diff --git a/src/Hedgehog.hs b/src/Hedgehog.hs
index 5dd39df..b23a1a5 100644
--- a/src/Hedgehog.hs
+++ b/src/Hedgehog.hs
@@ -108,6 +108,7 @@ module Hedgehog (
, tripping
, eval
+ , evalNF
, evalM
, evalIO
, evalEither
@@ -164,7 +165,7 @@ import Hedgehog.Internal.Property (assert, diff, (===), (/==))
import Hedgehog.Internal.Property (classify, cover)
import Hedgehog.Internal.Property (discard, failure, success)
import Hedgehog.Internal.Property (DiscardLimit, withDiscards)
-import Hedgehog.Internal.Property (eval, evalM, evalIO)
+import Hedgehog.Internal.Property (eval, evalNF, evalM, evalIO)
import Hedgehog.Internal.Property (evalEither, evalExceptT)
import Hedgehog.Internal.Property (footnote, footnoteShow)
import Hedgehog.Internal.Property (forAll, forAllWith)
diff --git a/src/Hedgehog/Gen.hs b/src/Hedgehog/Gen.hs
index 4b093cc..e5982c5 100644
--- a/src/Hedgehog/Gen.hs
+++ b/src/Hedgehog/Gen.hs
@@ -67,11 +67,16 @@ module Hedgehog.Gen (
-- ** Conditional
, discard
, filter
+ , filterT
, mapMaybe
+ , mapMaybeT
, just
+ , justT
-- ** Collections
, maybe
+ , either
+ , either_
, list
, seq
, nonEmpty
@@ -106,4 +111,4 @@ module Hedgehog.Gen (
import Hedgehog.Internal.Gen
import Hedgehog.Internal.State (sequential, parallel)
-import Prelude hiding (filter, print, maybe, map, seq)
+import Prelude hiding (either, filter, print, maybe, map, seq)
diff --git a/src/Hedgehog/Internal/Discovery.hs b/src/Hedgehog/Internal/Discovery.hs
index f10b1b4..f21a8d0 100644
--- a/src/Hedgehog/Internal/Discovery.hs
+++ b/src/Hedgehog/Internal/Discovery.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
module Hedgehog.Internal.Discovery (
PropertySource(..)
, readProperties
@@ -20,11 +21,14 @@ import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Ord as Ord
-import Data.Semigroup (Semigroup(..))
import Hedgehog.Internal.Property (PropertyName(..))
import Hedgehog.Internal.Source (LineNo(..), ColumnNo(..))
+#if __GLASGOW_HASKELL__ < 808
+import Data.Semigroup (Semigroup(..))
+#endif
+
------------------------------------------------------------------------
-- Property Extraction
diff --git a/src/Hedgehog/Internal/Distributive.hs b/src/Hedgehog/Internal/Distributive.hs
index b988a70..63e037b 100644
--- a/src/Hedgehog/Internal/Distributive.hs
+++ b/src/Hedgehog/Internal/Distributive.hs
@@ -1,5 +1,4 @@
{-# OPTIONS_HADDOCK not-home #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
diff --git a/src/Hedgehog/Internal/Gen.hs b/src/Hedgehog/Internal/Gen.hs
index d6d4ab2..9f77e3e 100644
--- a/src/Hedgehog/Internal/Gen.hs
+++ b/src/Hedgehog/Internal/Gen.hs
@@ -12,6 +12,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
@@ -21,6 +22,7 @@
#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE DerivingVia #-}
#endif
+
module Hedgehog.Internal.Gen (
-- * Transformer
Gen
@@ -107,6 +109,8 @@ module Hedgehog.Internal.Gen (
-- ** Collections
, maybe
+ , either
+ , either_
, list
, seq
, nonEmpty
@@ -174,8 +178,6 @@ 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 (..))
-import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Morph (MFunctor(..), MMonad(..))
import qualified Control.Monad.Morph as Morph
@@ -199,9 +201,6 @@ import Data.Bifunctor (first)
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)
@@ -210,7 +209,6 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
-import Data.Semigroup (Semigroup)
import qualified Data.Semigroup as Semigroup
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
@@ -221,6 +219,7 @@ import qualified Data.Text.Encoding as Text
import Data.Word (Word8, Word16, Word32, Word64)
import Hedgehog.Internal.Distributive (MonadTransDistributive(..))
+import Hedgehog.Internal.Prelude hiding (either, maybe, seq)
import Hedgehog.Internal.Seed (Seed)
import qualified Hedgehog.Internal.Seed as Seed
import qualified Hedgehog.Internal.Shrink as Shrink
@@ -229,8 +228,12 @@ import qualified Hedgehog.Internal.Tree as Tree
import Hedgehog.Range (Size, Range)
import qualified Hedgehog.Range as Range
-import Prelude hiding (filter, print, maybe, map, seq)
-
+#if __GLASGOW_HASKELL__ < 808
+import qualified Control.Monad.Fail as Fail
+#endif
+#if __GLASGOW_HASKELL__ < 806
+import Data.Coerce (coerce)
+#endif
------------------------------------------------------------------------
-- Generator transformer
@@ -517,8 +520,7 @@ instance Monad m => Monad (GenT m) where
runGenT size sk . k =<<
runGenT size sm m
-#if MIN_VERSION_base(4,13,0)
-#else
+#if __GLASGOW_HASKELL__ < 808
fail =
Fail.fail
#endif
@@ -666,12 +668,12 @@ instance MonadWriter w m => MonadWriter w (GenT m) where
lift . writer
tell =
lift . tell
- listen =
- undefined
- --mapGenT listen
- pass =
- undefined
- --mapGenT pass
+ listen m =
+ GenT $ \size seed ->
+ listen $ runGenT size seed m
+ pass m =
+ GenT $ \size seed ->
+ pass $ runGenT size seed m
instance MonadError e m => MonadError e (GenT m) where
throwError =
@@ -1354,6 +1356,29 @@ maybe gen =
, (1 + fromIntegral n, Just <$> gen)
]
+-- | Generates either an 'a' or a 'b'.
+--
+-- As the size grows, this generator generates @Right@s more often than @Left@s.
+--
+either :: MonadGen m => m a -> m b -> m (Either a b)
+either genA genB =
+ sized $ \n ->
+ frequency [
+ (2, Left <$> genA)
+ , (1 + fromIntegral n, Right <$> genB)
+ ]
+
+-- | Generates either an 'a' or a 'b', without bias.
+--
+-- This generator generates as many @Right@s as it does @Left@s.
+--
+either_ :: MonadGen m => m a -> m b -> m (Either a b)
+either_ genA genB =
+ choice [
+ Left <$> genA
+ , Right <$> genB
+ ]
+
-- | Generates a list using a 'Range' to determine the length.
--
list :: MonadGen m => Range Int -> m a -> m [a]
diff --git a/src/Hedgehog/Internal/Prelude.hs b/src/Hedgehog/Internal/Prelude.hs
new file mode 100644
index 0000000..c3a3e9e
--- /dev/null
+++ b/src/Hedgehog/Internal/Prelude.hs
@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Mostly for compatibility across different base Prelude changes.
+--
+module Hedgehog.Internal.Prelude (
+ Semigroup(..)
+ , MonadFail
+ , module Prelude
+ ) where
+
+import Control.Monad.Fail (MonadFail)
+
+import Data.Semigroup (Semigroup(..))
+
+import Prelude hiding (filter, print, map)
diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs
index 1c093e1..f382af7 100644
--- a/src/Hedgehog/Internal/Property.hs
+++ b/src/Hedgehog/Internal/Property.hs
@@ -12,6 +12,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -20,6 +21,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Distributive
+
module Hedgehog.Internal.Property (
-- * Property
Property(..)
@@ -71,6 +73,7 @@ module Hedgehog.Internal.Property (
, (/==)
, eval
+ , evalNF
, evalM
, evalIO
, evalEither
@@ -122,12 +125,12 @@ module Hedgehog.Internal.Property (
) where
import Control.Applicative (Alternative(..))
+import Control.DeepSeq (NFData, rnf)
import Control.Monad (MonadPlus(..))
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Catch (SomeException(..), displayException)
import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Fail (MonadFail (..))
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Morph (MFunctor(..))
@@ -152,13 +155,13 @@ import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Data.Char as Char
+import Data.Functor (($>))
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)
@@ -167,11 +170,13 @@ import Hedgehog.Internal.Distributive
import Hedgehog.Internal.Exception
import Hedgehog.Internal.Gen (Gen, GenT)
import qualified Hedgehog.Internal.Gen as Gen
+import Hedgehog.Internal.Prelude
import Hedgehog.Internal.Show
import Hedgehog.Internal.Source
import Language.Haskell.TH.Syntax (Lift)
+
------------------------------------------------------------------------
-- | A property test, along with some configurable limits like how many times
@@ -700,9 +705,17 @@ failDiff x y =
-- message.
--
failException :: (MonadTest m, HasCallStack) => SomeException -> m a
-failException (SomeException x) =
+failException x =
withFrozenCallStack $
- failWith Nothing $ unlines [
+ failExceptionWith [] x
+
+-- | Fails with an error which renders the given messages, the type of an exception,
+-- and its error message.
+--
+failExceptionWith :: (MonadTest m, HasCallStack) => [String] -> SomeException -> m a
+failExceptionWith messages (SomeException x) =
+ withFrozenCallStack
+ failWith Nothing $ unlines $ messages <> [
"━━━ Exception (" ++ show (typeOf x) ++ ") ━━━"
, List.dropWhileEnd Char.isSpace (displayException x)
]
@@ -779,6 +792,17 @@ eval :: (MonadTest m, HasCallStack) => a -> m a
eval x =
either (withFrozenCallStack failException) pure (tryEvaluate x)
+-- | Fails the test if the value throws an exception when evaluated to
+-- normal form (NF).
+--
+evalNF :: (MonadTest m, NFData a, HasCallStack) => a -> m a
+evalNF x =
+ let
+ messages =
+ ["━━━ Value could not be evaluated to normal form ━━━"]
+ in
+ either (withFrozenCallStack (failExceptionWith messages)) pure (tryEvaluate (rnf x)) $> x
+
-- | Fails the test if the action throws an exception.
--
-- /The benefit of using this over simply letting the exception bubble up is/
@@ -1107,7 +1131,7 @@ coverageSuccess tests =
coverageFailures :: TestCount -> Coverage CoverCount -> [Label CoverCount]
coverageFailures tests (Coverage kvs) =
- filter (not . labelCovered tests) (Map.elems kvs)
+ List.filter (not . labelCovered tests) (Map.elems kvs)
-- | Is true when the test coverage satisfies the specified 'Confidence'
-- contstraint for all 'Coverage CoverCount's
diff --git a/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs
index b1eba01..1b827fb 100644
--- a/src/Hedgehog/Internal/Report.hs
+++ b/src/Hedgehog/Internal/Report.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
@@ -45,14 +46,14 @@ import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe, catMaybes)
-import Data.Semigroup (Semigroup(..))
import Data.Traversable (for)
import Hedgehog.Internal.Config
import Hedgehog.Internal.Discovery (Pos(..), Position(..))
import qualified Hedgehog.Internal.Discovery as Discovery
-import Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))
+import Hedgehog.Internal.Prelude
import Hedgehog.Internal.Property (CoverCount(..), CoverPercentage(..))
+import Hedgehog.Internal.Property (Coverage(..), Label(..), LabelName(..))
import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))
import Hedgehog.Internal.Property (ShrinkCount(..), PropertyCount(..))
import Hedgehog.Internal.Property (TestCount(..), DiscardCount(..))
@@ -608,25 +609,34 @@ ppTextLines =
ppFailureReport :: MonadIO m => Maybe PropertyName -> TestCount -> FailureReport -> m [Doc Markup]
ppFailureReport name tests (FailureReport size seed _ mcoverage inputs0 mlocation0 msg mdiff msgs0) = do
+ let
+ basic =
+ -- Move the failure message to the end section if we have
+ -- no source location or can't find the source file.
+ let
+ msgs1 =
+ msgs0 ++
+ (if null msg then [] else [msg])
+
+ docs =
+ concatMap ppTextLines msgs1 ++
+ maybe [] ppDiff mdiff
+ in
+ (docs, Nothing)
+
(msgs1, mlocation) <-
case mlocation0 of
Nothing ->
- -- Move the failure message to the end section if we have
- -- no source location.
- let
- msgs1 =
- msgs0 ++
- (if null msg then [] else [msg])
-
- docs =
- concatMap ppTextLines msgs1 ++
- maybe [] ppDiff mdiff
- in
- pure (docs, Nothing)
-
- Just location0 ->
- fmap (concatMap ppTextLines msgs0,) $
+ return basic
+
+ Just location0 -> do
+ mAdvanced <-
ppFailureLocation (fmap WL.text $ List.lines msg) mdiff location0
+ case mAdvanced of
+ Just advanced ->
+ return (concatMap ppTextLines msgs0, Just advanced)
+ Nothing ->
+ return basic
coverageLocations <-
case mcoverage of
@@ -678,7 +688,7 @@ ppFailureReport name tests (FailureReport size seed _ mcoverage inputs0 mlocatio
WL.punctuate WL.line .
fmap (WL.vsep . fmap (WL.indent 2)) .
fmap (id :: [Doc Markup] -> [Doc Markup]) .
- filter (not . null) $
+ List.filter (not . null) $
concat [
with args $
WL.punctuate WL.line
diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs
index f41b56b..329f699 100644
--- a/src/Hedgehog/Internal/Runner.hs
+++ b/src/Hedgehog/Internal/Runner.hs
@@ -5,8 +5,10 @@
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
+
module Hedgehog.Internal.Runner (
-- * Running Individual Properties
check
@@ -29,20 +31,19 @@ import qualified Control.Concurrent.STM.TVar as TVar
import Control.Monad.Catch (MonadCatch(..), catchAll)
import Control.Monad.IO.Class (MonadIO(..))
-import Data.Semigroup ((<>))
-
import Hedgehog.Internal.Config
import Hedgehog.Internal.Gen (evalGenT)
+import Hedgehog.Internal.Prelude
import Hedgehog.Internal.Property (DiscardCount(..), ShrinkCount(..))
import Hedgehog.Internal.Property (Group(..), GroupName(..))
import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..))
import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..))
import Hedgehog.Internal.Property (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 (TestCount(..), PropertyCount(..))
import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure)
+import Hedgehog.Internal.Property (coverageSuccess, journalCoverage)
import Hedgehog.Internal.Property (defaultMinTests)
import Hedgehog.Internal.Queue
import Hedgehog.Internal.Region
diff --git a/src/Hedgehog/Internal/Source.hs b/src/Hedgehog/Internal/Source.hs
index f02b696..4e2de24 100644
--- a/src/Hedgehog/Internal/Source.hs
+++ b/src/Hedgehog/Internal/Source.hs
@@ -1,6 +1,5 @@
{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
diff --git a/src/Hedgehog/Internal/State.hs b/src/Hedgehog/Internal/State.hs
index 5ea46e2..9511769 100644
--- a/src/Hedgehog/Internal/State.hs
+++ b/src/Hedgehog/Internal/State.hs
@@ -1,5 +1,4 @@
{-# OPTIONS_HADDOCK not-home #-}
-{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
diff --git a/src/Hedgehog/Internal/Tree.hs b/src/Hedgehog/Internal/Tree.hs
index 495a696..617f241 100644
--- a/src/Hedgehog/Internal/Tree.hs
+++ b/src/Hedgehog/Internal/Tree.hs
@@ -11,6 +11,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- MonadBase
+#if __GLASGOW_HASKELL__ < 802
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+#endif
module Hedgehog.Internal.Tree (
Tree
, pattern Tree
@@ -86,7 +89,9 @@ type Tree =
pattern Tree :: NodeT Identity a -> Tree a
pattern Tree node =
TreeT (Identity node)
+#if __GLASGOW_HASKELL__ >= 802
{-# COMPLETE Tree #-}
+#endif
-- | An effectful tree, each node in the tree can have an effect before it is
-- produced.
@@ -105,7 +110,9 @@ instance MonadBaseControl b m => MonadBaseControl b (TreeT m) where
--
type Node =
NodeT Identity
+#if __GLASGOW_HASKELL__ >= 802
{-# COMPLETE Node #-}
+#endif
-- | Pattern to ease construction / deconstruction of pure nodes.
--
@@ -330,11 +337,30 @@ splits xs0 =
in
go (List.inits xs0) xs0
-dropOne :: Monad m => [NodeT m a] -> [TreeT m [a]]
-dropOne ts = do
- (xs, _y, zs) <- splits ts
- pure . TreeT . pure $
- interleave (xs ++ zs)
+-- | @removes n@ computes all ways we can remove chunks of size @n@ from a list
+--
+-- Examples
+--
+-- > removes 1 [1..3] == [[2,3],[1,3],[1,2]]
+-- > removes 2 [1..4] == [[3,4],[1,2]]
+-- > removes 2 [1..5] == [[3,4,5],[1,2,5],[1,2,3,4]]
+-- > removes 3 [1..5] == [[4,5],[1,2,3]]
+--
+-- Note that the last chunk we delete might have fewer elements than @n@.
+removes :: forall a. Int -> [a] -> [[a]]
+removes k = \xs -> go xs
+ where
+ go :: [a] -> [[a]]
+ go [] = []
+ go xs = xs2 : map (xs1 ++) (go xs2)
+ where
+ (xs1, xs2) = splitAt k xs
+
+dropSome :: Monad m => [NodeT m a] -> [TreeT m [a]]
+dropSome ts = do
+ n <- takeWhile (> 0) $ iterate (`div` 2) (length ts)
+ ts' <- removes n ts
+ pure . TreeT . pure $ interleave ts'
shrinkOne :: Monad m => [NodeT m a] -> [TreeT m [a]]
shrinkOne ts = do
@@ -349,7 +375,7 @@ interleave :: forall m a. Monad m => [NodeT m a] -> NodeT m [a]
interleave ts =
NodeT (fmap nodeValue ts) $
concat [
- dropOne ts
+ dropSome ts
, shrinkOne ts
]
diff --git a/src/Hedgehog/Main.hs b/src/Hedgehog/Main.hs
index 55958ac..ffcac56 100644
--- a/src/Hedgehog/Main.hs
+++ b/src/Hedgehog/Main.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
module Hedgehog.Main (
-- * Running tests
defaultMain