hedgehog (empty) → 0.1
raw patch · 19 files changed
+4848/−0 lines, 19 filesdep +ansi-terminaldep +asyncdep +basesetup-changed
Dependencies added: ansi-terminal, async, base, bytestring, concurrent-output, containers, directory, exceptions, hedgehog, mmorph, mtl, pretty-show, primitive, random, resourcet, semigroups, template-haskell, text, th-lift, time, transformers, transformers-base, wl-pprint-annotated
Files
- LICENSE +29/−0
- README.md +18/−0
- Setup.hs +2/−0
- hedgehog.cabal +120/−0
- src/Hedgehog.hs +88/−0
- src/Hedgehog/Gen.hs +1240/−0
- src/Hedgehog/Internal/Discovery.hs +226/−0
- src/Hedgehog/Internal/Property.hs +431/−0
- src/Hedgehog/Internal/Report.hs +786/−0
- src/Hedgehog/Internal/Runner.hs +339/−0
- src/Hedgehog/Internal/Seed.hs +230/−0
- src/Hedgehog/Internal/Show.hs +274/−0
- src/Hedgehog/Internal/Shrink.hs +128/−0
- src/Hedgehog/Internal/Source.hs +108/−0
- src/Hedgehog/Internal/TH.hs +92/−0
- src/Hedgehog/Internal/Tree.hs +366/−0
- src/Hedgehog/Internal/Tripping.hs +47/−0
- src/Hedgehog/Range.hs +306/−0
- test/test.hs +18/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright 2017, Jacob Stanley+All Rights Reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ 3. Neither the name of the copyright holder nor the names of+ its contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,18 @@+hedgehog [](http://hackage.haskell.org/package/hedgehog) [](https://travis-ci.org/hedgehogqa/haskell-hedgehog)+========++> Hedgehog will eat all your bugs.++<img src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo.png" width="307" align="right"/>++[Hedgehog](http://hedgehog.qa/) is a modern property-based testing+system, in the spirit of QuickCheck. Hedgehog uses integrated shrinking,+so shrinks obey the invariants of generated values by construction.++## Features++- Integrated shrinking, shrinks obey invariants by construction.+- Generators allow monadic effects.+- Range combinators for full control over the scope of generated numbers and collections.+- Equality and roundtrip assertions show a diff instead of the two inequal values.+- Template Haskell test runner which executes properties concurrently.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hedgehog.cabal view
@@ -0,0 +1,120 @@+name:+ hedgehog+version:+ 0.1+license:+ BSD3+author:+ Jacob Stanley+maintainer:+ Jacob Stanley <jacob@stanley.io>+homepage:+ https://hedgehog.qa+bug-reports:+ https://github.com/hedgehogqa/haskell-hedgehog/issues+synopsis:+ Hedgehog will eat all your bugs.+description:+ Hedgehog is a modern property-based testing system, in the spirit of+ QuickCheck. Hedgehog uses integrated shrinking, so shrinks obey the+ invariants of generated values by construction.+ .+ To get started quickly, see the examples:+ <https://github.com/hedgehogqa/haskell-hedgehog/tree/master/hedgehog-example>+category:+ Testing+license:+ BSD3+license-file:+ LICENSE+cabal-version:+ >= 1.8+build-type:+ Simple+tested-with:+ GHC == 7.10.2+ , GHC == 7.10.3+ , GHC == 8.0.1+ , GHC == 8.0.2+extra-source-files:+ README.md++source-repository head+ type: git+ location: git://github.com/hedgehogqa/haskell-hedgehog.git++library+ build-depends:+ base >= 3 && < 5+ , ansi-terminal >= 0.6 && < 0.7+ , async >= 2.0 && < 2.2+ , bytestring >= 0.10 && < 0.11+ , concurrent-output >= 1.7 && < 1.8+ , containers >= 0.4 && < 0.6+ , directory >= 1.2 && < 1.4+ , exceptions >= 0.7 && < 0.9+ , mmorph >= 1.0 && < 1.1+ , mtl >= 2.1 && < 2.3+ , pretty-show >= 1.6 && < 1.7+ , primitive >= 0.6 && < 0.7+ , random >= 1.1 && < 1.2+ , resourcet >= 1.1 && < 1.2+ , template-haskell >= 2.10 && < 2.12+ , text >= 1.1 && < 1.3+ , th-lift >= 0.7 && < 0.8+ , time >= 1.4 && < 1.9+ , transformers >= 0.3 && < 0.6+ , transformers-base >= 0.4 && < 0.5+ , wl-pprint-annotated >= 0.0 && < 0.1++ if impl(ghc < 8.0)+ build-depends:+ semigroups >= 0.16 && < 0.19++ ghc-options:+ -Wall++ hs-source-dirs:+ src++ exposed-modules:+ Hedgehog+ Hedgehog.Gen+ Hedgehog.Range++ Hedgehog.Internal.Discovery+ Hedgehog.Internal.Property+ Hedgehog.Internal.Report+ Hedgehog.Internal.Runner+ Hedgehog.Internal.Seed+ Hedgehog.Internal.Show+ Hedgehog.Internal.Shrink+ Hedgehog.Internal.Source+ Hedgehog.Internal.TH+ Hedgehog.Internal.Tree+ Hedgehog.Internal.Tripping++test-suite test+ type:+ exitcode-stdio-1.0++ main-is:+ test.hs++ ghc-options:+ -Wall -threaded -O2++ hs-source-dirs:+ test++ build-depends:+ hedgehog+ , base >= 3 && < 5+ , containers >= 0.4 && < 0.6+ , pretty-show >= 1.6 && < 1.7+ , text >= 1.1 && < 1.3+ , transformers >= 0.3 && < 0.6++ if impl(ghc < 8.0)+ build-depends:+ semigroups >= 0.16 && < 0.19
+ src/Hedgehog.hs view
@@ -0,0 +1,88 @@+-- |+-- This module includes almost everything you need to get started writing+-- property tests with Hedgehog.+--+-- It is designed to be used alongside "Hedgehog.Gen" and "Hedgehog.Range",+-- which should be imported qualified. You also need to enable Template Haskell+-- so the Hedgehog test runner can find your properties.+--+-- > {-# LANGUAGE TemplateHaskell #-}+-- >+-- > import Hedgehog+-- > import qualified Hedgehog.Gen as Gen+-- > import qualified Hedgehog.Range as Range+--+-- Once you have your imports set up, you can write a simple property:+--+-- > prop_reverse :: Property+-- > prop_reverse =+-- > property $ do+-- > xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha+-- > reverse (reverse xs) === xs+--+-- And add the Template Haskell splice which will run your properies:+--+-- > tests :: IO Bool+-- > tests =+-- > $$(checkConcurrent)+--+-- You can then load the module in GHCi, and run it:+--+-- >>> tests+-- ━━━ Test.Example ━━━+-- ✓ prop_reverse passed 100 tests.+--+module Hedgehog (+ Property+ , Test+ , TestLimit+ , DiscardLimit+ , ShrinkLimit++ , Gen+ , Range+ , Size(..)+ , Seed(..)++ -- * Property+ , property+ , withTests+ , withDiscards+ , withShrinks++ , check+ , checkSequential+ , checkConcurrent+ , recheck++ -- * Test+ , forAll+ , info+ , success+ , discard+ , failure+ , assert+ , (===)++ , liftEither+ , liftExceptT+ , withResourceT++ , tripping+ ) where++import Hedgehog.Gen (Gen)+import Hedgehog.Internal.Property (assert, (===))+import Hedgehog.Internal.Property (discard, failure, success)+import Hedgehog.Internal.Property (DiscardLimit, withDiscards)+import Hedgehog.Internal.Property (forAll, info)+import Hedgehog.Internal.Property (liftEither, liftExceptT, withResourceT)+import Hedgehog.Internal.Property (Property)+import Hedgehog.Internal.Property (ShrinkLimit, withShrinks)+import Hedgehog.Internal.Property (Test, property)+import Hedgehog.Internal.Property (TestLimit, withTests)+import Hedgehog.Internal.Runner (check, recheck)+import Hedgehog.Internal.Seed (Seed(..))+import Hedgehog.Internal.TH (checkSequential, checkConcurrent)+import Hedgehog.Internal.Tripping (tripping)+import Hedgehog.Range (Range, Size(..))
+ src/Hedgehog/Gen.hs view
@@ -0,0 +1,1240 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- MonadBase+module Hedgehog.Gen (+ -- * Transformer+ Gen(..)++ -- * Combinators+ -- ** Shrinking+ , shrink+ , prune++ -- ** Size+ , small+ , scale+ , resize+ , sized++ -- ** Integral+ , integral+ , integral_++ , int+ , int8+ , int16+ , int32+ , int64++ , word+ , word8+ , word16+ , word32+ , word64++ -- ** Floating-point+ , realFloat+ , realFrac_+ , float+ , double++ -- ** Enumeration+ , enum+ , enumBounded+ , bool+ , bool_++ -- ** Characters+ , binit+ , octit+ , digit+ , hexit+ , lower+ , upper+ , alpha+ , alphaNum++ -- ** Strings+ , string+ , text+ , utf8+ , bytes++ -- ** Choice+ , element+ , choice+ , frequency+ , recursive++ -- ** Conditional+ , discard+ , filter+ , just++ -- ** Collections+ , maybe+ , list+ , nonEmpty+ , set+ , map++ -- ** Subterms+ , subterm+ , subtermM+ , subterm2+ , subtermM2+ , subterm3+ , subtermM3++ -- ** Combinations & Permutations+ , subsequence+ , shuffle++ -- * Sampling Generators+ , sample+ , print+ , printTree+ , printWith+ , printTreeWith++ -- * Internal+ -- $internal++ -- ** Transfomer+ , runGen+ , mapGen+ , generate+ , liftTree+ , runDiscardEffect++ -- ** Size+ , golden++ -- ** Shrinking+ , atLeast++ -- ** Subterms+ , Vec(..)+ , Nat(..)+ , subtermMVec+ , freeze++ -- ** Sampling+ , renderNodes+ ) where++import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..), mfilter, filterM, replicateM, ap)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Morph (MFunctor(..), MMonad(..))+import Control.Monad.Primitive (PrimMonad(..))+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Trans.Resource (MonadResource(..))+import Control.Monad.Writer.Class (MonadWriter(..))++import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.Char as Char+import Data.Foldable (for_, toList)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import Data.Set (Set)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Word (Word8, Word16, Word32, Word64)++import Hedgehog.Internal.Seed (Seed)+import qualified Hedgehog.Internal.Seed as Seed+import qualified Hedgehog.Internal.Shrink as Shrink+import Hedgehog.Internal.Tree (Tree(..), Node(..))+import qualified Hedgehog.Internal.Tree as Tree+import Hedgehog.Range (Size, Range)+import qualified Hedgehog.Range as Range++import Prelude hiding (filter, print, maybe, map)+++------------------------------------------------------------------------+-- Generator transformer++-- | Generator for random values of @a@.+--+newtype Gen m a =+ Gen {+ unGen :: Size -> Seed -> Tree (MaybeT m) a+ }++-- | Runs a generator, producing its shrink tree.+--+runGen :: Size -> Seed -> Gen m a -> Tree (MaybeT m) a+runGen size seed (Gen m) =+ m size seed++-- | Map over a generator's shrink tree.+--+mapGen :: (Tree (MaybeT m) a -> Tree (MaybeT n) b) -> Gen m a -> Gen n b+mapGen f gen =+ Gen $ \size seed ->+ f (runGen size seed gen)++-- | Generate a value with no shrinks from a 'Size' and a 'Seed'.+--+generate :: Monad m => (Size -> Seed -> a) -> Gen m a+generate f =+ Gen $ \size seed ->+ pure (f size seed)++-- | Freeze the size and seed used by a generator, so we can inspect the value+-- which it will produce.+--+-- This is used for implementing `list` and `subtermMVec`. It allows us to+-- shrink the list itself before trying to shrink the values inside the list.+--+freeze :: Monad m => Gen m a -> Gen m (a, Gen m a)+freeze gen =+ Gen $ \size seed -> do+ mx <- lift . lift . runMaybeT . runTree $ runGen size seed gen+ case mx of+ Nothing ->+ mzero+ Just (Node x xs) ->+ pure (x, liftTree . Tree . pure $ Node x xs)++-- | Lift a predefined shrink tree in to a generator, ignoring the seed and the+-- size.+--+liftTree :: Tree (MaybeT m) a -> Gen m a+liftTree x =+ Gen (\_ _ -> x)++-- | Run the discard effects through the tree and reify them as 'Maybe' values+-- at the nodes. 'Nothing' means discarded, 'Just' means we have a value.+--+runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a)+runDiscardEffect s = do+ Tree $ do+ mx <- runMaybeT $ runTree s+ case mx of+ Nothing ->+ pure $ Node Nothing []+ Just (Node x xs) ->+ pure $ Node (Just x) (fmap runDiscardEffect xs)++------------------------------------------------------------------------+-- Gen instances++instance Functor m => Functor (Gen m) where+ fmap f gen =+ Gen $ \seed size ->+ fmap f (runGen seed size gen)++instance Monad m => Applicative (Gen m) where+ pure =+ return+ (<*>) =+ ap++instance Monad m => Monad (Gen m) where+ return =+ liftTree . pure++ (>>=) m k =+ Gen $ \size seed ->+ case Seed.split seed of+ (sk, sm) ->+ runGen size sk . k =<<+ runGen size sm m++instance Monad m => Alternative (Gen m) where+ empty =+ mzero+ (<|>) =+ mplus++instance Monad m => MonadPlus (Gen m) where+ mzero =+ liftTree mzero++ mplus x y =+ Gen $ \size seed ->+ case Seed.split seed of+ (sx, sy) ->+ runGen size sx x `mplus`+ runGen size sy y++instance MonadTrans Gen where+ lift =+ liftTree . lift . lift++instance MFunctor Gen where+ hoist f =+ mapGen (hoist (hoist f))++embedMaybe ::+ MonadTrans t+ => Monad n+ => Monad (t (MaybeT n))+ => (forall a. m a -> t (MaybeT n) a)+ -> MaybeT m b+ -> t (MaybeT n) b+embedMaybe f m =+ lift . MaybeT . pure =<< f (runMaybeT m)++embedTree :: Monad n => (forall a. m a -> Tree (MaybeT n) a) -> Tree (MaybeT m) b -> Tree (MaybeT n) b+embedTree f tree =+ embed (embedMaybe f) tree++embedGen :: Monad n => (forall a. m a -> Gen n a) -> Gen m b -> Gen n b+embedGen f gen =+ Gen $ \size seed ->+ case Seed.split seed of+ (sf, sg) ->+ (runGen size sf . f) `embedTree`+ (runGen size sg gen)++instance MMonad Gen where+ embed =+ embedGen++instance PrimMonad m => PrimMonad (Gen m) where+ type PrimState (Gen m) =+ PrimState m+ primitive =+ lift . primitive++instance MonadIO m => MonadIO (Gen m) where+ liftIO =+ lift . liftIO++instance MonadBase b m => MonadBase b (Gen m) where+ liftBase =+ lift . liftBase++instance MonadThrow m => MonadThrow (Gen m) where+ throwM =+ lift . throwM++instance MonadCatch m => MonadCatch (Gen m) where+ catch m onErr =+ Gen $ \size seed ->+ case Seed.split seed of+ (sm, se) ->+ (runGen size sm m) `catch`+ (runGen size se . onErr)++instance MonadReader r m => MonadReader r (Gen m) where+ ask =+ lift ask+ local f m =+ mapGen (local f) m++instance MonadState s m => MonadState s (Gen m) where+ get =+ lift get+ put =+ lift . put+ state =+ lift . state++instance MonadWriter w m => MonadWriter w (Gen m) where+ writer =+ lift . writer+ tell =+ lift . tell+ listen =+ mapGen listen+ pass =+ mapGen pass++instance MonadError e m => MonadError e (Gen m) where+ throwError =+ lift . throwError+ catchError m onErr =+ Gen $ \size seed ->+ case Seed.split seed of+ (sm, se) ->+ (runGen size sm m) `catchError`+ (runGen size se . onErr)++instance MonadResource m => MonadResource (Gen m) where+ liftResourceT =+ lift . liftResourceT++------------------------------------------------------------------------+-- Shrinking++-- | Apply a shrinking function to a generator.+--+-- This will give the generator additional shrinking options, while keeping+-- the existing shrinks intact.+--+shrink :: Monad m => (a -> [a]) -> Gen m a -> Gen m a+shrink =+ mapGen . Tree.expand++-- | Throw away a generator's shrink tree.+--+prune :: Monad m => Gen m a -> Gen m a+prune =+ mapGen Tree.prune++------------------------------------------------------------------------+-- Combinators - Size++-- | Construct a generator that depends on the size parameter.+--+sized :: (Size -> Gen m a) -> Gen m a+sized f =+ Gen $ \size seed ->+ runGen size seed (f size)++-- | Override the size parameter. Returns a generator which uses the given size+-- instead of the runtime-size parameter.+--+resize :: Size -> Gen m a -> Gen m a+resize size gen =+ if size < 0 then+ error "Hedgehog.Random.resize: negative size"+ else+ Gen $ \_ seed ->+ runGen size seed gen++-- | Adjust the size parameter by transforming it with the given function.+--+scale :: (Size -> Size) -> Gen m a -> Gen m a+scale f gen =+ sized $ \n ->+ resize (f n) gen++-- | Make a generator smaller by scaling its size parameter.+--+small :: Gen m a -> Gen m a+small =+ scale golden++-- | Scale a size using the golden ratio.+--+-- > golden x = x / φ+-- > golden x = x / 1.61803..+--+golden :: Size -> Size+golden x =+ round (fromIntegral x * 0.61803398875 :: Double)++------------------------------------------------------------------------+-- Combinators - Integral++-- | Generates a random integral number in the given @[inclusive,inclusive]@ range.+--+-- When the generator tries to shrink, it will shrink towards the+-- 'Range.origin' of the specified 'Range'.+--+-- For example, the following generator will produce a number between @1970@+-- and @2100@, but will shrink towards @2000@:+--+-- @+-- integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int'+-- @+--+-- Some sample outputs from this generator might look like:+--+-- > === Outcome ===+-- > 1973+-- > === Shrinks ===+-- > 2000+-- > 1987+-- > 1980+-- > 1976+-- > 1974+--+-- > === Outcome ===+-- > 2061+-- > === Shrinks ===+-- > 2000+-- > 2031+-- > 2046+-- > 2054+-- > 2058+-- > 2060+--+integral :: (Monad m, Integral a) => Range a -> Gen m a+integral range =+ shrink (Shrink.towards $ Range.origin range) (integral_ range)++-- | Generates a random integral number in the [inclusive,inclusive] range.+--+-- /This generator does not shrink./+--+integral_ :: (Monad m, Integral a) => Range a -> Gen m a+integral_ range =+ generate $ \size seed ->+ let+ (x, y) =+ Range.bounds size range+ in+ fromInteger . fst $+ Seed.nextInteger (toInteger x) (toInteger y) seed++-- | Generates a random machine integer in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+int :: Monad m => Range Int -> Gen m Int+int =+ integral++-- | Generates a random 8-bit integer in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+int8 :: Monad m => Range Int8 -> Gen m Int8+int8 =+ integral++-- | Generates a random 16-bit integer in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+int16 :: Monad m => Range Int16 -> Gen m Int16+int16 =+ integral++-- | Generates a random 32-bit integer in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+int32 :: Monad m => Range Int32 -> Gen m Int32+int32 =+ integral++-- | Generates a random 64-bit integer in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+int64 :: Monad m => Range Int64 -> Gen m Int64+int64 =+ integral++-- | Generates a random machine word in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+word :: Monad m => Range Word -> Gen m Word+word =+ integral++-- | Generates a random byte in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+word8 :: Monad m => Range Word8 -> Gen m Word8+word8 =+ integral++-- | Generates a random 16-bit word in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+word16 :: Monad m => Range Word16 -> Gen m Word16+word16 =+ integral++-- | Generates a random 32-bit word in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+word32 :: Monad m => Range Word32 -> Gen m Word32+word32 =+ integral++-- | Generates a random 64-bit word in the given @[inclusive,inclusive]@ range.+--+-- /This is a specialization of 'integral', offered for convenience./+--+word64 :: Monad m => Range Word64 -> Gen m Word64+word64 =+ integral++------------------------------------------------------------------------+-- Combinators - Fractional / Floating-Point++-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.+--+-- This generator works the same as 'integral', but for floating point numbers.+--+realFloat :: (Monad m, RealFloat a) => Range a -> Gen m a+realFloat range =+ shrink (Shrink.towardsFloat $ Range.origin range) (realFrac_ range)++-- | Generates a random fractional number in the [inclusive,exclusive) range.+--+-- /This generator does not shrink./+--+realFrac_ :: (Monad m, RealFrac a) => Range a -> Gen m a+realFrac_ range =+ generate $ \size seed ->+ let+ (x, y) =+ Range.bounds size range+ in+ realToFrac . fst $+ Seed.nextDouble (realToFrac x) (realToFrac y) seed++-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.+--+-- /This is a specialization of 'realFloat', offered for convenience./+--+float :: Monad m => Range Float -> Gen m Float+float =+ realFloat++-- | Generates a random floating-point number in the @[inclusive,exclusive)@ range.+--+-- /This is a specialization of 'realFloat', offered for convenience./+--+double :: Monad m => Range Double -> Gen m Double+double =+ realFloat++------------------------------------------------------------------------+-- Combinators - Enumeration++-- | Generates an element from an enumeration.+--+-- This generator shrinks towards the first argument.+--+-- For example:+--+-- @+-- enum \'a' \'z' :: 'Gen' 'Char'+-- @+--+enum :: (Monad m, Enum a) => a -> a -> Gen m a+enum lo hi =+ fmap toEnum . integral $+ Range.constant (fromEnum lo) (fromEnum hi)++-- | Generates a random value from a bounded enumeration.+--+-- This generator shrinks towards 'minBound'.+--+-- For example:+--+-- @+-- enumBounded :: 'Gen' 'Bool'+-- @+--+enumBounded :: (Monad m, Enum a, Bounded a) => Gen m a+enumBounded =+ enum minBound maxBound++-- | Generates a random boolean.+--+-- This generator shrinks to 'False'.+--+-- /This is a specialization of 'enumBounded', offered for convenience./+--+bool :: Monad m => Gen m Bool+bool =+ enumBounded++-- | Generates a random boolean.+--+-- /This generator does not shrink./+--+bool_ :: Monad m => Gen m Bool+bool_ =+ generate $ \_ seed ->+ (/= 0) . fst $ Seed.nextInteger 0 1 seed++------------------------------------------------------------------------+-- Combinators - Characters++-- | Generates an ASCII binit: @'0'..'1'@+--+binit :: Monad m => Gen m Char+binit =+ enum '0' '1'++-- | Generates an ASCII octit: @'0'..'7'@+--+octit :: Monad m => Gen m Char+octit =+ enum '0' '7'++-- | Generates an ASCII digit: @'0'..'9'@+--+digit :: Monad m => Gen m Char+digit =+ enum '0' '9'++-- | Generates an ASCII hexit: @'0'..'9', \'a\'..\'f\', \'A\'..\'F\'@+--+hexit :: Monad m => Gen m Char+hexit =+ -- FIXME optimize lookup, use a SmallArray or something.+ element "0123456789aAbBcCdDeEfF"++-- | Generates an ASCII lowercase letter: @\'a\'..\'z\'@+--+lower :: Monad m => Gen m Char+lower =+ enum 'a' 'z'++-- | Generates an ASCII uppercase letter: @\'A\'..\'Z\'@+--+upper :: Monad m => Gen m Char+upper =+ enum 'A' 'Z'++-- | Generates an ASCII letter: @\'a\'..\'z\', \'A\'..\'Z\'@+--+alpha :: Monad m => Gen m Char+alpha =+ -- FIXME optimize lookup, use a SmallArray or something.+ element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"++-- | Generates an ASCII letter or digit: @\'a\'..\'z\', \'A\'..\'Z\', \'0\'..\'9\'@+--+alphaNum :: Monad m => Gen m Char+alphaNum =+ -- FIXME optimize lookup, use a SmallArray or something.+ element "abcdefghiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"++------------------------------------------------------------------------+-- Combinators - Strings++-- | Generates a string using 'Range' to determine the length.+--+-- /This is a specialization of 'list', offered for convenience./+--+string :: Monad m => Range Int -> Gen m Char -> Gen m String+string =+ list++-- | Generates a string using 'Range' to determine the length.+--+text :: Monad m => Range Int -> Gen m Char -> Gen m Text+text range =+ fmap Text.pack . string range++-- | Generates a UTF-8 encoded string, using 'Range' to determine the length.+--+utf8 :: Monad m => Range Int -> Gen m Char -> Gen m ByteString+utf8 range =+ fmap Text.encodeUtf8 . text range++-- | Generates a random 'ByteString', using 'Range' to determine the+-- length.+--+bytes :: Monad m => Range Int -> Gen m ByteString+bytes range =+ fmap ByteString.pack $+ choice [+ list range . word8 $+ Range.constant+ (fromIntegral $ Char.ord 'a')+ (fromIntegral $ Char.ord 'z')++ , list range . word8 $+ Range.constant minBound maxBound+ ]++------------------------------------------------------------------------+-- Combinators - Choice++-- | Randomly selects one of the elements in the list.+--+-- This generator shrinks towards the first element in the list.+--+-- /The input list must be non-empty./+--+element :: Monad m => [a] -> Gen m a+element = \case+ [] ->+ error "Hedgehog.Gen.element: used with empty list"+ xs -> do+ n <- integral $ Range.constant 0 (length xs - 1)+ pure $ xs !! n++-- | Randomly selects one of the generators in the list.+--+-- This generator shrinks towards the first generator in the list.+--+-- /The input list must be non-empty./+--+choice :: Monad m => [Gen m a] -> Gen m a+choice = \case+ [] ->+ error "Hedgehog.Gen.choice: used with empty list"+ xs -> do+ n <- integral $ Range.constant 0 (length xs - 1)+ xs !! n++-- | Uses a weighted distribution to randomly select one of the generators in+-- the list.+--+-- This generator shrinks towards the first generator in the list.+--+-- /The input list must be non-empty./+--+frequency :: Monad m => [(Int, Gen m a)] -> Gen m a+frequency = \case+ [] ->+ error "Hedgehog.Gen.frequency: used with empty list"+ xs0 -> do+ let+ pick n = \case+ [] ->+ error "Hedgehog.Gen.frequency/pick: used with empty list"+ (k, x) : xs ->+ if n <= k then+ x+ else+ pick (n - k) xs++ total =+ sum (fmap fst xs0)++ n <- integral $ Range.constant 1 total+ pick n xs0++-- | Modifies combinators which choose from a list of generators, like 'choice'+-- or 'frequency', so that they can be used in recursive scenarios.+--+-- This combinator modifies its target to select one of the generators in+-- either the non-recursive or the recursive list. When a selection is made+-- from the recursive list, the 'Size' is halved. When the 'Size' gets to one+-- or less, selections are no longer made from the recursive list, this+-- ensures termination.+--+-- A good example of where this might be useful is abstract syntax trees:+--+-- @+-- data Expr =+-- Var String+-- | Lam String Expr+-- | App Expr Expr+--+-- -- Assuming we have a name generator+-- genName :: 'Monad' m => 'Gen' m String+--+-- -- We can write a generator for expressions+-- genExpr :: 'Monad' m => 'Gen' m Expr+-- genExpr =+-- Gen.'recursive' Gen.'choice' [+-- -- non-recursive generators+-- Var '<$>' genName+-- ] [+-- -- recursive generators+-- Gen.'subtermM' genExpr (\x -> Lam '<$>' genName '<*>' pure x)+-- , Gen.'subterm2' genExpr genExpr App+-- ]+-- @+--+-- If we wrote the above example using only 'choice', it is likely that it+-- would fail to terminate. This is because for every call to @genExpr@,+-- there is a 2 in 3 chance that we will recurse again.+--+recursive :: ([Gen m a] -> Gen m a) -> [Gen m a] -> [Gen m a] -> Gen m a+recursive f nonrec rec =+ sized $ \n ->+ if n <= 1 then+ f nonrec+ else+ f $ nonrec ++ fmap small rec++------------------------------------------------------------------------+-- Combinators - Conditional++-- | Discards the whole generator.+--+-- /This is another name for 'empty' \/ 'mzero'./+--+discard :: Monad m => Gen m a+discard =+ mzero++-- | Generates a value that satisfies a predicate.+--+-- This is essentially:+--+-- @+-- filter p gen = 'mfilter' p gen '<|>' filter p gen+-- @+--+-- It differs from the above in that we keep some state to avoid looping+-- forever. If we trigger these limits then the whole whole generator is+-- discarded.+--+filter :: Monad m => (a -> Bool) -> Gen m a -> Gen m a+filter p gen =+ let+ try k =+ if k > 100 then+ empty+ else+ mfilter p (scale (2 * k +) gen) <|> try (k + 1)+ in+ try 0++-- | Runs a 'Maybe' generator until it produces a 'Just'.+--+-- This is implemented using 'filter' and has the same caveats.+--+just :: Monad m => Gen m (Maybe a) -> Gen m a+just g = do+ mx <- filter Maybe.isJust g+ case mx of+ Just x ->+ pure x+ Nothing ->+ error "Hedgehog.Gen.just: internal error, unexpected Nothing"++------------------------------------------------------------------------+-- Combinators - Collections++-- | Generates a 'Nothing' some of the time.+--+maybe :: Monad m => Gen m a -> Gen m (Maybe a)+maybe gen = do+ sized $ \n ->+ frequency [+ (2, pure Nothing)+ , (1 + fromIntegral n, Just <$> gen)+ ]++-- | Generates a list using a 'Range' to determine the length.+--+list :: Monad m => Range Int -> Gen m a -> Gen m [a]+list range gen =+ sized $ \size ->+ (traverse snd =<<) .+ mfilter (atLeast $ Range.lowerBound size range) .+ shrink Shrink.list $ do+ k <- integral_ range+ replicateM k (freeze gen)++-- | Generates a non-empty list using a 'Range' to determine the length.+--+nonEmpty :: Monad m => Range Int -> Gen m a -> Gen m (NonEmpty a)+nonEmpty range gen = do+ xs <- list (fmap (max 1) range) gen+ case xs of+ [] ->+ error "Hedgehog.Gen.nonEmpty: internal error, generated empty list"+ _ ->+ pure $ NonEmpty.fromList xs++-- | Generates a set using a 'Range' to determine the length.+--+-- /This may fail to generate anything if the element generator/+-- /cannot produce a large enough number of unique items to satify/+-- /the required set size./+--+set :: (Monad m, Ord a) => Range Int -> Gen m a -> Gen m (Set a)+set range gen =+ fmap Map.keysSet . map range $ fmap (, ()) gen++-- | Generates a map using a 'Range' to determine the length.+--+-- /This may fail to generate anything if the keys produced by the/+-- /generator do not account for a large enough number of unique/+-- /items to satify the required map size./+--+map :: (Monad m, Ord k) => Range Int -> Gen m (k, v) -> Gen m (Map k v)+map range gen =+ sized $ \size ->+ mfilter ((>= Range.lowerBound size range) . Map.size) .+ fmap Map.fromList .+ (sequence =<<) .+ shrink Shrink.list $ do+ k <- integral_ range+ uniqueByKey k gen++-- | Generate exactly 'n' unique generators.+--+uniqueByKey :: (Monad m, Ord k) => Int -> Gen m (k, v) -> Gen m [Gen m (k, v)]+uniqueByKey n gen =+ let+ try k xs0 =+ if k > 100 then+ mzero+ else+ replicateM n (freeze gen) >>= \kvs ->+ case uniqueInsert n xs0 (fmap (first fst) kvs) of+ Left xs ->+ pure $ Map.elems xs+ Right xs ->+ try (k + 1) xs+ in+ try (0 :: Int) Map.empty++uniqueInsert :: Ord k => Int -> Map k v -> [(k, v)] -> Either (Map k v) (Map k v)+uniqueInsert n xs kvs0 =+ if Map.size xs >= n then+ Left xs+ else+ case kvs0 of+ [] ->+ Right xs+ (k, v) : kvs ->+ uniqueInsert n (Map.insertWith (\x _ -> x) k v xs) kvs++-- | Check that list contains at least a certain number of elements.+--+atLeast :: Int -> [a] -> Bool+atLeast n =+ if n == 0 then+ const True+ else+ not . null . drop (n - 1)++------------------------------------------------------------------------+-- Combinators - Subterms++data Subterms n a =+ One a+ | All (Vec n a)+ deriving (Functor, Foldable, Traversable)++data Nat =+ Z+ | S Nat++data Vec n a where+ Nil :: Vec 'Z a+ (:.) :: a -> Vec n a -> Vec ('S n) a++infixr 5 :.++deriving instance Functor (Vec n)+deriving instance Foldable (Vec n)+deriving instance Traversable (Vec n)++shrinkSubterms :: Subterms n a -> [Subterms n a]+shrinkSubterms = \case+ One _ ->+ []+ All xs ->+ fmap One $ toList xs++genSubterms :: Monad m => Vec n (Gen m a) -> Gen m (Subterms n a)+genSubterms =+ (sequence =<<) .+ shrink shrinkSubterms .+ fmap All .+ mapM (fmap snd . freeze)++fromSubterms :: Applicative m => (Vec n a -> m a) -> Subterms n a -> m a+fromSubterms f = \case+ One x ->+ pure x+ All xs ->+ f xs++-- | Constructs a generator from a number of sub-term generators.+--+-- /Shrinks to one of the sub-terms if possible./+--+subtermMVec :: Monad m => Vec n (Gen m a) -> (Vec n a -> Gen m a) -> Gen m a+subtermMVec gs f =+ fromSubterms f =<< genSubterms gs++-- | Constructs a generator from a sub-term generator.+--+-- /Shrinks to the sub-term if possible./+--+subtermM :: Monad m => Gen m a -> (a -> Gen m a) -> Gen m a+subtermM gx f =+ subtermMVec (gx :. Nil) $ \(x :. Nil) ->+ f x++-- | Constructs a generator from a sub-term generator.+--+-- /Shrinks to the sub-term if possible./+--+subterm :: Monad m => Gen m a -> (a -> a) -> Gen m a+subterm gx f =+ subtermM gx $ \x ->+ pure (f x)++-- | Constructs a generator from two sub-term generators.+--+-- /Shrinks to one of the sub-terms if possible./+--+subtermM2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> Gen m a) -> Gen m a+subtermM2 gx gy f =+ subtermMVec (gx :. gy :. Nil) $ \(x :. y :. Nil) ->+ f x y++-- | Constructs a generator from two sub-term generators.+--+-- /Shrinks to one of the sub-terms if possible./+--+subterm2 :: Monad m => Gen m a -> Gen m a -> (a -> a -> a) -> Gen m a+subterm2 gx gy f =+ subtermM2 gx gy $ \x y ->+ pure (f x y)++-- | Constructs a generator from three sub-term generators.+--+-- /Shrinks to one of the sub-terms if possible./+--+subtermM3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> Gen m a) -> Gen m a+subtermM3 gx gy gz f =+ subtermMVec (gx :. gy :. gz :. Nil) $ \(x :. y :. z :. Nil) ->+ f x y z++-- | Constructs a generator from three sub-term generators.+--+-- /Shrinks to one of the sub-terms if possible./+--+subterm3 :: Monad m => Gen m a -> Gen m a -> Gen m a -> (a -> a -> a -> a) -> Gen m a+subterm3 gx gy gz f =+ subtermM3 gx gy gz $ \x y z ->+ pure (f x y z)++------------------------------------------------------------------------+-- Combinators - Combinations & Permutations++-- | Generates a random subsequence of a list.+--+subsequence :: Monad m => [a] -> Gen m [a]+subsequence xs =+ shrink Shrink.list $ filterM (const bool_) xs++-- | Generates a random permutation of a list.+--+-- This shrinks towards the order of the list being identical to the input+-- list.+--+shuffle :: Monad m => [a] -> Gen 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.shuffle: internal error, split generated empty list"++------------------------------------------------------------------------+-- Sampling++-- | Generate a random sample of data from the a generator.+--+sample :: MonadIO m => Gen m a -> m [a]+sample gen =+ fmap (fmap nodeValue . Maybe.catMaybes) .+ replicateM 10 $ do+ seed <- liftIO $ Seed.random+ runMaybeT . runTree $ runGen 30 seed gen++-- | Print the value produced by a generator, and the first level of shrinks,+-- for the given size and seed.+--+-- Use 'print' to generate a value from a random seed.+--+printWith :: (MonadIO m, Show a) => Size -> Seed -> Gen m a -> m ()+printWith size seed gen = do+ Node x ss <- runTree $ renderNodes size seed gen+ liftIO $ putStrLn "=== Outcome ==="+ liftIO $ putStrLn x+ liftIO $ putStrLn "=== Shrinks ==="+ for_ ss $ \s -> do+ Node y _ <- runTree s+ liftIO $ putStrLn y++-- | Print the shrink tree produced by a generator, for the given size and+-- seed.+--+-- Use 'printTree' to generate a value from a random seed.+--+printTreeWith :: (MonadIO m, Show a) => Size -> Seed -> Gen m a -> m ()+printTreeWith size seed gen = do+ s <- Tree.render $ renderNodes size seed gen+ liftIO $ putStr s++-- | Run a generator with a random seed and print the outcome, and the first+-- level of shrinks.+--+-- @+-- Gen.print (Gen.'enum' \'a\' \'f\')+-- @+--+-- > === Outcome ===+-- > 'd'+-- > === Shrinks ===+-- > 'a'+-- > 'b'+-- > 'c'+--+print :: (MonadIO m, Show a) => Gen m a -> m ()+print gen = do+ seed <- liftIO $ Seed.random+ printWith 30 seed gen++-- | Run a generator with a random seed and print the resulting shrink tree.+--+-- @+-- Gen.printTree (Gen.'enum' \'a\' \'f\')+-- @+--+-- > 'd'+-- > ├╼'a'+-- > ├╼'b'+-- > │ └╼'a'+-- > └╼'c'+-- > ├╼'a'+-- > └╼'b'+-- > └╼'a'+--+-- /This may not terminate when the tree is very large./+--+printTree :: (MonadIO m, Show a) => Gen m a -> m ()+printTree gen = do+ seed <- liftIO $ Seed.random+ printTreeWith 30 seed gen++-- | Render a generator as a tree of strings.+--+renderNodes :: (Monad m, Show a) => Size -> Seed -> Gen m a -> Tree m String+renderNodes size seed =+ fmap (Maybe.maybe "<discard>" show) . runDiscardEffect . runGen size seed++------------------------------------------------------------------------+-- Internal++-- $internal+--+-- These functions are exported in case you need them in a pinch, but are not+-- part of the public API and may change at any time, even as part of a minor+-- update.
+ src/Hedgehog/Internal/Discovery.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+module Hedgehog.Internal.Discovery (+ PropertySource(..)+ , readProperties+ , findProperties+ , readDeclaration++ , Pos(..)+ , Position(..)+ ) where++import Control.Monad.IO.Class (MonadIO(..))++import qualified Data.Char as Char+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Ord as Ord+import Data.Semigroup (Semigroup(..))++import Hedgehog.Internal.Property (PropertyName(..))+import Hedgehog.Internal.Source (LineNo(..), ColumnNo(..))++------------------------------------------------------------------------+-- Property Extraction++newtype PropertySource =+ PropertySource {+ propertySource :: Pos String+ } deriving (Eq, Ord, Show)++readProperties :: MonadIO m => FilePath -> m (Map PropertyName PropertySource)+readProperties path = do+ findProperties path <$> liftIO (readFile path)++readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String))+readDeclaration path line = do+ decls <- findDeclarations path <$> liftIO (readFile path)+ pure .+ takeHead .+ List.sortBy (Ord.comparing $ Ord.Down . posLine . posPostion . snd) .+ filter ((<= line) . posLine . posPostion . snd) $+ Map.toList decls++takeHead :: [a] -> Maybe a+takeHead = \case+ [] ->+ Nothing+ x : _ ->+ Just x++findProperties :: FilePath -> String -> Map PropertyName PropertySource+findProperties path =+ Map.map PropertySource .+ Map.mapKeysMonotonic PropertyName .+ Map.filterWithKey (\k _ -> isProperty k) .+ findDeclarations path++findDeclarations :: FilePath -> String -> Map String (Pos String)+findDeclarations path =+ declarations .+ classified .+ positioned path++isProperty :: String -> Bool+isProperty =+ List.isPrefixOf "prop_"++------------------------------------------------------------------------+-- Declaration Identification++declarations :: [Classified (Pos Char)] -> Map String (Pos String)+declarations =+ let+ loop = \case+ [] ->+ []+ x : xs ->+ let+ (ys, zs) =+ break isDeclaration xs+ in+ tagWithName (forget x $ trimEnd ys) : loop zs+ in+ Map.fromListWith (<>) . loop . dropWhile (not . isDeclaration)++trimEnd :: [Classified (Pos Char)] -> [Classified (Pos Char)]+trimEnd xs =+ let+ (space0, code) =+ span isWhitespace $ reverse xs++ (line_tail0, space) =+ span (\(Classified _ (Pos _ x)) -> x /= '\n') $+ reverse space0++ line_tail =+ case space of+ [] ->+ line_tail0+ x : _ ->+ line_tail0 ++ [x]+ in+ reverse code ++ line_tail++isWhitespace :: Classified (Pos Char) -> Bool+isWhitespace (Classified c (Pos _ x)) =+ c == Comment ||+ Char.isSpace x++tagWithName :: Pos String -> (String, Pos String)+tagWithName (Pos p x) =+ (takeName x, Pos p x)++takeName :: String -> String+takeName xs =+ case words xs of+ [] ->+ ""+ x : _ ->+ x++forget :: Classified (Pos Char) -> [Classified (Pos Char)] -> Pos String+forget (Classified _ (Pos p x)) xs =+ Pos p $+ x : fmap (posValue . classifiedValue) xs++isDeclaration :: Classified (Pos Char) -> Bool+isDeclaration (Classified c (Pos p x)) =+ c == NotComment &&+ posColumn p == 1 &&+ (Char.isLower x || x == '_')++------------------------------------------------------------------------+-- Comment Classification++data Class =+ NotComment+ | Comment+ deriving (Eq, Ord, Show)++data Classified a =+ Classified {+ _classifiedClass :: !Class+ , classifiedValue :: !a+ } deriving (Eq, Ord, Show)++classified :: [Pos Char] -> [Classified (Pos Char)]+classified =+ let+ ok =+ Classified NotComment++ ko =+ Classified Comment++ loop nesting in_line = \case+ [] ->+ []++ x@(Pos _ '\n') : xs | in_line ->+ ok x : loop nesting False xs++ x : xs | in_line ->+ ko x : loop nesting in_line xs++ x@(Pos _ '{') : y@(Pos _ '-') : xs ->+ ko x : ko y : loop (nesting + 1) in_line xs++ x@(Pos _ '-') : y@(Pos _ '}') : xs | nesting > 0 ->+ ko x : ko y : loop (nesting - 1) in_line xs++ x : xs | nesting > 0 ->+ ko x : loop nesting in_line xs++ -- FIXME This is not technically correct, we should allow arbitrary runs+ -- FIXME of dashes followed by a symbol character. Here we have only+ -- FIXME allowed two.+ x@(Pos _ '-') : y@(Pos _ '-') : z@(Pos _ zz) : xs+ | not (Char.isSymbol zz)+ ->+ ko x : ko y : loop nesting True (z : xs)++ x : xs ->+ ok x : loop nesting in_line xs+ in+ loop (0 :: Int) False++------------------------------------------------------------------------+-- Character Positioning++data Position =+ Position {+ _posPath :: !FilePath+ , posLine :: !LineNo+ , posColumn :: !ColumnNo+ } deriving (Eq, Ord, Show)++data Pos a =+ Pos {+ posPostion :: !Position+ , posValue :: a+ } deriving (Eq, Ord, Show, Functor)++instance Semigroup a => Semigroup (Pos a) where+ (<>) (Pos p x) (Pos q y) =+ if p < q then+ Pos p (x <> y)+ else+ Pos q (y <> x)++positioned :: FilePath -> [Char] -> [Pos Char]+positioned path =+ let+ loop l c = \case+ [] ->+ []++ '\n' : xs ->+ Pos (Position path l c) '\n' : loop (l + 1) 1 xs++ x : xs ->+ Pos (Position path l c) x : loop l (c + 1) xs+ in+ loop 1 1
+ src/Hedgehog/Internal/Property.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- MonadBase+module Hedgehog.Internal.Property (+ -- * Property+ Property(..)+ , GroupName(..)+ , PropertyName(..)+ , PropertyConfig(..)+ , TestLimit(..)+ , DiscardLimit(..)+ , ShrinkLimit(..)+ , property+ , withTests+ , withDiscards+ , withShrinks++ -- * Test+ , Test(..)+ , Log(..)+ , Failure(..)+ , Diff(..)+ , forAll+ , info+ , discard+ , failure+ , success+ , assert+ , (===)++ , liftEither+ , liftExceptT+ , withResourceT++ -- * Internal+ -- $internal+ , defaultConfig+ , mapConfig+ , failWith+ , writeLog+ , runTest+ ) where++import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..))+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Morph (MFunctor(..))+import Control.Monad.Primitive (PrimMonad(..))+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)+import Control.Monad.Trans.Resource (MonadResource(..), MonadResourceBase)+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Control.Monad.Trans.Writer.Lazy (WriterT(..))+import Control.Monad.Writer.Class (MonadWriter(..))++import Data.Typeable (Typeable, TypeRep, typeOf)++import Hedgehog.Gen (Gen)+import qualified Hedgehog.Gen as Gen+import Hedgehog.Internal.Show+import Hedgehog.Internal.Source++import Language.Haskell.TH.Lift (deriveLift)++------------------------------------------------------------------------++-- | A property test to check, along with some configurable limits like how+-- many times to run the test.+--+data Property =+ Property {+ propertyConfig :: !PropertyConfig+ , propertyTest :: Test IO ()+ }++-- | A property test.+--+newtype Test m a =+ Test {+ unTest :: ExceptT Failure (WriterT [Log] (Gen m)) a+ } deriving (Functor, Applicative)++-- | The name of a group of properties.+--+newtype GroupName =+ GroupName {+ unGroupName :: String+ } deriving (Eq, Ord, Show)++-- | The name of a property.+--+newtype PropertyName =+ PropertyName {+ unPropertyName :: String+ } deriving (Eq, Ord, Show)++-- | Configuration for a property test.+--+data PropertyConfig =+ PropertyConfig {+ propertyTestLimit :: !TestLimit+ , propertyDiscardLimit :: !DiscardLimit+ , propertyShrinkLimit :: !ShrinkLimit+ } deriving (Eq, Ord, Show)++-- | The number of successful tests that need to be run before a property test+-- is considered successful.+--+newtype TestLimit =+ TestLimit Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++-- | The number of shrinks to try before giving up on shrinking.+--+newtype ShrinkLimit =+ ShrinkLimit Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++-- | The number of discards to allow before giving up.+--+newtype DiscardLimit =+ DiscardLimit Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++--+-- FIXME This whole Log/Failure thing could be a lot more structured to allow+-- FIXME for richer user controlled error messages, think Doc. Ideally we'd+-- FIXME allow user's to create their own diffs anywhere.+--++-- | Log messages which are recorded during a test run.+--+data Log =+ Info String+ | Input (Maybe Span) TypeRep String+ deriving (Eq, Show)++-- | Details on where and why a test failed.+--+data Failure =+ Failure (Maybe Span) String (Maybe Diff)+ deriving (Eq, Show)++-- | The difference between some expected and actual value.+--+data Diff =+ Diff {+ diffPrefix :: String+ , diffRemoved :: String+ , diffInfix :: String+ , diffAdded :: String+ , diffSuffix :: String+ , diffValue :: ValueDiff+ } deriving (Eq, Show)++instance Monad m => Monad (Test m) where+ return =+ Test . return++ (>>=) m k =+ Test $+ unTest m >>=+ unTest . k++ fail err =+ Test . ExceptT . pure . Left $ Failure Nothing err Nothing++instance Monad m => MonadPlus (Test m) where+ mzero =+ discard++ mplus x y =+ Test . ExceptT . WriterT $+ mplus (runTest x) (runTest y)++instance Monad m => Alternative (Test m) where+ empty =+ mzero+ (<|>) =+ mplus++instance MonadTrans Test where+ lift =+ Test . lift . lift . lift++instance MFunctor Test where+ hoist f =+ Test . hoist (hoist (hoist f)) . unTest++instance PrimMonad m => PrimMonad (Test m) where+ type PrimState (Test m) =+ PrimState m+ primitive =+ lift . primitive++instance MonadIO m => MonadIO (Test m) where+ liftIO =+ lift . liftIO++instance MonadBase b m => MonadBase b (Test m) where+ liftBase =+ lift . liftBase++instance MonadThrow m => MonadThrow (Test m) where+ throwM =+ lift . throwM++instance MonadCatch m => MonadCatch (Test m) where+ catch m onErr =+ Test $+ (unTest m) `catch`+ (unTest . onErr)++instance MonadReader r m => MonadReader r (Test m) where+ ask =+ lift ask+ local f m =+ Test $+ local f (unTest m)++instance MonadState s m => MonadState s (Test m) where+ get =+ lift get+ put =+ lift . put+ state =+ lift . state++-- FIXME instance MonadWriter Test++instance MonadError e m => MonadError e (Test m) where+ throwError =+ lift . throwError+ catchError m onErr =+ Test . ExceptT $+ (runExceptT $ unTest m) `catchError`+ (runExceptT . unTest . onErr)++instance MonadResource m => MonadResource (Test m) where+ liftResourceT =+ lift . liftResourceT++------------------------------------------------------------------------+-- Property++-- | The default configuration for a property test.+--+defaultConfig :: PropertyConfig+defaultConfig =+ PropertyConfig {+ propertyTestLimit =+ 100+ , propertyDiscardLimit =+ 100+ , propertyShrinkLimit =+ 1000+ }++-- | Map a config modification function over a property.+--+mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property+mapConfig f (Property cfg t) =+ Property (f cfg) t++-- | Set the number times a property should be executed before it is considered+-- successful.+--+withTests :: TestLimit -> Property -> Property+withTests n =+ mapConfig $ \config -> config { propertyTestLimit = n }++-- | Set the number times a property is allowed to discard before the test+-- runner gives up.+--+withDiscards :: DiscardLimit -> Property -> Property+withDiscards n =+ mapConfig $ \config -> config { propertyDiscardLimit = n }++-- | Set the number times a property is allowed to shrink before the test+-- runner gives up and prints the counterexample.+--+withShrinks :: ShrinkLimit -> Property -> Property+withShrinks n =+ mapConfig $ \config -> config { propertyShrinkLimit = n }++-- | Creates a property to check.+--+property :: Test IO () -> Property+property =+ Property defaultConfig++------------------------------------------------------------------------+-- Test++runTest :: Test m a -> Gen m (Either Failure a, [Log])+runTest =+ runWriterT . runExceptT . unTest++writeLog :: Monad m => Log -> Test m ()+writeLog =+ Test . lift . tell . pure++-- | Generates a random input for the test by running the provided generator.+--+forAll :: (Monad m, Show a, Typeable a, HasCallStack) => Gen m a -> Test m a+forAll gen = do+ x <- Test . lift $ lift gen+ writeLog $ Input (getCaller callStack) (typeOf x) (showPretty x)+ return x++-- | Logs an information message to be displayed if the test fails.+--+info :: Monad m => String -> Test m ()+info =+ writeLog . Info++-- | Discards a test entirely.+--+discard :: Monad m => Test m a+discard =+ Test . lift $ lift Gen.discard++-- | Fail with an error message, useful for building other failure combinators.+--+failWith :: (Monad m, HasCallStack) => Maybe Diff -> String -> Test m a+failWith diff msg =+ Test . ExceptT . pure . Left $ Failure (getCaller callStack) msg diff++-- | Causes a test to fail.+--+failure :: (Monad m, HasCallStack) => Test m a+failure =+ withFrozenCallStack $ failWith Nothing ""++-- | Another name for @pure ()@.+--+success :: Monad m => Test m ()+success =+ Test $ pure ()++-- | Fails the test if the condition provided is 'False'.+--+assert :: (Monad m, HasCallStack) => Bool -> Test m ()+assert b =+ if b then+ success+ else do+ withFrozenCallStack failure++infix 4 ===++-- | Fails the test if the two arguments provided are not equal.+--+(===) :: (Monad m, Eq a, Show a, HasCallStack) => a -> a -> Test m ()+(===) x y =+ if x == y then+ success+ else+ case valueDiff <$> mkValue x <*> mkValue y of+ Nothing ->+ withFrozenCallStack $+ failWith Nothing $ unlines [+ "━━━ Not Equal ━━━"+ , showPretty x+ , showPretty y+ ]+ Just diff ->+ withFrozenCallStack $+ failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) ""++-- | Fails the test if the 'Either' is 'Left', otherwise returns the value in+-- the 'Right'.+--+liftEither :: (Monad m, Show x, HasCallStack) => Either x a -> Test m a+liftEither = \case+ Left x -> do+ withFrozenCallStack $ failWith Nothing $ showPretty x+ Right x ->+ pure x++-- | Fails the test if the 'ExceptT' is 'Left', otherwise returns the value in+-- the 'Right'.+--+liftExceptT :: (Monad m, Show x, HasCallStack) => ExceptT x m a -> Test m a+liftExceptT m = do+ withFrozenCallStack liftEither =<< lift (runExceptT m)++-- | Run a computation which requires resource acquisition / release.+--+-- /Note that if you 'Control.Monad.Trans.Resource.allocate' anything before/+-- /a 'forAll' you will likely encounter unexpected behaviour, due to the way/+-- /'ResourceT' interacts with the control flow introduced by shrinking./+--+withResourceT :: MonadResourceBase m => Test (ResourceT m) a -> Test m a+withResourceT =+ hoist runResourceT++------------------------------------------------------------------------+-- FIXME Replace with DeriveLift when we drop 7.10 support.++$(deriveLift ''GroupName)+$(deriveLift ''PropertyName)+$(deriveLift ''PropertyConfig)+$(deriveLift ''TestLimit)+$(deriveLift ''ShrinkLimit)+$(deriveLift ''DiscardLimit)++------------------------------------------------------------------------+-- Internal++-- $internal+--+-- These functions are exported in case you need them in a pinch, but are not+-- part of the public API and may change at any time, even as part of a minor+-- update.
+ src/Hedgehog/Internal/Report.hs view
@@ -0,0 +1,786 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+module Hedgehog.Internal.Report (+ -- * Report+ Report(..)+ , Status(..)+ , FailureReport(..)+ , FailedInput(..)++ , ShrinkCount+ , TestCount+ , DiscardCount++ , Style(..)+ , Markup(..)++ , renderReport+ , ppReport++ , mkFailure+ ) where++import Control.Monad (zipWithM)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Maybe (MaybeT(..))++import Data.Bifunctor (bimap, first, second)+import qualified Data.Char as Char+import Data.Either (partitionEithers)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe, catMaybes)+import Data.Semigroup (Semigroup(..))+import Data.Typeable (TypeRep)++import Hedgehog.Internal.Discovery (Pos(..), Position(..))+import qualified Hedgehog.Internal.Discovery as Discovery+import Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))+import Hedgehog.Internal.Seed (Seed)+import Hedgehog.Internal.Show+import Hedgehog.Internal.Source+import Hedgehog.Range (Size)++import System.Console.ANSI (ColorIntensity(..), Color(..))+import System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..))+import System.Console.ANSI (SGR(..), setSGRCode, hSupportsANSI)+import System.Directory (makeRelativeToCurrentDirectory)+import System.Environment (lookupEnv)+import System.IO (stdout)++import Text.PrettyPrint.Annotated.WL (Doc, (<+>))+import qualified Text.PrettyPrint.Annotated.WL as WL+import Text.Printf (printf)++------------------------------------------------------------------------+-- Data++-- | The numbers of times a property was able to shrink after a failing test.+--+newtype ShrinkCount =+ ShrinkCount Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++-- | The number of tests a property ran successfully.+--+newtype TestCount =+ TestCount Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++-- | The number of tests a property had to discard.+--+newtype DiscardCount =+ DiscardCount Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++data FailedInput =+ FailedInput {+ failedSpan :: !(Maybe Span)+ , failedType :: !TypeRep+ , failedValue :: !String+ } deriving (Eq, Show)++data FailureReport =+ FailureReport {+ failureSize :: !Size+ , failureSeed :: !Seed+ , failureShrinks :: !ShrinkCount+ , failureInputs :: ![FailedInput]+ , failureLocation :: !(Maybe Span)+ , failureMessage :: !String+ , failureDiff :: !(Maybe Diff)+ , failureMessages :: ![String]+ } deriving (Eq, Show)++-- | The status of a property test run.+--+-- In the case of a failure it provides the seed used for the test, the+-- number of shrinks, and the execution log.+--+data Status =+ Waiting+ | Running+ | Shrinking !FailureReport+ | Failed !FailureReport+ | GaveUp+ | OK+ deriving (Eq, Show)++-- | The report from a property test run.+--+data Report =+ Report {+ reportTests :: !TestCount+ , reportDiscards :: !DiscardCount+ , reportStatus :: !Status+ } deriving (Show)++------------------------------------------------------------------------+-- Pretty Printing Helpers++data Line a =+ Line {+ _lineAnnotation :: !a+ , lineNumber :: !LineNo+ , _lineSource :: !String+ } deriving (Eq, Ord, Show, Functor)++data Declaration a =+ Declaration {+ declarationFile :: !FilePath+ , declarationLine :: !LineNo+ , _declarationName :: !String+ , declarationSource :: !(Map LineNo (Line a))+ } deriving (Eq, Ord, Show, Functor)++data Style =+ StyleInfo+ | StyleInput+ | StyleFailure+ deriving (Eq, Ord, Show)++data Markup =+ WaitingIcon+ | WaitingHeader+ | RunningIcon+ | RunningHeader+ | ShrinkingIcon+ | ShrinkingHeader+ | FailedIcon+ | FailedHeader+ | GaveUpIcon+ | GaveUpHeader+ | SuccessIcon+ | SuccessHeader+ | DeclarationLocation+ | StyledLineNo !Style+ | StyledBorder !Style+ | StyledSource !Style+ | InputGutter+ | InputValue+ | FailureArrows+ | FailureGutter+ | FailureMessage+ | DiffPrefix+ | DiffInfix+ | DiffSuffix+ | DiffSame+ | DiffRemoved+ | DiffAdded+ | ReproduceHeader+ | ReproduceGutter+ | ReproduceSource+ deriving (Eq, Ord, Show)++instance Semigroup Style where+ (<>) x y =+ case (x, y) of+ (StyleFailure, _) ->+ StyleFailure+ (_, StyleFailure) ->+ StyleFailure+ (StyleInput, _) ->+ StyleInput+ (_, StyleInput) ->+ StyleInput+ (StyleInfo, _) ->+ StyleInfo++------------------------------------------------------------------------++takeInput :: Log -> Maybe FailedInput+takeInput = \case+ Input loc typ val ->+ Just $ FailedInput loc typ val+ _ ->+ Nothing++takeInfo :: Log -> Maybe String+takeInfo = \case+ Info x ->+ Just x+ _ ->+ Nothing++mkFailure ::+ Size+ -> Seed+ -> ShrinkCount+ -> Maybe Span+ -> String+ -> Maybe Diff+ -> [Log]+ -> FailureReport+mkFailure size seed shrinks location message diff logs =+ let+ inputs =+ mapMaybe takeInput logs++ info =+ mapMaybe takeInfo logs+ in+ FailureReport size seed shrinks inputs location message diff info++------------------------------------------------------------------------+-- Pretty Printing++ppShow :: Show x => x -> Doc a+ppShow = -- unfortunate naming clash+ WL.text . show++markup :: Markup -> Doc Markup -> Doc Markup+markup =+ WL.annotate++gutter :: Markup -> Doc Markup -> Doc Markup+gutter m x =+ markup m ">" <+> x++icon :: Markup -> Char -> Doc Markup -> Doc Markup+icon m i x =+ markup m (WL.char i) <+> x++ppTestCount :: TestCount -> Doc a+ppTestCount = \case+ TestCount 1 ->+ "1 test"+ TestCount n ->+ ppShow n <+> "tests"++ppDiscardCount :: DiscardCount -> Doc a+ppDiscardCount = \case+ DiscardCount 1 ->+ "1 discard"+ DiscardCount n ->+ ppShow n <+> "discards"++ppShrinkCount :: ShrinkCount -> Doc a+ppShrinkCount = \case+ ShrinkCount 1 ->+ "1 shrink"+ ShrinkCount n ->+ ppShow n <+> "shrinks"++ppWithDiscardCount :: DiscardCount -> Doc Markup+ppWithDiscardCount = \case+ DiscardCount 0 ->+ mempty+ n ->+ " with" <+> ppDiscardCount n++ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup+ppShrinkDiscard s d =+ case (s, d) of+ (0, 0) ->+ ""+ (0, _) ->+ " and" <+> ppDiscardCount d+ (_, 0) ->+ " and" <+> ppShrinkCount s+ (_, _) ->+ "," <+> ppShrinkCount s <+> "and" <+> ppDiscardCount d++mapSource :: (Map LineNo (Line a) -> Map LineNo (Line a)) -> Declaration a -> Declaration a+mapSource f decl =+ decl {+ declarationSource =+ f (declarationSource decl)+ }++-- | The span of non-whitespace characters for the line.+--+-- The result is @[inclusive, exclusive)@.+--+lineSpan :: Line a -> (ColumnNo, ColumnNo)+lineSpan (Line _ _ x0) =+ let+ (pre, x1) =+ span Char.isSpace x0++ (_, x2) =+ span Char.isSpace (reverse x1)++ start =+ length pre++ end =+ start + length x2+ in+ (fromIntegral start, fromIntegral end)++takeLines :: Span -> Declaration a -> Map LineNo (Line a)+takeLines sloc =+ fst . Map.split (spanEndLine sloc + 1) .+ snd . Map.split (spanStartLine sloc - 1) .+ declarationSource++readDeclaration :: MonadIO m => Span -> m (Maybe (Declaration ()))+readDeclaration sloc =+ runMaybeT $ do+ path <- liftIO . makeRelativeToCurrentDirectory $ spanFile sloc++ (name, Pos (Position _ line0 _) src) <- MaybeT $+ Discovery.readDeclaration path (spanEndLine sloc)++ let+ line =+ fromIntegral line0++ pure . Declaration path line name .+ Map.fromList .+ zip [line..] .+ zipWith (Line ()) [line..] $+ lines src+++defaultStyle :: Declaration a -> Declaration (Style, [(Style, Doc Markup)])+defaultStyle =+ fmap $ const (StyleInfo, [])++lastLineSpan :: Monad m => Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo)+lastLineSpan sloc decl =+ case reverse . Map.elems $ takeLines sloc decl of+ [] ->+ MaybeT $ pure Nothing+ x : _ ->+ pure $+ lineSpan x++ppFailedInputTypedArgument :: Int -> FailedInput -> Doc Markup+ppFailedInputTypedArgument ix (FailedInput _ typ val) =+ WL.vsep [+ WL.text "forAll" <> ppShow ix <+> "::" <+> ppShow typ+ , WL.text "forAll" <> ppShow ix <+> "="+ , WL.indent 2 . WL.vsep . fmap (markup InputValue . WL.text) $ lines val+ ]++ppFailedInputDeclaration ::+ MonadIO m+ => FailedInput+ -> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))+ppFailedInputDeclaration (FailedInput msloc _ val) =+ runMaybeT $ do+ sloc <- MaybeT $ pure msloc+ decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc+ startCol <- fromIntegral . fst <$> lastLineSpan sloc decl++ let+ ppValLine =+ WL.indent startCol .+ (markup InputGutter (WL.text "│ ") <>) .+ markup InputValue .+ WL.text++ valDocs =+ fmap ((StyleInput, ) . ppValLine) $+ List.lines val++ startLine =+ fromIntegral $ spanStartLine sloc++ endLine =+ fromIntegral $ spanEndLine sloc++ styleInput kvs =+ foldr (Map.adjust . fmap . first $ const StyleInput) kvs [startLine..endLine]++ insertDoc =+ Map.adjust (fmap . second $ const valDocs) endLine++ pure $+ mapSource (styleInput . insertDoc) decl++ppFailedInput ::+ MonadIO m+ => Int+ -> FailedInput+ -> m (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)])))+ppFailedInput ix input = do+ mdecl <- ppFailedInputDeclaration input+ case mdecl of+ Nothing ->+ pure . Left $ ppFailedInputTypedArgument ix input+ Just decl ->+ pure $ Right decl++ppLineDiff :: LineDiff -> Doc Markup+ppLineDiff = \case+ LineSame x ->+ markup DiffSame $+ " " <> WL.text x++ LineRemoved x ->+ markup DiffRemoved $+ "- " <> WL.text x++ LineAdded x ->+ markup DiffAdded $+ "+ " <> WL.text x++ppDiff :: Diff -> [Doc Markup]+ppDiff (Diff prefix removed infix_ added suffix diff) = [+ markup DiffPrefix (WL.text prefix) <>+ markup DiffRemoved (WL.text removed) <+>+ markup DiffInfix (WL.text infix_) <+>+ markup DiffAdded (WL.text added) <>+ markup DiffSuffix (WL.text suffix)+ ] ++ fmap ppLineDiff (toLineDiff diff)++ppFailureLocation ::+ MonadIO m+ => String+ -> Maybe Diff+ -> Span+ -> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))+ppFailureLocation msg mdiff sloc =+ runMaybeT $ do+ decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc+ (startCol, endCol) <- bimap fromIntegral fromIntegral <$> lastLineSpan sloc decl++ let+ arrowDoc =+ WL.indent startCol $+ markup FailureArrows (WL.text (replicate (endCol - startCol) '^'))++ ppFailure x =+ WL.indent startCol $+ markup FailureGutter (WL.text "│ ") <> x++ msgDocs =+ fmap ((StyleFailure, ) . ppFailure . markup FailureMessage . WL.text) (List.lines msg)++ diffDocs =+ case mdiff of+ Nothing ->+ []+ Just diff ->+ fmap ((StyleFailure, ) . ppFailure) (ppDiff diff)++ docs =+ [(StyleFailure, arrowDoc)] ++ msgDocs ++ diffDocs++ startLine =+ spanStartLine sloc++ endLine =+ spanEndLine sloc++ styleFailure kvs =+ foldr (Map.adjust . fmap . first $ const StyleFailure) kvs [startLine..endLine]++ insertDoc =+ Map.adjust (fmap . second $ const docs) endLine++ pure $+ mapSource (styleFailure . insertDoc) decl++ppDeclaration :: Declaration (Style, [(Style, Doc Markup)]) -> Doc Markup+ppDeclaration decl =+ case Map.maxView $ declarationSource decl of+ Nothing ->+ mempty+ Just (lastLine, _) ->+ let+ ppLocation =+ WL.indent (digits + 1) $+ markup (StyledBorder StyleInfo) "┏━━" <+>+ markup DeclarationLocation (WL.text (declarationFile decl)) <+>+ markup (StyledBorder StyleInfo) "━━━"++ digits =+ length . show . unLineNo $ lineNumber lastLine++ ppLineNo =+ WL.text . printf ("%" <> show digits <> "d") . unLineNo++ ppEmptyNo =+ WL.text $ replicate digits ' '++ ppSource style n src =+ markup (StyledLineNo style) (ppLineNo n) <+>+ markup (StyledBorder style) "┃" <+>+ markup (StyledSource style) (WL.text src)++ ppAnnot (style, doc) =+ markup (StyledLineNo style) ppEmptyNo <+>+ markup (StyledBorder style) "┃" <+>+ doc++ ppLines = do+ Line (style, xs) n src <- Map.elems $ declarationSource decl+ ppSource style n src : fmap ppAnnot xs+ in+ WL.vsep (ppLocation : ppLines)++ppReproduce :: Maybe PropertyName -> Size -> Seed -> Doc Markup+ppReproduce name size seed =+ WL.vsep [+ markup ReproduceHeader+ "This failure can be reproduced by running:"+ , gutter ReproduceGutter . markup ReproduceSource $+ "recheck" <+>+ WL.text (showsPrec 11 size "") <+>+ WL.text (showsPrec 11 seed "") <+>+ maybe "<property>" (WL.text . unPropertyName) name+ ]++mergeLine :: Semigroup a => Line a -> Line a -> Line a+mergeLine (Line x no src) (Line y _ _) =+ Line (x <> y) no src++mergeDeclaration :: Semigroup a => Declaration a -> Declaration a -> Declaration a+mergeDeclaration (Declaration file line name src0) (Declaration _ _ _ src1) =+ Declaration file line name $+ Map.unionWith mergeLine src0 src1++mergeDeclarations :: Semigroup a => [Declaration a] -> [Declaration a]+mergeDeclarations =+ Map.elems .+ Map.fromListWith mergeDeclaration .+ fmap (\d -> ((declarationFile d, declarationLine d), d))++ppTextLines :: String -> [Doc Markup]+ppTextLines =+ fmap WL.text . List.lines++ppFailureReport :: MonadIO m => Maybe PropertyName -> FailureReport -> m (Doc Markup)+ppFailureReport name (FailureReport size seed _ inputs0 mlocation0 msg mdiff msgs0) = do+ (msgs, mlocation) <-+ case mlocation0 of+ Nothing ->+ -- Move the failure message to the end section if we have+ -- no source location.+ let+ msgs1 =+ msgs0 +++ (if null msg then [] else [msg])++ docs =+ concatMap ppTextLines msgs1 +++ maybe [] ppDiff mdiff+ in+ pure (docs, Nothing)++ Just location0 ->+ (concatMap ppTextLines msgs0,)+ <$> ppFailureLocation msg mdiff location0++ (args, idecls) <- partitionEithers <$> zipWithM ppFailedInput [0..] inputs0++ let+ decls =+ mergeDeclarations .+ catMaybes $+ mlocation : fmap pure idecls++ with xs f =+ if null xs then+ []+ else+ [f xs]++ pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat [+ with args $+ WL.vsep . WL.punctuate WL.line+ , with decls $+ WL.vsep . WL.punctuate WL.line . fmap ppDeclaration+ , with msgs $+ WL.vsep+ , [ppReproduce name size seed]+ ]++ppName :: Maybe PropertyName -> Doc a+ppName = \case+ Nothing ->+ "<interactive>"+ Just (PropertyName name) ->+ WL.text name++ppReport :: MonadIO m => Maybe PropertyName -> Report -> m (Doc Markup)+ppReport name (Report tests discards status) =+ case status of+ Waiting -> do+ pure . icon WaitingIcon '○' . WL.annotate WaitingHeader $+ ppName name++ Running -> do+ pure . icon RunningIcon '●' . WL.annotate RunningHeader $+ ppName name <+>+ "passed" <+>+ ppTestCount tests <>+ ppWithDiscardCount discards <+>+ "(running)"++ Shrinking failure -> do+ pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $+ ppName name <+>+ "failed after" <+>+ ppTestCount tests <>+ ppShrinkDiscard (failureShrinks failure) discards <+>+ "(shrinking)"++ Failed failure -> do+ pfailure <- ppFailureReport name failure+ pure . WL.vsep $ [+ icon FailedIcon '✗' . WL.annotate FailedHeader $+ ppName name <+>+ "failed after" <+>+ ppTestCount tests <>+ ppShrinkDiscard (failureShrinks failure) discards <>+ "."+ , mempty+ , pfailure+ , mempty+ ]+ GaveUp ->+ pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $+ ppName name <+>+ "gave up after" <+>+ ppDiscardCount discards <>+ ", passed" <+>+ ppTestCount tests <>+ "."+ OK ->+ pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $+ ppName name <+>+ "passed" <+>+ ppTestCount tests <>+ "."++useColor :: MonadIO m => m Bool+useColor =+ liftIO $ do+ menv <- lookupEnv "HEDGEHOG_COLOR"+ case menv of+ Just "0" ->+ pure False+ Just "no" ->+ pure False+ Just "false" ->+ pure False++ Just "1" ->+ pure True+ Just "yes" ->+ pure True+ Just "true" ->+ pure True++ Just _ ->+ hSupportsANSI stdout+ Nothing ->+ hSupportsANSI stdout++renderReport :: MonadIO m => Maybe PropertyName -> Report -> m String+renderReport name x = do+ doc <- ppReport name x+ color <- useColor++ let+ dull =+ SetColor Foreground Dull++ vivid =+ SetColor Foreground Vivid++ bold =+ SetConsoleIntensity BoldIntensity++ start = \case+ WaitingIcon ->+ setSGRCode []+ WaitingHeader ->+ setSGRCode []+ RunningIcon ->+ setSGRCode []+ RunningHeader ->+ setSGRCode []+ ShrinkingIcon ->+ setSGRCode [vivid Red]+ ShrinkingHeader ->+ setSGRCode [vivid Red]+ FailedIcon ->+ setSGRCode [vivid Red]+ FailedHeader ->+ setSGRCode [vivid Red]+ GaveUpIcon ->+ setSGRCode [dull Yellow]+ GaveUpHeader ->+ setSGRCode [dull Yellow]+ SuccessIcon ->+ setSGRCode [dull Green]+ SuccessHeader ->+ setSGRCode [dull Green]++ DeclarationLocation ->+ setSGRCode []++ StyledLineNo StyleInfo ->+ setSGRCode []+ StyledSource StyleInfo ->+ setSGRCode []+ StyledBorder StyleInfo ->+ setSGRCode []++ StyledLineNo StyleInput ->+ setSGRCode [dull Magenta]+ StyledSource StyleInput ->+ setSGRCode []+ StyledBorder StyleInput ->+ setSGRCode []+ InputGutter ->+ setSGRCode [dull Magenta]+ InputValue ->+ setSGRCode [dull Magenta]++ StyledLineNo StyleFailure ->+ setSGRCode [vivid Red]+ StyledSource StyleFailure ->+ setSGRCode [vivid Red, bold]+ StyledBorder StyleFailure ->+ setSGRCode []+ FailureArrows ->+ setSGRCode [vivid Red]+ FailureMessage ->+ setSGRCode []+ FailureGutter ->+ setSGRCode []++ DiffPrefix ->+ setSGRCode []+ DiffInfix ->+ setSGRCode []+ DiffSuffix ->+ setSGRCode []+ DiffSame ->+ setSGRCode []+ DiffRemoved ->+ setSGRCode [dull Red]+ DiffAdded ->+ setSGRCode [dull Green]++ ReproduceHeader ->+ setSGRCode []+ ReproduceGutter ->+ setSGRCode []+ ReproduceSource ->+ setSGRCode []++ end _ =+ setSGRCode [Reset]++ display =+ if color then+ WL.displayDecorated start end id+ else+ WL.display++ pure .+ display .+ WL.renderSmart 100 $+ WL.indent 2 doc
+ src/Hedgehog/Internal/Runner.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Hedgehog.Internal.Runner (+ -- * Runner+ RunnerConfig(..)+ , check+ , checkGroupWith+ , recheck++ -- * Internal+ , checkReport+ , checkConsoleRegion+ , checkNamed+ ) where++import Control.Concurrent.Async (forConcurrently)+import Control.Concurrent.MVar (MVar)+import qualified Control.Concurrent.MVar as MVar+import qualified Control.Concurrent.QSem as QSem+import Control.Monad (when)+import Control.Monad.Catch (MonadMask(..), MonadCatch(..), catchAll, bracket)+import Control.Monad.IO.Class (MonadIO(..))++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Traversable (for)++import qualified GHC.Conc as Conc++import Hedgehog.Gen (runGen)+import qualified Hedgehog.Gen as Gen+import Hedgehog.Internal.Report+import Hedgehog.Internal.Seed (Seed)+import qualified Hedgehog.Internal.Seed as Seed+import Hedgehog.Internal.Tree (Tree(..), Node(..))+import Hedgehog.Internal.Property (PropertyName(..), GroupName(..))+import Hedgehog.Internal.Property (Test, Log(..), Failure(..), runTest)+import Hedgehog.Internal.Property (Property(..), PropertyConfig(..))+import Hedgehog.Internal.Property (ShrinkLimit, withTests)+import Hedgehog.Range (Size)++import Language.Haskell.TH.Lift (deriveLift)++import System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion)+import qualified System.Console.Regions as Console+import System.Environment (lookupEnv)++import Text.Read (readMaybe)+++-- | Configuration for a property test run.+--+data RunnerConfig =+ RunnerConfig {+ -- | The number of property tests to run concurrently. 'Nothing' means+ -- use one worker per processor.+ runnerWorkers :: !(Maybe Int)+ } deriving (Eq, Ord, Show)++findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b+findM xs0 def p =+ case xs0 of+ [] ->+ return def+ x0 : xs ->+ p x0 >>= \m ->+ case m of+ Nothing ->+ findM xs def p+ Just x ->+ return x++isFailure :: Node m (Maybe (Either x a, b)) -> Bool+isFailure = \case+ Node (Just (Left _, _)) _ ->+ True+ _ ->+ False++takeSmallest ::+ MonadIO m+ => Size+ -> Seed+ -> ShrinkCount+ -> ShrinkLimit+ -> (Status -> m ())+ -> Node m (Maybe (Either Failure (), [Log]))+ -> m Status+takeSmallest size seed shrinks slimit updateUI = \case+ Node Nothing _ ->+ pure GaveUp++ Node (Just (x, w)) xs ->+ case x of+ Left (Failure loc err mdiff) -> do+ let+ failure =+ mkFailure size seed shrinks loc err mdiff w++ updateUI $ Shrinking failure++ if shrinks >= fromIntegral slimit then+ -- if we've hit the shrink limit, don't shrink any further+ pure $ Failed failure+ else+ findM xs (Failed failure) $ \m -> do+ o <- runTree m+ if isFailure o then+ Just <$> takeSmallest size seed (shrinks + 1) slimit updateUI o+ else+ return Nothing++ Right () ->+ return OK++checkReport ::+ forall m.+ MonadIO m+ => MonadCatch m+ => PropertyConfig+ -> Size+ -> Seed+ -> Test m ()+ -> (Report -> m ())+ -> m Report+checkReport cfg size0 seed0 test0 updateUI =+ let+ test =+ catchAll test0 (fail . show)++ loop :: TestCount -> DiscardCount -> Size -> Seed -> m Report+ loop !tests !discards !size !seed = do+ updateUI $ Report tests discards Running++ if size > 99 then+ -- size has reached limit, reset to 0+ loop tests discards 0 seed++ else if tests >= fromIntegral (propertyTestLimit cfg) then+ -- we've hit the test limit, test was successful+ pure $ Report tests discards OK++ else if discards >= fromIntegral (propertyDiscardLimit cfg) then+ -- we've hit the discard limit, give up+ pure $ Report tests discards GaveUp++ else+ case Seed.split seed of+ (s0, s1) -> do+ node@(Node x _) <-+ runTree . Gen.runDiscardEffect $ runGen size s0 (runTest test)+ case x of+ Nothing ->+ loop tests (discards + 1) (size + 1) s1++ Just (Left _, _) ->+ let+ mkReport =+ Report (tests + 1) discards+ in+ fmap mkReport $+ takeSmallest+ size+ seed+ 0+ (propertyShrinkLimit cfg)+ (updateUI . mkReport)+ node++ Just (Right (), _) ->+ loop (tests + 1) discards (size + 1) s1+ in+ loop 0 0 size0 seed0++checkConsoleRegion ::+ MonadIO m+ => ConsoleRegion+ -> Maybe PropertyName+ -> Size+ -> Seed+ -> Property+ -> m Report+checkConsoleRegion region name size seed prop =+ liftIO $ do+ report <-+ checkReport (propertyConfig prop) size seed (propertyTest prop) $ \report -> do+ setRegionReport region name report++ setRegionReport region name report++ pure report++checkNamed :: MonadIO m => ConsoleRegion -> Maybe PropertyName -> Property -> m Bool+checkNamed region name prop = do+ seed <- liftIO Seed.random+ report <- checkConsoleRegion region name 0 seed prop+ pure $+ reportStatus report == OK++-- | Check a property.+--+check :: MonadIO m => Property -> m Bool+check prop = do+ liftIO . displayRegion $ \region ->+ checkNamed region Nothing prop++-- | Check a property using a specific size and seed.+--+recheck :: MonadIO m => Size -> Seed -> Property -> m ()+recheck size seed prop0 = do+ let prop = withTests 1 prop0+ _ <- liftIO . displayRegion $ \region ->+ checkConsoleRegion region Nothing size seed prop+ pure ()++-- | Check a group of properties using the specified runner config.+--+checkGroupWith ::+ MonadIO m+ => RunnerConfig+ -> GroupName+ -> [(PropertyName, Property)]+ -> m Bool+checkGroupWith config group props0 =+ liftIO $ do+ n <- maybe getNumWorkers pure (runnerWorkers config)++ -- ensure one spare capability for concurrent-output, it's likely that our+ -- tests will saturate all the capabilities they're given.+ updateNumCapabilities (n + 1)++ putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━"+ Console.displayConsoleRegions $ do+ mvar <- MVar.newMVar (-1, Map.empty)++ props <-+ fmap (zip [0..]) . for props0 $ \(name, p) -> do+ region <- Console.openConsoleRegion Linear+ setRegionReport region (Just name) $ Report 0 0 Waiting+ pure (name, p, region)++ qsem <- QSem.newQSem n++ results <-+ forConcurrently props $ \(ix, (name, p, region)) ->+ bracket (QSem.waitQSem qsem) (const $ QSem.signalQSem qsem) $ \_ -> do+ ok <- checkNamed region (Just name) p+ finishIndexedRegion mvar ix region+ pure ok++ pure $+ and results++------------------------------------------------------------------------+-- concurrent-output utils++displayRegion ::+ MonadIO m+ => MonadMask m+ => LiftRegion m+ => (ConsoleRegion -> m a)+ -> m a+displayRegion =+ Console.displayConsoleRegions .+ bracket (Console.openConsoleRegion Linear) finishRegion++setRegionReport ::+ MonadIO m+ => LiftRegion m+ => ConsoleRegion+ -> Maybe PropertyName+ -> Report+ -> m ()+setRegionReport region name report = do+ content <- renderReport name report+ Console.setConsoleRegion region content++finishRegion :: (Monad m, LiftRegion m) => ConsoleRegion -> m ()+finishRegion region = do+ content <- Console.getConsoleRegion region+ Console.finishConsoleRegion region content++flushRegions ::+ MonadIO m+ => MVar (Int, Map Int ConsoleRegion)+ -> m ()+flushRegions mvar =+ liftIO $ do+ again <-+ MVar.modifyMVar mvar $ \original@(minIx, regions0) ->+ case Map.minViewWithKey regions0 of+ Nothing ->+ pure (original, False)++ Just ((ix, region), regions) ->+ if ix == minIx + 1 then do+ finishRegion region+ pure ((ix, regions), True)+ else+ pure (original, False)++ when again $+ flushRegions mvar++finishIndexedRegion ::+ MonadIO m+ => MVar (Int, Map Int ConsoleRegion)+ -> Int+ -> ConsoleRegion+ -> m ()+finishIndexedRegion mvar ix region = do+ liftIO . MVar.modifyMVar_ mvar $ \(minIx, regions) ->+ pure (minIx, Map.insert ix region regions)+ flushRegions mvar++-- | Update the number of capabilities but never set it lower than it already+-- is.+--+updateNumCapabilities :: Int -> IO ()+updateNumCapabilities n = do+ ncaps <- Conc.getNumCapabilities+ Conc.setNumCapabilities (max n ncaps)++getNumWorkers :: IO Int+getNumWorkers = do+ menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_WORKERS"+ case menv of+ Nothing ->+ Conc.getNumProcessors+ Just env ->+ pure env++------------------------------------------------------------------------+-- FIXME Replace with DeriveLift when we drop 7.10 support.++$(deriveLift ''RunnerConfig)
+ src/Hedgehog/Internal/Seed.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+-- |+-- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele+-- et. al. [1].+--+-- The paper's algorithm provides decent randomness for most purposes but+-- sacrifices cryptographic-quality randomness in favor of speed. The original+-- implementation is tested with DieHarder and BigCrush; see the paper for+-- details.+--+-- This implementation, originally from [2], is a port from the paper.+--+-- It also takes in to account the SplittableRandom.java source code in OpenJDK+-- v8u40-b25 as well as splittable_random.ml in Jane Street's standard library+-- overlay (kernel) v113.33.03, and Random.fs in FsCheck v3.+--+-- Other than the choice of initial seed for 'from' this port should be+-- faithful. Currently, we have not rerun the DieHarder, or BigCrush tests on+-- this implementation.+--+-- 1. Guy L. Steele, Jr., Doug Lea, Christine H. Flood+-- Fast splittable pseudorandom number generators+-- Comm ACM, 49(10), Oct 2014, pp453-472.+--+-- 2. Nikos Baxevanis+-- https://github.com/moodmosaic/SplitMix/blob/master/SplitMix.hs+--+module Hedgehog.Internal.Seed (+ Seed(..)+ , random+ , from+ , split+ , nextInteger+ , nextDouble++ -- * Internal+ -- $internal+ , goldenGamma+ , nextInt64+ , nextInt32+ , mix64+ , mix64variant13+ , mix32+ , mixGamma+ ) where++import Control.Monad.IO.Class (MonadIO(..))++import Data.Bifunctor (first)+import Data.Bits ((.|.), xor, shiftR, popCount)+import Data.Int (Int32, Int64)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.IORef (IORef)+import qualified Data.IORef as IORef++import System.IO.Unsafe (unsafePerformIO)+import System.Random (RandomGen)+import qualified System.Random as Random++-- | A splittable random number generator.+--+data Seed =+ Seed {+ seedValue :: !Int64+ , seedGamma :: !Int64 -- ^ must be an odd number+ } deriving (Eq, Ord)++instance Show Seed where+ showsPrec p (Seed v g) =+ showParen (p > 10) $+ showString "Seed " .+ showsPrec 11 v .+ showChar ' ' .+ showsPrec 11 g++instance Read Seed where+ readsPrec p =+ readParen (p > 10) $ \r0 -> do+ ("Seed", r1) <- lex r0+ (v, r2) <- readsPrec 11 r1+ (g, r3) <- readsPrec 11 r2+ pure (Seed v g, r3)++global :: IORef Seed+global =+ unsafePerformIO $ do+ -- FIXME use /dev/urandom on posix+ seconds <- getPOSIXTime+ IORef.newIORef $ from (round (seconds * 1000))+{-# NOINLINE global #-}++-- | Create a random 'Seed' using an effectful source of randomness.+--+random :: MonadIO m => m Seed+random = do+ liftIO $ IORef.atomicModifyIORef' global split++-- | Create a 'Seed' using an 'Int64'.+--+from :: Int64 -> Seed+from x =+ Seed x goldenGamma++-- | A predefined gamma value's needed for initializing the "root" instances of+-- 'Seed'. That is, instances not produced by splitting an already existing+-- instance.+--+-- We choose: the odd integer closest to @2^64/φ@, where @φ = (1 + √5)/2@ is+-- the golden ratio.+--+goldenGamma :: Int64+goldenGamma =+ -7046029254386353131++-- | Get the next value in the SplitMix sequence.+--+next :: Seed -> (Int64, Seed)+next (Seed v0 g) =+ let+ v = v0 + g+ in+ (v, Seed v g)++-- | Splits a random number generator in to two.+--+split :: Seed -> (Seed, Seed)+split s0 =+ let+ (v0, s1) = next s0+ (g0, s2) = next s1+ in+ (s2, Seed (mix64 v0) (mixGamma g0))++-- | Generate a random 'Int64'.+--+nextInt64 :: Seed -> (Int64, Seed)+nextInt64 s0 =+ let+ (v0, s1) = next s0+ in+ (mix64 v0, s1)++-- | Generate a random 'Int32'.+--+nextInt32 :: Seed -> (Int32, Seed)+nextInt32 s0 =+ let+ (v0, s1) = next s0+ in+ (mix32 v0, s1)++-- | Generate a random 'Integer' in the [inclusive,inclusive] range.+--+nextInteger :: Integer -> Integer -> Seed -> (Integer, Seed)+nextInteger lo hi =+ Random.randomR (lo, hi)++-- | Generate a random 'Double' in the [inclusive,exclusive) range.+--+nextDouble :: Double -> Double -> Seed -> (Double, Seed)+nextDouble lo hi =+ Random.randomR (lo, hi)++mix64 :: Int64 -> Int64+mix64 x =+ let+ y = (x `xor` (x `shiftR` 33)) * (-49064778989728563)+ z = (y `xor` (y `shiftR` 33)) * (-4265267296055464877)+ in+ z `xor` (z `shiftR` 33)++mix32 :: Int64 -> Int32+mix32 x =+ let+ y = (x `xor` (x `shiftR` 33)) * (-49064778989728563)+ z = (y `xor` (y `shiftR` 33)) * (-4265267296055464877)+ in+ fromIntegral (z `shiftR` 32)++mix64variant13 :: Int64 -> Int64+mix64variant13 x =+ let+ y = (x `xor` (x `shiftR` 30)) * (-4658895280553007687)+ z = (y `xor` (y `shiftR` 27)) * (-7723592293110705685)+ in+ z `xor` (z `shiftR` 31)++mixGamma :: Int64 -> Int64+mixGamma x =+ let+ y = mix64variant13 x .|. 1+ n = popCount $ y `xor` (y `shiftR` 1)+ in+ if n < 24 then+ y `xor` (-6148914691236517206)+ else+ y++------------------------------------------------------------------------+-- RandomGen instances++#include "MachDeps.h"++#if (SIZEOF_HSINT == 8)+instance RandomGen Seed where+ next =+ first fromIntegral . nextInt64+ genRange _ =+ (fromIntegral (minBound :: Int64), fromIntegral (maxBound :: Int64))+ split =+ split+#else+instance RandomGen Seed where+ next =+ first fromIntegral . nextInt32+ genRange _ =+ (fromIntegral (minBound :: Int32), fromIntegral (maxBound :: Int32))+ split =+ split+#endif++------------------------------------------------------------------------+-- Internal++-- $internal+--+-- These functions are exported in case you need them in a pinch, but are not+-- part of the public API and may change at any time, even as part of a minor+-- update.
+ src/Hedgehog/Internal/Show.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+module Hedgehog.Internal.Show (+ Name+ , Value(..)+ , ValueDiff(..)+ , LineDiff(..)++ , mkValue+ , showPretty++ , valueDiff+ , lineDiff+ , toLineDiff++ , renderValue+ , renderValueDiff+ , renderLineDiff++ , takeLeft+ , takeRight+ ) where++import Data.Bifunctor (second)++import Text.Show.Pretty (Value(..), Name, reify, valToStr, ppShow)+++data ValueDiff =+ ValueCon Name [ValueDiff]+ | ValueRec Name [(Name, ValueDiff)]+ | ValueTuple [ValueDiff]+ | ValueList [ValueDiff]+ | ValueSame Value+ | ValueDiff Value Value+ deriving (Eq, Show)++data LineDiff =+ LineSame String+ | LineRemoved String+ | LineAdded String+ deriving (Eq, Show)++data DocDiff =+ DocSame Int String+ | DocRemoved Int String+ | DocAdded Int String+ | DocOpen Int String+ | DocItem Int String [DocDiff]+ | DocClose Int String+ deriving (Eq, Show)++renderValue :: Value -> String+renderValue =+ valToStr++renderValueDiff :: ValueDiff -> String+renderValueDiff =+ unlines .+ fmap renderLineDiff .+ toLineDiff++renderLineDiff :: LineDiff -> String+renderLineDiff = \case+ LineSame x ->+ " " ++ x+ LineRemoved x ->+ "- " ++ x+ LineAdded x ->+ "+ " ++ x++mkValue :: Show a => a -> Maybe Value+mkValue =+ reify++showPretty :: Show a => a -> String+showPretty =+ ppShow++lineDiff :: Value -> Value -> [LineDiff]+lineDiff x y =+ toLineDiff $ valueDiff x y++toLineDiff :: ValueDiff -> [LineDiff]+toLineDiff =+ concatMap (mkLineDiff 0 "") .+ collapseOpen .+ dropLeadingSep .+ mkDocDiff 0++valueDiff :: Value -> Value -> ValueDiff+valueDiff x y =+ if x == y then+ ValueSame x+ else+ case (x, y) of+ (Con nx xs, Con ny ys)+ | nx == ny+ , length xs == length ys+ ->+ ValueCon nx (zipWith valueDiff xs ys)++ (Rec nx nxs, Rec ny nys)+ | nx == ny+ , fmap fst nxs == fmap fst nys+ , ns <- fmap fst nxs+ , xs <- fmap snd nxs+ , ys <- fmap snd nys+ ->+ ValueRec nx (zip ns (zipWith valueDiff xs ys))++ (Tuple xs, Tuple ys)+ | length xs == length ys+ ->+ ValueTuple (zipWith valueDiff xs ys)++ (List xs, List ys)+ | length xs == length ys+ ->+ ValueList (zipWith valueDiff xs ys)++ _ ->+ ValueDiff x y++takeLeft :: ValueDiff -> Value+takeLeft = \case+ ValueCon n xs ->+ Con n (fmap takeLeft xs)+ ValueRec n nxs ->+ Rec n (fmap (second takeLeft) nxs)+ ValueTuple xs ->+ Tuple (fmap takeLeft xs)+ ValueList xs ->+ List (fmap takeLeft xs)+ ValueSame x ->+ x+ ValueDiff x _ ->+ x++takeRight :: ValueDiff -> Value+takeRight = \case+ ValueCon n xs ->+ Con n (fmap takeRight xs)+ ValueRec n nxs ->+ Rec n (fmap (second takeRight) nxs)+ ValueTuple xs ->+ Tuple (fmap takeRight xs)+ ValueList xs ->+ List (fmap takeRight xs)+ ValueSame x ->+ x+ ValueDiff _ x ->+ x++mkLineDiff :: Int -> String -> DocDiff -> [LineDiff]+mkLineDiff indent0 prefix0 diff =+ let+ mkLinePrefix indent =+ spaces indent0 ++ prefix0 ++ spaces indent++ mkLineIndent indent =+ indent0 + length prefix0 + indent+ in+ case diff of+ DocSame indent x ->+ [LineSame $ mkLinePrefix indent ++ x]++ DocRemoved indent x ->+ [LineRemoved $ mkLinePrefix indent ++ x]++ DocAdded indent x ->+ [LineAdded $ mkLinePrefix indent ++ x]++ DocOpen indent x ->+ [LineSame $ mkLinePrefix indent ++ x]++ DocItem _ _ [] ->+ []++ DocItem indent prefix (x@DocRemoved{} : y@DocAdded{} : xs) ->+ mkLineDiff (mkLineIndent indent) prefix x +++ mkLineDiff (mkLineIndent indent) prefix y +++ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs++ DocItem indent prefix (x : xs) ->+ mkLineDiff (mkLineIndent indent) prefix x +++ concatMap (mkLineDiff (mkLineIndent (indent + length prefix)) "") xs++ DocClose indent x ->+ [LineSame $ spaces (mkLineIndent indent) ++ x]++spaces :: Int -> String+spaces indent =+ replicate indent ' '++collapseOpen :: [DocDiff] -> [DocDiff]+collapseOpen = \case+ DocSame indent line : DocOpen _ bra : xs ->+ DocSame indent (line ++ " " ++ bra) : collapseOpen xs+ DocItem indent prefix xs : ys ->+ DocItem indent prefix (collapseOpen xs) : collapseOpen ys+ x : xs ->+ x : collapseOpen xs+ [] ->+ []++dropLeadingSep :: [DocDiff] -> [DocDiff]+dropLeadingSep = \case+ DocOpen oindent bra : DocItem indent prefix xs : ys ->+ DocOpen oindent bra : DocItem (indent + length prefix) "" (dropLeadingSep xs) : dropLeadingSep ys+ DocItem indent prefix xs : ys ->+ DocItem indent prefix (dropLeadingSep xs) : dropLeadingSep ys+ x : xs ->+ x : dropLeadingSep xs+ [] ->+ []++mkDocDiff :: Int -> ValueDiff -> [DocDiff]+mkDocDiff indent = \case+ ValueSame x ->+ same indent (renderValue x)++ diff+ | x <- takeLeft diff+ , y <- takeRight diff+ , oneLiner x+ , oneLiner y+ ->+ removed indent (renderValue x) +++ added indent (renderValue y)++ ValueCon n xs ->+ same indent n +++ concatMap (mkDocDiff (indent + 2)) xs++ ValueRec n nxs ->+ same indent n +++ [DocOpen indent "{"] +++ fmap (\(name, x) -> DocItem (indent + 2) ", " (same 0 (name ++ " =") ++ mkDocDiff 2 x)) nxs +++ [DocClose (indent + 2) "}"]++ ValueTuple xs ->+ [DocOpen indent "("] +++ fmap (DocItem indent ", " . mkDocDiff 0) xs +++ [DocClose indent ")"]++ ValueList xs ->+ [DocOpen indent "["] +++ fmap (DocItem indent ", " . mkDocDiff 0) xs +++ [DocClose indent "]"]++ ValueDiff x y ->+ removed indent (renderValue x) +++ added indent (renderValue y)++oneLiner :: Value -> Bool+oneLiner x =+ case lines (renderValue x) of+ _ : _ : _ ->+ False+ _ ->+ True++same :: Int -> String -> [DocDiff]+same indent =+ fmap (DocSame indent) . lines++removed :: Int -> String -> [DocDiff]+removed indent =+ fmap (DocRemoved indent) . lines++added :: Int -> String -> [DocDiff]+added indent =+ fmap (DocAdded indent) . lines
+ src/Hedgehog/Internal/Shrink.hs view
@@ -0,0 +1,128 @@+module Hedgehog.Internal.Shrink (+ towards+ , towardsFloat+ , list++ , halves+ , removes+ , consNub+ ) where+++-- | Shrink an integral number by edging towards a destination.+--+-- >>> towards 0 100+-- [0,50,75,88,94,97,99]+--+-- >>> towards 500 1000+-- [500,750,875,938,969,985,993,997,999]+--+-- >>> towards (-50) (-26)+-- [-50,-38,-32,-29,-27]+--+-- /Note we always try the destination first, as that is the optimal shrink./+--+towards :: Integral a => a -> a -> [a]+towards destination x =+ if destination == x then+ []+ else+ let+ -- Halve the operands before subtracting them so they don't overflow.+ -- Consider 'minBound' and 'maxBound' for a fixed sized type like 'Int64'.+ diff =+ (x `quot` 2) - (destination `quot` 2)+ in+ destination `consNub` fmap (x -) (halves diff)++-- | Shrink a floating-point number by edging towards a destination.+--+-- >>> towards 0.0 100+-- [0.0,50.0,75.0,87.5,93.75,96.875,98.4375,..+--+-- >>> towards 1.0 0.5+-- [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125,..+--+-- /Note we always try the destination first, as that is the optimal shrink./+--+towardsFloat :: RealFloat a => a -> a -> [a]+towardsFloat destination x =+ if destination == x then+ []+ else+ let+ diff =+ x - destination++ ok y =+ y /= x && not (isNaN y) && not (isInfinite y)+ in+ takeWhile ok .+ fmap (x -) $+ iterate (/ 2) diff++-- | Shrink a list by edging towards the empty list.+--+-- >>> list [1,2,3]+-- [[],[2,3],[1,3],[1,2]]+--+-- >>> list "abcd"+-- ["","cd","ab","bcd","acd","abd","abc"]+--+-- /Note we always try the empty list first, as that is the optimal shrink./+--+list :: [a] -> [[a]]+list xs = do+ concatMap+ (\k -> removes k xs)+ (halves $ length xs)++-- | Produce all permutations of removing 'k' elements from a list.+--+-- >>> removes 2 "abcdef"+-- ["cdef","abef","abcd"]+--+removes :: Int -> [a] -> [[a]]+removes k0 xs0 =+ let+ loop k n xs =+ let+ (hd, tl) =+ splitAt k xs+ in+ if k > n then+ []+ else if null tl then+ [[]]+ else+ tl : fmap (hd ++) (loop k (n - k) tl)+ in+ loop k0 (length xs0) xs0++-- | Produce a list containing the progressive halving of an integral.+--+-- >>> halves 15+-- [15,7,3,1]+--+-- >>> halves 100+-- [100,50,25,12,6,3,1]+--+-- >>> halves (-26)+-- [-26,-13,-6,-3,-1]+--+halves :: Integral a => a -> [a]+halves =+ takeWhile (/= 0) . iterate (`quot` 2)++-- | Cons an element on to the front of a list unless it is already there.+--+consNub :: Eq a => a -> [a] -> [a]+consNub x ys0 =+ case ys0 of+ [] ->+ x : []+ y : ys ->+ if x == y then+ y : ys+ else+ x : y : ys
+ src/Hedgehog/Internal/Source.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Hedgehog.Internal.Source (+ LineNo(..)+ , ColumnNo(..)+ , Span(..)+ , getCaller++ -- * Re-exports from "GHC.Stack"+ , CallStack+ , HasCallStack+ , callStack+ , withFrozenCallStack+ ) where++#if MIN_VERSION_base(4,9,0)+import GHC.Stack (CallStack, HasCallStack, SrcLoc(..))+import GHC.Stack (callStack, getCallStack, withFrozenCallStack)+#else+import GHC.Exts (Constraint)+#endif++newtype LineNo =+ LineNo {+ unLineNo :: Int+ } deriving (Eq, Ord, Num, Enum, Real, Integral)++newtype ColumnNo =+ ColumnNo {+ unColumnNo :: Int+ } deriving (Eq, Ord, Num, Enum, Real, Integral)++data Span =+ Span {+ spanFile :: !FilePath+ , spanStartLine :: !LineNo+ , spanStartColumn :: !ColumnNo+ , spanEndLine :: !LineNo+ , spanEndColumn :: !ColumnNo+ } deriving (Eq, Ord)++#if !MIN_VERSION_base(4,9,0)+type family HasCallStack :: Constraint where+ HasCallStack = ()++data CallStack =+ CallStack+ deriving (Show)++callStack :: HasCallStack => CallStack+callStack =+ CallStack++withFrozenCallStack :: HasCallStack => (HasCallStack => a) -> a+withFrozenCallStack x =+ x+#endif++getCaller :: CallStack -> Maybe Span+#if MIN_VERSION_base(4,9,0)+getCaller stack =+ case getCallStack stack of+ [] ->+ Nothing+ (_, x) : _ ->+ Just $ Span+ (srcLocFile x)+ (fromIntegral $ srcLocStartLine x)+ (fromIntegral $ srcLocStartCol x)+ (fromIntegral $ srcLocEndLine x)+ (fromIntegral $ srcLocEndCol x)+#else+getCaller _ =+ Nothing+#endif++------------------------------------------------------------------------+-- Show instances++instance Show Span where+ showsPrec p (Span file sl sc el ec) =+ showParen (p > 10) $+ showString "Span " .+ showsPrec 11 file .+ showChar ' ' .+ showsPrec 11 sl .+ showChar ' ' .+ showsPrec 11 sc .+ showChar ' ' .+ showsPrec 11 el .+ showChar ' ' .+ showsPrec 11 ec++instance Show LineNo where+ showsPrec p (LineNo x) =+ showParen (p > 10) $+ showString "LineNo " .+ showsPrec 11 x++instance Show ColumnNo where+ showsPrec p (ColumnNo x) =+ showParen (p > 10) $+ showString "ColumnNo " .+ showsPrec 11 x
+ src/Hedgehog/Internal/TH.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+module Hedgehog.Internal.TH (+ TExpQ+ , checkSequential+ , checkConcurrent+ , checkWith+ ) where++import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Ord as Ord++import Hedgehog.Internal.Discovery+import Hedgehog.Internal.Property+import Hedgehog.Internal.Runner++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++type TExpQ a =+ Q (TExp a)++-- | Check all the properties in a file sequentially.+--+-- > tests :: IO Bool+-- > tests =+-- > $$(checkSequential)+--+checkSequential :: TExpQ (IO Bool)+checkSequential =+ checkWith $+ RunnerConfig {+ runnerWorkers =+ Just 1+ }++-- | Check all the properties in a file concurrently.+--+-- > tests :: IO Bool+-- > tests =+-- > $$(checkConcurrent)+--+checkConcurrent :: TExpQ (IO Bool)+checkConcurrent =+ checkWith $+ RunnerConfig {+ runnerWorkers =+ Nothing+ }++-- | Check all the properties in a file.+--+checkWith :: RunnerConfig -> TExpQ (IO Bool)+checkWith config = do+ file <- getCurrentFile+ properties <- Map.toList <$> runIO (readProperties file)++ let+ startLine =+ Ord.comparing $+ posLine .+ posPostion .+ propertySource .+ snd++ names =+ fmap (mkNamedProperty . fst) $+ List.sortBy startLine properties++ [|| checkGroupWith config $$(moduleName) $$(listTE names) ||]++mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property)+mkNamedProperty name = do+ [|| (name, $$(unsafeProperty name)) ||]++unsafeProperty :: PropertyName -> TExpQ Property+unsafeProperty =+ unsafeTExpCoerce . pure . VarE . mkName . unPropertyName++listTE :: [TExpQ a] -> TExpQ [a]+listTE xs = do+ unsafeTExpCoerce . pure . ListE =<< traverse unTypeQ xs++moduleName :: TExpQ GroupName+moduleName = do+ loc <- GroupName . loc_module <$> location+ [|| loc ||]++getCurrentFile :: Q FilePath+getCurrentFile =+ loc_filename <$> location
+ src/Hedgehog/Internal/Tree.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- MonadBase+module Hedgehog.Internal.Tree (+ Tree(..)+ , Node(..)++ , unfold+ , unfoldForest++ , expand+ , prune++ , render+ ) where++import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..), ap)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), Exception)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Morph (MFunctor(..), MMonad(..))+import Control.Monad.Primitive (PrimMonad(..))+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Resource (MonadResource(..))+import Control.Monad.Writer.Class (MonadWriter(..))++#if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes (Show1(..), showsPrec1)+import Data.Functor.Classes (showsUnaryWith, showsBinaryWith)+#endif++------------------------------------------------------------------------++-- | An effectful tree, each node in the tree can have an effect before it is+-- produced.+--+newtype Tree m a =+ Tree {+ runTree :: m (Node m a)+ }++-- | A node in an effectful tree, as well as its unevaluated children.+--+data Node m a =+ Node {+ nodeValue :: a+ , nodeChildren :: [Tree m a]+ }++-- | Create a tree from a value and an unfolding function.+--+unfold :: Monad m => (a -> [a]) -> a -> Tree m a+unfold f x =+ Tree . pure $+ Node x (unfoldForest f x)++-- | Create a forest from a value and an unfolding function.+--+unfoldForest :: Monad m => (a -> [a]) -> a -> [Tree m a]+unfoldForest f =+ fmap (unfold f) . f++-- | Expand a tree using an unfolding function.+--+expand :: Monad m => (a -> [a]) -> Tree m a -> Tree m a+expand f m =+ Tree $ do+ Node x xs <- runTree m+ pure . Node x $+ fmap (expand f) xs ++ unfoldForest f x++-- | Throw away a tree's children.+--+prune :: Monad m => Tree m a -> Tree m a+prune m =+ Tree $ do+ Node x _ <- runTree m+ pure $ Node x []++------------------------------------------------------------------------+-- Node/Tree instances++instance Functor m => Functor (Node m) where+ fmap f (Node x xs) =+ Node (f x) (fmap (fmap f) xs)++instance Functor m => Functor (Tree m) where+ fmap f =+ Tree . fmap (fmap f) . runTree++instance Monad m => Applicative (Node m) where+ pure =+ return+ (<*>) =+ ap++instance Monad m => Applicative (Tree m) where+ pure =+ return+ (<*>) =+ ap++instance Monad m => Monad (Node m) where+ return x =+ Node x []++ (>>=) (Node x xs) k =+ case k x of+ Node y ys ->+ Node y $+ fmap (Tree . fmap (>>= k) . runTree) xs ++ ys++instance Monad m => Monad (Tree m) where+ return x =+ Tree . pure $ Node x []++ (>>=) m k =+ Tree $ do+ Node x xs <- runTree m+ Node y ys <- runTree (k x)+ pure . Node y $+ fmap (>>= k) xs ++ ys++instance MonadPlus m => Alternative (Tree m) where+ empty =+ mzero+ (<|>) =+ mplus++instance MonadPlus m => MonadPlus (Tree m) where+ mzero =+ Tree mzero+ mplus x y =+ Tree (runTree x `mplus` runTree y)++instance MonadTrans Tree where+ lift m =+ Tree $ do+ x <- m+ pure (Node x [])++instance MFunctor Node where+ hoist f (Node x xs) =+ Node x (fmap (hoist f) xs)++instance MFunctor Tree where+ hoist f (Tree m) =+ Tree . f $ fmap (hoist f) m++embedNode :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Node t b -> Node m b+embedNode f (Node x xs) =+ Node x (fmap (embedTree f) xs)++embedTree :: Monad m => (t (Node t b) -> Tree m (Node t b)) -> Tree t b -> Tree m b+embedTree f (Tree m) =+ Tree . pure . embedNode f =<< f m++instance MMonad Tree where+ embed f m =+ embedTree f m++instance PrimMonad m => PrimMonad (Tree m) where+ type PrimState (Tree m) =+ PrimState m+ primitive =+ lift . primitive++instance MonadIO m => MonadIO (Tree m) where+ liftIO =+ lift . liftIO++instance MonadBase b m => MonadBase b (Tree m) where+ liftBase =+ lift . liftBase++instance MonadThrow m => MonadThrow (Tree m) where+ throwM =+ lift . throwM++handleNode :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Node m a -> Node m a+handleNode onErr (Node x xs) =+ Node x $+ fmap (handleTree onErr) xs++handleTree :: (Exception e, MonadCatch m) => (e -> Tree m a) -> Tree m a -> Tree m a+handleTree onErr m =+ Tree . fmap (handleNode onErr) $+ catch (runTree m) (runTree . onErr)++instance MonadCatch m => MonadCatch (Tree m) where+ catch =+ flip handleTree++localNode :: MonadReader r m => (r -> r) -> Node m a -> Node m a+localNode f (Node x xs) =+ Node x $+ fmap (localTree f) xs++localTree :: MonadReader r m => (r -> r) -> Tree m a -> Tree m a+localTree f (Tree m) =+ Tree $+ pure . localNode f =<< local f m++instance MonadReader r m => MonadReader r (Tree m) where+ ask =+ lift ask+ local =+ localTree++instance MonadState s m => MonadState s (Tree m) where+ get =+ lift get+ put =+ lift . put+ state =+ lift . state++listenNode :: MonadWriter w m => w -> Node m a -> Node m (a, w)+listenNode w (Node x xs) =+ Node (x, w) $+ fmap (listenTree w) xs++listenTree :: MonadWriter w m => w -> Tree m a -> Tree m (a, w)+listenTree w0 (Tree m) =+ Tree $ do+ (x, w) <- listen m+ pure $ listenNode (mappend w0 w) x++-- FIXME This just throws away the writer modification function.+passNode :: MonadWriter w m => Node m (a, w -> w) -> Node m a+passNode (Node (x, _) xs) =+ Node x $+ fmap passTree xs++passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a+passTree (Tree m) =+ Tree $ do+ pure . passNode =<< m++instance MonadWriter w m => MonadWriter w (Tree m) where+ writer =+ lift . writer+ tell =+ lift . tell+ listen =+ listenTree mempty+ pass =+ passTree++handleErrorNode :: MonadError e m => (e -> Tree m a) -> Node m a -> Node m a+handleErrorNode onErr (Node x xs) =+ Node x $+ fmap (handleErrorTree onErr) xs++handleErrorTree :: MonadError e m => (e -> Tree m a) -> Tree m a -> Tree m a+handleErrorTree onErr m =+ Tree . fmap (handleErrorNode onErr) $+ catchError (runTree m) (runTree . onErr)++instance MonadError e m => MonadError e (Tree m) where+ throwError =+ lift . throwError+ catchError =+ flip handleErrorTree++instance MonadResource m => MonadResource (Tree m) where+ liftResourceT =+ lift . liftResourceT++------------------------------------------------------------------------+-- Show/Show1 instances++#if MIN_VERSION_base(4,9,0)+instance (Show1 m, Show a) => Show (Node m a) where+ showsPrec =+ showsPrec1++instance (Show1 m, Show a) => Show (Tree m a) where+ showsPrec =+ showsPrec1++instance Show1 m => Show1 (Node m) where+ liftShowsPrec sp sl d (Node x xs) =+ let+ sp1 =+ liftShowsPrec sp sl++ sl1 =+ liftShowList sp sl++ sp2 =+ liftShowsPrec sp1 sl1+ in+ showsBinaryWith sp sp2 "Node" d x xs++instance Show1 m => Show1 (Tree m) where+ liftShowsPrec sp sl d (Tree m) =+ let+ sp1 =+ liftShowsPrec sp sl++ sl1 =+ liftShowList sp sl++ sp2 =+ liftShowsPrec sp1 sl1+ in+ showsUnaryWith sp2 "Tree" d m+#endif++------------------------------------------------------------------------+-- Pretty Printing++--+-- Rendering implementation based on the one from containers/Data.Tree+--++renderTreeLines :: Monad m => Tree m String -> m [String]+renderTreeLines (Tree m) = do+ Node x xs0 <- m+ xs <- renderForestLines xs0+ pure $+ lines (renderNode x) ++ xs++renderNode :: String -> String+renderNode xs =+ case xs of+ [_] ->+ ' ' : xs+ _ ->+ xs++renderForestLines :: Monad m => [Tree m String] -> m [String]+renderForestLines xs0 =+ let+ shift hd other =+ zipWith (++) (hd : repeat other)+ in+ case xs0 of+ [] ->+ pure []++ [x] -> do+ s <- renderTreeLines x+ pure $+ shift " └╼" " " s++ x : xs -> do+ s <- renderTreeLines x+ ss <- renderForestLines xs+ pure $+ shift " ├╼" " │ " s ++ ss++-- | Render a tree of strings, note that this forces all the delayed effects in+-- the tree.+render :: Monad m => Tree m String -> m String+render =+ fmap unlines . renderTreeLines
+ src/Hedgehog/Internal/Tripping.hs view
@@ -0,0 +1,47 @@+module Hedgehog.Internal.Tripping (+ tripping+ ) where++import Hedgehog.Internal.Property+import Hedgehog.Internal.Show+import Hedgehog.Internal.Source+++-- | Test that a pair of render / parse functions are compatible.+--+tripping ::+ HasCallStack+ => Applicative f+ => Monad m+ => Show (f a)+ => Eq (f a)+ => a+ -> (a -> b)+ -> (b -> f a)+ -> Test m ()+tripping x render parse =+ let+ mx =+ pure x++ my =+ (parse . render) x+ in+ if mx == my then+ success+ else+ case valueDiff <$> mkValue mx <*> mkValue my of+ Nothing ->+ withFrozenCallStack $+ failWith Nothing $ unlines [+ "━━━ Original ━━━"+ , showPretty mx+ , "━━━ Roundtrip ━━━"+ , showPretty my+ ]++ Just diff ->+ withFrozenCallStack $+ failWith+ (Just $ Diff "Failed (" "- Original" "/" "+ Roundtrip" ")" diff)+ ""
+ src/Hedgehog/Range.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Hedgehog.Range (+ -- * Size+ Size(..)++ -- * Range+ , Range(..)+ , origin+ , bounds+ , lowerBound+ , upperBound++ -- * Constant+ , singleton+ , constant+ , constantFrom+ , constantBounded++ -- * Linear+ , linear+ , linearFrom+ , linearFrac+ , linearFracFrom+ , linearBounded++ -- * Internal+ -- $internal+ , clamp+ , scaleLinear+ , scaleLinearFrac+ ) where++import Data.Bifunctor (bimap)++import Prelude hiding (minimum, maximum)++-- | Tests are parameterized by the size of the randomly-generated data, the+-- meaning of which depends on the particular generator used.+--+newtype Size =+ Size {+ unSize :: Int+ } deriving (Eq, Ord, Num, Real, Enum, Integral)++instance Show Size where+ showsPrec p (Size x) =+ showParen (p > 10) $+ showString "Size " .+ showsPrec 11 x++instance Read Size where+ readsPrec p =+ readParen (p > 10) $ \r0 -> do+ ("Size", r1) <- lex r0+ (s, r2) <- readsPrec 11 r1+ pure (Size s, r2)++-- | A range describes the bounds of a number to generate, which may or may not+-- be dependent on a 'Size'.+--+data Range a =+ Range !a (Size -> (a, a))++instance Functor Range where+ fmap f (Range z g) =+ Range (f z) $ \sz ->+ bimap f f (g sz)++-- | Get the origin of a range. This might be the mid-point or the lower bound,+-- depending on what the range represents.+--+-- The 'bounds' of a range are scaled around this value when using the+-- 'linear' family of combinators.+--+-- When using a 'Range' to generate numbers, the shrinking function will+-- shrink towards the origin.+--+origin :: Range a -> a+origin (Range z _) =+ z++-- | Get the extents of a range, for a given size.+--+bounds :: Size -> Range a -> (a, a)+bounds sz (Range _ f) =+ f sz++-- | Get the lower bound of a range for the given size.+--+lowerBound :: Ord a => Size -> Range a -> a+lowerBound sz range =+ let+ (x, y) =+ bounds sz range+ in+ min x y++-- | Get the upper bound of a range for the given size.+--+upperBound :: Ord a => Size -> Range a -> a+upperBound sz range =+ let+ (x, y) =+ bounds sz range+ in+ max x y++-- | Construct a range which represents a constant single value.+--+-- >>> bounds x $ singleton 5+-- (5,5)+--+-- >>> origin $ singleton 5+-- 5+--+singleton :: a -> Range a+singleton x =+ Range x $ \_ -> (x, x)++-- | Construct a range which is unaffected by the size parameter.+--+-- A range from @0@ to @10@, with the origin at @0@:+--+-- >>> bounds x $ constant 0 10+-- (0,10)+--+-- >>> origin $ constant 0 10+-- 0+--+constant :: a -> a -> Range a+constant x y =+ constantFrom x x y++-- | Construct a range which is unaffected by the size parameter with a origin+-- point which may differ from the bounds.+--+-- A range from @-10@ to @10@, with the origin at @0@:+--+-- >>> bounds x $ constantFrom 0 (-10) 10+-- (-10,10)+--+-- >>> origin $ constantFrom 0 (-10) 10+-- 0+--+-- A range from @1970@ to @2100@, with the origin at @2000@:+--+-- >>> bounds x $ constantFrom 2000 1970 2100+-- (1970,2100)+--+-- >>> origin $ constantFrom 2000 1970 2100+-- 2000+--+constantFrom :: a -> a -> a -> Range a+constantFrom z x y =+ Range z $ \_ -> (x, y)++-- | Construct a range which is unaffected by the size parameter using the full+-- range of a data type.+--+-- A range from @-128@ to @127@, with the origin at @0@:+--+-- >>> bounds x (constantBounded :: Range Int8)+-- (-128,127)+--+-- >>> origin (constantBounded :: Range Int8)+-- 0+--+constantBounded :: (Bounded a, Num a) => Range a+constantBounded =+ constantFrom 0 minBound maxBound++-- | Construct a range which scales the second bound relative to the size+-- parameter.+--+-- >>> bounds 0 $ linear 0 10+-- (0,0)+--+-- >>> bounds 50 $ linear 0 10+-- (0,5)+--+-- >>> bounds 99 $ linear 0 10+-- (0,10)+--+linear :: Integral a => a -> a -> Range a+linear x y =+ linearFrom x x y++-- | Construct a range which scales the bounds relative to the size parameter.+--+-- >>> bounds 0 $ linearFrom 0 (-10) 10+-- (0,0)+--+-- >>> bounds 50 $ linearFrom 0 (-10) 20+-- (-5,10)+--+-- >>> bounds 99 $ linearFrom 0 (-10) 20+-- (-10,20)+--+linearFrom :: Integral a => a -> a -> a -> Range a+linearFrom z x y =+ Range z $ \sz ->+ let+ x_sized =+ clamp x y $ scaleLinear sz z x++ y_sized =+ clamp x y $ scaleLinear sz z y+ in+ (x_sized, y_sized)++-- | Construct a range which is scaled relative to the size parameter and uses+-- the full range of a data type.+--+-- >>> bounds 0 (linearBounded :: Range Int8)+-- (0,0)+--+-- >>> bounds 50 (linearBounded :: Range Int8)+-- (-64,64)+--+-- >>> bounds 99 (linearBounded :: Range Int8)+-- (-128,127)+--+linearBounded :: (Bounded a, Integral a) => Range a+linearBounded =+ linearFrom 0 minBound maxBound++-- | Construct a range which scales the second bound relative to the size+-- parameter.+--+-- This works the same as 'linear', but for fractional values.+--+linearFrac :: (Fractional a, Ord a) => a -> a -> Range a+linearFrac x y =+ linearFracFrom x x y++-- | Construct a range which scales the bounds relative to the size parameter.+--+-- This works the same as 'linearFrom', but for fractional values.+--+linearFracFrom :: (Fractional a, Ord a) => a -> a -> a -> Range a+linearFracFrom z x y =+ Range z $ \sz ->+ let+ x_sized =+ clamp x y $ scaleLinearFrac sz z x++ y_sized =+ clamp x y $ scaleLinearFrac sz z y+ in+ (x_sized, y_sized)++-- | Truncate a value so it stays within some range.+--+-- >>> clamp 5 10 15+-- 10+--+-- >>> clamp 5 10 0+-- 5+--+clamp :: Ord a => a -> a -> a -> a+clamp x y n =+ if x > y then+ min x (max y n)+ else+ min y (max x n)++-- | Scale an integral linearly with the size parameter.+--+scaleLinear :: Integral a => Size -> a -> a -> a+scaleLinear sz0 z0 n0 =+ let+ sz =+ max 0 (min 99 sz0)++ z =+ toInteger z0++ n =+ toInteger n0++ diff =+ ((n - z) * fromIntegral sz) `quot` 99+ in+ fromInteger $ z + diff++-- | Scale a fractional number linearly with the size parameter.+--+scaleLinearFrac :: Fractional a => Size -> a -> a -> a+scaleLinearFrac sz0 z n =+ let+ sz =+ max 0 (min 99 sz0)++ diff =+ (n - z) * (fromIntegral sz / 99)+ in+ z + diff++------------------------------------------------------------------------+-- Internal++-- $internal+--+-- These functions are exported in case you need them in a pinch, but are not+-- part of the public API and may change at any time, even as part of a minor+-- update.
+ test/test.hs view
@@ -0,0 +1,18 @@+import Control.Monad (unless)+import System.IO (BufferMode(..), hSetBuffering, stdout, stderr)+import System.Exit (exitFailure)++import qualified Test.Hedgehog.Text+++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ results <- sequence [+ Test.Hedgehog.Text.tests+ ]++ unless (and results) $+ exitFailure