{-# LANGUAGE CPP #-}

-- | Replay seeds
--
-- We need a seed/gamma pair to initialize a splitmix PRNG. This is however a
-- pretty low level implementation detail that I'd prefer not be be directly
-- visible. We therefore provide a thin layer on top, which provides an
-- "encoded" replay seed. This has the additional benefits that the length of
-- the replay seed is always the same (unlike just writing a 'Word64'), and we
-- could in principle at some point support other kinds of PRNGs.
module Test.Falsify.Internal.Driver.ReplaySeed (
    ReplaySeed(..)
  , parseReplaySeed
  , safeReadReplaySeed
  , splitmixReplaySeed
  ) where

import Data.String
import Data.Word
import Data.Binary
import System.Random.SplitMix

import qualified Data.ByteString.Base16.Lazy as Lazy.Base16
import qualified Data.ByteString.Lazy.Char8  as Lazy.Char8

data ReplaySeed =
    ReplaySplitmix Word64 Word64

splitmixReplaySeed :: SMGen -> ReplaySeed
splitmixReplaySeed :: SMGen -> ReplaySeed
splitmixReplaySeed = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word64 -> Word64 -> ReplaySeed
ReplaySplitmix forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMGen -> (Word64, Word64)
unseedSMGen

instance Binary ReplaySeed where
  put :: ReplaySeed -> Put
put (ReplaySplitmix Word64
seed Word64
gamma) = do
      Word8 -> Put
putWord8 Word8
1
      forall t. Binary t => t -> Put
put Word64
seed
      forall t. Binary t => t -> Put
put Word64
gamma

  get :: Get ReplaySeed
get = do
      Word8
tag <- Get Word8
getWord8
      case Word8
tag of
        Word8
1 -> do Word64
seed  <- forall t. Binary t => Get t
get
                Word64
gamma <- forall t. Binary t => Get t
get
                if forall a. Integral a => a -> Bool
odd Word64
gamma
                  then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> ReplaySeed
ReplaySplitmix Word64
seed Word64
gamma
                  else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"ReplaySeed: expected odd gamma for splitmix"
        Word8
n -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"ReplaySeed: invalid tag: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
n

instance Show ReplaySeed where
  show :: ReplaySeed -> String
show = ByteString -> String
Lazy.Char8.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Lazy.Base16.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Binary a => a -> ByteString
encode

instance IsString ReplaySeed where
  fromString :: String -> ReplaySeed
fromString = Maybe ReplaySeed -> ReplaySeed
aux forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe ReplaySeed
safeReadReplaySeed
    where
      aux :: Maybe ReplaySeed -> ReplaySeed
      aux :: Maybe ReplaySeed -> ReplaySeed
aux Maybe ReplaySeed
Nothing  = forall a. HasCallStack => String -> a
error String
"ReplaySeed: invalid seed"
      aux (Just ReplaySeed
s) = ReplaySeed
s

safeReadReplaySeed :: String -> Maybe ReplaySeed
safeReadReplaySeed :: String -> Maybe ReplaySeed
safeReadReplaySeed = forall (m :: * -> *). MonadFail m => String -> m ReplaySeed
parseReplaySeed

#if MIN_VERSION_base(4,13,0)
parseReplaySeed :: forall m. MonadFail m => String -> m ReplaySeed
#else
parseReplaySeed :: forall m. Monad m => String -> m ReplaySeed
#endif

parseReplaySeed :: forall (m :: * -> *). MonadFail m => String -> m ReplaySeed
parseReplaySeed String
str = do
    ByteString
raw <- case ByteString -> Either String ByteString
Lazy.Base16.decode (String -> ByteString
Lazy.Char8.pack String
str) of
             Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
             Right ByteString
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
    case forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
raw of
      Left  (ByteString
_, ByteOffset
_, String
err) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
      Right (ByteString
_, ByteOffset
_, ReplaySeed
x)   -> forall (m :: * -> *) a. Monad m => a -> m a
return ReplaySeed
x