diff --git a/random.cabal b/random.cabal index 6cc5a4bf..92584eb9 100644 --- a/random.cabal +++ b/random.cabal @@ -147,6 +147,7 @@ test-suite spec other-modules: Spec.Range Spec.Run + Spec.Seed Spec.Stateful default-language: Haskell2010 diff --git a/src/System/Random/Seed.hs b/src/System/Random/Seed.hs index b1bbd52c..9788f9c8 100644 --- a/src/System/Random/Seed.hs +++ b/src/System/Random/Seed.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | -- Module : System.Random.Seed -- Copyright : (c) Alexey Kuleshevich 2024 @@ -30,6 +31,7 @@ module System.Random.Seed , withSeed , withSeedM , withSeedFile + , seedGenTypeName , nonEmptyToSeed , nonEmptyFromSeed ) where @@ -96,6 +98,23 @@ import qualified System.Random.SplitMix32 as SM32 -- independence is not sufficient, then an adventurous developer can try implementing -- conversion into bytes directly with `unseedGen` and `seedGen`. -- +-- Properties that must hold: +-- +-- @ +-- > seedGen (unseedGen gen) == gen +-- @ +-- +-- @ +-- > seedGen64 (unseedGen64 gen) == gen +-- @ +-- +-- Note, that there is no requirement for every `Seed` to roundtrip, eg. this proprty does +-- not even hold for `StdGen`: +-- +-- >>> let seed = nonEmptyToSeed (0xab :| [0xff00]) :: Seed StdGen +-- >>> seed == unseedGen (seedGen seed) +-- False +-- -- @since 1.3.0 class (KnownNat (SeedSize g), 1 <= SeedSize g, Typeable g) => SeedGen g where -- | Number of bytes that is required for storing the full state of a pseudo-random @@ -200,7 +219,7 @@ mkSeed ba = do ++ ". Exactly " ++ show (seedSize @g) ++ " bytes is required by the " - ++ show (genTypeName @g) + ++ show (seedGenTypeName @g) pure $ Seed ba -- | Helper function that allows for operating directly on the `Seed`, while supplying a @@ -230,8 +249,8 @@ withSeedM seed f = fmap unseedGen <$> f (seedGen seed) -- error reporting. -- -- @since 1.3.0 -genTypeName :: forall g. SeedGen g => String -genTypeName = show (typeOf (Proxy @g)) +seedGenTypeName :: forall g. SeedGen g => String +seedGenTypeName = show (typeOf (Proxy @g)) -- | Just like `mkSeed`, but uses `ByteString` as argument. Results in a memcopy of the seed. @@ -289,7 +308,7 @@ nonEmptyFromSeed (Seed ba) = Just ne -> ne Nothing -> -- Seed is at least 1 byte in size, so it can't be empty error $ "Impossible: Seed for " - ++ genTypeName @g + ++ seedGenTypeName @g ++ " must be at least: " ++ show (seedSize @g) ++ " bytes, but got " diff --git a/test/Spec.hs b/test/Spec.hs index 8c5ca258..2ab67cf2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -36,6 +36,7 @@ import Data.Monoid ((<>)) import qualified Spec.Range as Range import qualified Spec.Run as Run +import qualified Spec.Seed as Seed import qualified Spec.Stateful as Stateful main :: IO () @@ -106,6 +107,7 @@ main = , uniformSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word)) , uniformSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word)) , Stateful.statefulGenSpec + , Seed.spec ] floatTests :: TestTree diff --git a/test/Spec/Seed.hs b/test/Spec/Seed.hs new file mode 100644 index 00000000..591ed611 --- /dev/null +++ b/test/Spec/Seed.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Spec.Seed where + +import Data.Bits +import Data.List.NonEmpty as NE +import Data.Maybe (fromJust) +import Data.Proxy +import Data.Word +import System.Random +import Test.Tasty +import Test.Tasty.SmallCheck as SC +import qualified Data.ByteString as BS +import GHC.TypeLits +import qualified GHC.Exts as GHC (IsList(..)) +import Test.SmallCheck.Series hiding (NonEmpty(..)) +import Spec.Stateful () + +newtype GenN (n :: Nat) = GenN BS.ByteString + deriving (Eq, Show) + +instance (KnownNat n, Monad m) => Serial m (GenN n) where + series = GenN . fst . uniformByteString n . mkStdGen <$> series + where + n = fromInteger (natVal (Proxy :: Proxy n)) + +instance (KnownNat n, Monad m) => Serial m (Gen64 n) where + series = + Gen64 . dropExtra . fst . uniformList n . mkStdGen <$> series + where + (n, r8) = + case fromInteger (natVal (Proxy :: Proxy n)) `quotRem` 8 of + (q, 0) -> (q, 0) + (q, r) -> (q + 1, (8 - r) * 8) + -- We need to drop extra top most bits in the last generated Word64 in order for + -- roundtrip to work, because that is exactly what SeedGen will do + dropExtra xs = + case NE.reverse (fromJust (NE.nonEmpty xs)) of + w64 :| rest -> NE.reverse ((w64 `shiftL` r8) `shiftR` r8 :| rest) + +instance (1 <= n, KnownNat n) => SeedGen (GenN n) where + type SeedSize (GenN n) = n + unseedGen (GenN bs) = fromJust . mkSeed . GHC.fromList $ BS.unpack bs + seedGen = GenN . BS.pack . GHC.toList . unSeed + +newtype Gen64 (n :: Nat) = Gen64 (NonEmpty Word64) + deriving (Eq, Show) + +instance (1 <= n, KnownNat n) => SeedGen (Gen64 n) where + type SeedSize (Gen64 n) = n + unseedGen64 (Gen64 ws) = ws + seedGen64 = Gen64 + +seedGenSpec :: + forall g. (SeedGen g, Eq g, Show g, Serial IO g) + => TestTree +seedGenSpec = + testGroup (seedGenTypeName @g) + [ testProperty "seedGen/unseedGen" $ + forAll $ \(g :: g) -> g == seedGen (unseedGen g) + , testProperty "seedGen64/unseedGen64" $ + forAll $ \(g :: g) -> g == seedGen64 (unseedGen64 g) + ] + + +spec :: TestTree +spec = + testGroup + "SeedGen" + [ seedGenSpec @StdGen + , seedGenSpec @(GenN 1) + , seedGenSpec @(GenN 2) + , seedGenSpec @(GenN 3) + , seedGenSpec @(GenN 4) + , seedGenSpec @(GenN 5) + , seedGenSpec @(GenN 6) + , seedGenSpec @(GenN 7) + , seedGenSpec @(GenN 8) + , seedGenSpec @(GenN 9) + , seedGenSpec @(GenN 10) + , seedGenSpec @(GenN 11) + , seedGenSpec @(GenN 12) + , seedGenSpec @(GenN 13) + , seedGenSpec @(GenN 14) + , seedGenSpec @(GenN 15) + , seedGenSpec @(GenN 16) + , seedGenSpec @(GenN 17) + , seedGenSpec @(Gen64 1) + , seedGenSpec @(Gen64 2) + , seedGenSpec @(Gen64 3) + , seedGenSpec @(Gen64 4) + , seedGenSpec @(Gen64 5) + , seedGenSpec @(Gen64 6) + , seedGenSpec @(Gen64 7) + , seedGenSpec @(Gen64 8) + , seedGenSpec @(Gen64 9) + , seedGenSpec @(Gen64 10) + , seedGenSpec @(Gen64 11) + , seedGenSpec @(Gen64 12) + , seedGenSpec @(Gen64 13) + , seedGenSpec @(Gen64 14) + , seedGenSpec @(Gen64 15) + , seedGenSpec @(Gen64 16) + , seedGenSpec @(Gen64 17) + ] +