From 1eaeffc17f2ec9a2142011d83349a7d94547319c Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 9 Sep 2021 16:05:02 +0300 Subject: [PATCH] Add some Stateful tests for FrozenGen --- random.cabal | 5 +- src/System/Random/Internal.hs | 2 +- test/Spec.hs | 3 + test/Spec/Stateful.hs | 113 ++++++++++++++++++++++++++++++++++ 4 files changed, 121 insertions(+), 2 deletions(-) create mode 100644 test/Spec/Stateful.hs diff --git a/random.cabal b/random.cabal index 69c6d7a9..8111d80e 100644 --- a/random.cabal +++ b/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 diff --git a/src/System/Random/Internal.hs b/src/System/Random/Internal.hs index 715fa8ff..27db4ec6 100644 --- a/src/System/Random/Internal.hs +++ b/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_ #-} diff --git a/test/Spec.hs b/test/Spec.hs index 4317eced..5a7cfeb8 100644 --- a/test/Spec.hs +++ b/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) + diff --git a/test/Spec/Stateful.hs b/test/Spec/Stateful.hs new file mode 100644 index 00000000..8c951d43 --- /dev/null +++ b/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 + ] +