1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
{-# 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
{ genMaxSizeIntegral :: Word -- maximum number of bytes
, genMaxSizeArray :: Word -- number of elements, as placeholder
, genMaxSizeString :: Word -- maximum number of chars
}
newtype GenRng = GenRng XorShift.State
type GenSeed = Word64
genRng :: GenSeed -> [String] -> (Word64 -> GenRng)
genRng seed groups = \iteration -> GenRng $ XorShift.initialize rngSeed (rngSeed * iteration)
where
(SipHash rngSeed) = hashEnd $ hashMixBytes hashData iHashState
hashData = toBytes UTF8 $ intercalate "::" groups
iHashState :: Sip1_3
iHashState = hashNewParam (SipKey seed 0x12345678)
genGenerator :: GenRng -> (GenRng, GenRng)
genGenerator (GenRng rng) =
let (newSeed1, rngNext) = randomGenerateWord64 rng
(newSeed2, rngNext') = randomGenerateWord64 rngNext
in (GenRng $ XorShift.initialize newSeed1 newSeed2, GenRng rngNext')
-- | Generator monad
newtype Gen a = Gen { runGen :: GenRng -> GenParams -> a }
instance Functor Gen where
fmap f g = Gen (\rng params -> f (runGen g rng params))
instance Applicative Gen where
pure a = Gen (\_ _ -> a)
fab <*> fa = Gen $ \rng params ->
let (r1,r2) = genGenerator rng
ab = runGen fab r1 params
a = runGen fa r2 params
in ab a
instance Monad Gen where
return = pure
ma >>= mb = Gen $ \rng params ->
let (r1,r2) = genGenerator rng
a = runGen ma r1 params
in runGen (mb a) r2 params
genWithRng :: forall a . (forall randomly . MonadRandom randomly => randomly a) -> Gen a
genWithRng f = Gen $ \(GenRng rng) _ ->
let (a, _) = withRandomGenerator rng f in a
genWithParams :: (GenParams -> Gen a) -> Gen a
genWithParams f = Gen $ \rng params -> runGen (f params) rng params
|
