module Test.Falsify.Internal.Generator.Shrinking (
shrinkFrom
, ShrinkExplanation(..)
, ShrinkHistory(..)
, IsValidShrink(..)
, limitShrinkSteps
, shrinkHistory
, shrinkOutcome
) where
import Data.Bifunctor
import Data.Either
import Data.List.NonEmpty (NonEmpty((:|)))
import Test.Falsify.Internal.Generator.Definition
import Test.Falsify.Internal.SampleTree (SampleTree(..))
data ShrinkExplanation p n = ShrinkExplanation {
forall p n. ShrinkExplanation p n -> p
initial :: p
, forall p n. ShrinkExplanation p n -> ShrinkHistory p n
history :: ShrinkHistory p n
}
deriving (Int -> ShrinkExplanation p n -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p n.
(Show p, Show n) =>
Int -> ShrinkExplanation p n -> ShowS
forall p n. (Show p, Show n) => [ShrinkExplanation p n] -> ShowS
forall p n. (Show p, Show n) => ShrinkExplanation p n -> String
showList :: [ShrinkExplanation p n] -> ShowS
$cshowList :: forall p n. (Show p, Show n) => [ShrinkExplanation p n] -> ShowS
show :: ShrinkExplanation p n -> String
$cshow :: forall p n. (Show p, Show n) => ShrinkExplanation p n -> String
showsPrec :: Int -> ShrinkExplanation p n -> ShowS
$cshowsPrec :: forall p n.
(Show p, Show n) =>
Int -> ShrinkExplanation p n -> ShowS
Show)
data ShrinkHistory p n =
ShrunkTo p (ShrinkHistory p n)
| ShrinkingDone [n]
| ShrinkingStopped
deriving (Int -> ShrinkHistory p n -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p n. (Show p, Show n) => Int -> ShrinkHistory p n -> ShowS
forall p n. (Show p, Show n) => [ShrinkHistory p n] -> ShowS
forall p n. (Show p, Show n) => ShrinkHistory p n -> String
showList :: [ShrinkHistory p n] -> ShowS
$cshowList :: forall p n. (Show p, Show n) => [ShrinkHistory p n] -> ShowS
show :: ShrinkHistory p n -> String
$cshow :: forall p n. (Show p, Show n) => ShrinkHistory p n -> String
showsPrec :: Int -> ShrinkHistory p n -> ShowS
$cshowsPrec :: forall p n. (Show p, Show n) => Int -> ShrinkHistory p n -> ShowS
Show)
limitShrinkSteps :: Maybe Word -> ShrinkExplanation p n -> ShrinkExplanation p n
limitShrinkSteps :: forall p n.
Maybe Word -> ShrinkExplanation p n -> ShrinkExplanation p n
limitShrinkSteps Maybe Word
Nothing = forall a. a -> a
id
limitShrinkSteps (Just Word
limit) = \case
ShrinkExplanation{p
initial :: p
initial :: forall p n. ShrinkExplanation p n -> p
initial, ShrinkHistory p n
history :: ShrinkHistory p n
history :: forall p n. ShrinkExplanation p n -> ShrinkHistory p n
history} ->
ShrinkExplanation{
p
initial :: p
initial :: p
initial
, history :: ShrinkHistory p n
history = forall p n. Word -> ShrinkHistory p n -> ShrinkHistory p n
go Word
limit ShrinkHistory p n
history
}
where
go :: Word -> ShrinkHistory p n -> ShrinkHistory p n
go :: forall p n. Word -> ShrinkHistory p n -> ShrinkHistory p n
go Word
0 (ShrunkTo p
_ ShrinkHistory p n
_) = forall p n. ShrinkHistory p n
ShrinkingStopped
go Word
n (ShrunkTo p
x ShrinkHistory p n
xs) = forall p n. p -> ShrinkHistory p n -> ShrinkHistory p n
ShrunkTo p
x (forall p n. Word -> ShrinkHistory p n -> ShrinkHistory p n
go (forall a. Enum a => a -> a
pred Word
n) ShrinkHistory p n
xs)
go Word
_ (ShrinkingDone [n]
rej) = forall p n. [n] -> ShrinkHistory p n
ShrinkingDone [n]
rej
go Word
_ ShrinkHistory p n
ShrinkingStopped = forall p n. ShrinkHistory p n
ShrinkingStopped
shrinkHistory :: ShrinkExplanation p n -> NonEmpty p
shrinkHistory :: forall p n. ShrinkExplanation p n -> NonEmpty p
shrinkHistory = \(ShrinkExplanation p
unshrunk ShrinkHistory p n
shrunk) ->
p
unshrunk forall a. a -> [a] -> NonEmpty a
:| forall p n. ShrinkHistory p n -> [p]
go ShrinkHistory p n
shrunk
where
go :: ShrinkHistory p n -> [p]
go :: forall p n. ShrinkHistory p n -> [p]
go (ShrunkTo p
x ShrinkHistory p n
xs) = p
x forall a. a -> [a] -> [a]
: forall p n. ShrinkHistory p n -> [p]
go ShrinkHistory p n
xs
go (ShrinkingDone [n]
_) = []
go ShrinkHistory p n
ShrinkingStopped = []
shrinkOutcome :: forall p n. ShrinkExplanation p n -> (p, Maybe [n])
shrinkOutcome :: forall p n. ShrinkExplanation p n -> (p, Maybe [n])
shrinkOutcome = \ShrinkExplanation{p
initial :: p
initial :: forall p n. ShrinkExplanation p n -> p
initial, ShrinkHistory p n
history :: ShrinkHistory p n
history :: forall p n. ShrinkExplanation p n -> ShrinkHistory p n
history} ->
p -> ShrinkHistory p n -> (p, Maybe [n])
go p
initial ShrinkHistory p n
history
where
go :: p -> ShrinkHistory p n -> (p, Maybe [n])
go :: p -> ShrinkHistory p n -> (p, Maybe [n])
go p
_ (ShrunkTo p
p ShrinkHistory p n
h) = p -> ShrinkHistory p n -> (p, Maybe [n])
go p
p ShrinkHistory p n
h
go p
p (ShrinkingDone [n]
ns) = (p
p, forall a. a -> Maybe a
Just [n]
ns)
go p
p ShrinkHistory p n
ShrinkingStopped = (p
p, forall a. Maybe a
Nothing)
instance Functor (ShrinkExplanation p) where
fmap :: forall a b.
(a -> b) -> ShrinkExplanation p a -> ShrinkExplanation p b
fmap = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second
instance Functor (ShrinkHistory p) where
fmap :: forall a b. (a -> b) -> ShrinkHistory p a -> ShrinkHistory p b
fmap = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second
instance Bifunctor ShrinkExplanation where
bimap :: forall a b c d.
(a -> b)
-> (c -> d) -> ShrinkExplanation a c -> ShrinkExplanation b d
bimap a -> b
f c -> d
g ShrinkExplanation{a
initial :: a
initial :: forall p n. ShrinkExplanation p n -> p
initial, ShrinkHistory a c
history :: ShrinkHistory a c
history :: forall p n. ShrinkExplanation p n -> ShrinkHistory p n
history} = ShrinkExplanation{
initial :: b
initial = a -> b
f a
initial
, history :: ShrinkHistory b d
history = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g ShrinkHistory a c
history
}
instance Bifunctor ShrinkHistory where
bimap :: forall a b c d.
(a -> b) -> (c -> d) -> ShrinkHistory a c -> ShrinkHistory b d
bimap a -> b
f c -> d
g = \case
ShrunkTo a
truncated ShrinkHistory a c
history ->
forall p n. p -> ShrinkHistory p n -> ShrinkHistory p n
ShrunkTo (a -> b
f a
truncated) (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g ShrinkHistory a c
history)
ShrinkingDone [c]
rejected ->
forall p n. [n] -> ShrinkHistory p n
ShrinkingDone (forall a b. (a -> b) -> [a] -> [b]
map c -> d
g [c]
rejected)
ShrinkHistory a c
ShrinkingStopped ->
forall p n. ShrinkHistory p n
ShrinkingStopped
data IsValidShrink p n =
ValidShrink p
| InvalidShrink n
deriving stock (Int -> IsValidShrink p n -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p n. (Show p, Show n) => Int -> IsValidShrink p n -> ShowS
forall p n. (Show p, Show n) => [IsValidShrink p n] -> ShowS
forall p n. (Show p, Show n) => IsValidShrink p n -> String
showList :: [IsValidShrink p n] -> ShowS
$cshowList :: forall p n. (Show p, Show n) => [IsValidShrink p n] -> ShowS
show :: IsValidShrink p n -> String
$cshow :: forall p n. (Show p, Show n) => IsValidShrink p n -> String
showsPrec :: Int -> IsValidShrink p n -> ShowS
$cshowsPrec :: forall p n. (Show p, Show n) => Int -> IsValidShrink p n -> ShowS
Show)
shrinkFrom :: forall a p n.
(a -> IsValidShrink p n)
-> Gen a
-> (p, [SampleTree])
-> ShrinkExplanation p n
shrinkFrom :: forall a p n.
(a -> IsValidShrink p n)
-> Gen a -> (p, [SampleTree]) -> ShrinkExplanation p n
shrinkFrom a -> IsValidShrink p n
prop Gen a
gen = \(p
p, [SampleTree]
shrunk) ->
forall p n. p -> ShrinkHistory p n -> ShrinkExplanation p n
ShrinkExplanation p
p forall a b. (a -> b) -> a -> b
$ [SampleTree] -> ShrinkHistory p n
go [SampleTree]
shrunk
where
go :: [SampleTree] -> ShrinkHistory p n
go :: [SampleTree] -> ShrinkHistory p n
go [SampleTree]
shrunk =
case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (p, [SampleTree]) n]
candidates of
([], [n]
rejected) -> forall p n. [n] -> ShrinkHistory p n
ShrinkingDone [n]
rejected
((p
p, [SampleTree]
shrunk'):[(p, [SampleTree])]
_, [n]
_) -> forall p n. p -> ShrinkHistory p n -> ShrinkHistory p n
ShrunkTo p
p forall a b. (a -> b) -> a -> b
$ [SampleTree] -> ShrinkHistory p n
go [SampleTree]
shrunk'
where
candidates :: [Either (p, [SampleTree]) n]
candidates :: [Either (p, [SampleTree]) n]
candidates = forall a b. (a -> b) -> [a] -> [b]
map (a, [SampleTree]) -> Either (p, [SampleTree]) n
consider forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen Gen a
gen) [SampleTree]
shrunk
consider :: (a, [SampleTree]) -> Either (p, [SampleTree]) n
consider :: (a, [SampleTree]) -> Either (p, [SampleTree]) n
consider (a
a, [SampleTree]
shrunk) =
case a -> IsValidShrink p n
prop a
a of
ValidShrink p
p -> forall a b. a -> Either a b
Left (p
p, [SampleTree]
shrunk)
InvalidShrink n
n -> forall a b. b -> Either a b
Right n
n