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