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