random 1.2.0 → 1.2.1
raw patch · 14 files changed
+1542/−273 lines, 14 filesdep +ghc-byteorderdep +stmdep +tasty-benchdep −gaugedep −tasty-expected-failuredep ~basedep ~primitive
Dependencies added: ghc-byteorder, stm, tasty-bench, tasty-inspection-testing
Dependencies removed: gauge, tasty-expected-failure
Dependency ranges changed: base, primitive
Files
- CHANGELOG.md +21/−0
- README.md +5/−5
- bench-legacy/SimpleRNGBench.hs +1/−1
- bench/Main.hs +135/−108
- random.cabal +55/−25
- src/System/Random.hs +257/−45
- src/System/Random/GFinite.hs +282/−0
- src/System/Random/Internal.hs +360/−70
- src/System/Random/Stateful.hs +110/−6
- test-inspection/Spec.hs +23/−0
- test-inspection/Spec/Inspection.hs +52/−0
- test/Spec.hs +126/−12
- test/Spec/Stateful.hs +113/−0
- test/doctests.hs +2/−1
CHANGELOG.md view
@@ -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
README.md view
@@ -4,13 +4,13 @@ ### Status -| Language | Travis | Coveralls |-|:--------:|:------:|:---------:|-|  | [](http://travis-ci.org/haskell/random) | [](https://coveralls.io/github/haskell/random?branch=master)+| Language | Github Actions | Drone.io | Coveralls |+|:--------:|:--------------:|:--------:|:---------:|+|  | [](https://github.com/haskell/random/actions) | [](https://cloud.drone.io/haskell/random/) | [](https://coveralls.io/github/haskell/random?branch=master) -| Package | Hackage | Nightly | LTS |+| Github Repo | Hackage | Nightly | LTS | |:-------------------|:-------:|:-------:|:---:|-| [`random`](https://github.com/haskell/random)| [](https://hackage.haskell.org/package/random)| [](https://www.stackage.org/nightly/package/random)| [](https://www.stackage.org/lts/package/random)+| [`random`](https://github.com/haskell/random)| [](https://hackage.haskell.org/package/random)| [](https://www.stackage.org/nightly/package/random)| [](https://www.stackage.org/lts/package/random) ### Description
bench-legacy/SimpleRNGBench.hs view
@@ -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
bench/Main.hs view
@@ -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
random.cabal view
@@ -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
src/System/Random.hs view
@@ -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
+ src/System/Random/GFinite.hs view
@@ -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)
src/System/Random/Internal.hs view
@@ -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. --
src/System/Random/Stateful.hs view
@@ -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
+ test-inspection/Spec.hs view
@@ -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++
+ test-inspection/Spec/Inspection.hs view
@@ -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)+ ]
test/Spec.hs view
@@ -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
+ test/Spec/Stateful.hs view
@@ -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+ ]+
test/doctests.hs view
@@ -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"