From 673fdc3d634cdd6c325ddb51df4f73ae41dc41d9 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 27 Dec 2024 16:36:26 -0700 Subject: [PATCH 1/3] Change semantics of `withSeedFile` --- src/System/Random/Seed.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/System/Random/Seed.hs b/src/System/Random/Seed.hs index 74ae5561..4a39653c 100644 --- a/src/System/Random/Seed.hs +++ b/src/System/Random/Seed.hs @@ -279,11 +279,11 @@ unSeedToByteString = SBS.fromShort . byteArrayToShortByteString . unSeed -- resulting generator will be converted back to a seed and written to the same file. -- -- @since 1.3.0 -withSeedFile :: (SeedGen g, MonadIO m) => FilePath -> (g -> m (a, g)) -> m a -withSeedFile fileName f = do +withSeedFile :: (SeedGen g, MonadIO m) => FilePath -> (Seed g -> m (a, Seed g)) -> m a +withSeedFile fileName action = do bs <- liftIO $ BS.readFile fileName seed <- liftIO $ mkSeedFromByteString bs - (res, seed') <- withSeedM seed f + (res, seed') <- action seed liftIO $ BS.writeFile fileName $ unSeedToByteString seed' pure res From b512aac886fa4e4156e734c29327a665d152f618 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 27 Dec 2024 20:39:14 -0700 Subject: [PATCH 2/3] Rename some functions, add `seedSizeProxy` and a doctest example: Rename for clairty: * `seedGen` -> `fromSeed` and `seedGen64` -> `fromSeed64` * `unSeedGen` -> `toSeed` and `unSeedGen64` -> `toSeed64` * `withMutableSeedGen` -> `withSeedMutableGen` and `withMutableSeedGen_` -> `withSeedMutableGen_` --- CHANGELOG.md | 4 ++- src/System/Random/Seed.hs | 67 +++++++++++++++++++---------------- src/System/Random/Stateful.hs | 62 ++++++++++++++++++++++++-------- test/Spec.hs | 4 +-- test/Spec/Seed.hs | 16 ++++----- 5 files changed, 97 insertions(+), 56 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5c21e39b..6fffa1d9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,8 +2,10 @@ * Improve floating point value generation and avoid degenerate cases: [#172](https://github.com/haskell/random/pull/172) * Add `Uniform` instance for `Maybe` and `Either`: [#167](https://github.com/haskell/random/pull/167) -* Add `Seed`, `SeedGen`, `seedSize`, `mkSeed` and `unSeed`: +* Add `Seed`, `SeedGen`, `seedSize`, `seedSizeProxy`, `mkSeed` and `unSeed`: [#162](https://github.com/haskell/random/pull/162) +* Add `mkSeedFromByteString`, `unSeedToByteString`, `withSeed`, `withSeedM`, `withSeedFile`, + `seedGenTypeName`, `nonEmptyToSeed`, `nonEmptyFromSeed`, `withSeedM`, `withSeedMutableGen` and `withSeedMutableGen_` * Add `SplitGen` and `splitGen`: [#160](https://github.com/haskell/random/pull/160) * Add `unifromShuffleList` and `unifromShuffleListM`: [#140](https://github.com/haskell/random/pull/140) * Add `uniformWordR`: [#140](https://github.com/haskell/random/pull/140) diff --git a/src/System/Random/Seed.hs b/src/System/Random/Seed.hs index 4a39653c..58507e6b 100644 --- a/src/System/Random/Seed.hs +++ b/src/System/Random/Seed.hs @@ -23,6 +23,7 @@ module System.Random.Seed , -- ** Seed Seed , seedSize + , seedSizeProxy , mkSeed , unSeed , mkSeedFromByteString @@ -66,7 +67,7 @@ import qualified System.Random.SplitMix32 as SM32 -- It is not trivial to implement platform independence. For this reason this type class -- has two alternative ways of creating an instance for this class. The easiest way for -- constructing a platform indepent seed is by converting the inner state of a generator --- to and from a list of 64 bit words using `unSeedGen64` and `seedGen64` respectively. In +-- to and from a list of 64 bit words using `toSeed64` and `fromSeed64` respectively. In -- that case cross-platform support will be handled automaticaly. -- -- >>> :set -XDataKinds -XTypeFamilies @@ -77,41 +78,41 @@ import qualified System.Random.SplitMix32 as SM32 -- >>> :{ -- instance SeedGen FiveByteGen where -- type SeedSize FiveByteGen = 5 --- seedGen64 (w64 :| _) = +-- fromSeed64 (w64 :| _) = -- FiveByteGen (fromIntegral (w64 `shiftR` 32)) (fromIntegral w64) --- unSeedGen64 (FiveByteGen x1 x4) = +-- toSeed64 (FiveByteGen x1 x4) = -- let w64 = (fromIntegral x1 `shiftL` 32) .|. fromIntegral x4 -- in (w64 :| []) -- :} -- -- >>> FiveByteGen 0x80 0x01020304 -- FiveByteGen 128 16909060 --- >>> seedGen (unSeedGen (FiveByteGen 0x80 0x01020304)) +-- >>> fromSeed (toSeed (FiveByteGen 0x80 0x01020304)) -- FiveByteGen 128 16909060 --- >>> unSeedGen (FiveByteGen 0x80 0x01020304) +-- >>> toSeed (FiveByteGen 0x80 0x01020304) -- Seed [0x04, 0x03, 0x02, 0x01, 0x80] --- >>> unSeedGen64 (FiveByteGen 0x80 0x01020304) +-- >>> toSeed64 (FiveByteGen 0x80 0x01020304) -- 549772722948 :| [] -- -- However, when performance is of utmost importance or default handling of cross platform -- independence is not sufficient, then an adventurous developer can try implementing --- conversion into bytes directly with `unSeedGen` and `seedGen`. +-- conversion into bytes directly with `toSeed` and `fromSeed`. -- -- Properties that must hold: -- -- @ --- > seedGen (unSeedGen gen) == gen +-- > fromSeed (toSeed gen) == gen -- @ -- -- @ --- > seedGen64 (unSeedGen64 gen) == gen +-- > fromSeed64 (toSeed64 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) +-- >>> seed == toSeed (fromSeed seed) -- False -- -- @since 1.3.0 @@ -120,23 +121,23 @@ class (KnownNat (SeedSize g), 1 <= SeedSize g, Typeable g) => SeedGen g where -- number generator. It should be big enough to satisfy the roundtrip property: -- -- @ - -- > seedGen (unSeedGen gen) == gen + -- > fromSeed (toSeed gen) == gen -- @ -- type SeedSize g :: Nat - {-# MINIMAL (seedGen, unSeedGen)|(seedGen64, unSeedGen64) #-} + {-# MINIMAL (fromSeed, toSeed)|(fromSeed64, toSeed64) #-} -- | Convert from a binary representation to a pseudo-random number generator -- -- @since 1.3.0 - seedGen :: Seed g -> g - seedGen = seedGen64 . nonEmptyFromSeed + fromSeed :: Seed g -> g + fromSeed = fromSeed64 . nonEmptyFromSeed -- | Convert to a binary representation of a pseudo-random number generator -- -- @since 1.3.0 - unSeedGen :: g -> Seed g - unSeedGen = nonEmptyToSeed . unSeedGen64 + toSeed :: g -> Seed g + toSeed = nonEmptyToSeed . toSeed64 -- | Construct pseudo-random number generator from a list of words. Whenever list does -- not have enough bytes to satisfy the `SeedSize` requirement, it will be padded with @@ -146,8 +147,8 @@ class (KnownNat (SeedSize g), 1 <= SeedSize g, Typeable g) => SeedGen g where -- element in the list will be used. -- -- @since 1.3.0 - seedGen64 :: NonEmpty Word64 -> g - seedGen64 = seedGen . nonEmptyToSeed + fromSeed64 :: NonEmpty Word64 -> g + fromSeed64 = fromSeed . nonEmptyToSeed -- | Convert pseudo-random number generator to a list of words -- @@ -155,24 +156,24 @@ class (KnownNat (SeedSize g), 1 <= SeedSize g, Typeable g) => SeedGen g where -- in the list will be set to zero. -- -- @since 1.3.0 - unSeedGen64 :: g -> NonEmpty Word64 - unSeedGen64 = nonEmptyFromSeed . unSeedGen + toSeed64 :: g -> NonEmpty Word64 + toSeed64 = nonEmptyFromSeed . toSeed instance SeedGen StdGen where type SeedSize StdGen = SeedSize SM.SMGen - seedGen = coerce (seedGen :: Seed SM.SMGen -> SM.SMGen) - unSeedGen = coerce (unSeedGen :: SM.SMGen -> Seed SM.SMGen) + fromSeed = coerce (fromSeed :: Seed SM.SMGen -> SM.SMGen) + toSeed = coerce (toSeed :: SM.SMGen -> Seed SM.SMGen) instance SeedGen g => SeedGen (StateGen g) where type SeedSize (StateGen g) = SeedSize g - seedGen = coerce (seedGen :: Seed g -> g) - unSeedGen = coerce (unSeedGen :: g -> Seed g) + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) instance SeedGen SM.SMGen where type SeedSize SM.SMGen = 16 - seedGen (Seed ba) = + fromSeed (Seed ba) = SM.seedSMGen (indexWord64LE ba 0) (indexWord64LE ba 8) - unSeedGen g = + toSeed g = case SM.unseedSMGen g of (seed, gamma) -> Seed $ runST $ do mba <- newMutableByteArray 16 @@ -182,13 +183,13 @@ instance SeedGen SM.SMGen where instance SeedGen SM32.SMGen where type SeedSize SM32.SMGen = 8 - seedGen (Seed ba) = + fromSeed (Seed ba) = let x = indexWord64LE ba 0 seed, gamma :: Word32 seed = fromIntegral (shiftR x 32) gamma = fromIntegral x in SM32.seedSMGen seed gamma - unSeedGen g = + toSeed g = let seed, gamma :: Word32 (seed, gamma) = SM32.unseedSMGen g in Seed $ runST $ do @@ -207,6 +208,12 @@ instance SeedGen g => Uniform (Seed g) where seedSize :: forall g. SeedGen g => Int seedSize = fromIntegral $ natVal (Proxy :: Proxy (SeedSize g)) +-- | Just like `seedSize`, except it accepts a proxy as an argument. +-- +-- @since 1.3.0 +seedSizeProxy :: forall proxy g. SeedGen g => proxy g -> Int +seedSizeProxy _px = seedSize @g + -- | Construct a `Seed` from a `ByteArray` of expected length. Whenever `ByteArray` does -- not match the `SeedSize` specified by the pseudo-random generator, this function will -- `F.fail`. @@ -240,12 +247,12 @@ withSeed seed f = runIdentity (withSeedM seed (pure . f)) -- | Same as `withSeed`, except it is useful with monadic computation and frozen generators. -- --- See `System.Random.Stateful.withMutableSeedGen` for a helper that also handles seeds +-- See `System.Random.Stateful.withSeedMutableGen` for a helper that also handles seeds -- for mutable pseduo-random number generators. -- -- @since 1.3.0 withSeedM :: (SeedGen g, Functor f) => Seed g -> (g -> f (a, g)) -> f (a, Seed g) -withSeedM seed f = fmap unSeedGen <$> f (seedGen seed) +withSeedM seed f = fmap toSeed <$> f (fromSeed seed) -- | This is a function that shows the name of the generator type, which is useful for -- error reporting. diff --git a/src/System/Random/Stateful.hs b/src/System/Random/Stateful.hs index ea029db1..17eb69e0 100644 --- a/src/System/Random/Stateful.hs +++ b/src/System/Random/Stateful.hs @@ -41,8 +41,8 @@ module System.Random.Stateful , ThawedGen(..) , withMutableGen , withMutableGen_ - , withMutableSeedGen - , withMutableSeedGen_ + , withSeedMutableGen + , withSeedMutableGen_ , randomM , randomRM , splitGenM @@ -320,17 +320,49 @@ withMutableGen_ fg action = thawGen fg >>= action -- | Just like `withMutableGen`, except uses a `Seed` instead of a frozen generator. -- +-- ====__Examples__ +-- +-- Here is good example of how `withSeedMutableGen` can be used with `withSeedFile`, which uses a locally stored seed. +-- +-- First we define a @reportSeed@ function that will print the contents of a seed file as a list of bytes: +-- +-- >>> import Data.ByteString as BS (readFile, writeFile, unpack) +-- >>> :seti -XOverloadedStrings +-- >>> let reportSeed fp = print . ("Seed: " <>) . show . BS.unpack =<< BS.readFile fp +-- +-- Given a file path, write an `StdGen` seed into the file: +-- +-- >>> :seti -XFlexibleContexts -XScopedTypeVariables +-- >>> let writeInitSeed fp = BS.writeFile fp (unSeedToByteString (toSeed (mkStdGen 2025))) +-- +-- Apply a `StatefulGen` monadic action that uses @`IOGen` `StdGen`@, restored from the seed in the given path: +-- +-- >>> let withMutableSeedFile fp action = withSeedFile fp (\(seed :: Seed (IOGen StdGen)) -> withSeedMutableGen seed action) +-- +-- Given a path and an action initialize the seed file and apply the action using that seed: +-- +-- >>> let withInitSeedFile fp action = writeInitSeed fp *> reportSeed fp *> withMutableSeedFile fp action <* reportSeed fp +-- +-- For the sake of example we will use a temporary directory for storing the seed. Here we +-- report the contents of the seed file before and after we shuffle a list: +-- +-- >>> import UnliftIO.Temporary (withSystemTempDirectory) +-- >>> withSystemTempDirectory "random" (\fp -> withInitSeedFile (fp ++ "/seed.bin") (uniformShuffleListM [1..10])) +-- "Seed: [183,178,143,77,132,163,109,14,157,105,82,99,148,82,109,173]" +-- "Seed: [60,105,117,203,187,138,69,39,157,105,82,99,148,82,109,173]" +-- [7,5,4,3,1,8,10,6,9,2] +-- -- @since 1.3.0 -withMutableSeedGen :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m (a, Seed g) -withMutableSeedGen seed f = withSeedM seed (`withMutableGen` f) +withSeedMutableGen :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m (a, Seed g) +withSeedMutableGen seed f = withSeedM seed (`withMutableGen` f) --- | Just like `withMutableSeedGen`, except it doesn't return the final generator, only +-- | Just like `withSeedMutableGen`, except it doesn't return the final generator, only -- the resulting value. This is slightly more efficient, since it doesn't incur overhead -- from freezeing the mutable generator -- -- @since 1.3.0 -withMutableSeedGen_ :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m a -withMutableSeedGen_ seed = withMutableGen_ (seedGen seed) +withSeedMutableGen_ :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m a +withSeedMutableGen_ seed = withMutableGen_ (fromSeed seed) -- | Generates a pseudo-random value using monadic interface and `Random` instance. @@ -395,8 +427,8 @@ newtype AtomicGen g = AtomicGen { unAtomicGen :: g} -- Standalone definition due to GHC-8.0 not supporting deriving with associated type families instance SeedGen g => SeedGen (AtomicGen g) where type SeedSize (AtomicGen g) = SeedSize g - seedGen = coerce (seedGen :: Seed g -> g) - unSeedGen = coerce (unSeedGen :: g -> Seed g) + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) -- | Creates a new 'AtomicGenM'. -- @@ -508,8 +540,8 @@ newtype IOGen g = IOGen { unIOGen :: g } -- Standalone definition due to GHC-8.0 not supporting deriving with associated type families instance SeedGen g => SeedGen (IOGen g) where type SeedSize (IOGen g) = SeedSize g - seedGen = coerce (seedGen :: Seed g -> g) - unSeedGen = coerce (unSeedGen :: g -> Seed g) + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) -- | Creates a new 'IOGenM'. -- @@ -584,8 +616,8 @@ newtype STGen g = STGen { unSTGen :: g } -- Standalone definition due to GHC-8.0 not supporting deriving with associated type families instance SeedGen g => SeedGen (STGen g) where type SeedSize (STGen g) = SeedSize g - seedGen = coerce (seedGen :: Seed g -> g) - unSeedGen = coerce (unSeedGen :: g -> Seed g) + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) -- | Creates a new 'STGenM'. -- @@ -685,8 +717,8 @@ newtype TGen g = TGen { unTGen :: g } -- Standalone definition due to GHC-8.0 not supporting deriving with associated type families instance SeedGen g => SeedGen (TGen g) where type SeedSize (TGen g) = SeedSize g - seedGen = coerce (seedGen :: Seed g -> g) - unSeedGen = coerce (unSeedGen :: g -> Seed g) + fromSeed = coerce (fromSeed :: Seed g -> g) + toSeed = coerce (toSeed :: g -> Seed g) -- | Creates a new 'TGenM' in `STM`. -- diff --git a/test/Spec.hs b/test/Spec.hs index d6cc8f43..de79ca73 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -304,8 +304,8 @@ newtype ConstGen = ConstGen Word64 instance SeedGen ConstGen where type SeedSize ConstGen = 8 - seedGen64 (w :| _) = ConstGen w - unSeedGen64 (ConstGen w) = pure w + fromSeed64 (w :| _) = ConstGen w + toSeed64 (ConstGen w) = pure w instance RandomGen ConstGen where genWord64 g@(ConstGen c) = (c, g) diff --git a/test/Spec/Seed.hs b/test/Spec/Seed.hs index 3367df78..8d31ffd3 100644 --- a/test/Spec/Seed.hs +++ b/test/Spec/Seed.hs @@ -49,26 +49,26 @@ instance (KnownNat n, Monad m) => Serial m (Gen64 n) where 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 + toSeed (GenN bs) = fromJust . mkSeed . GHC.fromList $ BS.unpack bs + fromSeed = 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 + toSeed64 (Gen64 ws) = ws + fromSeed64 = 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) + [ testProperty "fromSeed/toSeed" $ + forAll $ \(g :: g) -> g == fromSeed (toSeed g) + , testProperty "fromSeed64/toSeed64" $ + forAll $ \(g :: g) -> g == fromSeed64 (toSeed64 g) ] From 4b626bc107a120d835407adbb366d8f97132c8cb Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sat, 28 Dec 2024 09:36:02 -0700 Subject: [PATCH 3/3] Switch to primitive `Proxy#` for seed size --- src/System/Random/Seed.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/System/Random/Seed.hs b/src/System/Random/Seed.hs index 58507e6b..0be3709e 100644 --- a/src/System/Random/Seed.hs +++ b/src/System/Random/Seed.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeApplications #-} @@ -50,7 +51,8 @@ import Data.Functor.Identity (runIdentity) import Data.List.NonEmpty as NE (NonEmpty(..), nonEmpty, toList) import Data.Typeable import Data.Word -import GHC.TypeLits (Nat, KnownNat, natVal, type (<=)) +import GHC.Exts (Proxy#, proxy#) +import GHC.TypeLits (Nat, KnownNat, natVal', type (<=)) import System.Random.Internal import qualified System.Random.SplitMix as SM import qualified System.Random.SplitMix32 as SM32 @@ -206,7 +208,7 @@ instance SeedGen g => Uniform (Seed g) where -- -- @since 1.3.0 seedSize :: forall g. SeedGen g => Int -seedSize = fromIntegral $ natVal (Proxy :: Proxy (SeedSize g)) +seedSize = fromInteger $ natVal' (proxy# :: Proxy# (SeedSize g)) -- | Just like `seedSize`, except it accepts a proxy as an argument. --