diff --git a/CHANGELOG.md b/CHANGELOG.md index 2461c3d9..bc2cda35 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,7 @@ # 1.3.0 +* Move `thawGen` from `FreezeGen` into the new `ThawGen` type class. Fixes an issue with + an unlawful instance of `StateGen` for `FreezeGen`. * Add `modifyGen` and `overwriteGen` to the `FrozenGen` type class * Add `splitGen` and `splitMutableGen` * Switch `randomM` and `randomRM` to use `FrozenGen` instead of `RandomGenM` diff --git a/src/System/Random/Internal.hs b/src/System/Random/Internal.hs index afa5fa42..39ba464f 100644 --- a/src/System/Random/Internal.hs +++ b/src/System/Random/Internal.hs @@ -30,6 +30,7 @@ module System.Random.Internal RandomGen(..) , StatefulGen(..) , FrozenGen(..) + , ThawedGen(..) , splitGen , splitMutableGen @@ -286,33 +287,57 @@ class Monad m => StatefulGen g m where {-# INLINE uniformShortByteString #-} - --- | This class is designed for stateful pseudo-random number generators that --- can be saved as and restored from an immutable data type. +-- | This class is designed for mutable pseudo-random number generators that have a frozen +-- imutable counterpart that can be manipulated in pure code. +-- +-- It also works great with frozen generators that are based on pure generators that have +-- a `RandomGen` instance. +-- +-- Here are a few of laws that are important for this interface: +-- +-- * Roundtrip and complete destruction on overwrite: +-- +-- @ +-- (overwriteGen mg fg >> freezeGen mg) = pure fg +-- @ +-- +-- * Modification of mutable generator: +-- +-- @ +-- overwriteGen mg fg = modifyGen mg (const ((), fg) +-- @ -- --- It also works great on working with mutable generators that are based on a pure --- generator that has a `RandomGen` instance. +-- * Freeing of mutable generator: +-- +-- @ +-- freezeGen mg = modifyGen mg (\fg -> (fg, fg)) +-- @ -- -- @since 1.2.0 class StatefulGen (MutableGen f m) m => FrozenGen f m where + {-# MINIMAL (modifyGen|(freezeGen,overwriteGen)) #-} -- | Represents the state of the pseudo-random number generator for use with -- 'thawGen' and 'freezeGen'. -- -- @since 1.2.0 type MutableGen f m = (g :: Type) | g -> f + -- | Saves the state of the pseudo-random number generator as a frozen seed. -- -- @since 1.2.0 freezeGen :: MutableGen f m -> m f - -- | Restores the pseudo-random number generator from its frozen seed. - -- - -- @since 1.2.0 - thawGen :: f -> m (MutableGen f m) + freezeGen mg = modifyGen mg (\fg -> (fg, fg)) + {-# INLINE freezeGen #-} -- | Apply a pure function to the frozen pseudo-random number generator. -- -- @since 1.3.0 modifyGen :: MutableGen f m -> (f -> (a, f)) -> m a + modifyGen mg f = do + fg <- freezeGen mg + case f fg of + (a, !fg') -> a <$ overwriteGen mg fg' + {-# INLINE modifyGen #-} -- | Overwrite contents of the mutable pseudo-random number generator with the -- supplied frozen one @@ -320,6 +345,27 @@ class StatefulGen (MutableGen f m) m => FrozenGen f m where -- @since 1.3.0 overwriteGen :: MutableGen f m -> f -> m () overwriteGen mg fg = modifyGen mg (const ((), fg)) + {-# INLINE overwriteGen #-} + +-- | Functionality for thawing frozen generators was split into a separate type class, +-- becase not all mutable generators support functionality of creating new mutable +-- generators, which is what thawing is in its essence. For this reason `StateGen` does +-- not have an instance for this type class, but it has one for `FrozenGen`. +-- +-- Here is an important law that relates this type class to `FrozenGen` +-- +-- * Roundtrip and independence of mutable generators: +-- +-- @ +-- (mapM thawGen fgs >>= mapM freezeGen) = pure fgs +-- @ +-- +-- @since 1.3.0 +class FrozenGen f m => ThawedGen f m where + -- | Create a new mutable pseudo-random number generator from its frozen state. + -- + -- @since 1.2.0 + thawGen :: f -> m (MutableGen f m) -- | Splits a pseudo-random number generator into two. Overwrites the mutable -- wrapper with one of the resulting generators and returns the other. @@ -328,11 +374,11 @@ class StatefulGen (MutableGen f m) m => FrozenGen f m where splitGen :: (RandomGen f, FrozenGen f m) => MutableGen f m -> m f splitGen = flip modifyGen split --- | Splits a pseudo-random number generator into two. Overwrites the mutable --- wrapper with one of the resulting generators and returns the other. +-- | Splits a pseudo-random number generator into two. Overwrites the mutable wrapper with +-- one of the resulting generators and returns the other as a new mutable generator. -- -- @since 1.3.0 -splitMutableGen :: (RandomGen f, FrozenGen f m) => MutableGen f m -> m (MutableGen f m) +splitMutableGen :: (RandomGen f, ThawedGen f m) => MutableGen f m -> m (MutableGen f m) splitMutableGen = splitGen >=> thawGen @@ -481,7 +527,6 @@ instance (RandomGen g, MonadState g m) => StatefulGen (StateGenM g) m where instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m where type MutableGen (StateGen g) m = StateGenM g freezeGen _ = fmap StateGen get - thawGen (StateGen g) = StateGenM <$ put g modifyGen _ f = state (coerce f) {-# INLINE modifyGen #-} overwriteGen _ f = put (coerce f) diff --git a/src/System/Random/Stateful.hs b/src/System/Random/Stateful.hs index 5a6e2e6a..3adc53b6 100644 --- a/src/System/Random/Stateful.hs +++ b/src/System/Random/Stateful.hs @@ -30,6 +30,7 @@ module System.Random.Stateful -- $interfaces , StatefulGen(..) , FrozenGen(..) + , ThawedGen(..) , withMutableGen , withMutableGen_ , randomM @@ -257,7 +258,7 @@ instance RandomGen r => RandomGenM (TGenM r) r STM where -- ([-74,37,-50,-2,3],IOGen {unIOGen = StdGen {unStdGen = SMGen 4273268533320920145 15251669095119325999}}) -- -- @since 1.2.0 -withMutableGen :: FrozenGen f m => f -> (MutableGen f m -> m a) -> m (a, f) +withMutableGen :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m (a, f) withMutableGen fg action = do g <- thawGen fg res <- action g @@ -274,7 +275,7 @@ withMutableGen fg action = do -- 4 -- -- @since 1.2.0 -withMutableGen_ :: FrozenGen f m => f -> (MutableGen f m -> m a) -> m a +withMutableGen_ :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m a withMutableGen_ fg action = thawGen fg >>= action @@ -311,6 +312,7 @@ uniformListM n gen = replicateM n (uniformM gen) -- @since 1.2.0 randomM :: forall a g m. (Random a, RandomGen g, FrozenGen g m) => MutableGen g m -> m a randomM = flip modifyGen random +{-# INLINE randomM #-} -- | Generates a pseudo-random value using monadic interface and `Random` instance. -- @@ -331,6 +333,7 @@ randomM = flip modifyGen random -- @since 1.2.0 randomRM :: forall a g m. (Random a, RandomGen g, FrozenGen g m) => (a, a) -> MutableGen g m -> m a randomRM r = flip modifyGen (randomR r) +{-# INLINE randomRM #-} -- | Wraps an 'IORef' that holds a pure pseudo-random number generator. All -- operations are performed atomically. @@ -386,13 +389,15 @@ instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where type MutableGen (AtomicGen g) m = AtomicGenM g freezeGen = fmap AtomicGen . liftIO . readIORef . unAtomicGenM - thawGen (AtomicGen g) = newAtomicGenM g modifyGen (AtomicGenM ioRef) f = liftIO $ atomicModifyIORef' ioRef $ \g -> case f (AtomicGen g) of (a, AtomicGen g') -> (g', a) {-# INLINE modifyGen #-} +instance (RandomGen g, MonadIO m) => ThawedGen (AtomicGen g) m where + thawGen (AtomicGen g) = newAtomicGenM g + -- | Atomically applies a pure operation to the wrapped pseudo-random number -- generator. -- @@ -466,7 +471,6 @@ instance (RandomGen g, MonadIO m) => StatefulGen (IOGenM g) m where instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where type MutableGen (IOGen g) m = IOGenM g freezeGen = fmap IOGen . liftIO . readIORef . unIOGenM - thawGen (IOGen g) = newIOGenM g modifyGen (IOGenM ref) f = liftIO $ do g <- readIORef ref let (a, IOGen g') = f (IOGen g) @@ -476,6 +480,9 @@ instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where overwriteGen (IOGenM ref) = liftIO . writeIORef ref . unIOGen {-# INLINE overwriteGen #-} +instance (RandomGen g, MonadIO m) => ThawedGen (IOGen g) m where + thawGen (IOGen g) = newIOGenM g + -- | Applies a pure operation to the wrapped pseudo-random number generator. -- -- ====__Examples__ @@ -533,7 +540,6 @@ instance RandomGen g => StatefulGen (STGenM g s) (ST s) where instance RandomGen g => FrozenGen (STGen g) (ST s) where type MutableGen (STGen g) (ST s) = STGenM g s freezeGen = fmap STGen . readSTRef . unSTGenM - thawGen (STGen g) = newSTGenM g modifyGen (STGenM ref) f = do g <- readSTRef ref let (a, STGen g') = f (STGen g) @@ -543,6 +549,9 @@ instance RandomGen g => FrozenGen (STGen g) (ST s) where overwriteGen (STGenM ref) = writeSTRef ref . unSTGen {-# INLINE overwriteGen #-} +instance RandomGen g => ThawedGen (STGen g) (ST s) where + thawGen (STGen g) = newSTGenM g + -- | Applies a pure operation to the wrapped pseudo-random number generator. -- @@ -636,7 +645,6 @@ instance RandomGen g => StatefulGen (TGenM g) STM where instance RandomGen g => FrozenGen (TGen g) STM where type MutableGen (TGen g) STM = TGenM g freezeGen = fmap TGen . readTVar . unTGenM - thawGen (TGen g) = newTGenM g modifyGen (TGenM ref) f = do g <- readTVar ref let (a, TGen g') = f (TGen g) @@ -646,6 +654,9 @@ instance RandomGen g => FrozenGen (TGen g) STM where overwriteGen (TGenM ref) = writeTVar ref . unTGen {-# INLINE overwriteGen #-} +instance RandomGen g => ThawedGen (TGen g) STM where + thawGen (TGen g) = newTGenM g + -- | Applies a pure operation to the wrapped pseudo-random number generator. -- @@ -797,19 +808,17 @@ applyTGen f (TGenM tvar) = do -- -- === @FrozenGen@ -- --- `FrozenGen` gives us ability to use any stateful pseudo-random number generator in its --- immutable form, if one exists that is. This concept is commonly known as a seed, which --- allows us to save and restore the actual mutable state of a pseudo-random number --- generator. The biggest benefit that can be drawn from a polymorphic access to a --- stateful pseudo-random number generator in a frozen form is the ability to serialize, --- deserialize and possibly even use the stateful generator in a pure setting without --- knowing the actual type of a generator ahead of time. For example we can write a --- function that accepts a frozen state of some pseudo-random number generator and --- produces a short list with random even integers. +-- `FrozenGen` gives us ability to use most of stateful pseudo-random number generator in +-- its immutable form, if one exists that is. The biggest benefit that can be drawn from +-- a polymorphic access to a stateful pseudo-random number generator in a frozen form is +-- the ability to serialize, deserialize and possibly even use the stateful generator in a +-- pure setting without knowing the actual type of a generator ahead of time. For example +-- we can write a function that accepts a frozen state of some pseudo-random number +-- generator and produces a short list with random even integers. -- -- >>> import Data.Int (Int8) -- >>> :{ --- myCustomRandomList :: FrozenGen f m => f -> m [Int8] +-- myCustomRandomList :: ThawedGen f m => f -> m [Int8] -- myCustomRandomList f = -- withMutableGen_ f $ \gen -> do -- len <- uniformRM (5, 10) gen diff --git a/test/Spec.hs b/test/Spec.hs index 8868a6c4..078d4d0a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -94,7 +94,7 @@ main = , uniformSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word)) , uniformSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word)) , uniformSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word)) - , Stateful.statefulSpec + , Stateful.statefulGenSpec ] floatTests :: TestTree diff --git a/test/Spec/Stateful.hs b/test/Spec/Stateful.hs index 26e2685d..dbed18c4 100644 --- a/test/Spec/Stateful.hs +++ b/test/Spec/Stateful.hs @@ -7,8 +7,8 @@ module Spec.Stateful where import Control.Concurrent.STM +import Control.Monad import Control.Monad.ST -import Control.Monad.Trans.State.Strict import Data.Proxy import Data.Typeable import System.Random.Stateful @@ -36,23 +36,24 @@ instance (Monad m, Serial m g) => Serial m (StateGen g) where matchRandomGenSpec :: - forall b f m. (RandomGen f, FrozenGen f m, Eq f, Show f, Eq b) - => (forall a. m a -> IO a) - -> (MutableGen f m -> m b) - -> (forall g. RandomGen g => g -> (b, g)) + forall f a sg m. (StatefulGen sg m, RandomGen f, Eq f, Show f, Eq a) + => (forall g n. StatefulGen g n => g -> n a) + -> (forall g. RandomGen g => g -> (a, g)) + -> (StdGen -> f) -> (f -> StdGen) - -> f + -> (f -> (sg -> m a) -> IO (a, f)) -> Property IO -matchRandomGenSpec toIO genM gen toStdGen frozen = - monadic $ do - (x1, fg1) <- toIO $ withMutableGen frozen genM - (x2, fg2) <- toIO $ withMutableGen frozen (`modifyGen` gen) - let (x3, g3) = gen $ toStdGen frozen - let (x4, g4) = toStdGen <$> gen frozen - pure $ and [x1 == x2, x2 == x3, x3 == x4, fg1 == fg2, toStdGen fg1 == g3, g3 == g4] +matchRandomGenSpec genM gen fromStdGen toStdGen runStatefulGen = + forAll $ \seed -> monadic $ do + let stdGen = mkStdGen seed + g = fromStdGen stdGen + (x1, g1) = gen stdGen + (x2, g2) = gen g + (x3, g3) <- runStatefulGen g genM + pure $ and [x1 == x2, x2 == x3, g1 == toStdGen g2, g1 == toStdGen g3, g2 == g3] withMutableGenSpec :: - forall f m. (FrozenGen f m, Eq f, Show f) + forall f m. (ThawedGen f m, Eq f, Show f) => (forall a. m a -> IO a) -> f -> Property IO @@ -65,7 +66,7 @@ withMutableGenSpec toIO frozen = pure $ x == y && r == r' overwriteMutableGenSpec :: - forall f m. (FrozenGen f m, Eq f, Show f) + forall f m. (ThawedGen f m, Eq f, Show f) => (forall a. m a -> IO a) -> f -> Property IO @@ -80,8 +81,27 @@ overwriteMutableGenSpec toIO frozen = pure (r1, r2) pure $ r1 == r2 && frozen == frozen' +indepMutableGenSpec :: + forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f) + => (forall a. m a -> IO a) -> [f] -> Property IO +indepMutableGenSpec toIO fgs = + monadic $ toIO $ do + (fgs ==) <$> (mapM freezeGen =<< mapM thawGen fgs) + +immutableFrozenGenSpec :: + forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f) + => (forall a. m a -> IO a) -> f -> Property IO +immutableFrozenGenSpec toIO frozen = + forAll $ \n -> monadic $ toIO $ do + let action = do + mg <- thawGen frozen + (,) <$> uniformWord8 mg <*> freezeGen mg + x <- action + xs <- replicateM n action + pure $ all (x ==) xs + splitMutableGenSpec :: - forall f m. (RandomGen f, FrozenGen f m, Eq f, Show f) + forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f) => (forall a. m a -> IO a) -> f -> Property IO @@ -92,56 +112,94 @@ splitMutableGenSpec toIO frozen = sfg3 <- freezeGen smg2 pure $ fg1 == fg2 && sfg1 == sfg3 -statefulSpecFor :: - forall f m. (RandomGen f, FrozenGen f m, Eq f, Show f, Serial IO f, Typeable f) +thawedGenSpecFor :: + forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f, Serial IO f, Typeable f) => (forall a. m a -> IO a) - -> (f -> StdGen) + -> Proxy f -> TestTree -statefulSpecFor toIO toStdGen = +thawedGenSpecFor toIO px = testGroup - (showsTypeRep (typeRep (Proxy :: Proxy f)) "") + (showsTypeRep (typeRep px) "") [ testProperty "withMutableGen" $ forAll $ \(f :: f) -> withMutableGenSpec toIO f , testProperty "overwriteGen" $ forAll $ \(f :: f) -> overwriteMutableGenSpec toIO f + , testProperty "independent mutable generators" $ + forAll $ \(fs :: [f]) -> indepMutableGenSpec toIO fs + , testProperty "immutable frozen generators" $ + forAll $ \(f :: f) -> immutableFrozenGenSpec toIO f , testProperty "splitGen" $ forAll $ \(f :: f) -> splitMutableGenSpec toIO f - , testGroup - "matchRandomGenSpec" - [ testProperty "uniformWord8/genWord8" $ - forAll $ \(f :: f) -> - matchRandomGenSpec toIO uniformWord8 genWord8 toStdGen f - , testProperty "uniformWord16/genWord16" $ - forAll $ \(f :: f) -> - matchRandomGenSpec toIO uniformWord16 genWord16 toStdGen f - , testProperty "uniformWord32/genWord32" $ - forAll $ \(f :: f) -> - matchRandomGenSpec toIO uniformWord32 genWord32 toStdGen f - , testProperty "uniformWord64/genWord64" $ - forAll $ \(f :: f) -> - matchRandomGenSpec toIO uniformWord64 genWord64 toStdGen f - , testProperty "uniformWord32R/genWord32R" $ - forAll $ \(w32, f :: f) -> - matchRandomGenSpec toIO (uniformWord32R w32) (genWord32R w32) toStdGen f - , testProperty "uniformWord64R/genWord64R" $ - forAll $ \(w64, f :: f) -> - matchRandomGenSpec toIO (uniformWord64R w64) (genWord64R w64) toStdGen f - , testProperty "uniformShortByteString/genShortByteString" $ - forAll $ \(n', f :: f) -> - let n = abs n' `mod` 1000 -- Ensure it is not too big - in matchRandomGenSpec toIO (uniformShortByteString n) (genShortByteString n) toStdGen f - ] ] +frozenGenSpecFor :: + forall f sg m. (RandomGen f, StatefulGen sg m, Eq f, Show f, Typeable f) + => (StdGen -> f) + -> (f -> StdGen) + -> (forall a. f -> (sg -> m a) -> IO (a, f)) + -> TestTree +frozenGenSpecFor fromStdGen toStdGen runStatefulGen = + testGroup (showsTypeRep (typeRep (Proxy :: Proxy f)) "") + [ testGroup "matchRandomGenSpec" + [ testProperty "uniformWord8/genWord8" $ + matchRandomGenSpec uniformWord8 genWord8 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord16/genWord16" $ + matchRandomGenSpec uniformWord16 genWord16 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord32/genWord32" $ + matchRandomGenSpec uniformWord32 genWord32 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord64/genWord64" $ + matchRandomGenSpec uniformWord64 genWord64 fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord32R/genWord32R" $ + forAll $ \w32 -> + matchRandomGenSpec (uniformWord32R w32) (genWord32R w32) fromStdGen toStdGen runStatefulGen + , testProperty "uniformWord64R/genWord64R" $ + forAll $ \w64 -> + matchRandomGenSpec (uniformWord64R w64) (genWord64R w64) fromStdGen toStdGen runStatefulGen + , testProperty "uniformShortByteString/genShortByteString" $ + forAll $ \(NonNegative n') -> + let n = n' `mod` 100000 -- Ensure it is not too big + in matchRandomGenSpec + (uniformShortByteString n) + (genShortByteString n) + fromStdGen + toStdGen + runStatefulGen + ] + ] -statefulSpec :: TestTree -statefulSpec = + +statefulGenSpec :: TestTree +statefulGenSpec = testGroup - "Stateful" - [ statefulSpecFor id unIOGen - , statefulSpecFor id unAtomicGen - , statefulSpecFor stToIO unSTGen - , statefulSpecFor atomically unTGen - , statefulSpecFor (`evalStateT` mkStdGen 0) unStateGen + "StatefulGen" + [ testGroup "ThawedGen" + [ thawedGenSpecFor id (Proxy :: Proxy (IOGen StdGen)) + , thawedGenSpecFor id (Proxy :: Proxy (AtomicGen StdGen)) + , thawedGenSpecFor stToIO (Proxy :: Proxy (STGen StdGen)) + , thawedGenSpecFor atomically (Proxy :: Proxy (TGen StdGen)) + ] + , testGroup "FrozenGen" + [ frozenGenSpecFor StateGen unStateGen runStateGenT + , frozenGenSpecFor IOGen unIOGen $ \g action -> do + mg <- newIOGenM (unIOGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + , frozenGenSpecFor AtomicGen unAtomicGen $ \g action -> do + mg <- newAtomicGenM (unAtomicGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + , frozenGenSpecFor STGen unSTGen $ \g action -> stToIO $ do + mg <- newSTGenM (unSTGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + , frozenGenSpecFor TGen unTGen $ \g action -> atomically $ do + mg <- newTGenM (unTGen g) + res <- action mg + g' <- freezeGen mg + pure (res, g') + ] ]