-
Notifications
You must be signed in to change notification settings - Fork 109
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #276 from jystic/topic/tree-interleave
Improved, and dare I say minimal, shrinking of lists
- Loading branch information
Showing
14 changed files
with
757 additions
and
417 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,132 @@ | ||
{-# LANGUAGE FlexibleContexts #-} | ||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
{-# LANGUAGE LambdaCase #-} | ||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE TemplateHaskell #-} | ||
module Test.Example.List where | ||
|
||
import Control.Monad.Zip (mzip) | ||
import qualified Control.Monad.State.Lazy as Lazy | ||
import qualified Control.Monad.State.Class as State | ||
import qualified Control.Monad.Writer.Lazy as Lazy | ||
import qualified Control.Monad.Writer.Class as Writer | ||
import Control.Monad.Morph (MFunctor(..)) | ||
|
||
import Data.Maybe (fromJust) | ||
import Data.Foldable (toList) | ||
import Data.Monoid (Sum(..)) | ||
import qualified Data.List as List | ||
|
||
import Hedgehog | ||
import qualified Hedgehog.Range as Range | ||
|
||
import qualified Hedgehog.Internal.Gen as Gen | ||
import qualified Hedgehog.Internal.Shrink as Shrink | ||
import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack) | ||
import Hedgehog.Internal.Tree (Tree) | ||
import qualified Hedgehog.Internal.Tree as Tree | ||
|
||
|
||
genInt :: MonadGen m => m Int | ||
genInt = | ||
Gen.int (Range.constant 0 2) | ||
|
||
genList :: MonadGen m => m a -> m [a] | ||
genList = | ||
Gen.list (Range.constant 0 2) | ||
|
||
prop_list :: Property | ||
prop_list = | ||
property $ do | ||
let | ||
cond :: [Int] -> Bool | ||
cond xs = | ||
all (>= length xs) xs | ||
|
||
renderTree :: Tree [Int] -> String | ||
renderTree = | ||
Tree.render . | ||
fmap show . | ||
fmap (\xs -> (cond xs, xs)) | ||
|
||
ts <- forAllWith renderTree (Gen.toTree $ genList genInt) | ||
xs0 <- forAll (Gen.fromTree ts) | ||
|
||
assert (cond xs0) | ||
|
||
newtype Index = | ||
Index Int | ||
deriving (Eq, Num, Show) | ||
|
||
genStateInt :: (MonadGen m, State.MonadState Index m) => m (Index, Int) | ||
genStateInt = do | ||
x <- genInt | ||
State.modify (+ 1) | ||
index <- State.get | ||
pure (index, x) | ||
|
||
prop_state_list :: Property | ||
prop_state_list = | ||
property $ do | ||
let | ||
cond :: [(a, Int)] -> Bool | ||
cond xs = | ||
all ((>= length xs) . snd) xs | ||
|
||
renderTree :: Tree [(Index, Int)] -> String | ||
renderTree = | ||
Tree.render . | ||
fmap show . | ||
fmap (\xs -> (cond xs, xs)) | ||
|
||
ts <- forAllWith renderTree (Gen.toTree $ hoist (`Lazy.evalStateT` 0) $ genList genStateInt) | ||
xs0 <- forAll (Gen.fromTree ts) | ||
|
||
assert (cond xs0) | ||
|
||
data Log = | ||
List Int | ||
| Int Int | ||
deriving (Show) | ||
|
||
genWriterList :: (MonadGen m, Writer.MonadWriter [Log] m) => m a -> m [a] | ||
genWriterList gen = do | ||
xs <- Gen.list (Range.constant 0 2) gen | ||
Writer.tell [List (length xs)] | ||
pure xs | ||
|
||
genWriterInt :: (MonadGen m, Writer.MonadWriter [Log] m) => m Int | ||
genWriterInt = do | ||
x <- genInt | ||
Writer.tell [Int x] | ||
pure x | ||
|
||
renderLog :: [Log] -> String | ||
renderLog xs = | ||
concat . flip fmap xs $ \case | ||
List n -> | ||
" L" ++ show n | ||
Int n -> | ||
show n | ||
|
||
prop_writer_list :: Property | ||
prop_writer_list = | ||
property $ do | ||
let | ||
cond :: [Int] -> Bool | ||
cond xs = | ||
all ((>= length xs)) xs | ||
|
||
renderTree = | ||
Tree.render . | ||
fmap (\(ns, ws) -> show (cond ns, ns) ++ " (" ++ renderLog ws ++ ")") | ||
|
||
ts <- forAllWith renderTree (Gen.toTree . Lazy.runWriterT $ genWriterList genWriterInt) | ||
(xs0, _) <- forAll (Gen.fromTree ts) | ||
|
||
assert (cond xs0) | ||
|
||
|
||
tests :: IO Bool | ||
tests = | ||
checkParallel $$(discover) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,9 +1,6 @@ | ||
module Hedgehog.Gen ( | ||
-- * Combinators | ||
lift | ||
|
||
-- ** Shrinking | ||
, shrink | ||
shrink | ||
, prune | ||
|
||
-- ** Size | ||
|
Oops, something went wrong.