{-# 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 -- maximum number of bytes
    , GenParams -> Word
genMaxSizeArray    :: Word -- number of elements, as placeholder
    , GenParams -> Word
genMaxSizeString   :: Word -- maximum number of chars
    }

newtype GenRng = GenRng XorShift.State

type GenSeed = Word64

genRng :: GenSeed -> [String] -> (Word64 -> GenRng)
genRng :: GenSeed -> [String] -> GenSeed -> GenRng
genRng seed :: GenSeed
seed groups :: [String]
groups = \iteration :: GenSeed
iteration -> State -> GenRng
GenRng (State -> GenRng) -> State -> GenRng
forall a b. (a -> b) -> a -> b
$ GenSeed -> GenSeed -> State
XorShift.initialize GenSeed
rngSeed (GenSeed
rngSeed GenSeed -> GenSeed -> GenSeed
forall a. Multiplicative a => a -> a -> a
* GenSeed
iteration)
  where
    (SipHash rngSeed :: GenSeed
rngSeed) = Sip1_3 -> SipHash
forall st. Hasher st => st -> HashResult st
hashEnd (Sip1_3 -> SipHash) -> Sip1_3 -> SipHash
forall a b. (a -> b) -> a -> b
$ UArray Word8 -> 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]
groups
    iHashState :: Sip1_3
    iHashState :: Sip1_3
iHashState = HashInitParam Sip1_3 -> Sip1_3
forall st. Hasher st => HashInitParam st -> st
hashNewParam (GenSeed -> GenSeed -> SipKey
SipKey GenSeed
seed 0x12345678)

genGenerator :: GenRng -> (GenRng, GenRng)
genGenerator :: GenRng -> (GenRng, GenRng)
genGenerator (GenRng rng :: State
rng) =
    let (newSeed1 :: GenSeed
newSeed1, rngNext :: State
rngNext) = State -> (GenSeed, State)
forall gen. RandomGen gen => gen -> (GenSeed, gen)
randomGenerateWord64 State
rng
        (newSeed2 :: GenSeed
newSeed2, rngNext' :: State
rngNext') = State -> (GenSeed, State)
forall gen. RandomGen gen => gen -> (GenSeed, gen)
randomGenerateWord64 State
rngNext
     in (State -> GenRng
GenRng (State -> GenRng) -> State -> GenRng
forall a b. (a -> b) -> a -> b
$ GenSeed -> GenSeed -> State
XorShift.initialize GenSeed
newSeed1 GenSeed
newSeed2, State -> GenRng
GenRng State
rngNext')

-- | Generator monad
newtype Gen a = Gen { Gen a -> GenRng -> GenParams -> a
runGen :: GenRng -> GenParams -> a }

instance Functor Gen where
    fmap :: (a -> b) -> Gen a -> Gen b
fmap f :: a -> b
f g :: Gen a
g = (GenRng -> GenParams -> b) -> Gen b
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen (\rng :: GenRng
rng params :: 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 :: a -> Gen a
pure a :: a
a     = (GenRng -> GenParams -> a) -> Gen a
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen (\_ _ -> a
a)
    fab :: Gen (a -> b)
fab <*> :: Gen (a -> b) -> Gen a -> Gen b
<*> fa :: 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
$ \rng :: GenRng
rng params :: GenParams
params ->
        let (r1 :: GenRng
r1,r2 :: 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 :: a -> Gen a
return a :: a
a  = (GenRng -> GenParams -> a) -> Gen a
forall a. (GenRng -> GenParams -> a) -> Gen a
Gen (\_ _ -> a
a)
    ma :: Gen a
ma >>= :: Gen a -> (a -> Gen b) -> Gen b
>>= mb :: 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
$ \rng :: GenRng
rng params :: GenParams
params ->
            let (r1 :: GenRng
r1,r2 :: 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 (randomly :: * -> *). MonadRandom randomly => randomly a)
-> Gen a
genWithRng f :: 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 rng :: State
rng) _ ->
    let (a :: a
a, _) = 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 :: (GenParams -> Gen a) -> Gen a
genWithParams f :: 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
$ \rng :: GenRng
rng params :: 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