diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +# 1.2.1 + +* Fix support for ghc-9.2 [#99](https://github.com/haskell/random/pull/99) +* Fix performance regression for ghc-9.0 [#101](https://github.com/haskell/random/pull/101) +* Add `uniformEnumM` and `uniformEnumRM` +* Add `initStdGen` [#103](https://github.com/haskell/random/pull/103) +* Add `globalStdGen` [#117](https://github.com/haskell/random/pull/117) +* Add `runStateGenST_` +* Ensure that default implementation of `ShortByteString` generation uses + unpinned memory. [#116](https://github.com/haskell/random/pull/116) +* Fix [#54](https://github.com/haskell/random/issues/54) with + [#68](https://github.com/haskell/random/pull/68) - if exactly one value in the + range of floating point is infinite, then `uniformRM`/`randomR` returns that + value. +* Add default implementation of `uniformM` that uses `Generic` + [#70](https://github.com/haskell/random/pull/70) +* `Random` instance for `CBool` [#77](https://github.com/haskell/random/pull/77) +* Addition of `TGen` and `TGenM` [#95](https://github.com/haskell/random/pull/95) +* Addition of tuple instances for `Random` up to 7-tuple + [#72](https://github.com/haskell/random/pull/72) + # 1.2.0 1. Breaking change which mostly maintains backwards compatibility, see diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,13 +4,13 @@ ### Status -| Language | Travis | Coveralls | -|:--------:|:------:|:---------:| -| ![GitHub top language](https://img.shields.io/github/languages/top/haskell/random.svg) | [![Build Status](https://secure.travis-ci.org/haskell/random.svg?master)](http://travis-ci.org/haskell/random) | [![Coverage Status](https://coveralls.io/repos/github/haskell/random/badge.svg?branch=master)](https://coveralls.io/github/haskell/random?branch=master) +| Language | Github Actions | Drone.io | Coveralls | +|:--------:|:--------------:|:--------:|:---------:| +| ![GitHub top language](https://img.shields.io/github/languages/top/haskell/random.svg) | [![Build Status](https://github.com/haskell/random/workflows/random-CI/badge.svg)](https://github.com/haskell/random/actions) | [![Build Status](https://cloud.drone.io/api/badges/haskell/random/status.svg?ref=refs/heads/master)](https://cloud.drone.io/haskell/random/) | [![Coverage Status](https://coveralls.io/repos/github/haskell/random/badge.svg?branch=master)](https://coveralls.io/github/haskell/random?branch=master) -| Package | Hackage | Nightly | LTS | +| Github Repo | Hackage | Nightly | LTS | |:-------------------|:-------:|:-------:|:---:| -| [`random`](https://github.com/haskell/random)| [![Hackage](https://img.shields.io/hackage/v/random.svg)](https://hackage.haskell.org/package/random)| [![Nightly](https://www.stackage.org/package/random/badge/nightly)](https://www.stackage.org/nightly/package/random)| [![Nightly](https://www.stackage.org/package/random/badge/lts)](https://www.stackage.org/lts/package/random) +| [`random`](https://github.com/haskell/random)| [![Hackage](https://img.shields.io/hackage/v/random.svg)](https://hackage.haskell.org/package/random)| [![Nightly](https://www.stackage.org/package/random/badge/nightly)](https://www.stackage.org/nightly/package/random)| [![LTS](https://www.stackage.org/package/random/badge/lts)](https://www.stackage.org/lts/package/random) ### Description diff --git a/bench-legacy/SimpleRNGBench.hs b/bench-legacy/SimpleRNGBench.hs --- a/bench-legacy/SimpleRNGBench.hs +++ b/bench-legacy/SimpleRNGBench.hs @@ -222,7 +222,7 @@ randBool = random :: RandomGen g => g -> (Bool,g) randChar = random :: RandomGen g => g -> (Char,g) - gen = mkStdGen 23852358661234 + gen = mkStdGen 238523586 gamut th = do putStrLn " First, timing System.Random.next:" timeit th freq "constant zero gen" NoopRNG next diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -10,63 +10,82 @@ import Data.Typeable import Data.Word import Foreign.C.Types -import Gauge.Main import Numeric.Natural (Natural) import System.Random.SplitMix as SM +import Test.Tasty.Bench +import Control.Monad.Primitive +import Data.Primitive.PrimArray +import Data.Primitive.Types import System.Random.Stateful +seed :: Int +seed = 1337 + main :: IO () main = do let !sz = 100000 genLengths = -- create 5000 small lengths that are needed for ShortByteString generation runStateGen (mkStdGen 2020) $ \g -> replicateM 5000 (uniformRM (16 + 1, 16 + 7) g) + setStdGen $ mkStdGen seed defaultMain [ bgroup "baseline" - [ let !smGen = SM.mkSMGen 1337 in bench "nextWord32" $ nf (genMany SM.nextWord32 smGen) sz - , let !smGen = SM.mkSMGen 1337 in bench "nextWord64" $ nf (genMany SM.nextWord64 smGen) sz - , let !smGen = SM.mkSMGen 1337 in bench "nextInt" $ nf (genMany SM.nextInt smGen) sz - , let !smGen = SM.mkSMGen 1337 in bench "split" $ nf (genMany SM.splitSMGen smGen) sz + [ env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "nextWord32" $ whnf (genMany SM.nextWord32 smGen) sz + , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "nextWord64" $ whnf (genMany SM.nextWord64 smGen) sz + , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "nextInt" $ whnf (genMany SM.nextInt smGen) sz + , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen -> + bench "split" $ whnf (genMany SM.splitSMGen smGen) sz ] , bgroup "pure" [ bgroup "random" - [ pureRandomBench (Proxy :: Proxy Float) sz - , pureRandomBench (Proxy :: Proxy Double) sz - , pureRandomBench (Proxy :: Proxy Integer) sz + [ pureBench random sz (Proxy :: Proxy Word8) + , pureBench random sz (Proxy :: Proxy Word16) + , pureBench random sz (Proxy :: Proxy Word32) + , pureBench random sz (Proxy :: Proxy Word64) + , pureBench random sz (Proxy :: Proxy Int8) + , pureBench random sz (Proxy :: Proxy Int16) + , pureBench random sz (Proxy :: Proxy Int32) + , pureBench random sz (Proxy :: Proxy Int64) + , pureBench random sz (Proxy :: Proxy Bool) + , pureBench random sz (Proxy :: Proxy Char) + , pureBench random sz (Proxy :: Proxy Float) + , pureBench random sz (Proxy :: Proxy Double) + , pureBench random sz (Proxy :: Proxy Integer) ] , bgroup "uniform" - [ pureUniformBench (Proxy :: Proxy Word8) sz - , pureUniformBench (Proxy :: Proxy Word16) sz - , pureUniformBench (Proxy :: Proxy Word32) sz - , pureUniformBench (Proxy :: Proxy Word64) sz - , pureUniformBench (Proxy :: Proxy Word) sz - , pureUniformBench (Proxy :: Proxy Int8) sz - , pureUniformBench (Proxy :: Proxy Int16) sz - , pureUniformBench (Proxy :: Proxy Int32) sz - , pureUniformBench (Proxy :: Proxy Int64) sz - , pureUniformBench (Proxy :: Proxy Int) sz - , pureUniformBench (Proxy :: Proxy Char) sz - , pureUniformBench (Proxy :: Proxy Bool) sz - , pureUniformBench (Proxy :: Proxy CChar) sz - , pureUniformBench (Proxy :: Proxy CSChar) sz - , pureUniformBench (Proxy :: Proxy CUChar) sz - , pureUniformBench (Proxy :: Proxy CShort) sz - , pureUniformBench (Proxy :: Proxy CUShort) sz - , pureUniformBench (Proxy :: Proxy CInt) sz - , pureUniformBench (Proxy :: Proxy CUInt) sz - , pureUniformBench (Proxy :: Proxy CLong) sz - , pureUniformBench (Proxy :: Proxy CULong) sz - , pureUniformBench (Proxy :: Proxy CPtrdiff) sz - , pureUniformBench (Proxy :: Proxy CSize) sz - , pureUniformBench (Proxy :: Proxy CWchar) sz - , pureUniformBench (Proxy :: Proxy CSigAtomic) sz - , pureUniformBench (Proxy :: Proxy CLLong) sz - , pureUniformBench (Proxy :: Proxy CULLong) sz - , pureUniformBench (Proxy :: Proxy CIntPtr) sz - , pureUniformBench (Proxy :: Proxy CUIntPtr) sz - , pureUniformBench (Proxy :: Proxy CIntMax) sz - , pureUniformBench (Proxy :: Proxy CUIntMax) sz + [ pureBench uniform sz (Proxy :: Proxy Word8) + , pureBench uniform sz (Proxy :: Proxy Word16) + , pureBench uniform sz (Proxy :: Proxy Word32) + , pureBench uniform sz (Proxy :: Proxy Word64) + , pureBench uniform sz (Proxy :: Proxy Int8) + , pureBench uniform sz (Proxy :: Proxy Int16) + , pureBench uniform sz (Proxy :: Proxy Int32) + , pureBench uniform sz (Proxy :: Proxy Int64) + , pureBench uniform sz (Proxy :: Proxy Bool) + , pureBench uniform sz (Proxy :: Proxy Char) + , pureBench uniform sz (Proxy :: Proxy CChar) + , pureBench uniform sz (Proxy :: Proxy CSChar) + , pureBench uniform sz (Proxy :: Proxy CUChar) + , pureBench uniform sz (Proxy :: Proxy CShort) + , pureBench uniform sz (Proxy :: Proxy CUShort) + , pureBench uniform sz (Proxy :: Proxy CInt) + , pureBench uniform sz (Proxy :: Proxy CUInt) + , pureBench uniform sz (Proxy :: Proxy CLong) + , pureBench uniform sz (Proxy :: Proxy CULong) + , pureBench uniform sz (Proxy :: Proxy CPtrdiff) + , pureBench uniform sz (Proxy :: Proxy CSize) + , pureBench uniform sz (Proxy :: Proxy CWchar) + , pureBench uniform sz (Proxy :: Proxy CSigAtomic) + , pureBench uniform sz (Proxy :: Proxy CLLong) + , pureBench uniform sz (Proxy :: Proxy CULLong) + , pureBench uniform sz (Proxy :: Proxy CIntPtr) + , pureBench uniform sz (Proxy :: Proxy CUIntPtr) + , pureBench uniform sz (Proxy :: Proxy CIntMax) + , pureBench uniform sz (Proxy :: Proxy CUIntMax) ] , bgroup "uniformR" [ bgroup "full" @@ -180,76 +199,59 @@ ] , bgroup "floating" [ bgroup "IO" - [ bench "uniformFloat01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> - replicateM_ sz $ do !_ <- uniformFloat01M g - return () - , bench "uniformFloatPositive01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> - replicateM_ sz $ do !_ <- uniformFloatPositive01M g - return () - , bench "uniformDouble01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> - replicateM_ sz $ do !_ <- uniformDouble01M g - return () - , bench "uniformDoublePositive01M" $ nfIO $ runStateGenT_ (mkStdGen 1337) $ \g -> - replicateM_ sz $ do !_ <- uniformDoublePositive01M g - return () + [ env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformFloat01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformFloat01M ma)) + , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformFloatPositive01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformFloatPositive01M ma)) + , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformDouble01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformDouble01M ma)) + , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> + bench "uniformDoublePositive01M" $ + nfIO (runStateGenT gen (fillMutablePrimArrayM uniformDoublePositive01M ma)) ] - -- - , bgroup "St" - [ bench "uniformFloat01M" $ nf - (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformFloat01M g - return () - ) sz - , bench "uniformFloatPositive01M" $ nf - (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformFloatPositive01M g - return () - ) sz - , bench "uniformDouble01M" $ nf - (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformDouble01M g - return () - ) sz - , bench "uniformDoublePositive01M" $ nf - (\n -> runStateGen_ (mkStdGen 1337) $ \g -> replicateM_ n $ do !_ <- uniformDoublePositive01M g - return () - ) sz + , bgroup "State" + [ env getStdGen $ + bench "uniformFloat01M" . nf (`runStateGen` (replicateM_ sz . uniformFloat01M)) + , env getStdGen $ + bench "uniformFloatPositive01M" . + nf (`runStateGen` (replicateM_ sz . uniformFloatPositive01M)) + , env getStdGen $ + bench "uniformDouble01M" . nf (`runStateGen` (replicateM_ sz . uniformDouble01M)) + , env getStdGen $ + bench "uniformDoublePositive01M" . + nf (`runStateGen` (replicateM_ sz . uniformDoublePositive01M)) ] , bgroup "pure" - [ let !stdGen = mkStdGen 1337 - in bench "uniformFloat01M" $ nf - (genMany (runState $ uniformFloat01M (StateGenM :: StateGenM StdGen)) stdGen) - sz - , let !stdGen = mkStdGen 1337 - in bench "uniformFloatPositive01M" $ nf - (genMany (runState $ uniformFloatPositive01M (StateGenM :: StateGenM StdGen)) stdGen) - sz - , let !stdGen = mkStdGen 1337 - in bench "uniformDouble01M" $ nf - (genMany (runState $ uniformDouble01M (StateGenM :: StateGenM StdGen)) stdGen) - sz - , let !stdGen = mkStdGen 1337 - in bench "uniformDoublePositive01M" $ nf - (genMany (runState $ uniformDoublePositive01M (StateGenM :: StateGenM StdGen)) stdGen) - sz + [ env getStdGen $ \gen -> + bench "uniformFloat01M" $ nf + (genMany (runState $ uniformFloat01M (StateGenM :: StateGenM StdGen)) gen) + sz + , env getStdGen $ \gen -> + bench "uniformFloatPositive01M" $ nf + (genMany (runState $ uniformFloatPositive01M (StateGenM :: StateGenM StdGen)) gen) + sz + , env getStdGen $ \gen -> + bench "uniformDouble01M" $ nf + (genMany (runState $ uniformDouble01M (StateGenM :: StateGenM StdGen)) gen) + sz + , env getStdGen $ \gen -> + bench "uniformDoublePositive01M" $ nf + (genMany (runState $ uniformDoublePositive01M (StateGenM :: StateGenM StdGen)) gen) + sz ] ] , bgroup "ShortByteString" [ env (pure genLengths) $ \ ~(ns, gen) -> bench "genShortByteString" $ - nfIO $ runStateGenT_ gen $ \g -> mapM (`uniformShortByteString` g) ns + nfIO $ runStateGenT gen $ \g -> mapM (`uniformShortByteString` g) ns ] ] ] ] -pureRandomBench :: forall a. (Typeable a, Random a) => Proxy a -> Int -> Benchmark -pureRandomBench px = - let !stdGen = mkStdGen 1337 - in pureBench px (genMany (random :: StdGen -> (a, StdGen)) stdGen) - -pureUniformBench :: forall a. (Typeable a, Uniform a) => Proxy a -> Int -> Benchmark -pureUniformBench px = - let !stdGen = mkStdGen 1337 - in pureBench px (genMany (uniform :: StdGen -> (a, StdGen)) stdGen) - pureUniformRFullBench :: forall a. (Typeable a, UniformRange a, Bounded a) => Proxy a @@ -258,6 +260,7 @@ pureUniformRFullBench px = let range = (minBound :: a, maxBound :: a) in pureUniformRBench px range +{-# INLINE pureUniformRFullBench #-} pureUniformRExcludeMaxBench :: forall a. (Typeable a, UniformRange a, Bounded a, Enum a) @@ -267,6 +270,7 @@ pureUniformRExcludeMaxBench px = let range = (minBound :: a, pred (maxBound :: a)) in pureUniformRBench px range +{-# INLINE pureUniformRExcludeMaxBench #-} pureUniformRIncludeHalfBench :: forall a. (Typeable a, UniformRange a, Bounded a, Integral a) @@ -276,6 +280,7 @@ pureUniformRIncludeHalfBench px = let range = ((minBound :: a) + 1, ((maxBound :: a) `div` 2) + 1) in pureUniformRBench px range +{-# INLINE pureUniformRIncludeHalfBench #-} pureUniformRIncludeHalfEnumBench :: forall a. (Typeable a, UniformRange a, Bounded a, Enum a) @@ -285,6 +290,7 @@ pureUniformRIncludeHalfEnumBench px = let range = (succ (minBound :: a), toEnum ((fromEnum (maxBound :: a) `div` 2) + 1)) in pureUniformRBench px range +{-# INLINE pureUniformRIncludeHalfEnumBench #-} pureUniformRBench :: forall a. (Typeable a, UniformRange a) @@ -292,18 +298,39 @@ -> (a, a) -> Int -> Benchmark -pureUniformRBench px range@(!_, !_) = - let !stdGen = mkStdGen 1337 - in pureBench px (genMany (uniformR range) stdGen) +pureUniformRBench px range@(!_, !_) sz = pureBench (uniformR range) sz px +{-# INLINE pureUniformRBench #-} -pureBench :: forall a. (Typeable a) => Proxy a -> (Int -> ()) -> Int -> Benchmark -pureBench px f sz = bench (showsTypeRep (typeRep px) "") $ nf f sz +pureBench :: + forall a. Typeable a + => (StdGen -> (a, StdGen)) + -> Int + -> Proxy a + -> Benchmark +pureBench f sz px = + env getStdGen $ \gen -> + bench (showsTypeRep (typeRep px) "") $ whnf (genMany f gen) sz +{-# INLINE pureBench #-} -genMany :: (g -> (a, g)) -> g -> Int -> () -genMany f g0 n = go g0 0 + +genMany :: (g -> (a, g)) -> g -> Int -> a +genMany f g0 n = go 0 $ f g0 where - go g i - | i < n = - case f g of - (x, g') -> x `seq` go g' (i + 1) - | otherwise = g `seq` () + go i (!y, !g) + | i < n = go (i + 1) $ f g + | otherwise = y + + +fillMutablePrimArrayM :: + (Prim a, PrimMonad m) + => (gen -> m a) + -> MutablePrimArray (PrimState m) a + -> gen + -> m (PrimArray a) +fillMutablePrimArrayM f ma g = do + n <- getSizeofMutablePrimArray ma + let go i + | i < n = f g >>= writePrimArray ma i >> go (i + 1) + | otherwise = pure () + go 0 + unsafeFreezePrimArray ma diff --git a/random.cabal b/random.cabal --- a/random.cabal +++ b/random.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: random -version: 1.2.0 +version: 1.2.1 license: BSD3 license-file: LICENSE maintainer: core-libraries-committee@haskell.org @@ -42,7 +42,7 @@ >>> runStateGen_ pureGen (replicateM 10 . rollM) :: [Word] [1,1,3,2,4,5,3,4,6,2] . - The monadic adapter 'System.Random.Stateful.runGenState_' is used here to lift + The monadic adapter 'System.Random.Stateful.runStateGen_' is used here to lift the pure pseudo-random number generator @pureGen@ into the 'System.Random.Stateful.StatefulGen' context. . @@ -86,6 +86,8 @@ System.Random System.Random.Internal System.Random.Stateful + other-modules: + System.Random.GFinite hs-source-dirs: src default-language: Haskell2010 @@ -97,13 +99,15 @@ build-depends: base >=4.8 && <5, - bytestring >=0.10.4 && <0.11, + bytestring >=0.10.4 && <0.12, deepseq >=1.1 && <2, mtl >=2.2 && <2.3, splitmix >=0.1 && <0.2 if impl(ghc < 8.0) build-depends: transformers + if impl(ghc < 8.4) + build-depends: ghc-byteorder test-suite legacy-test type: exitcode-stdio-1.0 @@ -122,9 +126,9 @@ ghc-options: -Wno-deprecations build-depends: - base -any, + base, containers >=0.5 && <0.7, - random -any + random test-suite doctests type: exitcode-stdio-1.0 @@ -132,13 +136,16 @@ hs-source-dirs: test default-language: Haskell2010 build-depends: - base -any, - doctest >=0.15 && <0.18, - mwc-random >=0.13 && <0.15, - primitive >=0.6 && <0.8, - random -any, - unliftio >=0.2 && <0.3, - vector >= 0.10 && <0.14 + base, + doctest >=0.15 && <0.19 + if impl(ghc >= 8.2) && impl(ghc < 8.10) + build-depends: + mwc-random >=0.13 && <0.16, + primitive >=0.6 && <0.8, + random, + stm, + unliftio >=0.2 && <0.3, + vector >= 0.10 && <0.14 test-suite spec type: exitcode-stdio-1.0 @@ -147,19 +154,41 @@ other-modules: Spec.Range Spec.Run + Spec.Stateful default-language: Haskell2010 ghc-options: -Wall build-depends: - base -any, - bytestring -any, - random -any, + base, + bytestring, + random, smallcheck >=1.2 && <1.3, - tasty >=1.0 && <1.4, + stm, + tasty >=1.0 && <1.5, tasty-smallcheck >=0.8 && <0.9, - tasty-expected-failure >=0.11 && <0.12, - 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 +test-suite spec-inspection + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test-inspection + build-depends: + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base, + random, + tasty >=1.0 && <1.5 + if impl(ghc >= 8.0) + build-depends: + tasty-inspection-testing + other-modules: + Spec.Inspection + benchmark legacy-bench type: exitcode-stdio-1.0 main-is: SimpleRNGBench.hs @@ -173,9 +202,9 @@ -Wno-deprecations build-depends: - base -any, - random -any, - rdtsc -any, + base, + random, + rdtsc, split >=0.2 && <0.3, time >=1.4 && <1.11 @@ -186,8 +215,9 @@ default-language: Haskell2010 ghc-options: -Wall -O2 build-depends: - base -any, - gauge >=0.2.3 && <0.3, + base, mtl, - random -any, - splitmix >=0.1 && <0.2 + primitive >= 0.7.1, + random, + splitmix >=0.1 && <0.2, + tasty-bench diff --git a/src/System/Random.hs b/src/System/Random.hs --- a/src/System/Random.hs +++ b/src/System/Random.hs @@ -27,9 +27,12 @@ , Random(..) , Uniform , UniformRange + , Finite + -- ** Standard pseudo-random number generator , StdGen , mkStdGen + , initStdGen -- ** Global standard pseudo-random number generator -- $globalstdgen @@ -57,13 +60,14 @@ import Control.Arrow import Control.Monad.IO.Class +import Control.Monad.State.Strict import Data.ByteString (ByteString) import Data.Int import Data.IORef import Data.Word import Foreign.C.Types import GHC.Exts -import System.IO.Unsafe (unsafePerformIO) +import System.Random.GFinite (Finite) import System.Random.Internal import qualified System.Random.SplitMix as SM @@ -95,7 +99,7 @@ -- [4,2,6,1,6,6,5,1,1,5] -- -- To run use a /monadic/ pseudo-random computation in pure code with a pure --- pseudo-random number generator, use 'runGenState' and its variants. +-- pseudo-random number generator, use 'runStateGen' and its variants. -- -- >>> :{ -- let rollsM :: StatefulGen g m => Int -> g -> m [Word] @@ -143,6 +147,7 @@ -- @since 1.2.0 uniform :: (RandomGen g, Uniform a) => g -> (a, g) uniform g = runStateGen g uniformM +{-# INLINE uniform #-} -- | Generates a value uniformly distributed over the provided range, which -- is interpreted as inclusive in the lower and upper bound. @@ -169,9 +174,10 @@ -- @since 1.2.0 uniformR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g) uniformR r g = runStateGen g (uniformRM r) +{-# INLINE uniformR #-} -- | Generates a 'ByteString' of the specified size using a pure pseudo-random --- number generator. See 'uniformByteString' for the monadic version. +-- number generator. See 'uniformByteStringM' for the monadic version. -- -- ====__Examples__ -- @@ -186,20 +192,43 @@ genByteString n g = runStateGenST g (uniformByteStringM n) {-# INLINE genByteString #-} --- | The class of types for which uniformly distributed values can be --- generated. +-- | The class of types for which random values can be generated. Most +-- instances of `Random` will produce values that are uniformly distributed on the full +-- range, but for those types without a well-defined "full range" some sensible default +-- subrange will be selected. -- -- 'Random' exists primarily for backwards compatibility with version 1.1 of -- this library. In new code, use the better specified 'Uniform' and -- 'UniformRange' instead. +-- +-- @since 1.0.0 class Random a where -- | Takes a range /(lo,hi)/ and a pseudo-random number generator -- /g/, and returns a pseudo-random value uniformly distributed over the -- closed interval /[lo,hi]/, together with a new generator. It is unspecified - -- what happens if /lo>hi/. For continuous types there is no requirement - -- that the values /lo/ and /hi/ are ever produced, but they may be, - -- depending on the implementation and the interval. + -- what happens if /lo>hi/, but usually the values will simply get swapped. + -- + -- >>> let gen = mkStdGen 2021 + -- >>> fst $ randomR ('a', 'z') gen + -- 't' + -- >>> fst $ randomR ('z', 'a') gen + -- 't' + -- + -- For continuous types there is no requirement that the values /lo/ and /hi/ are ever + -- produced, but they may be, depending on the implementation and the interval. + -- + -- There is no requirement to follow the @Ord@ instance and the concept of range can be + -- defined on per type basis. For example product types will treat their values + -- independently: + -- + -- >>> fst $ randomR (('a', 5.0), ('z', 10.0)) $ mkStdGen 2021 + -- ('t',6.240232662366563) + -- + -- In case when a lawful range is desired `uniformR` should be used + -- instead. + -- + -- @since 1.0.0 {-# INLINE randomR #-} randomR :: RandomGen g => (a, a) -> g -> (a, g) default randomR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g) @@ -210,10 +239,11 @@ -- * For bounded types (instances of 'Bounded', such as 'Char'), -- the range is normally the whole type. -- - -- * For fractional types, the range is normally the semi-closed interval - -- @[0,1)@. + -- * For floating point types, the range is normally the closed interval @[0,1]@. -- -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. + -- + -- @since 1.0.0 {-# INLINE random #-} random :: RandomGen g => g -> (a, g) default random :: (RandomGen g, Uniform a) => g -> (a, g) @@ -221,12 +251,16 @@ -- | Plural variant of 'randomR', producing an infinite list of -- pseudo-random values instead of returning a new generator. + -- + -- @since 1.0.0 {-# INLINE randomRs #-} randomRs :: RandomGen g => (a,a) -> g -> [a] randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) -- | Plural variant of 'random', producing an infinite list of -- pseudo-random values instead of returning a new generator. + -- + -- @since 1.0.0 {-# INLINE randoms #-} randoms :: RandomGen g => g -> [a] randoms g = build (\cons _nil -> buildRandoms cons random g) @@ -243,7 +277,7 @@ -- {-# INLINE buildRandoms #-} buildRandoms :: RandomGen g - => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion + => (a -> as -> as) -- ^ E.g. @(:)@ but subject to fusion -> (g -> (a,g)) -- ^ E.g. 'random' -> g -- ^ A 'RandomGen' instance -> as @@ -252,9 +286,10 @@ -- The seq fixes part of #4218 and also makes fused Core simpler. go g = x `seq` (x `cons` go g') where (x,g') = rand g --- Generate values in the Int range +-- | /Note/ - `random` generates values in the `Int` range instance Random Integer where random = first (toInteger :: Int -> Integer) . random + {-# INLINE random #-} instance Random Int8 instance Random Int16 instance Random Int32 @@ -265,7 +300,7 @@ instance Random Word16 instance Random Word32 instance Random Word64 -#if __GLASGOW_HASKELL >= 802 +#if __GLASGOW_HASKELL__ >= 802 instance Random CBool #endif instance Random CChar @@ -287,22 +322,135 @@ instance Random CUIntPtr instance Random CIntMax instance Random CUIntMax +-- | /Note/ - `random` produces values in the closed range @[0,1]@. instance Random CFloat where - randomR (CFloat l, CFloat h) = first CFloat . randomR (l, h) + randomR r = coerce . randomR (coerce r :: (Float, Float)) + {-# INLINE randomR #-} random = first CFloat . random + {-# INLINE random #-} +-- | /Note/ - `random` produces values in the closed range @[0,1]@. instance Random CDouble where - randomR (CDouble l, CDouble h) = first CDouble . randomR (l, h) + randomR r = coerce . randomR (coerce r :: (Double, Double)) + {-# INLINE randomR #-} random = first CDouble . random + {-# INLINE random #-} instance Random Char instance Random Bool +-- | /Note/ - `random` produces values in the closed range @[0,1]@. instance Random Double where randomR r g = runStateGen g (uniformRM r) - random g = runStateGen g (uniformRM (0, 1)) + {-# INLINE randomR #-} + -- We return 1 - uniformDouble01M here for backwards compatibility with + -- v1.2.0. Just return the result of uniformDouble01M in the next major + -- version. + random g = runStateGen g (fmap (1 -) . uniformDouble01M) + {-# INLINE random #-} +-- | /Note/ - `random` produces values in the closed range @[0,1]@. instance Random Float where randomR r g = runStateGen g (uniformRM r) - random g = runStateGen g (uniformRM (0, 1)) + {-# INLINE randomR #-} + -- We return 1 - uniformFloat01M here for backwards compatibility with + -- v1.2.0. Just return the result of uniformFloat01M in the next major + -- version. + random g = runStateGen g (fmap (1 -) . uniformFloat01M) + {-# INLINE random #-} + + +-- | Initialize 'StdGen' using system entropy (i.e. @\/dev\/urandom@) when it is +-- available, while falling back on using system time as the seed. +-- +-- @since 1.2.1 +initStdGen :: MonadIO m => m StdGen +initStdGen = liftIO (StdGen <$> SM.initSMGen) + + +-- | /Note/ - `randomR` treats @a@ and @b@ types independently +instance (Random a, Random b) => Random (a, b) where + randomR ((al, bl), (ah, bh)) = runState $ + (,) <$> state (randomR (al, ah)) <*> state (randomR (bl, bh)) + {-# INLINE randomR #-} + random = runState $ (,) <$> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@ and @c@ types independently +instance (Random a, Random b, Random c) => Random (a, b, c) where + randomR ((al, bl, cl), (ah, bh, ch)) = runState $ + (,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + {-# INLINE randomR #-} + random = runState $ (,,) <$> state random <*> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@ and @d@ types independently +instance (Random a, Random b, Random c, Random d) => Random (a, b, c, d) where + randomR ((al, bl, cl, dl), (ah, bh, ch, dh)) = runState $ + (,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + {-# INLINE randomR #-} + random = runState $ + (,,,) <$> state random <*> state random <*> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@ and @e@ types independently +instance (Random a, Random b, Random c, Random d, Random e) => Random (a, b, c, d, e) where + randomR ((al, bl, cl, dl, el), (ah, bh, ch, dh, eh)) = runState $ + (,,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + <*> state (randomR (el, eh)) + {-# INLINE randomR #-} + random = runState $ + (,,,,) <$> state random <*> state random <*> state random <*> state random <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@ and @f@ types independently +instance (Random a, Random b, Random c, Random d, Random e, Random f) => + Random (a, b, c, d, e, f) where + randomR ((al, bl, cl, dl, el, fl), (ah, bh, ch, dh, eh, fh)) = runState $ + (,,,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + <*> state (randomR (el, eh)) + <*> state (randomR (fl, fh)) + {-# INLINE randomR #-} + random = runState $ + (,,,,,) <$> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random + {-# INLINE random #-} + +-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@, @f@ and @g@ types independently +instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) => + Random (a, b, c, d, e, f, g) where + randomR ((al, bl, cl, dl, el, fl, gl), (ah, bh, ch, dh, eh, fh, gh)) = runState $ + (,,,,,,) <$> state (randomR (al, ah)) + <*> state (randomR (bl, bh)) + <*> state (randomR (cl, ch)) + <*> state (randomR (dl, dh)) + <*> state (randomR (el, eh)) + <*> state (randomR (fl, fh)) + <*> state (randomR (gl, gh)) + {-# INLINE randomR #-} + random = runState $ + (,,,,,,) <$> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random + {-# INLINE random #-} + ------------------------------------------------------------------------------- -- Global pseudo-random number generator ------------------------------------------------------------------------------- @@ -310,53 +458,117 @@ -- $globalstdgen -- -- There is a single, implicit, global pseudo-random number generator of type --- 'StdGen', held in a global variable maintained by the 'IO' monad. It is --- initialised automatically in some system-dependent fashion. To get --- deterministic behaviour, use 'setStdGen'. +-- 'StdGen', held in a global mutable variable that can be manipulated from +-- within the 'IO' monad. It is also available as +-- 'System.Random.Stateful.globalStdGen', therefore it is recommended to use the +-- new "System.Random.Stateful" interface to explicitly operate on the global +-- pseudo-random number generator. -- --- Note that 'mkStdGen' also gives deterministic behaviour without requiring an --- 'IO' context. +-- It is initialised with 'initStdGen', although it is possible to override its +-- value with 'setStdGen'. All operations on the global pseudo-random number +-- generator are thread safe, however in presence of concurrency they are +-- naturally become non-deterministic. Moreover, relying on the global mutable +-- state makes it hard to know which of the dependent libraries are using it as +-- well, making it unpredictable in the local context. Precisely of this reason, +-- the global pseudo-random number generator is only suitable for uses in +-- applications, test suites, etc. and is advised against in development of +-- reusable libraries. +-- +-- It is also important to note that either using 'StdGen' with pure functions +-- from other sections of this module or by relying on +-- 'System.Random.Stateful.runStateGen' from stateful interface does not only +-- give us deterministic behaviour without requiring 'IO', but it is also more +-- efficient. --- |Sets the global pseudo-random number generator. + +-- | Sets the global pseudo-random number generator. Overwrites the contents of +-- 'System.Random.Stateful.globalStdGen' +-- +-- @since 1.0.0 setStdGen :: MonadIO m => StdGen -> m () setStdGen = liftIO . writeIORef theStdGen --- |Gets the global pseudo-random number generator. +-- | Gets the global pseudo-random number generator. Extracts the contents of +-- 'System.Random.Stateful.globalStdGen' +-- +-- @since 1.0.0 getStdGen :: MonadIO m => m StdGen getStdGen = liftIO $ readIORef theStdGen -theStdGen :: IORef StdGen -theStdGen = unsafePerformIO $ SM.initSMGen >>= newIORef . StdGen -{-# NOINLINE theStdGen #-} - --- |Applies 'split' to the current global pseudo-random generator, --- updates it with one of the results, and returns the other. +-- | Applies 'split' to the current global pseudo-random generator +-- 'System.Random.Stateful.globalStdGen', updates it with one of the results, +-- and returns the other. +-- +-- @since 1.0.0 newStdGen :: MonadIO m => m StdGen newStdGen = liftIO $ atomicModifyIORef' theStdGen split -{- |Uses the supplied function to get a value from the current global -random generator, and updates the global generator with the new generator -returned by the function. For example, @rollDice@ gets a pseudo-random integer -between 1 and 6: - -> rollDice :: IO Int -> rollDice = getStdRandom (randomR (1,6)) - --} +-- | Uses the supplied function to get a value from the current global +-- random generator, and updates the global generator with the new generator +-- returned by the function. For example, @rollDice@ produces a pseudo-random integer +-- between 1 and 6: +-- +-- >>> rollDice = getStdRandom (randomR (1, 6)) +-- >>> replicateM 10 (rollDice :: IO Int) +-- [5,6,6,1,1,6,4,2,4,1] +-- +-- This is an outdated function and it is recommended to switch to its +-- equivalent 'System.Random.Stateful.applyAtomicGen' instead, possibly with the +-- 'System.Random.Stateful.globalStdGen' if relying on the global state is +-- acceptable. +-- +-- >>> import System.Random.Stateful +-- >>> rollDice = applyAtomicGen (uniformR (1, 6)) globalStdGen +-- >>> replicateM 10 (rollDice :: IO Int) +-- [4,6,1,1,4,4,3,2,1,2] +-- +-- @since 1.0.0 getStdRandom :: MonadIO m => (StdGen -> (a, StdGen)) -> m a getStdRandom f = liftIO $ atomicModifyIORef' theStdGen (swap . f) where swap (v, g) = (g, v) --- | A variant of 'randomR' that uses the global pseudo-random number --- generator. +-- | A variant of 'System.Random.Stateful.randomRM' that uses the global +-- pseudo-random number generator 'System.Random.Stateful.globalStdGen' +-- +-- >>> randomRIO (2020, 2100) :: IO Int +-- 2040 +-- +-- Similar to 'randomIO', this function is equivalent to @'getStdRandom' +-- 'randomR'@ and is included in this interface for historical reasons and +-- backwards compatibility. It is recommended to use +-- 'System.Random.Stateful.uniformRM' instead, possibly with the +-- 'System.Random.Stateful.globalStdGen' if relying on the global state is +-- acceptable. +-- +-- >>> import System.Random.Stateful +-- >>> uniformRM (2020, 2100) globalStdGen :: IO Int +-- 2079 +-- +-- @since 1.0.0 randomRIO :: (Random a, MonadIO m) => (a, a) -> m a -randomRIO range = liftIO $ getStdRandom (randomR range) +randomRIO range = getStdRandom (randomR range) --- | A variant of 'random' that uses the global pseudo-random number --- generator. +-- | A variant of 'System.Random.Stateful.randomM' that uses the global +-- pseudo-random number generator 'System.Random.Stateful.globalStdGen'. +-- +-- >>> import Data.Int +-- >>> randomIO :: IO Int32 +-- -1580093805 +-- +-- This function is equivalent to @'getStdRandom' 'random'@ and is included in +-- this interface for historical reasons and backwards compatibility. It is +-- recommended to use 'System.Random.Stateful.uniformM' instead, possibly with +-- the 'System.Random.Stateful.globalStdGen' if relying on the global state is +-- acceptable. +-- +-- >>> import System.Random.Stateful +-- >>> uniformM globalStdGen :: IO Int32 +-- -1649127057 +-- +-- @since 1.0.0 randomIO :: (Random a, MonadIO m) => m a -randomIO = liftIO $ getStdRandom random +randomIO = getStdRandom random ------------------------------------------------------------------------------- -- Notes diff --git a/src/System/Random/GFinite.hs b/src/System/Random/GFinite.hs new file mode 100644 --- /dev/null +++ b/src/System/Random/GFinite.hs @@ -0,0 +1,282 @@ +-- | +-- Module : System.Random.GFinite +-- Copyright : (c) Andrew Lelechenko 2020 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- Maintainer : libraries@haskell.org +-- + +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module System.Random.GFinite + ( Cardinality(..) + , Finite(..) + , GFinite(..) + ) where + +import Data.Bits +import Data.Int +import Data.Void +import Data.Word +import GHC.Exts (Proxy#, proxy#) +import GHC.Generics + +-- | Cardinality of a set. +data Cardinality + = Shift !Int -- ^ Shift n is equivalent to Card (bit n) + | Card !Integer + deriving (Eq, Ord, Show) + +-- | This is needed only as a superclass of 'Integral'. +instance Enum Cardinality where + toEnum = fromIntegral + fromEnum = fromIntegral + succ = (+ 1) + pred = subtract 1 + enumFrom x = map fromInteger (enumFrom (toInteger x)) + enumFromThen x y = map fromInteger (enumFromThen (toInteger x) (toInteger y)) + enumFromTo x y = map fromInteger (enumFromTo (toInteger x) (toInteger y)) + enumFromThenTo x y z = map fromInteger (enumFromThenTo (toInteger x) (toInteger y) (toInteger z)) + +instance Num Cardinality where + fromInteger 1 = Shift 0 -- () + fromInteger 2 = Shift 1 -- Bool + fromInteger n = Card n + {-# INLINE fromInteger #-} + + x + y = fromInteger (toInteger x + toInteger y) + {-# INLINE (+) #-} + + Shift x * Shift y = Shift (x + y) + Shift x * Card y = Card (y `shiftL` x) + Card x * Shift y = Card (x `shiftL` y) + Card x * Card y = Card (x * y) + {-# INLINE (*) #-} + + abs = Card . abs . toInteger + signum = Card . signum . toInteger + negate = Card . negate . toInteger + +-- | This is needed only as a superclass of 'Integral'. +instance Real Cardinality where + toRational = fromIntegral + +instance Integral Cardinality where + toInteger = \case + Shift n -> bit n + Card n -> n + {-# INLINE toInteger #-} + + quotRem x' = \case + Shift n -> (Card (x `shiftR` n), Card (x .&. (bit n - 1))) + Card n -> let (q, r) = x `quotRem` n in (Card q, Card r) + where + x = toInteger x' + {-# INLINE quotRem #-} + +-- | A type class for data with a finite number of inhabitants. +-- This type class is used +-- in default implementations of 'System.Random.Stateful.Uniform'. +-- +-- Users are not supposed to write instances of 'Finite' manually. +-- There is a default implementation in terms of 'Generic' instead. +-- +-- >>> :set -XDeriveGeneric -XDeriveAnyClass +-- >>> import GHC.Generics (Generic) +-- >>> data MyBool = MyTrue | MyFalse deriving (Generic, Finite) +-- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Generic, Finite) +-- +class Finite a where + cardinality :: Proxy# a -> Cardinality + toFinite :: Integer -> a + fromFinite :: a -> Integer + + default cardinality :: (Generic a, GFinite (Rep a)) => Proxy# a -> Cardinality + cardinality _ = gcardinality (proxy# :: Proxy# (Rep a)) + {-# INLINE cardinality #-} + + default toFinite :: (Generic a, GFinite (Rep a)) => Integer -> a + toFinite = to . toGFinite + {-# INLINE toFinite #-} + + default fromFinite :: (Generic a, GFinite (Rep a)) => a -> Integer + fromFinite = fromGFinite . from + {-# INLINE fromFinite #-} + +class GFinite f where + gcardinality :: Proxy# f -> Cardinality + toGFinite :: Integer -> f a + fromGFinite :: f a -> Integer + +instance GFinite V1 where + gcardinality _ = 0 + {-# INLINE gcardinality #-} + toGFinite = const $ error "GFinite: V1 has no inhabitants" + {-# INLINE toGFinite #-} + fromGFinite = const $ error "GFinite: V1 has no inhabitants" + {-# INLINE fromGFinite #-} + +instance GFinite U1 where + gcardinality _ = 1 + {-# INLINE gcardinality #-} + toGFinite = const U1 + {-# INLINE toGFinite #-} + fromGFinite = const 0 + {-# INLINE fromGFinite #-} + +instance Finite a => GFinite (K1 _x a) where + gcardinality _ = cardinality (proxy# :: Proxy# a) + {-# INLINE gcardinality #-} + toGFinite = K1 . toFinite + {-# INLINE toGFinite #-} + fromGFinite = fromFinite . unK1 + {-# INLINE fromGFinite #-} + +instance GFinite a => GFinite (M1 _x _y a) where + gcardinality _ = gcardinality (proxy# :: Proxy# a) + {-# INLINE gcardinality #-} + toGFinite = M1 . toGFinite + {-# INLINE toGFinite #-} + fromGFinite = fromGFinite . unM1 + {-# INLINE fromGFinite #-} + +instance (GFinite a, GFinite b) => GFinite (a :+: b) where + gcardinality _ = + gcardinality (proxy# :: Proxy# a) + gcardinality (proxy# :: Proxy# b) + {-# INLINE gcardinality #-} + + toGFinite n + | n < cardA = L1 $ toGFinite n + | otherwise = R1 $ toGFinite (n - cardA) + where + cardA = toInteger (gcardinality (proxy# :: Proxy# a)) + {-# INLINE toGFinite #-} + + fromGFinite = \case + L1 x -> fromGFinite x + R1 x -> fromGFinite x + toInteger (gcardinality (proxy# :: Proxy# a)) + {-# INLINE fromGFinite #-} + +instance (GFinite a, GFinite b) => GFinite (a :*: b) where + gcardinality _ = + gcardinality (proxy# :: Proxy# a) * gcardinality (proxy# :: Proxy# b) + {-# INLINE gcardinality #-} + + toGFinite n = toGFinite (toInteger q) :*: toGFinite (toInteger r) + where + cardB = gcardinality (proxy# :: Proxy# b) + (q, r) = Card n `quotRem` cardB + {-# INLINE toGFinite #-} + + fromGFinite (q :*: r) = + toInteger (gcardinality (proxy# :: Proxy# b) * Card (fromGFinite q)) + fromGFinite r + {-# INLINE fromGFinite #-} + +instance Finite Void +instance Finite () +instance Finite Bool +instance Finite Ordering + +instance Finite Char where + cardinality _ = Card $ toInteger (fromEnum (maxBound :: Char)) + 1 + {-# INLINE cardinality #-} + toFinite = toEnum . fromInteger + {-# INLINE toFinite #-} + fromFinite = toInteger . fromEnum + {-# INLINE fromFinite #-} + +cardinalityDef :: forall a. (Num a, FiniteBits a) => Proxy# a -> Cardinality +cardinalityDef _ = Shift (finiteBitSize (0 :: a)) + +toFiniteDef :: forall a. (Num a, FiniteBits a) => Integer -> a +toFiniteDef n + | isSigned (0 :: a) = fromInteger (n - bit (finiteBitSize (0 :: a) - 1)) + | otherwise = fromInteger n + +fromFiniteDef :: (Integral a, FiniteBits a) => a -> Integer +fromFiniteDef x + | isSigned x = toInteger x + bit (finiteBitSize x - 1) + | otherwise = toInteger x + +instance Finite Word8 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word16 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word32 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word64 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Word where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int8 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int16 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int32 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int64 where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} +instance Finite Int where + cardinality = cardinalityDef + {-# INLINE cardinality #-} + toFinite = toFiniteDef + {-# INLINE toFinite #-} + fromFinite = fromFiniteDef + {-# INLINE fromFinite #-} + +instance Finite a => Finite (Maybe a) +instance (Finite a, Finite b) => Finite (Either a b) +instance (Finite a, Finite b) => Finite (a, b) +instance (Finite a, Finite b, Finite c) => Finite (a, b, c) +instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d) +instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e) +instance (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f) => Finite (a, b, c, d, e, f) diff --git a/src/System/Random/Internal.hs b/src/System/Random/Internal.hs --- a/src/System/Random/Internal.hs +++ b/src/System/Random/Internal.hs @@ -3,13 +3,14 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UnliftedFFITypes #-} @@ -17,7 +18,6 @@ {-# LANGUAGE TypeFamilyDependencies #-} #else {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} #endif {-# OPTIONS_HADDOCK hide, not-home #-} @@ -38,6 +38,7 @@ -- ** Standard pseudo-random number generator , StdGen(..) , mkStdGen + , theStdGen -- * Monadic adapters for pure pseudo-random number generators -- ** Pure adapter @@ -49,15 +50,19 @@ , runStateGenT , runStateGenT_ , runStateGenST + , runStateGenST_ -- * Pseudo-random values of various types , Uniform(..) + , uniformViaFiniteM , UniformRange(..) , uniformByteStringM , uniformDouble01M , uniformDoublePositive01M , uniformFloat01M , uniformFloatPositive01M + , uniformEnumM + , uniformEnumRM -- * Generators for sequences of pseudo-random bytes , genShortByteStringIO @@ -66,24 +71,27 @@ import Control.Arrow import Control.DeepSeq (NFData) -import Control.Monad.IO.Class +import Control.Monad (when) +import Control.Monad.Cont (ContT, runContT) +import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.ST import Control.Monad.ST.Unsafe -import Control.Monad.State.Strict +import Control.Monad.State.Strict (MonadState(..), State, StateT(..), runState) +import Control.Monad.Trans (lift) import Data.Bits -import Data.ByteString.Builder.Prim (word64LE) -import Data.ByteString.Builder.Prim.Internal (runF) import Data.ByteString.Short.Internal (ShortByteString(SBS), fromShort) +import Data.IORef (IORef, newIORef) import Data.Int import Data.Word import Foreign.C.Types -import Foreign.Ptr (plusPtr) -import Foreign.Storable (Storable(pokeByteOff)) +import Foreign.Storable (Storable) import GHC.Exts +import GHC.Generics import GHC.IO (IO(..)) import GHC.Word import Numeric.Natural (Natural) import System.IO.Unsafe (unsafePerformIO) +import System.Random.GFinite (Cardinality(..), GFinite(..)) import qualified System.Random.SplitMix as SM import qualified System.Random.SplitMix32 as SM32 #if __GLASGOW_HASKELL__ >= 800 @@ -96,9 +104,15 @@ import Data.ByteString (ByteString) #endif +-- Needed for WORDS_BIGENDIAN +#include "MachDeps.h" + + -- | 'RandomGen' is an interface to pure pseudo-random number generators. -- -- 'StdGen' is the standard 'RandomGen' instance provided by this library. +-- +-- @since 1.0.0 {-# DEPRECATED next "No longer used" #-} {-# DEPRECATED genRange "No longer used" #-} class RandomGen g where @@ -108,6 +122,8 @@ -- is inefficient as all operations go via 'Integer'. See -- [here](https://alexey.kuleshevi.ch/blog/2019/12/21/random-benchmarks) for -- more details. It is thus deprecated. + -- + -- @since 1.0.0 next :: g -> (Int, g) next g = runStateGen g (uniformRM (genRange g)) @@ -117,6 +133,7 @@ -- @since 1.2.0 genWord8 :: g -> (Word8, g) genWord8 = first fromIntegral . genWord32 + {-# INLINE genWord8 #-} -- | Returns a 'Word16' that is uniformly distributed over the entire 'Word16' -- range. @@ -124,6 +141,7 @@ -- @since 1.2.0 genWord16 :: g -> (Word16, g) genWord16 = first fromIntegral . genWord32 + {-# INLINE genWord16 #-} -- | Returns a 'Word32' that is uniformly distributed over the entire 'Word32' -- range. @@ -133,6 +151,7 @@ genWord32 = randomIvalIntegral (minBound, maxBound) -- Once `next` is removed, this implementation should be used instead: -- first fromIntegral . genWord64 + {-# INLINE genWord32 #-} -- | Returns a 'Word64' that is uniformly distributed over the entire 'Word64' -- range. @@ -145,6 +164,7 @@ case genWord32 g' of (h32, g'') -> ((fromIntegral h32 `shiftL` 32) .|. fromIntegral l32, g'') + {-# INLINE genWord64 #-} -- | @genWord32R upperBound g@ returns a 'Word32' that is uniformly -- distributed over the range @[0, upperBound]@. @@ -152,6 +172,7 @@ -- @since 1.2.0 genWord32R :: Word32 -> g -> (Word32, g) genWord32R m g = runStateGen g (unbiasedWordMult32 m) + {-# INLINE genWord32R #-} -- | @genWord64R upperBound g@ returns a 'Word64' that is uniformly -- distributed over the range @[0, upperBound]@. @@ -159,6 +180,7 @@ -- @since 1.2.0 genWord64R :: Word64 -> g -> (Word64, g) genWord64R m g = runStateGen g (unsignedBitmaskWithRejectionM uniformWord64 m) + {-# INLINE genWord64R #-} -- | @genShortByteString n g@ returns a 'ShortByteString' of length @n@ -- filled with pseudo-random bytes. @@ -178,6 +200,8 @@ -- determined only by the instance of 'RandomGen'. -- -- The default definition spans the full range of 'Int'. + -- + -- @since 1.0.0 genRange :: g -> (Int, Int) genRange _ = (minBound, maxBound) @@ -187,10 +211,14 @@ -- are not correlated. Some pseudo-random number generators are not -- splittable. In that case, the 'split' implementation should fail with a -- descriptive 'error' message. + -- + -- @since 1.0.0 split :: g -> (g, g) -- | 'StatefulGen' is an interface to monadic pseudo-random number generators. +-- +-- @since 1.2.0 class Monad m => StatefulGen g m where {-# MINIMAL (uniformWord32|uniformWord64) #-} -- | @uniformWord32R upperBound g@ generates a 'Word32' that is uniformly @@ -199,6 +227,7 @@ -- @since 1.2.0 uniformWord32R :: Word32 -> g -> m Word32 uniformWord32R = unsignedBitmaskWithRejectionM uniformWord32 + {-# INLINE uniformWord32R #-} -- | @uniformWord64R upperBound g@ generates a 'Word64' that is uniformly -- distributed over the range @[0, upperBound]@. @@ -206,6 +235,7 @@ -- @since 1.2.0 uniformWord64R :: Word64 -> g -> m Word64 uniformWord64R = unsignedBitmaskWithRejectionM uniformWord64 + {-# INLINE uniformWord64R #-} -- | Generates a 'Word8' that is uniformly distributed over the entire 'Word8' -- range. @@ -215,6 +245,7 @@ -- @since 1.2.0 uniformWord8 :: g -> m Word8 uniformWord8 = fmap fromIntegral . uniformWord32 + {-# INLINE uniformWord8 #-} -- | Generates a 'Word16' that is uniformly distributed over the entire -- 'Word16' range. @@ -224,6 +255,7 @@ -- @since 1.2.0 uniformWord16 :: g -> m Word16 uniformWord16 = fmap fromIntegral . uniformWord32 + {-# INLINE uniformWord16 #-} -- | Generates a 'Word32' that is uniformly distributed over the entire -- 'Word32' range. @@ -233,6 +265,7 @@ -- @since 1.2.0 uniformWord32 :: g -> m Word32 uniformWord32 = fmap fromIntegral . uniformWord64 + {-# INLINE uniformWord32 #-} -- | Generates a 'Word64' that is uniformly distributed over the entire -- 'Word64' range. @@ -246,6 +279,7 @@ l32 <- uniformWord32 g h32 <- uniformWord32 g pure (shiftL (fromIntegral h32) 32 .|. fromIntegral l32) + {-# INLINE uniformWord64 #-} -- | @uniformShortByteString n g@ generates a 'ShortByteString' of length @n@ -- filled with pseudo-random bytes. @@ -282,7 +316,7 @@ thawGen :: f -> m (MutableGen f m) -data MBA s = MBA (MutableByteArray# s) +data MBA = MBA (MutableByteArray# RealWorld) -- | Efficiently generates a sequence of pseudo-random bytes in a platform @@ -297,52 +331,79 @@ genShortByteStringIO n0 gen64 = do let !n@(I# n#) = max 0 n0 !n64 = n `quot` 8 - !nrem64 = n `rem` 8 - MBA mba# <- - liftIO $ - IO $ \s# -> - case newPinnedByteArray# n# s# of + !nrem = n `rem` 8 + mba@(MBA mba#) <- + liftIO $ IO $ \s# -> + case newByteArray# n# s# of (# s'#, mba# #) -> (# s'#, MBA mba# #) - let go i ptr - | i < n64 = do + let go i = + when (i < n64) $ do w64 <- gen64 -- Writing 8 bytes at a time in a Little-endian order gives us -- platform portability - liftIO $ runF word64LE w64 ptr - go (i + 1) (ptr `plusPtr` 8) - | otherwise = return ptr - ptr <- go 0 (Ptr (byteArrayContents# (unsafeCoerce# mba#))) - when (nrem64 > 0) $ do + liftIO $ writeWord64LE mba i w64 + go (i + 1) + go 0 + when (nrem > 0) $ do w64 <- gen64 - -- In order to not mess up the byte order we write generated Word64 into a - -- temporary pointer and then copy only the missing bytes over to the array. - -- It is tempting to simply generate as many bytes as we still need using - -- smaller generators (eg. uniformWord8), but that would result in - -- inconsistent tail when total length is slightly varied. - liftIO $ do - let goRem64 z i = - when (i < nrem64) $ do - pokeByteOff ptr i (fromIntegral z :: Word8) - goRem64 (z `shiftR` 8) (i + 1) - goRem64 w64 0 - liftIO $ - IO $ \s# -> - case unsafeFreezeByteArray# mba# s# of - (# s'#, ba# #) -> (# s'#, SBS ba# #) + -- In order to not mess up the byte order we write 1 byte at a time in + -- Little endian order. It is tempting to simply generate as many bytes as we + -- still need using smaller generators (eg. uniformWord8), but that would + -- result in inconsistent tail when total length is slightly varied. + liftIO $ writeByteSliceWord64LE mba (n - nrem) n w64 + liftIO $ IO $ \s# -> + case unsafeFreezeByteArray# mba# s# of + (# s'#, ba# #) -> (# s'#, SBS ba# #) {-# INLINE genShortByteStringIO #-} +-- Architecture independent helpers: +io_ :: (State# RealWorld -> State# RealWorld) -> IO () +io_ m# = IO $ \s# -> (# m# s#, () #) +{-# INLINE io_ #-} + +writeWord8 :: MBA -> Int -> Word8 -> IO () +writeWord8 (MBA mba#) (I# i#) (W8# w#) = io_ (writeWord8Array# mba# i# w#) +{-# INLINE writeWord8 #-} + +writeByteSliceWord64LE :: MBA -> Int -> Int -> Word64 -> IO () +writeByteSliceWord64LE mba fromByteIx toByteIx = go fromByteIx + where + go !i !z = + when (i < toByteIx) $ do + writeWord8 mba i (fromIntegral z :: Word8) + go (i + 1) (z `shiftR` 8) +{-# INLINE writeByteSliceWord64LE #-} + +writeWord64LE :: MBA -> Int -> Word64 -> IO () +#ifdef WORDS_BIGENDIAN +writeWord64LE mba i w64 = do + let !i8 = i * 8 + writeByteSliceWord64LE mba i8 (i8 + 8) w64 +#else +writeWord64LE (MBA mba#) (I# i#) w64@(W64# w64#) + | wordSizeInBits == 64 = io_ (writeWord64Array# mba# i# w64#) + | otherwise = do + let !i32# = i# *# 2# + !(W32# w32l#) = fromIntegral w64 + !(W32# w32u#) = fromIntegral (w64 `shiftR` 32) + io_ (writeWord32Array# mba# i32# w32l#) + io_ (writeWord32Array# mba# (i32# +# 1#) w32u#) +#endif +{-# INLINE writeWord64LE #-} + + -- | Same as 'genShortByteStringIO', but runs in 'ST'. -- -- @since 1.2.0 genShortByteStringST :: Int -> ST s Word64 -> ST s ShortByteString genShortByteStringST n action = unsafeIOToST (genShortByteStringIO n (unsafeSTToIO action)) +{-# INLINE genShortByteStringST #-} -- | Generates a pseudo-random 'ByteString' of the specified size. -- -- @since 1.2.0 -{-# INLINE uniformByteStringM #-} uniformByteStringM :: StatefulGen g m => Int -> g -> m ByteString uniformByteStringM n g = do ba <- uniformShortByteString n g @@ -354,6 +415,7 @@ if isTrue# (isByteArrayPinned# ba#) then pinnedByteArrayToByteString ba# else fromShort ba +{-# INLINE uniformByteStringM #-} pinnedByteArrayToByteString :: ByteArray# -> ByteString pinnedByteArrayToByteString ba# = @@ -382,12 +444,19 @@ instance (RandomGen g, MonadState g m) => StatefulGen (StateGenM g) m where uniformWord32R r _ = state (genWord32R r) + {-# INLINE uniformWord32R #-} uniformWord64R r _ = state (genWord64R r) + {-# INLINE uniformWord64R #-} uniformWord8 _ = state genWord8 + {-# INLINE uniformWord8 #-} uniformWord16 _ = state genWord16 + {-# INLINE uniformWord16 #-} uniformWord32 _ = state genWord32 + {-# INLINE uniformWord32 #-} uniformWord64 _ = state genWord64 + {-# INLINE uniformWord64 #-} uniformShortByteString n _ = state (genShortByteString n) + {-# INLINE uniformShortByteString #-} instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m where type MutableGen (StateGen g) m = StateGenM g @@ -400,6 +469,7 @@ -- @since 1.2.0 splitGen :: (MonadState g m, RandomGen g) => m g splitGen = state split +{-# INLINE splitGen #-} -- | Runs a monadic generating action in the `State` monad using a pure -- pseudo-random number generator. @@ -414,6 +484,7 @@ -- @since 1.2.0 runStateGen :: RandomGen g => g -> (StateGenM g -> State g a) -> (a, g) runStateGen g f = runState (f StateGenM) g +{-# INLINE runStateGen #-} -- | Runs a monadic generating action in the `State` monad using a pure -- pseudo-random number generator. Returns only the resulting pseudo-random @@ -423,12 +494,13 @@ -- -- >>> import System.Random.Stateful -- >>> let pureGen = mkStdGen 137 --- >>> runStateGen_ pureGen randomM :: Int +-- >>> runStateGen_ pureGen randomM :: Int -- 7879794327570578227 -- -- @since 1.2.0 runStateGen_ :: RandomGen g => g -> (StateGenM g -> State g a) -> a runStateGen_ g = fst . runStateGen g +{-# INLINE runStateGen_ #-} -- | Runs a monadic generating action in the `StateT` monad using a pure -- pseudo-random number generator. @@ -443,6 +515,7 @@ -- @since 1.2.0 runStateGenT :: RandomGen g => g -> (StateGenM g -> StateT g m a) -> m (a, g) runStateGenT g f = runStateT (f StateGenM) g +{-# INLINE runStateGenT #-} -- | Runs a monadic generating action in the `StateT` monad using a pure -- pseudo-random number generator. Returns only the resulting pseudo-random @@ -455,9 +528,10 @@ -- >>> 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_ #-} -- | Runs a monadic generating action in the `ST` monad using a pure -- pseudo-random number generator. @@ -467,7 +541,16 @@ runStateGenST g action = runST $ runStateGenT g action {-# INLINE runStateGenST #-} +-- | Runs a monadic generating action in the `ST` monad using a pure +-- pseudo-random number generator. Same as `runStateGenST`, but discards the +-- resulting generator. +-- +-- @since 1.2.1 +runStateGenST_ :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> a +runStateGenST_ g action = runST $ runStateGenT_ g action +{-# INLINE runStateGenST_ #-} + -- | The standard pseudo-random number generator. newtype StdGen = StdGen { unStdGen :: SM.SMGen } deriving (Show, RandomGen, NFData) @@ -477,20 +560,34 @@ instance RandomGen SM.SMGen where next = SM.nextInt + {-# INLINE next #-} genWord32 = SM.nextWord32 + {-# INLINE genWord32 #-} genWord64 = SM.nextWord64 + {-# INLINE genWord64 #-} split = SM.splitSMGen + {-# INLINE split #-} instance RandomGen SM32.SMGen where next = SM32.nextInt + {-# INLINE next #-} genWord32 = SM32.nextWord32 + {-# INLINE genWord32 #-} genWord64 = SM32.nextWord64 + {-# INLINE genWord64 #-} split = SM32.splitSMGen + {-# INLINE split #-} -- | Constructs a 'StdGen' deterministically. mkStdGen :: Int -> StdGen mkStdGen = StdGen . SM.mkSMGen . fromIntegral +-- | Global mutable veriable with `StdGen` +theStdGen :: IORef StdGen +theStdGen = unsafePerformIO $ SM.initSMGen >>= newIORef . StdGen +{-# NOINLINE theStdGen #-} + + -- | The class of types for which a uniformly distributed value can be drawn -- from all possible values of the type. -- @@ -499,9 +596,80 @@ -- | Generates a value uniformly distributed over all possible values of that -- type. -- + -- There is a default implementation via 'Generic': + -- + -- >>> :set -XDeriveGeneric -XDeriveAnyClass + -- >>> import GHC.Generics (Generic) + -- >>> import System.Random.Stateful + -- >>> data MyBool = MyTrue | MyFalse deriving (Show, Generic, Finite, Uniform) + -- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Show, Generic, Finite, Uniform) + -- >>> gen <- newIOGenM (mkStdGen 42) + -- >>> uniformListM 10 gen :: IO [Action] + -- [Code MyTrue,Code MyTrue,Eat Nothing,Code MyFalse,Eat (Just False),Eat (Just True),Eat Nothing,Eat (Just False),Sleep,Code MyFalse] + -- -- @since 1.2.0 uniformM :: StatefulGen g m => g -> m a + default uniformM :: (StatefulGen g m, Generic a, GUniform (Rep a)) => g -> m a + uniformM = fmap to . (`runContT` pure) . guniformM + {-# INLINE uniformM #-} + +-- | Default implementation of 'Uniform' type class for 'Generic' data. +-- It's important to use 'ContT', because without it 'fmap' and '>>=' remain +-- polymorphic too long and GHC fails to inline or specialize it, ending up +-- building full 'Rep' a structure in memory. 'ContT' +-- makes 'fmap' and '>>=' used in 'guniformM' monomorphic, so GHC is able to +-- specialize 'Generic' instance reasonably close to a handwritten one. +class GUniform f where + guniformM :: StatefulGen g m => g -> ContT r m (f a) + +instance GUniform f => GUniform (M1 i c f) where + guniformM = fmap M1 . guniformM + {-# INLINE guniformM #-} + +instance Uniform a => GUniform (K1 i a) where + guniformM = fmap K1 . lift . uniformM + {-# INLINE guniformM #-} + +instance GUniform U1 where + guniformM = const $ return U1 + {-# INLINE guniformM #-} + +instance (GUniform f, GUniform g) => GUniform (f :*: g) where + guniformM g = (:*:) <$> guniformM g <*> guniformM g + {-# INLINE guniformM #-} + +instance (GFinite f, GFinite g) => GUniform (f :+: g) where + guniformM = lift . finiteUniformM + {-# INLINE guniformM #-} + +finiteUniformM :: forall g m f a. (StatefulGen g m, GFinite f) => g -> m (f a) +finiteUniformM = fmap toGFinite . case gcardinality (proxy# :: Proxy# f) of + Shift n + | n <= 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (bit n - 1) + | otherwise -> boundedByPowerOf2ExclusiveIntegralM n + Card n + | n <= bit 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (fromInteger n - 1) + | otherwise -> boundedExclusiveIntegralM n +{-# INLINE finiteUniformM #-} + +-- | A definition of 'Uniform' for 'System.Random.Finite' types. +-- If your data has several fields of sub-'Word' cardinality, +-- this instance may be more efficient than one, derived via 'Generic' and 'GUniform'. +-- +-- >>> :set -XDeriveGeneric -XDeriveAnyClass +-- >>> import GHC.Generics (Generic) +-- >>> import System.Random.Stateful +-- >>> data Triple = Triple Word8 Word8 Word8 deriving (Show, Generic, Finite) +-- >>> instance Uniform Triple where uniformM = uniformViaFiniteM +-- >>> gen <- newIOGenM (mkStdGen 42) +-- >>> uniformListM 5 gen :: IO [Triple] +-- [Triple 60 226 48,Triple 234 194 151,Triple 112 96 95,Triple 51 251 15,Triple 6 0 208] +-- +uniformViaFiniteM :: (StatefulGen g m, Generic a, GFinite (Rep a)) => g -> m a +uniformViaFiniteM = fmap to . finiteUniformM +{-# INLINE uniformViaFiniteM #-} + -- | The class of types for which a uniformly distributed value can be drawn -- from a range. -- @@ -525,29 +693,36 @@ instance UniformRange Integer where uniformRM = uniformIntegralM + {-# INLINE uniformRM #-} instance UniformRange Natural where uniformRM = uniformIntegralM + {-# INLINE uniformRM #-} instance Uniform Int8 where uniformM = fmap (fromIntegral :: Word8 -> Int8) . uniformWord8 + {-# INLINE uniformM #-} instance UniformRange Int8 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral + {-# INLINE uniformRM #-} instance Uniform Int16 where uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16 + {-# INLINE uniformM #-} instance UniformRange Int16 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral {-# INLINE uniformRM #-} instance Uniform Int32 where uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32 + {-# INLINE uniformM #-} instance UniformRange Int32 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral {-# INLINE uniformRM #-} instance Uniform Int64 where uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64 + {-# INLINE uniformM #-} instance UniformRange Int64 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int64 -> Word64) fromIntegral {-# INLINE uniformRM #-} @@ -561,6 +736,7 @@ fmap (fromIntegral :: Word64 -> Int) . uniformWord64 | otherwise = fmap (fromIntegral :: Word32 -> Int) . uniformWord32 + {-# INLINE uniformM #-} instance UniformRange Int where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int -> Word) fromIntegral @@ -572,42 +748,44 @@ fmap (fromIntegral :: Word64 -> Word) . uniformWord64 | otherwise = fmap (fromIntegral :: Word32 -> Word) . uniformWord32 + {-# INLINE uniformM #-} instance UniformRange Word where - {-# INLINE uniformRM #-} uniformRM = unsignedBitmaskWithRejectionRM + {-# INLINE uniformRM #-} instance Uniform Word8 where - {-# INLINE uniformM #-} uniformM = uniformWord8 + {-# INLINE uniformM #-} instance UniformRange Word8 where - {-# INLINE uniformRM #-} uniformRM = unbiasedWordMult32RM + {-# INLINE uniformRM #-} instance Uniform Word16 where - {-# INLINE uniformM #-} uniformM = uniformWord16 + {-# INLINE uniformM #-} instance UniformRange Word16 where - {-# INLINE uniformRM #-} uniformRM = unbiasedWordMult32RM + {-# INLINE uniformRM #-} instance Uniform Word32 where - {-# INLINE uniformM #-} uniformM = uniformWord32 + {-# INLINE uniformM #-} instance UniformRange Word32 where - {-# INLINE uniformRM #-} uniformRM = unbiasedWordMult32RM + {-# INLINE uniformRM #-} instance Uniform Word64 where - {-# INLINE uniformM #-} uniformM = uniformWord64 + {-# INLINE uniformM #-} instance UniformRange Word64 where - {-# INLINE uniformRM #-} uniformRM = unsignedBitmaskWithRejectionRM + {-# INLINE uniformRM #-} #if __GLASGOW_HASKELL__ >= 802 instance Uniform CBool where uniformM = fmap CBool . uniformM + {-# INLINE uniformM #-} instance UniformRange CBool where uniformRM (CBool b, CBool t) = fmap CBool . uniformRM (b, t) {-# INLINE uniformRM #-} @@ -615,114 +793,133 @@ instance Uniform CChar where uniformM = fmap CChar . uniformM + {-# INLINE uniformM #-} instance UniformRange CChar where uniformRM (CChar b, CChar t) = fmap CChar . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CSChar where uniformM = fmap CSChar . uniformM + {-# INLINE uniformM #-} instance UniformRange CSChar where uniformRM (CSChar b, CSChar t) = fmap CSChar . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CUChar where uniformM = fmap CUChar . uniformM + {-# INLINE uniformM #-} instance UniformRange CUChar where uniformRM (CUChar b, CUChar t) = fmap CUChar . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CShort where uniformM = fmap CShort . uniformM + {-# INLINE uniformM #-} instance UniformRange CShort where uniformRM (CShort b, CShort t) = fmap CShort . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CUShort where uniformM = fmap CUShort . uniformM + {-# INLINE uniformM #-} instance UniformRange CUShort where uniformRM (CUShort b, CUShort t) = fmap CUShort . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CInt where uniformM = fmap CInt . uniformM + {-# INLINE uniformM #-} instance UniformRange CInt where uniformRM (CInt b, CInt t) = fmap CInt . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CUInt where uniformM = fmap CUInt . uniformM + {-# INLINE uniformM #-} instance UniformRange CUInt where uniformRM (CUInt b, CUInt t) = fmap CUInt . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CLong where uniformM = fmap CLong . uniformM + {-# INLINE uniformM #-} instance UniformRange CLong where uniformRM (CLong b, CLong t) = fmap CLong . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CULong where uniformM = fmap CULong . uniformM + {-# INLINE uniformM #-} instance UniformRange CULong where uniformRM (CULong b, CULong t) = fmap CULong . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CPtrdiff where uniformM = fmap CPtrdiff . uniformM + {-# INLINE uniformM #-} instance UniformRange CPtrdiff where uniformRM (CPtrdiff b, CPtrdiff t) = fmap CPtrdiff . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CSize where uniformM = fmap CSize . uniformM + {-# INLINE uniformM #-} instance UniformRange CSize where uniformRM (CSize b, CSize t) = fmap CSize . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CWchar where uniformM = fmap CWchar . uniformM + {-# INLINE uniformM #-} instance UniformRange CWchar where uniformRM (CWchar b, CWchar t) = fmap CWchar . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CSigAtomic where uniformM = fmap CSigAtomic . uniformM + {-# INLINE uniformM #-} instance UniformRange CSigAtomic where uniformRM (CSigAtomic b, CSigAtomic t) = fmap CSigAtomic . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CLLong where uniformM = fmap CLLong . uniformM + {-# INLINE uniformM #-} instance UniformRange CLLong where uniformRM (CLLong b, CLLong t) = fmap CLLong . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CULLong where uniformM = fmap CULLong . uniformM + {-# INLINE uniformM #-} instance UniformRange CULLong where uniformRM (CULLong b, CULLong t) = fmap CULLong . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CIntPtr where - uniformM = fmap CIntPtr . uniformM + uniformM = fmap CIntPtr . uniformM + {-# INLINE uniformM #-} instance UniformRange CIntPtr where uniformRM (CIntPtr b, CIntPtr t) = fmap CIntPtr . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CUIntPtr where uniformM = fmap CUIntPtr . uniformM + {-# INLINE uniformM #-} instance UniformRange CUIntPtr where uniformRM (CUIntPtr b, CUIntPtr t) = fmap CUIntPtr . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CIntMax where uniformM = fmap CIntMax . uniformM + {-# INLINE uniformM #-} instance UniformRange CIntMax where uniformRM (CIntMax b, CIntMax t) = fmap CIntMax . uniformRM (b, t) {-# INLINE uniformRM #-} instance Uniform CUIntMax where uniformM = fmap CUIntMax . uniformM + {-# INLINE uniformM #-} instance UniformRange CUIntMax where uniformRM (CUIntMax b, CUIntMax t) = fmap CUIntMax . uniformRM (b, t) {-# INLINE uniformRM #-} @@ -745,11 +942,19 @@ -- `Char`, therefore it is totally fine to omit all the unnecessary checks involved in -- other paths of conversion. word32ToChar :: Word32 -> Char +#if __GLASGOW_HASKELL__ < 902 word32ToChar (W32# w#) = C# (chr# (word2Int# w#)) +#else +word32ToChar (W32# w#) = C# (chr# (word2Int# (word32ToWord# w#))) +#endif {-# INLINE word32ToChar #-} charToWord32 :: Char -> Word32 +#if __GLASGOW_HASKELL__ < 902 charToWord32 (C# c#) = W32# (int2Word# (ord# c#)) +#else +charToWord32 (C# c#) = W32# (wordToWord32# (int2Word# (ord# c#))) +#endif {-# INLINE charToWord32 #-} instance Uniform Char where @@ -760,34 +965,52 @@ word32ToChar <$> unbiasedWordMult32RM (charToWord32 l, charToWord32 h) g {-# INLINE uniformRM #-} +instance Uniform () where + uniformM = const $ pure () + {-# INLINE uniformM #-} +instance UniformRange () where + uniformRM = const $ const $ pure () + {-# INLINE uniformRM #-} + instance Uniform Bool where uniformM = fmap wordToBool . uniformWord8 where wordToBool w = (w .&. 1) /= 0 + {-# INLINE wordToBool #-} + {-# INLINE uniformM #-} instance UniformRange Bool where uniformRM (False, False) _g = return False uniformRM (True, True) _g = return True uniformRM _ g = uniformM g + {-# INLINE uniformRM #-} -- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). instance UniformRange Double where uniformRM (l, h) g | l == h = return l + | isInfinite l || isInfinite h = + -- Optimisation exploiting absorption: + -- (-Infinity) + (anything but +Infinity) = -Infinity + -- (anything but -Infinity) + (+Infinity) = +Infinity + -- (-Infinity) + (+Infinity) = NaN + return $! h + l | otherwise = do x <- uniformDouble01M g return $ x * l + (1 -x) * h + {-# INLINE uniformRM #-} -- | Generates uniformly distributed 'Double' in the range \([0, 1]\). -- Numbers are generated by generating uniform 'Word64' and dividing --- it by \(2^{64}\). It's used to implement 'UniformR' instance for +-- it by \(2^{64}\). It's used to implement 'UniformRange' instance for -- 'Double'. -- -- @since 1.2.0 -uniformDouble01M :: StatefulGen g m => g -> m Double +uniformDouble01M :: forall g m. StatefulGen g m => g -> m Double uniformDouble01M g = do w64 <- uniformWord64 g return $ fromIntegral w64 / m where m = fromIntegral (maxBound :: Word64) :: Double +{-# INLINE uniformDouble01M #-} -- | Generates uniformly distributed 'Double' in the range -- \((0, 1]\). Number is generated as \(2^{-64}/2+\operatorname{uniformDouble01M}\). @@ -795,32 +1018,41 @@ -- by 'uniformDouble01M'. -- -- @since 1.2.0 -uniformDoublePositive01M :: StatefulGen g m => g -> m Double +uniformDoublePositive01M :: forall g m. StatefulGen g m => g -> m Double uniformDoublePositive01M g = (+ d) <$> uniformDouble01M g where -- We add small constant to shift generated value from zero. It's -- selected as 1/2 of smallest possible nonzero value d = 2.710505431213761e-20 -- 2**(-65) +{-# INLINE uniformDoublePositive01M #-} -- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). instance UniformRange Float where uniformRM (l, h) g | l == h = return l + | isInfinite l || isInfinite h = + -- Optimisation exploiting absorption: + -- (-Infinity) + (anything but +Infinity) = -Infinity + -- (anything but -Infinity) + (+Infinity) = +Infinity + -- (-Infinity) + (+Infinity) = NaN + return $! h + l | otherwise = do x <- uniformFloat01M g return $ x * l + (1 - x) * h + {-# INLINE uniformRM #-} -- | Generates uniformly distributed 'Float' in the range \([0, 1]\). -- Numbers are generated by generating uniform 'Word32' and dividing --- it by \(2^{32}\). It's used to implement 'UniformR' instance for 'Float' +-- it by \(2^{32}\). It's used to implement 'UniformRange' instance for 'Float'. -- -- @since 1.2.0 -uniformFloat01M :: StatefulGen g m => g -> m Float +uniformFloat01M :: forall g m. StatefulGen g m => g -> m Float uniformFloat01M g = do w32 <- uniformWord32 g return $ fromIntegral w32 / m where m = fromIntegral (maxBound :: Word32) :: Float +{-# INLINE uniformFloat01M #-} -- | Generates uniformly distributed 'Float' in the range -- \((0, 1]\). Number is generated as \(2^{-32}/2+\operatorname{uniformFloat01M}\). @@ -828,21 +1060,46 @@ -- by 'uniformFloat01M'. -- -- @since 1.2.0 -uniformFloatPositive01M :: StatefulGen g m => g -> m Float +uniformFloatPositive01M :: forall g m. StatefulGen g m => g -> m Float uniformFloatPositive01M g = (+ d) <$> uniformFloat01M g where -- See uniformDoublePositive01M d = 1.1641532182693481e-10 -- 2**(-33) +{-# INLINE uniformFloatPositive01M #-} +-- | Generates uniformly distributed 'Enum'. +-- One can use it to define a 'Uniform' instance: +-- +-- > data Colors = Red | Green | Blue deriving (Enum, Bounded) +-- > instance Uniform Colors where uniformM = uniformEnumM +-- +-- @since 1.2.1 +uniformEnumM :: forall a g m. (Enum a, Bounded a, StatefulGen g m) => g -> m a +uniformEnumM g = toEnum <$> uniformRM (fromEnum (minBound :: a), fromEnum (maxBound :: a)) g +{-# INLINE uniformEnumM #-} + +-- | Generates uniformly distributed 'Enum' in the given range. +-- One can use it to define a 'UniformRange' instance: +-- +-- > data Colors = Red | Green | Blue deriving (Enum) +-- > instance UniformRange Colors where +-- > uniformRM = uniformEnumRM +-- > inInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x) +-- +-- @since 1.2.1 +uniformEnumRM :: forall a g m. (Enum a, StatefulGen g m) => (a, a) -> g -> m a +uniformEnumRM (l, h) g = toEnum <$> uniformRM (fromEnum l, fromEnum h) g +{-# INLINE uniformEnumRM #-} + -- The two integer functions below take an [inclusive,inclusive] range. randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) -randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) +randomIvalIntegral (l, h) = randomIvalInteger (toInteger l, toInteger h) {-# SPECIALIZE randomIvalInteger :: (Num a) => (Integer, Integer) -> StdGen -> (a, StdGen) #-} randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng +randomIvalInteger (l, h) rng | l > h = randomIvalInteger (h,l) rng | otherwise = case f 1 0 rng of (v, rng') -> (fromInteger (l + v `mod` k), rng') where @@ -867,7 +1124,7 @@ -- | Generate an integral in the range @[l, h]@ if @l <= h@ and @[h, l]@ -- otherwise. -uniformIntegralM :: (Bits a, Integral a, StatefulGen g m) => (a, a) -> g -> m a +uniformIntegralM :: forall a g m. (Bits a, Integral a, StatefulGen g m) => (a, a) -> g -> m a uniformIntegralM (l, h) gen = case l `compare` h of LT -> do let limit = h - l @@ -881,6 +1138,8 @@ GT -> uniformIntegralM (h, l) gen EQ -> pure l {-# INLINEABLE uniformIntegralM #-} +{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Integer, Integer) -> g -> m Integer #-} +{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Natural, Natural) -> g -> m Natural #-} -- | Generate an integral in the range @[0, s)@ using a variant of Lemire's -- multiplication method. @@ -913,6 +1172,15 @@ else return $ m `shiftR` k {-# INLINE boundedExclusiveIntegralM #-} +-- | boundedByPowerOf2ExclusiveIntegralM s ~ boundedExclusiveIntegralM (bit s) +boundedByPowerOf2ExclusiveIntegralM :: + forall a g m. (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a +boundedByPowerOf2ExclusiveIntegralM s gen = do + let n = (s + wordSizeInBits - 1) `quot` wordSizeInBits + x <- uniformIntegralWords n gen + return $ x .&. (bit s - 1) +{-# INLINE boundedByPowerOf2ExclusiveIntegralM #-} + -- | @integralWordSize i@ returns that least @w@ such that -- @i <= WORD_SIZE_IN_BITS^w@. integralWordSize :: (Bits a, Num a) => a -> Int @@ -925,7 +1193,7 @@ -- | @uniformIntegralWords n@ is a uniformly pseudo-random integral in the range -- @[0, WORD_SIZE_IN_BITS^n)@. -uniformIntegralWords :: (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a +uniformIntegralWords :: forall a g m. (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a uniformIntegralWords n gen = go 0 n where go !acc i @@ -938,14 +1206,14 @@ -- | Uniformly generate an 'Integral' in an inclusive-inclusive range. -- -- Only use for integrals size less than or equal to that of 'Word32'. -unbiasedWordMult32RM :: (StatefulGen g m, Integral a) => (a, a) -> g -> m a +unbiasedWordMult32RM :: forall a g m. (Integral a, StatefulGen g m) => (a, a) -> g -> m a unbiasedWordMult32RM (b, t) g | b <= t = (+b) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (t - b)) g | otherwise = (+t) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (b - t)) g -{-# SPECIALIZE unbiasedWordMult32RM :: StatefulGen g m => (Word8, Word8) -> g -> m Word8 #-} +{-# INLINE unbiasedWordMult32RM #-} -- | Uniformly generate Word32 in @[0, s]@. -unbiasedWordMult32 :: StatefulGen g m => Word32 -> g -> m Word32 +unbiasedWordMult32 :: forall g m. StatefulGen g m => Word32 -> g -> m Word32 unbiasedWordMult32 s g | s == maxBound = uniformWord32 g | otherwise = unbiasedWordMult32Exclusive (s+1) g @@ -970,10 +1238,11 @@ l :: Word32 l = fromIntegral m if l >= t then return (fromIntegral $ m `shiftR` 32) else go +{-# INLINE unbiasedWordMult32Exclusive #-} -- | This only works for unsigned integrals unsignedBitmaskWithRejectionRM :: - (StatefulGen g m, FiniteBits a, Num a, Ord a, Uniform a) + forall a g m . (FiniteBits a, Num a, Ord a, Uniform a, StatefulGen g m) => (a, a) -> g -> m a @@ -988,12 +1257,12 @@ -- overflow. It uses `unsignedBitmaskWithRejectionM`, therefore it requires functions that -- take the value to unsigned and back. signedBitmaskWithRejectionRM :: - (Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g f, Uniform a) + forall a b g m. (Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g m, Uniform a) => (b -> a) -- ^ Convert signed to unsigned. @a@ and @b@ must be of the same size. -> (a -> b) -- ^ Convert unsigned to signed. @a@ and @b@ must be of the same size. -> (b, b) -- ^ Range. -> g -- ^ Generator. - -> f b + -> m b signedBitmaskWithRejectionRM toUnsigned fromUnsigned (bottom, top) gen | bottom == top = pure top | otherwise = @@ -1010,7 +1279,7 @@ -- | Detailed explanation about the algorithm employed here can be found in this post: -- http://web.archive.org/web/20200520071940/https://www.pcg-random.org/posts/bounded-rands.html unsignedBitmaskWithRejectionM :: - forall a g m . (Ord a, FiniteBits a, Num a, StatefulGen g m) => (g -> m a) -> a -> g -> m a + forall a g m. (Ord a, FiniteBits a, Num a, StatefulGen g m) => (g -> m a) -> a -> g -> m a unsignedBitmaskWithRejectionM genUniformM range gen = go where mask :: a @@ -1029,21 +1298,42 @@ instance (Uniform a, Uniform b) => Uniform (a, b) where uniformM g = (,) <$> uniformM g <*> uniformM g + {-# INLINE uniformM #-} instance (Uniform a, Uniform b, Uniform c) => Uniform (a, b, c) where uniformM g = (,,) <$> uniformM g <*> uniformM g <*> uniformM g + {-# INLINE uniformM #-} instance (Uniform a, Uniform b, Uniform c, Uniform d) => Uniform (a, b, c, d) where uniformM g = (,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g + {-# INLINE uniformM #-} instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e) => Uniform (a, b, c, d, e) where uniformM g = (,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g + {-# INLINE uniformM #-} -instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f) => Uniform (a, b, c, d, e, f) where - uniformM g = (,,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g +instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f) => + Uniform (a, b, c, d, e, f) where + uniformM g = (,,,,,) + <$> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + {-# INLINE uniformM #-} -instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f, Uniform g) => Uniform (a, b, c, d, e, f, g) where - uniformM g = (,,,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g +instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f, Uniform g) => + Uniform (a, b, c, d, e, f, g) where + uniformM g = (,,,,,,) + <$> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + {-# INLINE uniformM #-} -- Appendix 1. -- diff --git a/src/System/Random/Stateful.hs b/src/System/Random/Stateful.hs --- a/src/System/Random/Stateful.hs +++ b/src/System/Random/Stateful.hs @@ -48,11 +48,13 @@ , runStateGenT , runStateGenT_ , runStateGenST + , runStateGenST_ -- ** Mutable adapter with atomic operations , AtomicGen(..) , AtomicGenM(..) , newAtomicGenM , applyAtomicGen + , globalStdGen -- ** Mutable adapter in 'IO' , IOGen(..) , IOGenM(..) @@ -65,11 +67,18 @@ , applySTGen , runSTGen , runSTGen_ + -- ** Mutable adapter in 'STM' + , TGen(..) + , TGenM(..) + , newTGenM + , newTGenMIO + , applyTGen -- * Pseudo-random values of various types -- $uniform , Uniform(..) , uniformListM + , uniformViaFiniteM , UniformRange(..) -- * Generators for sequences of pseudo-random bytes @@ -80,6 +89,8 @@ , uniformDoublePositive01M , uniformFloat01M , uniformFloatPositive01M + , uniformEnumM + , uniformEnumRM -- * Appendix @@ -96,6 +107,7 @@ 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 @@ -110,8 +122,8 @@ -- [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. @@ -182,7 +194,7 @@ -- $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 @@ -197,6 +209,11 @@ -- -- * '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'. -- @@ -223,8 +240,11 @@ 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 'Frozen' state. + +-- | Runs a mutable pseudo-random number generator from its 'FrozenGen' state. -- -- ====__Examples__ -- @@ -319,6 +339,18 @@ newAtomicGenM :: MonadIO m => g -> m (AtomicGenM g) newAtomicGenM = fmap AtomicGenM . liftIO . newIORef + +-- | Global mutable standard pseudo-random number generator. This is the same +-- generator that was historically used by `randomIO` and `randomRIO` functions. +-- +-- >>> replicateM 10 (uniformRM ('a', 'z') globalStdGen) +-- "tdzxhyfvgr" +-- +-- @since 1.2.1 +globalStdGen :: AtomicGenM StdGen +globalStdGen = AtomicGenM theStdGen + + instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where uniformWord32R r = applyAtomicGen (genWord32R r) {-# INLINE uniformWord32R #-} @@ -352,7 +384,7 @@ -- 7879794327570578227 -- -- @since 1.2.0 -applyAtomicGen :: MonadIO m => (g -> (a, g)) -> (AtomicGenM g) -> m a +applyAtomicGen :: MonadIO m => (g -> (a, g)) -> AtomicGenM g -> m a applyAtomicGen op (AtomicGenM gVar) = liftIO $ atomicModifyIORef' gVar $ \g -> case op g of @@ -392,6 +424,8 @@ newIOGenM :: MonadIO m => g -> m (IOGenM g) newIOGenM = fmap IOGenM . liftIO . newIORef + + instance (RandomGen g, MonadIO m) => StatefulGen (IOGenM g) m where uniformWord32R r = applyIOGen (genWord32R r) {-# INLINE uniformWord32R #-} @@ -521,6 +555,74 @@ 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 +-- >>> import Data.Int (Int32) +-- >>> let pureGen = mkStdGen 137 +-- >>> stmGen <- newTGenMIO pureGen +-- >>> atomically $ applyTGen uniform stmGen :: IO Int32 +-- 637238067 +-- +-- @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: @@ -533,7 +635,7 @@ -- Types may have instances for both or just one of 'UniformRange' and -- 'Uniform'. A few examples illustrate this: -- --- * 'Int', 'Word16' and 'Bool' are instances of both 'UniformRange' and +-- * 'Int', 'Data.Word.Word16' and 'Bool' are instances of both 'UniformRange' and -- 'Uniform'. -- * 'Integer', 'Float' and 'Double' each have an instance for 'UniformRange' -- but no 'Uniform' instance. @@ -606,6 +708,7 @@ -- NaN -- -- * If \(a\) is @-Infinity@ and \(b\) is @Infinity@, the result is @NaN@. +-- -- >>> let (a, b, x) = (-inf, inf, 0.5) in x * a + (1 - x) * b -- NaN -- @@ -699,6 +802,7 @@ -- $setup -- >>> import Control.Monad.Primitive -- >>> import qualified System.Random.MWC as MWC +-- >>> writeIORef theStdGen $ mkStdGen 2021 -- -- >>> :set -XFlexibleContexts -- >>> :set -XFlexibleInstances diff --git a/test-inspection/Spec.hs b/test-inspection/Spec.hs new file mode 100644 --- /dev/null +++ b/test-inspection/Spec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +module Main (main) where +#if __GLASGOW_HASKELL__ >= 800 + +import qualified Spec.Inspection as Inspection +import Test.Tasty + +main :: IO () +main = + defaultMain $ + testGroup + "InspectionSpec" + [ Inspection.inspectionTests + ] + +#else + +main :: IO () +main = putStrLn "\nInspection testing is not supported for pre ghc-8.0 versions\n" + +#endif + + diff --git a/test-inspection/Spec/Inspection.hs b/test-inspection/Spec/Inspection.hs new file mode 100644 --- /dev/null +++ b/test-inspection/Spec/Inspection.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-missing-signatures -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} + +module Spec.Inspection (inspectionTests) where + +import Data.Int +import Data.Void +import Data.Word +import GHC.Generics +import System.Random +import System.Random.Stateful +import Test.Tasty +import Test.Tasty.Inspection + +uniform' :: Uniform a => (a, StdGen) +uniform' = uniform (mkStdGen 42) + +uniform_Word8 = uniform' @Word8 +uniform_Int8 = uniform' @Int8 +uniform_Char = uniform' @Char + +data MyAction = Code (Maybe Bool) | Never Void | Eat (Bool, Bool) | Sleep () + deriving (Eq, Ord, Show, Generic, Finite) +instance Uniform MyAction + +uniform_MyAction = uniform' @MyAction + +uniformR' :: (Bounded a, UniformRange a) => (a, StdGen) +uniformR' = uniformR (minBound, maxBound) (mkStdGen 42) + +uniformR_Word8 = uniformR' @Word8 +uniformR_Int8 = uniformR' @Int8 +uniformR_Char = uniformR' @Char + +uniformR_Double = uniformR (0 :: Double, 1) (mkStdGen 42) + +inspectionTests :: TestTree +inspectionTests = testGroup "Inspection" $ + [ $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Word8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Int8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Char) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_MyAction) + + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Word8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Int8) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Char) + , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Double) + ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,18 +1,24 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} module Main (main) where -import Data.ByteString.Short as SBS +import Control.Monad (replicateM, forM_) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS import Data.Int import Data.Typeable +import Data.Void import Data.Word import Foreign.C.Types +import GHC.Generics import Numeric.Natural (Natural) -import System.Random +import System.Random.Stateful import Test.SmallCheck.Series as SC import Test.Tasty import Test.Tasty.HUnit @@ -20,6 +26,7 @@ import qualified Spec.Range as Range import qualified Spec.Run as Run +import qualified Spec.Stateful as Stateful main :: IO () main = @@ -42,7 +49,7 @@ , integralSpec (Proxy :: Proxy Int) , integralSpec (Proxy :: Proxy Char) , integralSpec (Proxy :: Proxy Bool) -#if __GLASGOW_HASKELL >= 802 +#if __GLASGOW_HASKELL__ >= 802 , integralSpec (Proxy :: Proxy CBool) #endif , integralSpec (Proxy :: Proxy CChar) @@ -66,11 +73,25 @@ , integralSpec (Proxy :: Proxy CUIntMax) , integralSpec (Proxy :: Proxy Integer) , integralSpec (Proxy :: Proxy Natural) + , enumSpec (Proxy :: Proxy Colors) , runSpec , floatTests , byteStringSpec , SC.testProperty "uniformRangeWithinExcludedF" $ seeded Range.uniformRangeWithinExcludedF , SC.testProperty "uniformRangeWithinExcludedD" $ seeded Range.uniformRangeWithinExcludedD + , randomSpec (Proxy :: Proxy (CFloat, CDouble)) + , randomSpec (Proxy :: Proxy (Int8, Int16, Int32)) + , randomSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64)) + , randomSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word)) + , randomSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word)) + , randomSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word)) + , uniformSpec (Proxy :: Proxy (Int, Bool)) + , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32)) + , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64)) + , 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 ] floatTests :: TestTree @@ -92,13 +113,19 @@ byteStringSpec = testGroup "ByteString" - [ SC.testProperty "genShortByteString" $ \(seed, n8) -> - let n = fromIntegral (n8 :: Word8) -- no need to generate huge collection of bytes - in SBS.length (fst (seeded (genShortByteString n) seed)) == n - , SC.testProperty "genByteString" $ \(seed, n8) -> - let n = fromIntegral (n8 :: Word8) - in SBS.toShort (fst (seeded (genByteString n) seed)) == - fst (seeded (genShortByteString n) seed) + [ SC.testProperty "genShortByteString" $ + seededWithLen $ \n g -> SBS.length (fst (genShortByteString n g)) == n + , SC.testProperty "genByteString" $ + seededWithLen $ \n g -> + SBS.toShort (fst (genByteString n g)) == fst (genShortByteString n g) + , testCase "genByteString/ShortByteString consistency" $ do + let g = mkStdGen 2021 + bs = [78,232,117,189,13,237,63,84,228,82,19,36,191,5,128,192] :: [Word8] + forM_ [0 .. length bs - 1] $ \ n -> do + xs <- SBS.unpack <$> runStateGenT_ g (uniformShortByteString n) + xs @?= take n bs + ys <- BS.unpack <$> runStateGenT_ g (uniformByteStringM n) + ys @?= xs ] @@ -124,20 +151,107 @@ -- TODO: Add more tests ] +enumSpec :: + forall a. + (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a) + => Proxy a -> TestTree +enumSpec = integralSpec + floatingSpec :: forall a. - (SC.Serial IO a, Typeable a, Num a, Ord a, Random a, UniformRange a, Show a) + (SC.Serial IO a, Typeable a, Num a, Ord a, Random a, UniformRange a, Read a, Show a) => Proxy a -> TestTree floatingSpec px = testGroup ("(" ++ showsType px ")") [ SC.testProperty "uniformR" $ seeded $ Range.uniformRangeWithin px + , testCase "r = +inf, x = 0" $ positiveInf @?= fst (uniformR (0, positiveInf) (ConstGen 0)) + , testCase "r = +inf, x = 1" $ positiveInf @?= fst (uniformR (0, positiveInf) (ConstGen 1)) + , testCase "l = -inf, x = 0" $ negativeInf @?= fst (uniformR (negativeInf, 0) (ConstGen 0)) + , testCase "l = -inf, x = 1" $ negativeInf @?= fst (uniformR (negativeInf, 0) (ConstGen 1)) -- TODO: Add more tests ] + where + positiveInf, negativeInf :: a + positiveInf = read "Infinity" + negativeInf = read "-Infinity" +randomSpec :: + forall a. + (Typeable a, Eq a, Random a, Show a) + => Proxy a -> TestTree +randomSpec px = + testGroup + ("Random " ++ showsType px ")") + [ SC.testProperty "randoms" $ + seededWithLen $ \len g -> + take len (randoms g :: [a]) == runStateGen_ g (replicateM len . randomM) + , SC.testProperty "randomRs" $ + seededWithLen $ \len g -> + case random g of + (l, g') -> + case random g' of + (h, g'') -> + take len (randomRs (l, h) g'' :: [a]) == + runStateGen_ g'' (replicateM len . randomRM (l, h)) + ] + +uniformSpec :: + forall a. + (Typeable a, Eq a, Random a, Uniform a, Show a) + => Proxy a -> TestTree +uniformSpec px = + testGroup + ("Uniform " ++ showsType px ")") + [ SC.testProperty "uniformListM" $ + seededWithLen $ \len g -> + take len (randoms g :: [a]) == runStateGen_ g (uniformListM len) + ] + runSpec :: TestTree -runSpec = testGroup "runGenState_ and runPrimGenIO_" +runSpec = testGroup "runStateGen_ and runPrimGenIO_" [ SC.testProperty "equal outputs" $ seeded $ \g -> monadic $ Run.runsEqual g ] -- | Create a StdGen instance from an Int and pass it to the given function. seeded :: (StdGen -> a) -> Int -> a seeded f = f . mkStdGen + +-- | Same as `seeded`, but also produces a length in range 0-255 suitable for generating +-- lists and such +seededWithLen :: (Int -> StdGen -> a) -> Word8 -> Int -> a +seededWithLen f w8 = seeded (f (fromIntegral w8)) + +data MyBool = MyTrue | MyFalse + deriving (Eq, Ord, Show, Generic, Finite, Uniform) +instance Monad m => Serial m MyBool + +data MyAction = Code (Maybe MyBool) | Never Void | Eat (Bool, Bool) | Sleep () + deriving (Eq, Ord, Show, Generic, Finite) +instance Monad m => Serial m MyAction +instance Uniform MyAction + +data Foo + = Quux Char + | Bar Int | Baz Word + | Bar8 Int8 | Baz8 Word8 + | Bar16 Int16 | Baz16 Word16 + | Bar32 Int32 | Baz32 Word32 + | Bar64 Int64 | Baz64 Word64 + | Final () + deriving (Eq, Ord, Show, Generic, Finite, Uniform) +instance Monad m => Serial m Foo + +newtype ConstGen = ConstGen Word64 + +instance RandomGen ConstGen where + genWord64 g@(ConstGen c) = (c, g) + split g = (g, g) + +data Colors = Red | Green | Blue | Purple | Yellow | Black | White | Orange + deriving (Eq, Ord, Show, Generic, Enum, Bounded) +instance Monad m => Serial m Colors + +instance Uniform Colors where + uniformM = uniformEnumM + +instance UniformRange Colors where + uniformRM = uniformEnumRM diff --git a/test/Spec/Stateful.hs b/test/Spec/Stateful.hs new file mode 100644 --- /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 + ] + diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Main where -#if __GLASGOW_HASKELL__ >= 802 +#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ < 810 import Test.DocTest (doctest) @@ -10,6 +10,7 @@ #else +-- Also disabled in cabal file. -- TODO: fix doctest support main :: IO () main = putStrLn "\nDoctests are not supported for older ghc version\n"