Add some Stateful tests for FrozenGen

random.cabal

@@ -152,6 +152,7 @@ test-suite spec
     other-modules:
         Spec.Range
         Spec.Run
+        Spec.Stateful
 
     default-language: Haskell2010
     ghc-options:      -Wall
@@ -160,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

@@ -516,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_ #-}

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
+    ]
+