{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module Foundation.Check.Gen
( Gen
, runGen
, GenParams(..)
, GenRng
, genRng
, genWithRng
, genWithParams
) where
import Basement.Imports
import Foundation.Collection
import Foundation.Random
import qualified Foundation.Random.XorShift as XorShift
import Foundation.String
import Foundation.Numerical
import Foundation.Hashing.SipHash
import Foundation.Hashing.Hasher
data GenParams = GenParams
{ GenParams -> Word
genMaxSizeIntegral :: Word
, GenParams -> Word
genMaxSizeArray :: Word
, GenParams -> Word
genMaxSizeString :: Word
}
newtype GenRng = GenRng XorShift.State
type GenSeed = Word64
genRng :: GenSeed -> [String] -> (Word64 -> GenRng)
genRng :: Word64 -> [String] -> Word64 -> GenRng
genRng Word64
seed [String]
groups = \Word64
iteration -> State -> GenRng
GenRng (State -> GenRng) -> State -> GenRng
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> State
XorShift.initialize Word64
rngSeed (Word64
rngSeed Word64 -> Word64 -> Word64
forall a. Multiplicative a => a -> a -> a
* Word64
iteration)
where
(SipHash Word64
rngSeed) = Sip1_3 -> HashResult Sip1_3
forall st. Hasher st => st -> HashResult st
hashEnd (Sip1_3 -> HashResult Sip1_3) -> Sip1_3 -> HashResult Sip1_3
forall a b. (a -> b) -> a -> b
$ UArray Word8 -> Sip1_3 -> Sip1_3
forall e. PrimType e => UArray e -> Sip1_3 -> Sip1_3
forall st e. (Hasher st, PrimType e) => UArray e -> st -> st
hashMixBytes UArray Word8
hashData Sip1_3
iHashState
hashData :: UArray Word8
hashData = Encoding -> String -> UArray Word8
toBytes Encoding
UTF8 (String -> UArray Word8) -> String -> UArray Word8
forall a b. (a -> b) -> a -> b
$ Element [String] -> [String] -> Element [String]
forall c.
(Sequential c, Monoid (Item c)) =>
Element c -> c -> Element c
intercalate String
Element [String]
"::" [String]
groups
iHashState :: Sip1_3
iHashState :: Sip1_3
iHashState = HashInitParam Sip1_3 -> Sip1_3
forall st. Hasher st => HashInitParam st -> st
hashNewParam (Word64 -> Word64 -> SipKey
SipKey Word64
seed Word64
0x12345678)
genGenerator :: GenRng -> (GenRng, GenRng)
genGenerator :: GenRng -> (GenRng, GenRng)
genGenerator (GenRng State
rng) =
let (Word64
newSeed1, State
rngNext) = State -> (Word64, State)
forall gen. RandomGen gen => gen -> (Word64, gen)
randomGenerateWord64 State
rng
(Word64
newSeed2, State
rngNext') = State -> (Word64, State)
forall gen. RandomGen gen => gen -> (Word64, gen)
randomGenerateWord64 State
rngNext
in (State -> GenRng
GenRng (State -> GenRng) -> State -> GenRng
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> State
XorShift.initialize Word64
newSeed1 Word64
newSeed2, State -> GenRng
GenRng State
rngNext')
newtype Gen a = Gen { forall a. Gen a -> GenRng -> GenParams -> a
runGen :: GenRng -> GenParams -> a }
instance Functor Gen where
fmap :: forall a b. (a -> b) -> Gen a -> Gen b
fmap a -> b
f Gen a
g = (GenRng -> GenParams -> b) -> Gen b
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen (\GenRng
rng GenParams
params -> a -> b
f (Gen a -> GenRng -> GenParams -> a
forall a. Gen a -> GenRng -> GenParams -> a
runGen Gen a
g GenRng
rng GenParams
params))
instance Applicative Gen where
pure :: forall a. a -> Gen a
pure a
a = (GenRng -> GenParams -> a) -> Gen a
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen (\GenRng
_ GenParams
_ -> a
a)
Gen (a -> b)
fab <*> :: forall a b. Gen (a -> b) -> Gen a -> Gen b
<*> Gen a
fa = (GenRng -> GenParams -> b) -> Gen b
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen ((GenRng -> GenParams -> b) -> Gen b)
-> (GenRng -> GenParams -> b) -> Gen b
forall a b. (a -> b) -> a -> b
$ \GenRng
rng GenParams
params ->
let (GenRng
r1,GenRng
r2) = GenRng -> (GenRng, GenRng)
genGenerator GenRng
rng
ab :: a -> b
ab = Gen (a -> b) -> GenRng -> GenParams -> a -> b
forall a. Gen a -> GenRng -> GenParams -> a
runGen Gen (a -> b)
fab GenRng
r1 GenParams
params
a :: a
a = Gen a -> GenRng -> GenParams -> a
forall a. Gen a -> GenRng -> GenParams -> a
runGen Gen a
fa GenRng
r2 GenParams
params
in a -> b
ab a
a
instance Monad Gen where
return :: forall a. a -> Gen a
return = a -> Gen a
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Gen a
ma >>= :: forall a b. Gen a -> (a -> Gen b) -> Gen b
>>= a -> Gen b
mb = (GenRng -> GenParams -> b) -> Gen b
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen ((GenRng -> GenParams -> b) -> Gen b)
-> (GenRng -> GenParams -> b) -> Gen b
forall a b. (a -> b) -> a -> b
$ \GenRng
rng GenParams
params ->
let (GenRng
r1,GenRng
r2) = GenRng -> (GenRng, GenRng)
genGenerator GenRng
rng
a :: a
a = Gen a -> GenRng -> GenParams -> a
forall a. Gen a -> GenRng -> GenParams -> a
runGen Gen a
ma GenRng
r1 GenParams
params
in Gen b -> GenRng -> GenParams -> b
forall a. Gen a -> GenRng -> GenParams -> a
runGen (a -> Gen b
mb a
a) GenRng
r2 GenParams
params
genWithRng :: forall a . (forall randomly . MonadRandom randomly => randomly a) -> Gen a
genWithRng :: forall a.
(forall (randomly :: * -> *). MonadRandom randomly => randomly a)
-> Gen a
genWithRng forall (randomly :: * -> *). MonadRandom randomly => randomly a
f = (GenRng -> GenParams -> a) -> Gen a
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen ((GenRng -> GenParams -> a) -> Gen a)
-> (GenRng -> GenParams -> a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \(GenRng State
rng) GenParams
_ ->
let (a
a, State
_) = State -> MonadRandomState State a -> (a, State)
forall gen a.
RandomGen gen =>
gen -> MonadRandomState gen a -> (a, gen)
withRandomGenerator State
rng MonadRandomState State a
forall (randomly :: * -> *). MonadRandom randomly => randomly a
f in a
a
genWithParams :: (GenParams -> Gen a) -> Gen a
genWithParams :: forall a. (GenParams -> Gen a) -> Gen a
genWithParams GenParams -> Gen a
f = (GenRng -> GenParams -> a) -> Gen a
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen ((GenRng -> GenParams -> a) -> Gen a)
-> (GenRng -> GenParams -> a) -> Gen a
forall a b. (a -> b) -> a -> b
$ \GenRng
rng GenParams
params -> Gen a -> GenRng -> GenParams -> a
forall a. Gen a -> GenRng -> GenParams -> a
runGen (GenParams -> Gen a
f GenParams
params) GenRng
rng GenParams
params