Merge 1eaeffc into 71c19c6

CHANGELOG.md

@@ -4,6 +4,7 @@
 * Addition of `initStdGen`
 * Addition of `runStateGenST_`
 * Ensure that default implementation of `ShortByteString` generation uses unpinned memory.
+* Addition of `TGen` and `TGenM`
 
 # 1.2.0
 

random.cabal

@@ -141,6 +141,7 @@ test-suite doctests
         mwc-random >=0.13 && <0.16,
         primitive >=0.6 && <0.8,
         random,
+        stm,
         unliftio >=0.2 && <0.3,
         vector >= 0.10 && <0.14
 
@@ -151,6 +152,7 @@ test-suite spec
     other-modules:
         Spec.Range
         Spec.Run
+        Spec.Stateful
 
     default-language: Haskell2010
     ghc-options:      -Wall
@@ -159,9 +161,11 @@ test-suite spec
         bytestring,
         random,
         smallcheck >=1.2 && <1.3,
+        stm,
         tasty >=1.0 && <1.5,
         tasty-smallcheck >=0.8 && <0.9,
-        tasty-hunit >=0.10 && <0.11
+        tasty-hunit >=0.10 && <0.11,
+        transformers
 
 -- Note. Fails when compiled with coverage:
 -- https://github.com/haskell/random/issues/107

src/System/Random/Internal.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE GHCForeignImportPrim #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MagicHash #-}
@@ -17,7 +17,6 @@
 #if __GLASGOW_HASKELL__ >= 800
 {-# LANGUAGE TypeFamilyDependencies #-}
 #else
-{-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE TypeFamilies #-}
 #endif
 {-# OPTIONS_HADDOCK hide, not-home #-}
@@ -517,7 +516,7 @@ runStateGenT g f = runStateT (f StateGenM) g
 -- >>> runStateGenT_ pureGen randomM :: IO Int
 -- 7879794327570578227
 --
--- @since 1.2.0
+-- @since 1.2.1
 runStateGenT_ :: (RandomGen g, Functor f) => g -> (StateGenM g -> StateT g f a) -> f a
 runStateGenT_ g = fmap fst . runStateGenT g
 {-# INLINE runStateGenT_ #-}

src/System/Random/Stateful.hs

@@ -67,6 +67,12 @@ module System.Random.Stateful
   , applySTGen
   , runSTGen
   , runSTGen_
+  -- ** Mutable adapter in 'STM'
+  , TGen(..)
+  , TGenM(..)
+  , newTGenM
+  , newTGenMIO
+  , applyTGen
 
   -- * Pseudo-random values of various types
   -- $uniform
@@ -101,6 +107,7 @@ module System.Random.Stateful
 import Control.DeepSeq
 import Control.Monad.IO.Class
 import Control.Monad.ST
+import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar)
 import Control.Monad.State.Strict
 import Data.IORef
 import Data.STRef
@@ -115,8 +122,8 @@ import System.Random.Internal
 -- [Monadic pseudo-random number generators] 'StatefulGen' is an interface to
 --     monadic pseudo-random number generators.
 --
--- [Monadic adapters] 'StateGenM', 'AtomicGenM', 'IOGenM' and 'STGenM' turn a
---     'RandomGen' instance into a 'StatefulGen' instance.
+-- [Monadic adapters] 'StateGenM', 'AtomicGenM', 'IOGenM', 'STGenM` and 'TGenM'
+--     turn a 'RandomGen' instance into a 'StatefulGen' instance.
 --
 -- [Drawing from a range] 'UniformRange' is used to generate a value of a
 --     type uniformly within a range.
@@ -187,7 +194,7 @@ import System.Random.Internal
 -- $monadicadapters
 --
 -- Pure pseudo-random number generators can be used in monadic code via the
--- adapters 'StateGenM', 'AtomicGenM', 'IOGenM' and 'STGenM'.
+-- adapters 'StateGenM', 'AtomicGenM', 'IOGenM', 'STGenM' and 'TGenM'
 --
 -- *   'StateGenM' can be used in any state monad. With strict 'StateT' there is
 --     no performance overhead compared to using the 'RandomGen' instance
@@ -202,6 +209,11 @@ import System.Random.Internal
 --
 -- *   'STGenM' is a wrapper around an 'STRef' that holds a pure generator.
 --     'STGenM' is safe in the presence of exceptions, but not concurrency.
+--
+-- *   'TGenM' is a wrapper around a 'TVar' that holds a pure generator. 'TGenM'
+--     can be used in a software transactional memory monad 'STM`. It is not as
+--     performant as 'AtomicGenM`, but it can provide stronger guarantees in a
+--     concurrent setting.
 
 -- | Interface to operations on 'RandomGen' wrappers like 'IOGenM' and 'StateGenM'.
 --
@@ -228,6 +240,9 @@ instance (RandomGen r, MonadState r m) => RandomGenM (StateGenM r) r m where
 instance RandomGen r => RandomGenM (STGenM r s) r (ST s) where
   applyRandomGenM = applySTGen
 
+instance RandomGen r => RandomGenM (TGenM r) r STM where
+  applyRandomGenM = applyTGen
+
 
 -- | Runs a mutable pseudo-random number generator from its 'FrozenGen' state.
 --
@@ -552,6 +567,73 @@ runSTGen_ :: RandomGen g => g -> (forall s . STGenM g s -> ST s a) -> a
 runSTGen_ g action = fst $ runSTGen g action
 
 
+-- | Wraps a 'TVar' that holds a pure pseudo-random number generator.
+--
+-- @since 1.2.1
+newtype TGenM g = TGenM { unTGenM :: TVar g }
+
+-- | Frozen version of mutable `TGenM` generator
+--
+-- @since 1.2.1
+newtype TGen g = TGen { unTGen :: g }
+  deriving (Eq, Ord, Show, RandomGen, Storable, NFData)
+
+-- | Creates a new 'TGenM' in `STM`.
+--
+-- @since 1.2.1
+newTGenM :: g -> STM (TGenM g)
+newTGenM = fmap TGenM . newTVar
+
+
+-- | Creates a new 'TGenM' in `IO`.
+--
+-- @since 1.2.1
+newTGenMIO :: MonadIO m => g -> m (TGenM g)
+newTGenMIO g = liftIO (TGenM <$> newTVarIO g)
+
+
+-- | @since 1.2.1
+instance RandomGen g => StatefulGen (TGenM g) STM where
+  uniformWord32R r = applyTGen (genWord32R r)
+  {-# INLINE uniformWord32R #-}
+  uniformWord64R r = applyTGen (genWord64R r)
+  {-# INLINE uniformWord64R #-}
+  uniformWord8 = applyTGen genWord8
+  {-# INLINE uniformWord8 #-}
+  uniformWord16 = applyTGen genWord16
+  {-# INLINE uniformWord16 #-}
+  uniformWord32 = applyTGen genWord32
+  {-# INLINE uniformWord32 #-}
+  uniformWord64 = applyTGen genWord64
+  {-# INLINE uniformWord64 #-}
+  uniformShortByteString n = applyTGen (genShortByteString n)
+
+-- | @since 1.2.1
+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
+
+
+-- | Applies a pure operation to the wrapped pseudo-random number generator.
+--
+-- ====__Examples__
+--
+-- >>> import Control.Concurrent.STM
+-- >>> import System.Random.Stateful
+-- >>> let pureGen = mkStdGen 137
+-- >>> stmGen <- newTGenMIO pureGen
+-- >>> atomically $ applyTGen uniform stmGen :: IO Int
+-- 7879794327570578227
+--
+-- @since 1.2.1
+applyTGen :: (g -> (a, g)) -> TGenM g -> STM a
+applyTGen f (TGenM tvar) = do
+  g <- readTVar tvar
+  case f g of
+    (a, !g') -> a <$ writeTVar tvar g'
+{-# INLINE applyTGen #-}
+
 -- $uniform
 --
 -- This library provides two type classes to generate pseudo-random values:

test/Spec.hs

@@ -27,6 +27,7 @@ import Test.Tasty.SmallCheck as SC
 
 import qualified Spec.Range as Range
 import qualified Spec.Run as Run
+import qualified Spec.Stateful as Stateful
 
 main :: IO ()
 main =
@@ -82,6 +83,7 @@ main =
     , byteStringSpec
     , SC.testProperty "uniformRangeWithinExcludedF" $ seeded Range.uniformRangeWithinExcludedF
     , SC.testProperty "uniformRangeWithinExcludedD" $ seeded Range.uniformRangeWithinExcludedD
+    , Stateful.statefulSpec
     ]
 
 floatTests :: TestTree
@@ -211,3 +213,4 @@ instance Uniform Colors where
 instance UniformRange Colors where
   uniformRM = uniformEnumRM
   isInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x)
+

test/Spec/Stateful.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Spec.Stateful where
+
+import Control.Concurrent.STM
+import Control.Monad.ST
+import Control.Monad.Trans.State.Strict
+import Data.Proxy
+import Data.Typeable
+import System.Random.Stateful
+import Test.SmallCheck.Series
+import Test.Tasty
+import Test.Tasty.SmallCheck as SC
+
+instance Monad m => Serial m StdGen where
+  series = mkStdGen <$> series
+
+instance (Monad m, Serial m g) => Serial m (AtomicGen g) where
+  series = AtomicGen <$> series
+
+instance (Monad m, Serial m g) => Serial m (IOGen g) where
+  series = IOGen <$> series
+
+instance (Monad m, Serial m g) => Serial m (STGen g) where
+  series = STGen <$> series
+
+instance (Monad m, Serial m g) => Serial m (TGen g) where
+  series = TGen <$> series
+
+instance (Monad m, Serial m g) => Serial m (StateGen g) where
+  series = StateGen <$> series
+
+
+matchRandomGenSpec ::
+     forall b f m. (FrozenGen f m, Eq f, Show f, Eq b)
+  => (forall a. m a -> IO a)
+  -> (MutableGen f m -> m b)
+  -> (StdGen -> (b, StdGen))
+  -> (f -> StdGen)
+  -> f
+  -> Property IO
+matchRandomGenSpec toIO genM gen toStdGen frozen =
+  monadic $ do
+    (x1, fg1) <- toIO $ withMutableGen frozen genM
+    let (x2, g2) = gen $ toStdGen frozen
+    pure $ x1 == x2 && toStdGen fg1 == g2
+
+withMutableGenSpec ::
+     forall f m. (FrozenGen f m, Eq f, Show f)
+  => (forall a. m a -> IO a)
+  -> f
+  -> Property IO
+withMutableGenSpec toIO frozen =
+  forAll $ \n -> monadic $ do
+    let gen = uniformListM n
+    x :: ([Word], f) <- toIO $ withMutableGen frozen gen
+    y <- toIO $ withMutableGen frozen gen
+    pure $ x == y
+
+
+statefulSpecFor ::
+     forall f m. (FrozenGen f m, Eq f, Show f, Serial IO f, Typeable f)
+  => (forall a. m a -> IO a)
+  -> (f -> StdGen)
+  -> TestTree
+statefulSpecFor toIO toStdGen =
+  testGroup
+    (showsTypeRep (typeRep (Proxy :: Proxy f)) "")
+    [ testProperty "withMutableGen" $
+      forAll $ \(f :: f) -> withMutableGenSpec 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
+        ]
+    ]
+
+
+statefulSpec :: TestTree
+statefulSpec =
+  testGroup
+    "Stateful"
+    [ statefulSpecFor id unIOGen
+    , statefulSpecFor id unAtomicGen
+    , statefulSpecFor stToIO unSTGen
+    , statefulSpecFor atomically unTGen
+    , statefulSpecFor (`evalStateT` mkStdGen 0) unStateGen
+    ]
+