Implementation of TGen and TGenM

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 -any,
+        stm,
         unliftio >=0.2 && <0.3,
         vector >= 0.10 && <0.14
 

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 #-}

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: