module Test.Falsify.Internal.Generator.Definition (
Gen(..)
, bindWithoutShortcut
, prim
, primWith
, exhaustive
, captureLocalTree
, bindIntegral
, perturb
, withoutShrinking
) where
import Control.Monad
import Control.Selective
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Word
import Optics.Core (Lens', (%))
import qualified Optics.Core as Optics
import Data.Falsify.Integer (Bit(..), encIntegerEliasG)
import Test.Falsify.Internal.SampleTree (SampleTree(..), Sample (..), pattern Inf)
import Test.Falsify.Internal.Search
import qualified Test.Falsify.Internal.SampleTree as SampleTree
newtype Gen a = Gen { forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen :: SampleTree -> (a, [SampleTree]) }
deriving stock (forall a b. a -> Gen b -> Gen a
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Gen b -> Gen a
$c<$ :: forall a b. a -> Gen b -> Gen a
fmap :: forall a b. (a -> b) -> Gen a -> Gen b
$cfmap :: forall a b. (a -> b) -> Gen a -> Gen b
Functor)
instance Applicative Gen where
pure :: forall a. a -> Gen a
pure a
x = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ \SampleTree
_st -> (a
x, [])
<*> :: forall a b. Gen (a -> b) -> Gen a -> Gen b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad Gen where
return :: forall a. a -> Gen a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
Gen a
x >>= :: forall a b. Gen a -> (a -> Gen b) -> Gen b
>>= a -> Gen b
f = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ \(Inf Sample
s SampleTree
l SampleTree
r) ->
let (a
a, [SampleTree]
ls) = forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen Gen a
x SampleTree
l
(b
b, [SampleTree]
rs) = forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen (a -> Gen b
f a
a) SampleTree
r
in (b
b, Sample
-> NonEmpty SampleTree -> NonEmpty SampleTree -> [SampleTree]
combineShrunk Sample
s (SampleTree
l forall a. a -> [a] -> NonEmpty a
:| [SampleTree]
ls) (SampleTree
r forall a. a -> [a] -> NonEmpty a
:| [SampleTree]
rs))
instance Selective Gen where
select :: forall a b. Gen (Either a b) -> Gen (a -> b) -> Gen b
select Gen (Either a b)
e Gen (a -> b)
f = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ \(Inf Sample
s SampleTree
l SampleTree
r) -> do
let (Either a b
ma, [SampleTree]
ls) = forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen Gen (Either a b)
e SampleTree
l
case Either a b
ma of
Left a
a ->
let (a -> b
f', [SampleTree]
rs) = forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen Gen (a -> b)
f SampleTree
r
in (a -> b
f' a
a, Sample
-> NonEmpty SampleTree -> NonEmpty SampleTree -> [SampleTree]
combineShrunk Sample
s (SampleTree
l forall a. a -> [a] -> NonEmpty a
:| [SampleTree]
ls) (SampleTree
r forall a. a -> [a] -> NonEmpty a
:| [SampleTree]
rs))
Right b
b ->
(b
b, Sample
-> NonEmpty SampleTree -> NonEmpty SampleTree -> [SampleTree]
combineShrunk Sample
s (SampleTree
l forall a. a -> [a] -> NonEmpty a
:| [SampleTree]
ls) (SampleTree
r forall a. a -> [a] -> NonEmpty a
:| []))
combineShrunk ::
Sample
-> NonEmpty SampleTree
-> NonEmpty SampleTree
-> [SampleTree]
combineShrunk :: Sample
-> NonEmpty SampleTree -> NonEmpty SampleTree -> [SampleTree]
combineShrunk Sample
s (SampleTree
l :| [SampleTree]
ls) (SampleTree
r :| [SampleTree]
rs) = [SampleTree] -> [SampleTree]
shortcut forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[Sample -> SampleTree -> SampleTree -> SampleTree
SampleTree Sample
s SampleTree
l' SampleTree
r | SampleTree
l' <- forall a. SampleTree -> [a] -> [a]
unlessMinimal SampleTree
l [SampleTree]
ls]
, [Sample -> SampleTree -> SampleTree -> SampleTree
SampleTree Sample
s SampleTree
l SampleTree
r' | SampleTree
r' <- forall a. SampleTree -> [a] -> [a]
unlessMinimal SampleTree
r [SampleTree]
rs]
]
where
unlessMinimal :: SampleTree -> [a] -> [a]
unlessMinimal :: forall a. SampleTree -> [a] -> [a]
unlessMinimal SampleTree
Minimal [a]
_ = []
unlessMinimal SampleTree
_ [a]
xs = [a]
xs
shortcut :: [SampleTree] -> [SampleTree]
shortcut :: [SampleTree] -> [SampleTree]
shortcut [] = []
shortcut [SampleTree]
ts = SampleTree
Minimal forall a. a -> [a] -> [a]
: [SampleTree]
ts
bindWithoutShortcut :: Gen a -> (a -> Gen b) -> Gen b
bindWithoutShortcut :: forall a b. Gen a -> (a -> Gen b) -> Gen b
bindWithoutShortcut Gen a
x a -> Gen b
f = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ \(Inf Sample
s SampleTree
l SampleTree
r) ->
let (a
a, [SampleTree]
ls) = forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen Gen a
x SampleTree
l
(b
b, [SampleTree]
rs) = forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen (a -> Gen b
f a
a) SampleTree
r
in (b
b, Sample
-> NonEmpty SampleTree -> NonEmpty SampleTree -> [SampleTree]
combine Sample
s (SampleTree
l forall a. a -> [a] -> NonEmpty a
:| [SampleTree]
ls) (SampleTree
r forall a. a -> [a] -> NonEmpty a
:| [SampleTree]
rs))
where
combine ::
Sample
-> NonEmpty SampleTree
-> NonEmpty SampleTree
-> [SampleTree]
combine :: Sample
-> NonEmpty SampleTree -> NonEmpty SampleTree -> [SampleTree]
combine Sample
s (SampleTree
l :| [SampleTree]
ls) (SampleTree
r :| [SampleTree]
rs) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[Sample -> SampleTree -> SampleTree -> SampleTree
SampleTree Sample
s SampleTree
l' SampleTree
r | SampleTree
l' <- [SampleTree]
ls]
, [Sample -> SampleTree -> SampleTree -> SampleTree
SampleTree Sample
s SampleTree
l SampleTree
r' | SampleTree
r' <- [SampleTree]
rs]
]
bindIntegral :: Integral a => Gen a -> (a -> Gen b) -> Gen b
bindIntegral :: forall a b. Integral a => Gen a -> (a -> Gen b) -> Gen b
bindIntegral Gen a
x a -> Gen b
f = Gen a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall a b. Integral a => a -> Gen b -> Gen b
perturb a
a (a -> Gen b
f a
a)
perturb :: Integral a => a -> Gen b -> Gen b
perturb :: forall a b. Integral a => a -> Gen b -> Gen b
perturb a
a Gen b
g = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ \SampleTree
st ->
let (b
b, [SampleTree]
shrunk) = forall a. Gen a -> SampleTree -> (a, [SampleTree])
runGen Gen b
g (forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
Optics.view Lens' SampleTree SampleTree
lens SampleTree
st)
in (b
b, forall a b. (a -> b) -> [a] -> [b]
map (\SampleTree
st' -> forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
Optics.set Lens' SampleTree SampleTree
lens SampleTree
st' SampleTree
st) [SampleTree]
shrunk)
where
lens :: Lens' SampleTree SampleTree
lens :: Lens' SampleTree SampleTree
lens = [Bit] -> Lens' SampleTree SampleTree
computeLens (Integer -> [Bit]
encIntegerEliasG forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a)
computeLens :: [Bit] -> Lens' SampleTree SampleTree
computeLens :: [Bit] -> Lens' SampleTree SampleTree
computeLens [] = forall destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
Optics.castOptic forall a. Iso' a a
Optics.simple
computeLens (Bit
O : [Bit]
bs) = Lens' SampleTree SampleTree
SampleTree.left forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% [Bit] -> Lens' SampleTree SampleTree
computeLens [Bit]
bs
computeLens (Bit
I : [Bit]
bs) = Lens' SampleTree SampleTree
SampleTree.right forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% [Bit] -> Lens' SampleTree SampleTree
computeLens [Bit]
bs
prim :: Gen Word64
prim :: Gen Word64
prim =
Sample -> Word64
SampleTree.sampleValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Sample -> [Word64]) -> Gen Sample
primWith (Word64 -> [Word64]
binarySearch forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> Word64
SampleTree.sampleValue)
primWith :: (Sample -> [Word64]) -> Gen Sample
primWith :: (Sample -> [Word64]) -> Gen Sample
primWith Sample -> [Word64]
f = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ \(Inf Sample
s SampleTree
l SampleTree
r) -> (
Sample
s
, (\Word64
s' -> Sample -> SampleTree -> SampleTree -> SampleTree
SampleTree (Word64 -> Sample
Shrunk Word64
s') SampleTree
l SampleTree
r) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sample -> [Word64]
f Sample
s
)
exhaustive :: Word64 -> Gen Word64
exhaustive :: Word64 -> Gen Word64
exhaustive Word64
n =
forall a. Ord a => a -> a -> a
min Word64
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> Word64
SampleTree.sampleValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(Sample -> [Word64]) -> Gen Sample
primWith (Word64 -> [Word64]
completeSearch forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sample -> Word64
SampleTree.sampleValue)
where
completeSearch :: Word64 -> [Word64]
completeSearch :: Word64 -> [Word64]
completeSearch Word64
0 = []
completeSearch Word64
x = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Ord a => a -> a -> Bool
<= Word64
n) [Word64
0 .. forall a. Enum a => a -> a
pred Word64
x]
captureLocalTree :: Gen SampleTree
captureLocalTree :: Gen SampleTree
captureLocalTree = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ \SampleTree
st -> (SampleTree
st, [])
withoutShrinking :: Gen a -> Gen a
withoutShrinking :: forall a. Gen a -> Gen a
withoutShrinking (Gen SampleTree -> (a, [SampleTree])
g) = forall a. (SampleTree -> (a, [SampleTree])) -> Gen a
Gen forall a b. (a -> b) -> a -> b
$ forall a. (a, [SampleTree]) -> (a, [SampleTree])
aux forall b c a. (b -> c) -> (a -> b) -> a -> c
. SampleTree -> (a, [SampleTree])
g
where
aux :: (a, [SampleTree]) -> (a, [SampleTree])
aux :: forall a. (a, [SampleTree]) -> (a, [SampleTree])
aux (a
outcome, [SampleTree]
_) = (a
outcome, [])