diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +hedgehog [![Hackage version](https://img.shields.io/hackage/v/hedgehog.svg?style=flat)](http://hackage.haskell.org/package/hedgehog) [![Build Status](https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master)](https://travis-ci.org/hedgehogqa/haskell-hedgehog) +======== + +> Hedgehog will eat all your bugs. + + + +[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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hedgehog.cabal b/hedgehog.cabal new file mode 100644 --- /dev/null +++ b/hedgehog.cabal @@ -0,0 +1,120 @@ +name: + hedgehog +version: + 0.1 +license: + BSD3 +author: + Jacob Stanley +maintainer: + Jacob Stanley +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: + +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 diff --git a/src/Hedgehog.hs b/src/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog.hs @@ -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(..)) diff --git a/src/Hedgehog/Gen.hs b/src/Hedgehog/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Gen.hs @@ -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 "" 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. diff --git a/src/Hedgehog/Internal/Discovery.hs b/src/Hedgehog/Internal/Discovery.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Discovery.hs @@ -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 diff --git a/src/Hedgehog/Internal/Property.hs b/src/Hedgehog/Internal/Property.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Property.hs @@ -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. diff --git a/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Report.hs @@ -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 "" (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 -> + "" + 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 diff --git a/src/Hedgehog/Internal/Runner.hs b/src/Hedgehog/Internal/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Runner.hs @@ -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) diff --git a/src/Hedgehog/Internal/Seed.hs b/src/Hedgehog/Internal/Seed.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Seed.hs @@ -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. diff --git a/src/Hedgehog/Internal/Show.hs b/src/Hedgehog/Internal/Show.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Show.hs @@ -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 diff --git a/src/Hedgehog/Internal/Shrink.hs b/src/Hedgehog/Internal/Shrink.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Shrink.hs @@ -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 diff --git a/src/Hedgehog/Internal/Source.hs b/src/Hedgehog/Internal/Source.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Source.hs @@ -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 diff --git a/src/Hedgehog/Internal/TH.hs b/src/Hedgehog/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/TH.hs @@ -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 diff --git a/src/Hedgehog/Internal/Tree.hs b/src/Hedgehog/Internal/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Tree.hs @@ -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 diff --git a/src/Hedgehog/Internal/Tripping.hs b/src/Hedgehog/Internal/Tripping.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Tripping.hs @@ -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) + "" diff --git a/src/Hedgehog/Range.hs b/src/Hedgehog/Range.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Range.hs @@ -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. diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -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