random 1.2.1.1 → 1.3.1

raw patch · 17 files changed

Files

CHANGELOG.md +51/−0
README.md +3/−3
bench-legacy/SimpleRNGBench.hs +3/−2
bench/Main.hs +110/−47
random.cabal +33/−54
src/System/Random.hs +227/−22
src/System/Random/Array.hs +362/−0
src/System/Random/GFinite.hs +10/−11
src/System/Random/Internal.hs +578/−164
src/System/Random/Seed.hs +333/−0
src/System/Random/Stateful.hs +334/−154
test-inspection/Spec/Inspection.hs +10/−1
test/Spec.hs +95/−27
test/Spec/Range.hs +11/−11
test/Spec/Seed.hs +115/−0
test/Spec/Stateful.hs +167/−57
test/doctests.hs +0/−18

CHANGELOG.md view

@@ -1,3 +1,54 @@+# 1.3.1++* Add missing `SplitGen` instance for `StateGen`: [#183](https://github.com/haskell/random/pull/183)++# 1.3.0++* Improve floating point value generation and avoid degenerate cases: [#172](https://github.com/haskell/random/pull/172)+* Add `Uniform` instance for `Maybe` and `Either`: [#167](https://github.com/haskell/random/pull/167)+* Add `Seed`, `SeedGen`, `seedSize`, `seedSizeProxy`, `mkSeed` and `unSeed`:+  [#162](https://github.com/haskell/random/pull/162)+* Add `mkSeedFromByteString`, `unSeedToByteString`, `withSeed`, `withSeedM`, `withSeedFile`,+  `seedGenTypeName`, `nonEmptyToSeed`, `nonEmptyFromSeed`, `withSeedM`, `withSeedMutableGen` and `withSeedMutableGen_`+* Add `SplitGen` and `splitGen`: [#160](https://github.com/haskell/random/pull/160)+* Add `unifromShuffleList` and `unifromShuffleListM`: [#140](https://github.com/haskell/random/pull/140)+* Add `uniformWordR`: [#140](https://github.com/haskell/random/pull/140)+* Add `mkStdGen64`: [#155](https://github.com/haskell/random/pull/155)+* Add `uniformListRM`, `uniformList`, `uniformListR`, `uniforms` and `uniformRs`:+  [#154](https://github.com/haskell/random/pull/154)+* Add compatibility with recently added `ByteArray` to `base`:+  [#153](https://github.com/haskell/random/pull/153)+  * Switch to using `ByteArray` for type class implementation instead of+    `ShortByteString`+  * Add `unsafeUniformFillMutableByteArray` to `RandomGen` and a helper function+    `defaultUnsafeUniformFillMutableByteArray` that makes implementation+    for most instances easier.+  * Add `uniformByteArray`, `uniformByteString` and `uniformFillMutableByteArray`+  * Deprecate `genByteString` in favor of `uniformByteString`+  * Add `uniformByteArrayM` to `StatefulGen`+  * Add `uniformByteStringM` and `uniformShortByteStringM`+  * Deprecate `System.Random.Stateful.uniformShortByteString` in favor of `uniformShortByteStringM` for+    consistent naming and a future plan of removing it from `StatefulGen`+    type class+  * Add a pure `System.Random.uniformShortByteString` generating function.+  * Deprecate `genShortByteString` in favor of `System.Random.uniformShortByteString`+  * Expose a helper function `fillByteArrayST`, that can be used for+    defining implementation for `uniformByteArrayM`+  * Deprecate `genShortByteStringST` and `genShortByteStringIO` in favor of `fillByteArrayST`+* Improve `FrozenGen` interface: [#149](https://github.com/haskell/random/pull/149)+  * Move `thawGen` from `FreezeGen` into the new `ThawGen` type class. Fixes an issue with+    an unlawful instance of `StateGen` for `FreezeGen`.+  * Add `modifyGen` and `overwriteGen` to the `FrozenGen` type class+  * Switch `splitGenM` to use `SplitGen` and `FrozenGen` instead of deprecated `RandomGenM`+  * Add `splitMutableGenM`+  * Switch `randomM` and `randomRM` to use `FrozenGen` instead of `RandomGenM`+  * Deprecate `RandomGenM` in favor of a more powerful `FrozenGen`+* Add `isInRangeOrd` and `isInRangeEnum` that can be used for implementing `isInRange`:+  [#148](https://github.com/haskell/random/pull/148)+* Add `isInRange` to `UniformRange`: [#78](https://github.com/haskell/random/pull/78)+* Add default implementation for `uniformRM` using `Generics`:+  [#92](https://github.com/haskell/random/pull/92)+ # 1.2.1  * Fix support for ghc-9.2 [#99](https://github.com/haskell/random/pull/99)

README.md view

@@ -4,9 +4,9 @@  ### Status -| Language | Github Actions | Drone.io | Coveralls |-|:--------:|:--------------:|:--------:|:---------:|-| ![GitHub top language](https://img.shields.io/github/languages/top/haskell/random.svg) | [![Build Status](https://github.com/haskell/random/workflows/random-CI/badge.svg)](https://github.com/haskell/random/actions) | [![Build Status](https://cloud.drone.io/api/badges/haskell/random/status.svg?ref=refs/heads/master)](https://cloud.drone.io/haskell/random/) | [![Coverage Status](https://coveralls.io/repos/github/haskell/random/badge.svg?branch=master)](https://coveralls.io/github/haskell/random?branch=master)+| Language | Github Actions | Coveralls |+|:--------:|:--------------:|:---------:|+| ![GitHub top language](https://img.shields.io/github/languages/top/haskell/random.svg) | [![Build Status](https://github.com/haskell/random/actions/workflows/ci.yaml/badge.svg?branch=master)](https://github.com/haskell/random/actions/workflows/ci.yaml) | [![Coverage Status](https://coveralls.io/repos/github/haskell/random/badge.svg?branch=master)](https://coveralls.io/github/haskell/random?branch=master)  |    Github Repo     | Hackage | Nightly | LTS | |:-------------------|:-------:|:-------:|:---:|

bench-legacy/SimpleRNGBench.hs view

@@ -1,8 +1,9 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables, ForeignFunctionInterface #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fwarn-unused-imports #-}  -- | A simple script to do some very basic timing of the RNGs.- module Main where  import System.Exit (exitSuccess, exitFailure)

bench/Main.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Main (main) where@@ -6,6 +7,7 @@ import Control.Monad import Control.Monad.State.Strict import Data.Int+import Data.List (sortOn) import Data.Proxy import Data.Typeable import Data.Word@@ -13,9 +15,11 @@ import Numeric.Natural (Natural) import System.Random.SplitMix as SM import Test.Tasty.Bench+#if MIN_VERSION_primitive(0,7,1) import Control.Monad.Primitive-import Data.Primitive.PrimArray import Data.Primitive.Types+import Data.Primitive.PrimArray+#endif  import System.Random.Stateful @@ -25,6 +29,8 @@ main :: IO () main = do   let !sz = 100000+      !sz100MiB = 100 * 1024 * 1024+      genLengths :: ([Int], StdGen)       genLengths =         -- create 5000 small lengths that are needed for ShortByteString generation         runStateGen (mkStdGen 2020) $ \g -> replicateM 5000 (uniformRM (16 + 1, 16 + 7) g)@@ -198,58 +204,105 @@             in pureUniformRBench (Proxy :: Proxy Natural) range sz           ]         , bgroup "floating"-          [ bgroup "IO"-            [ 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))+          [+#if MIN_VERSION_primitive(0,7,1)+            bgroup "IO"+            [ bgroup "Float"+              [ env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) ->+                  bench "uniformRM" $+                  nfIO (runStateGenT gen (fillMutablePrimArrayM (uniformRM (0 :: Float, 1.1)) ma))+              , 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))+              ]+            , bgroup "Double"+              [ env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) ->+                  bench "uniformRM" $+                  nfIO (runStateGenT gen (fillMutablePrimArrayM (uniformRM (0 :: Double, 1.1)) 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 "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))+          ,+#endif+            bgroup "State"+            [ bgroup "Float"+              [ env getStdGen $+                  bench "uniformRM" . nf (`runStateGen` (replicateM_ sz . uniformRM (0.1 :: Float, 1.1)))+              , env getStdGen $+                  bench "uniformFloat01M" . nf (`runStateGen` (replicateM_ sz . uniformFloat01M))+              , env getStdGen $+                  bench "uniformFloatPositive01M" .+                  nf (`runStateGen` (replicateM_ sz . uniformFloatPositive01M))+              ]+            , bgroup "Double"+              [ env getStdGen $+                  bench "uniformRM" . nf (`runStateGen` (replicateM_ sz . uniformRM (0.1 :: Double, 1.1)))+              , env getStdGen $+                  bench "uniformDouble01M" . nf (`runStateGen` (replicateM_ sz . uniformDouble01M))+              , env getStdGen $+                  bench "uniformDoublePositive01M" .+                  nf (`runStateGen` (replicateM_ sz . uniformDoublePositive01M))+              ]             ]           , bgroup "pure"-            [ 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 "Float"+              [ env getStdGen $ \gen ->+                  bench "uniformRM" $ nf+                  (genMany (runState $ uniformRM (0.1 :: Float, 1.1) (StateGenM :: StateGenM StdGen)) gen)+                  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+              ]+            , bgroup "Double"+              [ env getStdGen $ \gen ->+                  bench "uniformRM" $ nf+                  (genMany (runState $ uniformRM (0.1 :: Double, 1.1) (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-          ]         ]+      , bgroup "Bytes"+        [ env (pure genLengths) $ \ ~(ns, gen) ->+            bench "uniformShortByteStringM" $+            nfIO $ runStateGenT gen $ \g -> mapM (`uniformShortByteStringM` g) ns+        , env getStdGen $ \gen ->+            bench "uniformByteStringM 100MB" $+            nf (runStateGen gen . uniformByteStringM) sz100MiB+        , env getStdGen $ \gen ->+            bench "uniformByteArray 100MB" $ nf (\n -> uniformByteArray False n gen) sz100MiB+        , env getStdGen $ \gen ->+            bench "uniformByteString 100MB" $ nf (`uniformByteString` gen) sz100MiB+        ]       ]+      , env (pure [0 :: Integer .. 200000]) $ \xs ->+        bgroup "shuffle"+          [ env getStdGen $ bench "uniformShuffleList" . nf (uniformShuffleList xs)+          , env getStdGen $ bench "uniformShuffleListM" . nf (`runStateGen` uniformShuffleListM xs)+          , env getStdGen $ bench "naiveShuffleListM" . nf (`runStateGen` naiveShuffleListM xs)+          ]     ]  pureUniformRFullBench ::@@ -320,7 +373,7 @@       | i < n = go (i + 1) $ f g       | otherwise = y -+#if MIN_VERSION_primitive(0,7,1) fillMutablePrimArrayM ::      (Prim a, PrimMonad m)   => (gen -> m a)@@ -334,3 +387,13 @@         | otherwise = pure ()   go 0   unsafeFreezePrimArray ma+#endif+++naiveShuffleListM :: StatefulGen g m => [a] -> g -> m [a]+naiveShuffleListM xs gen = do+  is <- uniformListM n gen+  pure $ map snd $ sortOn fst $ zip (is :: [Int]) xs+  where+    !n = length xs+{-# INLINE naiveShuffleListM #-}

random.cabal view

@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               random-version:            1.2.1.1+version:            1.3.1 license:            BSD3 license-file:       LICENSE maintainer:         core-libraries-committee@haskell.org@@ -63,18 +63,19 @@ extra-source-files:     README.md     CHANGELOG.md-tested-with:         GHC == 7.10.2-                   , GHC == 7.10.3-                   , GHC == 8.0.2+tested-with:         GHC == 8.0.2                    , GHC == 8.2.2-                   , GHC == 8.4.3                    , GHC == 8.4.4-                   , GHC == 8.6.3-                   , GHC == 8.6.4                    , GHC == 8.6.5-                   , GHC == 8.8.1-                   , GHC == 8.8.2-                   , GHC == 8.10.1+                   , GHC == 8.8.4+                   , GHC == 8.10.7+                   , GHC == 9.0.2+                   , GHC == 9.2.8+                   , GHC == 9.4.8+                   , GHC == 9.6.6+                   , GHC == 9.8.4+                   , GHC == 9.10.1+                   , GHC == 9.12.1  source-repository head     type:     git@@ -87,25 +88,25 @@         System.Random.Internal         System.Random.Stateful     other-modules:+        System.Random.Array+        System.Random.Seed         System.Random.GFinite      hs-source-dirs:   src     default-language: Haskell2010     ghc-options:         -Wall-    if impl(ghc >= 8.0)-        ghc-options:-            -Wincomplete-record-updates -Wincomplete-uni-patterns+        -Wincomplete-record-updates -Wincomplete-uni-patterns      build-depends:-        base >=4.8 && <5,-        bytestring >=0.10.4 && <0.12,+        base >=4.9 && <5,+        bytestring >=0.10.4 && <0.13,         deepseq >=1.1 && <2,         mtl >=2.2 && <2.4,+        transformers >=0.4 && <0.7,         splitmix >=0.1 && <0.2-    if impl(ghc < 8.0)-       build-depends:-           transformers+    if impl(ghc < 9.4)+      build-depends: data-array-byte  test-suite legacy-test     type:             exitcode-stdio-1.0@@ -119,32 +120,14 @@         RangeTest      default-language: Haskell2010-    ghc-options:      -with-rtsopts=-M8M-    if impl(ghc >= 8.0)-        ghc-options:-            -Wno-deprecations+    ghc-options:+      -with-rtsopts=-M9M+      -Wno-deprecations     build-depends:         base,-        containers >=0.5 && <0.7,+        containers >=0.5 && <0.8,         random -test-suite doctests-    type:             exitcode-stdio-1.0-    main-is:          doctests.hs-    hs-source-dirs:   test-    default-language: Haskell2010-    build-depends:-        base,-        doctest >=0.15 && <0.21-    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     main-is:          Spec.hs@@ -152,6 +135,7 @@     other-modules:         Spec.Range         Spec.Run+        Spec.Seed         Spec.Stateful      default-language: Haskell2010@@ -162,7 +146,7 @@         random,         smallcheck >=1.2 && <1.3,         stm,-        tasty >=1.0 && <1.5,+        tasty >=1.0 && <1.6,         tasty-smallcheck >=0.8 && <0.9,         tasty-hunit >=0.10 && <0.11,         transformers@@ -173,19 +157,17 @@     type:             exitcode-stdio-1.0     main-is:          Spec.hs     hs-source-dirs:   test-inspection-    build-depends:-     default-language: Haskell2010     ghc-options:      -Wall+    other-modules:+        Spec.Inspection     build-depends:         base,         random,-        tasty >=1.0 && <1.5-    if impl(ghc >= 8.0)-        build-depends:-            tasty-inspection-testing-        other-modules:-            Spec.Inspection+        tasty >=1.0 && <1.6,+        tasty-inspection-testing+    if impl(ghc >=9.10)+        buildable: False  benchmark legacy-bench     type:             exitcode-stdio-1.0@@ -194,10 +176,7 @@     other-modules:    BinSearch     default-language: Haskell2010     ghc-options:-        -Wall -O2 -threaded -rtsopts -with-rtsopts=-N-    if impl(ghc >= 8.0)-        ghc-options:-            -Wno-deprecations+        -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -Wno-deprecations      build-depends:         base,@@ -215,7 +194,7 @@     build-depends:         base,         mtl,-        primitive >= 0.7.1,+        primitive,         random,         splitmix >=0.1 && <0.2,         tasty-bench

src/System/Random.hs view

@@ -1,5 +1,7 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE Trustworthy #-}  -- |@@ -20,18 +22,45 @@    -- * Pure number generator interface   -- $interfaces-    RandomGen(..)+    RandomGen+      ( split+      , genWord8+      , genWord16+      , genWord32+      , genWord64+      , genWord32R+      , genWord64R+      , unsafeUniformFillMutableByteArray+      )+  , SplitGen (splitGen)   , uniform   , uniformR-  , genByteString   , Random(..)   , Uniform   , UniformRange   , Finite+  -- ** Seed+  , module System.Random.Seed+  -- * Generators for sequences of pseudo-random bytes+  -- ** Lists+  , uniforms+  , uniformRs+  , uniformList+  , uniformListR+  , uniformShuffleList+  -- ** Bytes+  , uniformByteArray+  , uniformByteString+  , uniformShortByteString+  , uniformFillMutableByteArray+  -- *** Deprecated+  , genByteString+  , genShortByteString    -- ** Standard pseudo-random number generator   , StdGen   , mkStdGen+  , mkStdGen64   , initStdGen    -- ** Global standard pseudo-random number generator@@ -45,6 +74,8 @@    -- * Compatibility and reproducibility   -- ** Backwards compatibility and deprecations+  , genRange+  , next   -- $deprecations    -- ** Reproducibility@@ -61,14 +92,19 @@ import Control.Arrow import Control.Monad.IO.Class import Control.Monad.State.Strict+import Control.Monad.ST (ST)+import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) import Data.ByteString (ByteString)+import Data.ByteString.Short.Internal (ShortByteString(..)) import Data.Int import Data.IORef import Data.Word import Foreign.C.Types import GHC.Exts+import System.Random.Array (getSizeOfMutableByteArray, shortByteStringToByteString, shuffleListST) import System.Random.GFinite (Finite)-import System.Random.Internal+import System.Random.Internal hiding (uniformShortByteString)+import System.Random.Seed import qualified System.Random.SplitMix as SM  -- $introduction@@ -91,7 +127,7 @@ -- -- >>> :{ -- let rolls :: RandomGen g => Int -> g -> [Word]---     rolls n = take n . unfoldr (Just . uniformR (1, 6))+--     rolls n = fst . uniformListR n (1, 6) --     pureGen = mkStdGen 137 -- in --     rolls 10 pureGen :: [Word]@@ -103,7 +139,7 @@ -- -- >>> :{ -- let rollsM :: StatefulGen g m => Int -> g -> m [Word]---     rollsM n = replicateM n . uniformRM (1, 6)+--     rollsM n = uniformListRM n (1, 6) --     pureGen = mkStdGen 137 -- in --     runStateGen_ pureGen (rollsM 10) :: [Word]@@ -144,8 +180,14 @@ -- >>> uniform pureGen :: (Bool, StdGen) -- (True,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) --+-- You can use type applications to disambiguate the type of the generated numbers:+--+-- >>> :seti -XTypeApplications+-- >>> uniform @Bool pureGen+-- (True,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627})+-- -- @since 1.2.0-uniform :: (RandomGen g, Uniform a) => g -> (a, g)+uniform :: (Uniform a, RandomGen g) => g -> (a, g) uniform g = runStateGen g uniformM {-# INLINE uniform #-} @@ -171,11 +213,108 @@ -- >>> uniformR (1 :: Int, 4 :: Int) pureGen -- (4,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627}) --+-- You can use type applications to disambiguate the type of the generated numbers:+--+-- >>> :seti -XTypeApplications+-- >>> uniformR @Int (1, 4) pureGen+-- (4,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627})+-- -- @since 1.2.0-uniformR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)+uniformR :: (UniformRange a, RandomGen g) => (a, a) -> g -> (a, g) uniformR r g = runStateGen g (uniformRM r) {-# INLINE uniformR #-} +-- | Produce an infinite list of pseudo-random values. Integrates nicely with list+-- fusion. Naturally, there is no way to recover the final generator, therefore either use+-- `split` before calling `uniforms` or use `uniformList` instead.+--+-- Similar to `randoms`, except it relies on `Uniform` type class instead of `Random`+--+-- ====__Examples__+--+-- >>> let gen = mkStdGen 2023+-- >>> import Data.Word (Word16)+-- >>> take 5 $ uniforms gen :: [Word16]+-- [56342,15850,25292,14347,13919]+--+-- @since 1.3.0+uniforms :: (Uniform a, RandomGen g) => g -> [a]+uniforms g0 =+  build $ \cons _nil ->+    let go g =+          case uniform g of+            (x, g') -> x `seq` (x `cons` go g')+     in go g0+{-# INLINE uniforms #-}++-- | Produce an infinite list of pseudo-random values in a specified range. Same as+-- `uniforms`, integrates nicely with list fusion. There is no way to recover the final+-- generator, therefore either use `split` before calling `uniformRs` or use+-- `uniformListR` instead.+--+-- Similar to `randomRs`, except it relies on `UniformRange` type class instead of+-- `Random`.+--+-- ====__Examples__+--+-- >>> let gen = mkStdGen 2023+-- >>> take 5 $ uniformRs (10, 100) gen :: [Int]+-- [32,86,21,57,39]+--+-- @since 1.3.0+uniformRs :: (UniformRange a, RandomGen g) => (a, a) -> g -> [a]+uniformRs range g0 =+  build $ \cons _nil ->+    let go g =+          case uniformR range g of+            (x, g') -> x `seq` (x `cons` go g')+     in go g0+{-# INLINE uniformRs #-}++-- | Produce a list of the supplied length with elements generated uniformly.+--+-- See `uniformListM` for a stateful counterpart.+--+-- ====__Examples__+--+-- >>> let gen = mkStdGen 2023+-- >>> import Data.Word (Word16)+-- >>> uniformList 5 gen :: ([Word16], StdGen)+-- ([56342,15850,25292,14347,13919],StdGen {unStdGen = SMGen 6446154349414395371 1920468677557965761})+--+-- @since 1.3.0+uniformList :: (Uniform a, RandomGen g) => Int -> g -> ([a], g)+uniformList n g = runStateGen g (uniformListM n)+{-# INLINE uniformList #-}++-- | Produce a list of the supplied length with elements generated uniformly.+--+-- See `uniformListM` for a stateful counterpart.+--+-- ====__Examples__+--+-- >>> let gen = mkStdGen 2023+-- >>> uniformListR 10 (20, 30) gen :: ([Int], StdGen)+-- ([26,30,27,24,30,25,27,21,27,27],StdGen {unStdGen = SMGen 12965503083958398648 1920468677557965761})+--+-- @since 1.3.0+uniformListR :: (UniformRange a, RandomGen g) => Int -> (a, a) -> g -> ([a], g)+uniformListR n r g = runStateGen g (uniformListRM n r)+{-# INLINE uniformListR #-}++-- | Shuffle elements of a list in a uniformly random order.+--+-- ====__Examples__+--+-- >>> uniformShuffleList "ELVIS" $ mkStdGen 252+-- ("LIVES",StdGen {unStdGen = SMGen 17676540583805057877 5302934877338729551})+--+-- @since 1.3.0+uniformShuffleList :: RandomGen g => [a] -> g -> ([a], g)+uniformShuffleList xs g =+  runStateGenST g $ \gen -> shuffleListST (`uniformWordR` gen) xs+{-# INLINE uniformShuffleList #-}+ -- | Generates a 'ByteString' of the specified size using a pure pseudo-random -- number generator. See 'uniformByteStringM' for the monadic version. --@@ -184,14 +323,78 @@ -- >>> import System.Random -- >>> import Data.ByteString -- >>> let pureGen = mkStdGen 137+-- >>> :seti -Wno-deprecations -- >>> unpack . fst . genByteString 10 $ pureGen -- [51,123,251,37,49,167,90,109,1,4] -- -- @since 1.2.0 genByteString :: RandomGen g => Int -> g -> (ByteString, g)-genByteString n g = runStateGenST g (uniformByteStringM n)+genByteString = uniformByteString {-# INLINE genByteString #-}+{-# DEPRECATED genByteString "In favor of `uniformByteString`" #-} +-- | Generates a 'ByteString' of the specified size using a pure pseudo-random+-- number generator. See 'uniformByteStringM' for the monadic version.+--+-- ====__Examples__+--+-- >>> import System.Random+-- >>> import Data.ByteString (unpack)+-- >>> let pureGen = mkStdGen 137+-- >>> unpack . fst $ uniformByteString 10 pureGen+-- [51,123,251,37,49,167,90,109,1,4]+--+-- @since 1.3.0+uniformByteString :: RandomGen g => Int -> g -> (ByteString, g)+uniformByteString n g =+  case uniformByteArray True n g of+    (byteArray, g') ->+      (shortByteStringToByteString $ byteArrayToShortByteString byteArray, g')+{-# INLINE uniformByteString #-}++-- | Same as @`uniformByteArray` `False`@, but for `ShortByteString`.+--+-- Returns a 'ShortByteString' of length @n@ filled with pseudo-random bytes.+--+-- ====__Examples__+--+-- >>> import System.Random+-- >>> import Data.ByteString.Short (unpack)+-- >>> let pureGen = mkStdGen 137+-- >>> unpack . fst $ uniformShortByteString 10 pureGen+-- [51,123,251,37,49,167,90,109,1,4]+--+-- @since 1.3.0+uniformShortByteString :: RandomGen g => Int -> g -> (ShortByteString, g)+uniformShortByteString n g =+  case uniformByteArray False n g of+    (ByteArray ba#, g') -> (SBS ba#, g')+{-# INLINE uniformShortByteString #-}++-- | Fill in a slice of a mutable byte array with randomly generated bytes. This function+-- does not fail, instead it clamps the offset and number of bytes to generate into a valid+-- range.+--+-- @since 1.3.0+uniformFillMutableByteArray ::+     RandomGen g+  => MutableByteArray s+  -- ^ Mutable array to fill with random bytes+  -> Int+  -- ^ Offset into a mutable array from the beginning in number of bytes. Offset will be+  -- clamped into the range between 0 and the total size of the mutable array+  -> Int+  -- ^ Number of randomly generated bytes to write into the array. This number will be+  -- clamped between 0 and the total size of the array without the offset.+  -> g+  -> ST s g+uniformFillMutableByteArray mba i0 n g = do+  !sz <- getSizeOfMutableByteArray mba+  let !offset = max 0 (min sz i0)+      !numBytes = min (sz - offset) (max 0 n)+  unsafeUniformFillMutableByteArray mba offset numBytes g+{-# INLINE uniformFillMutableByteArray #-}+ -- | 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@@ -209,11 +412,11 @@   -- closed interval /[lo,hi]/, together with a new generator. It is unspecified   -- what happens if /lo>hi/, but usually the values will simply get swapped.   ---  -- >>> let gen = mkStdGen 2021+  -- >>> let gen = mkStdGen 26   -- >>> fst $ randomR ('a', 'z') gen-  -- 't'-  -- >>> fst $ randomR ('z', 'a') gen-  -- 't'+  -- 'z'+  -- >>> fst $ randomR ('a', 'z') gen+  -- 'z'   --   -- 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.@@ -222,8 +425,8 @@   -- 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)+  -- >>> fst $ randomR (('a', 5.0), ('z', 10.0)) $ mkStdGen 26+  -- ('z',5.22694980853051)   --   -- In case when a lawful range is desired `uniformR` should be used   -- instead.@@ -283,7 +486,8 @@              -> as buildRandoms cons rand = go   where-    -- The seq fixes part of #4218 and also makes fused Core simpler.+    -- The seq fixes part of #4218 and also makes fused Core simpler:+    -- https://gitlab.haskell.org/ghc/ghc/-/issues/4218     go g = x `seq` (x `cons` go g') where (x,g') = rand g  -- | /Note/ - `random` generates values in the `Int` range@@ -501,7 +705,7 @@ -- -- @since 1.0.0 newStdGen :: MonadIO m => m StdGen-newStdGen = liftIO $ atomicModifyIORef' theStdGen split+newStdGen = liftIO $ atomicModifyIORef' theStdGen splitGen  -- | Uses the supplied function to get a value from the current global -- random generator, and updates the global generator with the new generator@@ -510,7 +714,7 @@ -- -- >>> rollDice = getStdRandom (randomR (1, 6)) -- >>> replicateM 10 (rollDice :: IO Int)--- [5,6,6,1,1,6,4,2,4,1]+-- [1,1,1,4,5,6,1,2,2,5] -- -- This is an outdated function and it is recommended to switch to its -- equivalent 'System.Random.Stateful.applyAtomicGen' instead, possibly with the@@ -520,7 +724,7 @@ -- >>> 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]+-- [2,1,1,5,4,3,6,6,3,2] -- -- @since 1.0.0 getStdRandom :: MonadIO m => (StdGen -> (a, StdGen)) -> m a@@ -532,7 +736,7 @@ -- pseudo-random number generator 'System.Random.Stateful.globalStdGen' -- -- >>> randomRIO (2020, 2100) :: IO Int--- 2040+-- 2028 -- -- Similar to 'randomIO', this function is equivalent to @'getStdRandom' -- 'randomR'@ and is included in this interface for historical reasons and@@ -543,7 +747,7 @@ -- -- >>> import System.Random.Stateful -- >>> uniformRM (2020, 2100) globalStdGen :: IO Int--- 2079+-- 2044 -- -- @since 1.0.0 randomRIO :: (Random a, MonadIO m) => (a, a) -> m a@@ -554,7 +758,7 @@ -- -- >>> import Data.Int -- >>> randomIO :: IO Int32--- -1580093805+-- 114794456 -- -- This function is equivalent to @'getStdRandom' 'random'@ and is included in -- this interface for historical reasons and backwards compatibility. It is@@ -564,7 +768,7 @@ -- -- >>> import System.Random.Stateful -- >>> uniformM globalStdGen :: IO Int32--- -1649127057+-- -1768545016 -- -- @since 1.0.0 randomIO :: (Random a, MonadIO m) => m a@@ -710,3 +914,4 @@ -- -- >>> import Control.Monad (replicateM) -- >>> import Data.List (unfoldr)+-- >>> setStdGen (mkStdGen 0)

+ src/System/Random/Array.hs view

@@ -0,0 +1,362 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE UnboxedTuples #-}+-- |+-- Module      :  System.Random.Array+-- Copyright   :  (c) Alexey Kuleshevich 2024+-- License     :  BSD-style (see the file LICENSE in the 'random' repository)+-- Maintainer  :  libraries@haskell.org+--+module System.Random.Array+  ( -- * Helper array functionality+    ioToST+  , wordSizeInBits+    -- ** MutableByteArray+  , newMutableByteArray+  , newPinnedMutableByteArray+  , freezeMutableByteArray+  , writeWord8+  , writeWord64LE+  , writeByteSliceWord64LE+  , indexWord8+  , indexWord64LE+  , indexByteSliceWord64LE+  , sizeOfByteArray+  , shortByteStringToByteArray+  , byteArrayToShortByteString+  , getSizeOfMutableByteArray+  , shortByteStringToByteString+  -- ** MutableArray+  , Array (..)+  , MutableArray (..)+  , newMutableArray+  , freezeMutableArray+  , writeArray+  , shuffleListM+  , shuffleListST+  ) where++import Control.Monad.Trans (lift, MonadTrans)+import Control.Monad (when)+import Control.Monad.ST+import Data.Array.Byte (ByteArray(..), MutableByteArray(..))+import Data.Bits+import Data.ByteString.Short.Internal (ShortByteString(SBS))+import qualified Data.ByteString.Short.Internal as SBS (fromShort)+import Data.Word+import GHC.Exts+import GHC.IO (IO(..))+import GHC.ST (ST(..))+import GHC.Word+#if __GLASGOW_HASKELL__ >= 802+import Data.ByteString.Internal (ByteString(PS))+import GHC.ForeignPtr+#else+import Data.ByteString (ByteString)+#endif++-- Needed for WORDS_BIGENDIAN+#include "MachDeps.h"++wordSizeInBits :: Int+wordSizeInBits = finiteBitSize (0 :: Word)++----------------+-- Byte Array --+----------------++-- Architecture independent helpers:++sizeOfByteArray :: ByteArray -> Int+sizeOfByteArray (ByteArray ba#) = I# (sizeofByteArray# ba#)++st_ :: (State# s -> State# s) -> ST s ()+st_ m# = ST $ \s# -> (# m# s#, () #)+{-# INLINE st_ #-}++ioToST :: IO a -> ST RealWorld a+ioToST (IO m#) = ST m#+{-# INLINE ioToST #-}++newMutableByteArray :: Int -> ST s (MutableByteArray s)+newMutableByteArray (I# n#) =+  ST $ \s# ->+    case newByteArray# n# s# of+      (# s'#, mba# #) -> (# s'#, MutableByteArray mba# #)+{-# INLINE newMutableByteArray #-}++newPinnedMutableByteArray :: Int -> ST s (MutableByteArray s)+newPinnedMutableByteArray (I# n#) =+  ST $ \s# ->+    case newPinnedByteArray# n# s# of+      (# s'#, mba# #) -> (# s'#, MutableByteArray mba# #)+{-# INLINE newPinnedMutableByteArray #-}++freezeMutableByteArray :: MutableByteArray s -> ST s ByteArray+freezeMutableByteArray (MutableByteArray mba#) =+  ST $ \s# ->+    case unsafeFreezeByteArray# mba# s# of+      (# s'#, ba# #) -> (# s'#, ByteArray ba# #)++writeWord8 :: MutableByteArray s -> Int -> Word8 -> ST s ()+writeWord8 (MutableByteArray mba#) (I# i#) (W8# w#) = st_ (writeWord8Array# mba# i# w#)+{-# INLINE writeWord8 #-}++writeByteSliceWord64LE :: MutableByteArray s -> Int -> Int -> Word64 -> ST s ()+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 #-}++indexWord8 ::+     ByteArray+  -> Int -- ^ Offset into immutable byte array in number of bytes+  -> Word8+indexWord8 (ByteArray ba#) (I# i#) =+  W8# (indexWord8Array# ba# i#)+{-# INLINE indexWord8 #-}++indexWord64LE ::+     ByteArray+  -> Int -- ^ Offset into immutable byte array in number of bytes+  -> Word64+#if defined WORDS_BIGENDIAN || !(__GLASGOW_HASKELL__ >= 806)+indexWord64LE ba i = indexByteSliceWord64LE ba i (i + 8)+#else+indexWord64LE (ByteArray ba#) (I# i#)+  | wordSizeInBits == 64 = W64# (indexWord8ArrayAsWord64# ba# i#)+  | otherwise =+    let !w32l = W32# (indexWord8ArrayAsWord32# ba# i#)+        !w32u = W32# (indexWord8ArrayAsWord32# ba# (i# +# 4#))+    in (fromIntegral w32u `shiftL` 32) .|. fromIntegral w32l+#endif+{-# INLINE indexWord64LE #-}++indexByteSliceWord64LE ::+     ByteArray+  -> Int -- ^ Starting offset in number of bytes+  -> Int -- ^ Ending offset in number of bytes+  -> Word64+indexByteSliceWord64LE ba fromByteIx toByteIx = goWord8 fromByteIx 0+  where+    r = (toByteIx - fromByteIx) `rem` 8+    nPadBits = if r == 0 then 0 else 8 * (8 - r)+    goWord8 i !w64+      | i < toByteIx = goWord8 (i + 1) (shiftL w64 8 .|. fromIntegral (indexWord8 ba i))+      | otherwise = byteSwap64 (shiftL w64 nPadBits)+{-# INLINE indexByteSliceWord64LE #-}++-- On big endian machines we need to write one byte at a time for consistency with little+-- endian machines. Also for GHC versions prior to 8.6 we don't have primops that can+-- write with byte offset, eg. writeWord8ArrayAsWord64# and writeWord8ArrayAsWord32#, so we+-- also must fallback to writing one byte a time. Such fallback results in about 3 times+-- slow down, which is not the end of the world.+writeWord64LE ::+     MutableByteArray s+  -> Int -- ^ Offset into mutable byte array in number of bytes+  -> Word64 -- ^ 8 bytes that will be written into the supplied array+  -> ST s ()+#if defined WORDS_BIGENDIAN || !(__GLASGOW_HASKELL__ >= 806)+writeWord64LE mba i w64 =+  writeByteSliceWord64LE mba i (i + 8) w64+#else+writeWord64LE (MutableByteArray mba#) (I# i#) w64@(W64# w64#)+  | wordSizeInBits == 64 = st_ (writeWord8ArrayAsWord64# mba# i# w64#)+  | otherwise = do+    let !(W32# w32l#) = fromIntegral w64+        !(W32# w32u#) = fromIntegral (w64 `shiftR` 32)+    st_ (writeWord8ArrayAsWord32# mba# i# w32l#)+    st_ (writeWord8ArrayAsWord32# mba# (i# +# 4#) w32u#)+#endif+{-# INLINE writeWord64LE #-}++getSizeOfMutableByteArray :: MutableByteArray s -> ST s Int+getSizeOfMutableByteArray (MutableByteArray mba#) =+#if __GLASGOW_HASKELL__ >=802+  ST $ \s ->+    case getSizeofMutableByteArray# mba# s of+      (# s', n# #) -> (# s', I# n# #)+#else+  pure $! I# (sizeofMutableByteArray# mba#)+#endif+{-# INLINE getSizeOfMutableByteArray #-}++shortByteStringToByteArray :: ShortByteString -> ByteArray+shortByteStringToByteArray (SBS ba#) = ByteArray ba#+{-# INLINE shortByteStringToByteArray #-}++byteArrayToShortByteString :: ByteArray -> ShortByteString+byteArrayToShortByteString (ByteArray ba#) = SBS ba#+{-# INLINE byteArrayToShortByteString #-}++-- | Convert a ShortByteString to ByteString by casting, whenever memory is pinned,+-- otherwise make a copy into a new pinned ByteString+shortByteStringToByteString :: ShortByteString -> ByteString+shortByteStringToByteString ba =+#if __GLASGOW_HASKELL__ < 802+  SBS.fromShort ba+#else+  let !(SBS ba#) = ba in+  if isTrue# (isByteArrayPinned# ba#)+    then pinnedByteArrayToByteString ba#+    else SBS.fromShort ba+{-# INLINE shortByteStringToByteString #-}++pinnedByteArrayToByteString :: ByteArray# -> ByteString+pinnedByteArrayToByteString ba# =+  PS (pinnedByteArrayToForeignPtr ba#) 0 (I# (sizeofByteArray# ba#))+{-# INLINE pinnedByteArrayToByteString #-}++pinnedByteArrayToForeignPtr :: ByteArray# -> ForeignPtr a+pinnedByteArrayToForeignPtr ba# =+  ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#))+{-# INLINE pinnedByteArrayToForeignPtr #-}+#endif++-----------------+-- Boxed Array --+-----------------++data Array a = Array (Array# a)++data MutableArray s a = MutableArray (MutableArray# s a)++newMutableArray :: Int -> a -> ST s (MutableArray s a)+newMutableArray (I# n#) a =+  ST $ \s# ->+    case newArray# n# a s# of+      (# s'#, ma# #) -> (# s'#, MutableArray ma# #)+{-# INLINE newMutableArray #-}++freezeMutableArray :: MutableArray s a -> ST s (Array a)+freezeMutableArray (MutableArray ma#) =+  ST $ \s# ->+    case unsafeFreezeArray# ma# s# of+      (# s'#, a# #) -> (# s'#, Array a# #)+{-# INLINE freezeMutableArray #-}++sizeOfMutableArray :: MutableArray s a -> Int+sizeOfMutableArray (MutableArray ma#) = I# (sizeofMutableArray# ma#)+{-# INLINE sizeOfMutableArray #-}++readArray :: MutableArray s a -> Int -> ST s a+readArray (MutableArray ma#) (I# i#) = ST (readArray# ma# i#)+{-# INLINE readArray #-}++writeArray :: MutableArray s a -> Int -> a -> ST s ()+writeArray (MutableArray ma#) (I# i#) a = st_ (writeArray# ma# i# a)+{-# INLINE writeArray #-}++swapArray :: MutableArray s a -> Int -> Int -> ST s ()+swapArray ma i j = do+  x <- readArray ma i+  y <- readArray ma j+  writeArray ma j x+  writeArray ma i y+{-# INLINE swapArray #-}++-- | Write contents of the list into the mutable array. Make sure that array is big+-- enough or segfault will happen.+fillMutableArrayFromList :: MutableArray s a -> [a] -> ST s ()+fillMutableArrayFromList ma = go 0+  where+    go _ [] = pure ()+    go i (x:xs) = writeArray ma i x >> go (i + 1) xs+{-# INLINE fillMutableArrayFromList #-}++readListFromMutableArray :: MutableArray s a -> ST s [a]+readListFromMutableArray ma = go (len - 1) []+  where+    len = sizeOfMutableArray ma+    go i !acc+       | i >= 0 = do+           x <- readArray ma i+           go (i - 1) (x : acc)+       | otherwise = pure acc+{-# INLINE readListFromMutableArray #-}+++-- | Generate a list of indices that will be used for swapping elements in uniform shuffling:+--+-- @+-- [ (0, n - 1)+-- , (0, n - 2)+-- , (0, n - 3)+-- , ...+-- , (0, 3)+-- , (0, 2)+-- , (0, 1)+-- ]+-- @+genSwapIndices+  :: Monad m+  => (Word -> m Word)+  -- ^ Action that generates a Word in the supplied range.+  -> Word+  -- ^ Number of index swaps to generate.+  -> m [Int]+genSwapIndices genWordR n = go 1 []+  where+    go i !acc+      | i >= n = pure acc+      | otherwise = do+          x <- genWordR i+          let !xi = fromIntegral x+          go (i + 1) (xi : acc)+{-# INLINE genSwapIndices #-}+++-- | Implementation of mutable version of Fisher-Yates shuffle. Unfortunately, we cannot generally+-- interleave pseudo-random number generation and mutation of `ST` monad, therefore we have to+-- pre-generate all of the index swaps with `genSwapIndices` and store them in a list before we can+-- perform the actual swaps.+shuffleListM :: Monad m => (Word -> m Word) -> [a] -> m [a]+shuffleListM genWordR ls+  | len <= 1 = pure ls+  | otherwise = do+    swapIxs <- genSwapIndices genWordR (fromIntegral len)+    pure $ runST $ do+      ma <- newMutableArray len $ error "Impossible: shuffleListM"+      fillMutableArrayFromList ma ls++      -- Shuffle elements of the mutable array according to the uniformly generated index swap list+      let goSwap _ [] = pure ()+          goSwap i (j:js) = swapArray ma i j >> goSwap (i - 1) js+      goSwap (len - 1) swapIxs++      readListFromMutableArray ma+  where+    len = length ls+{-# INLINE shuffleListM #-}++-- | This is a ~x2-x3 more efficient version of `shuffleListM`. It is more efficient because it does+-- not need to pregenerate a list of indices and instead generates them on demand. Because of this the+-- result that will be produced will differ for the same generator, since the order in which index+-- swaps are generated is reversed.+--+-- Unfortunately, most stateful generator monads can't handle `MonadTrans`, so this version is only+-- used for implementing the pure shuffle.+shuffleListST :: (Monad (t (ST s)), MonadTrans t) => (Word -> t (ST s) Word) -> [a] -> t (ST s) [a]+shuffleListST genWordR ls+  | len <= 1 = pure ls+  | otherwise = do+     ma <- lift $ newMutableArray len $ error "Impossible: shuffleListST"+     lift $ fillMutableArrayFromList ma ls++     -- Shuffle elements of the mutable array according to the uniformly generated index swap+     let goSwap i =+           when (i > 0) $ do+             j <- genWordR $ (fromIntegral :: Int -> Word) i+             lift $ swapArray ma i ((fromIntegral :: Word -> Int) j)+             goSwap (i - 1)+     goSwap (len - 1)++     lift $ readListFromMutableArray ma+  where+    len = length ls+{-# INLINE shuffleListST #-}

src/System/Random/GFinite.hs view

@@ -1,10 +1,3 @@--- |--- 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           #-}@@ -12,6 +5,12 @@ {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE TypeOperators        #-} +-- |+-- Module      :  System.Random.GFinite+-- Copyright   :  (c) Andrew Lelechenko 2020+-- License     :  BSD-style (see the file LICENSE in the 'random' repository)+-- Maintainer  :  libraries@haskell.org+-- module System.Random.GFinite   ( Cardinality(..)   , Finite(..)@@ -78,14 +77,13 @@       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'.+-- | A type class for data with a finite number of inhabitants. This type class+-- is used in the default implementation 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+-- >>> :seti -XDeriveGeneric -XDeriveAnyClass -- >>> import GHC.Generics (Generic) -- >>> data MyBool = MyTrue | MyFalse deriving (Generic, Finite) -- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Generic, Finite)@@ -280,3 +278,4 @@ 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)+instance (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f, Finite g) => Finite (a, b, c, d, e, f, g)

src/System/Random/Internal.hs view

@@ -3,22 +3,17 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GHCForeignImportPrim #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UnliftedFFITypes #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE TypeFamilyDependencies #-}-#else-{-# LANGUAGE TypeFamilies #-}-#endif {-# OPTIONS_HADDOCK hide, not-home #-}  -- |@@ -32,19 +27,25 @@ module System.Random.Internal   (-- * Pure and monadic pseudo-random number generator interfaces     RandomGen(..)+  , SplitGen(..)+  , Seed(..)+  -- * Stateful   , StatefulGen(..)   , FrozenGen(..)+  , ThawedGen(..)+  , splitGenM+  , splitMutableGenM    -- ** Standard pseudo-random number generator   , StdGen(..)   , mkStdGen+  , mkStdGen64   , theStdGen    -- * Monadic adapters for pure pseudo-random number generators   -- ** Pure adapter   , StateGen(..)   , StateGenM(..)-  , splitGen   , runStateGen   , runStateGen_   , runStateGenT@@ -56,30 +57,52 @@   , Uniform(..)   , uniformViaFiniteM   , UniformRange(..)-  , uniformByteStringM+  , uniformWordR   , uniformDouble01M   , uniformDoublePositive01M   , uniformFloat01M   , uniformFloatPositive01M   , uniformEnumM   , uniformEnumRM+  , uniformListM+  , uniformListRM+  , isInRangeOrd+  , isInRangeEnum+  , scaleFloating    -- * Generators for sequences of pseudo-random bytes+  , uniformShortByteStringM+  , uniformByteArray+  , fillByteArrayST   , genShortByteStringIO   , genShortByteStringST+  , defaultUnsafeFillMutableByteArrayT+  , defaultUnsafeUniformFillMutableByteArray+  -- ** Helpers for dealing with MutableByteArray+  , newMutableByteArray+  , newPinnedMutableByteArray+  , freezeMutableByteArray+  , writeWord8+  , writeWord64LE+  , indexWord8+  , indexWord64LE+  , indexByteSliceWord64LE+  , sizeOfByteArray+  , shortByteStringToByteArray+  , byteArrayToShortByteString   ) where  import Control.Arrow import Control.DeepSeq (NFData)-import Control.Monad (when)+import Control.Monad (replicateM, 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 (MonadState(..), State, StateT(..), runState)-import Control.Monad.Trans (lift)+import Control.Monad.State.Strict (MonadState(..), State, StateT(..), execStateT, runState)+import Control.Monad.Trans (lift, MonadTrans)+import Control.Monad.Trans.Identity (IdentityT (runIdentityT))+import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) import Data.Bits-import Data.ByteString.Short.Internal (ShortByteString(SBS), fromShort)+import Data.ByteString.Short.Internal (ShortByteString(SBS)) import Data.IORef (IORef, newIORef) import Data.Int import Data.Word@@ -88,24 +111,28 @@ import GHC.Exts import GHC.Generics import GHC.IO (IO(..))+import GHC.ST (ST(..)) import GHC.Word import Numeric.Natural (Natural) import System.IO.Unsafe (unsafePerformIO)-import System.Random.GFinite (Cardinality(..), GFinite(..))+import System.Random.Array+import System.Random.GFinite (Cardinality(..), GFinite(..), Finite) import qualified System.Random.SplitMix as SM import qualified System.Random.SplitMix32 as SM32-#if __GLASGOW_HASKELL__ >= 800 import Data.Kind-#endif-#if __GLASGOW_HASKELL__ >= 802-import Data.ByteString.Internal (ByteString(PS))-import GHC.ForeignPtr-#else-import Data.ByteString (ByteString)-#endif --- Needed for WORDS_BIGENDIAN-#include "MachDeps.h"+-- | This is a binary form of pseudo-random number generator's state. It is designed to be+-- safe and easy to use for input/output operations like restoring from file, transmitting+-- over the network, etc.+--+-- Constructor is not exported, becasue it is important for implementation to enforce the+-- invariant of the underlying byte array being of the exact same length as the generator has+-- specified in `System.Random.Seed.SeedSize`. Use `System.Random.Seed.mkSeed` and+-- `System.Random.Seed.unSeed` to get access to the raw bytes in a safe manner.+--+-- @since 1.3.0+newtype Seed g = Seed ByteArray+  deriving (Eq, Ord, Show)   -- | 'RandomGen' is an interface to pure pseudo-random number generators.@@ -116,7 +143,7 @@ {-# DEPRECATED next "No longer used" #-} {-# DEPRECATED genRange "No longer used" #-} class RandomGen g where-  {-# MINIMAL split,(genWord32|genWord64|(next,genRange)) #-}+  {-# MINIMAL (genWord32|genWord64|(next,genRange)) #-}   -- | Returns an 'Int' that is uniformly distributed over the range returned by   -- 'genRange' (including both end points), and a new generator. Using 'next'   -- is inefficient as all operations go via 'Integer'. See@@ -182,15 +209,43 @@   genWord64R m g = runStateGen g (unsignedBitmaskWithRejectionM uniformWord64 m)   {-# INLINE genWord64R #-} -  -- | @genShortByteString n g@ returns a 'ShortByteString' of length @n@-  -- filled with pseudo-random bytes.+  -- | Same as @`uniformByteArray` `False`@, but for `ShortByteString`.   --+  -- @genShortByteString n g@ returns a 'ShortByteString' of length @n@ filled with+  -- pseudo-random bytes.+  --+  -- /Note/ - This function will be removed from the type class in the next major release as+  -- it is no longer needed because of `unsafeUniformFillMutableByteArray`.+  --   -- @since 1.2.0   genShortByteString :: Int -> g -> (ShortByteString, g)   genShortByteString n g =-    unsafePerformIO $ runStateGenT g (genShortByteStringIO n . uniformWord64)+    case uniformByteArray False n g of+      (ByteArray ba#, g') -> (SBS ba#, g')   {-# INLINE genShortByteString #-} +  -- | Fill in the supplied `MutableByteArray` with uniformly generated random bytes. This function+  -- is unsafe because it is not required to do any bounds checking. For a safe variant use+  -- `System.Random.Sateful.uniformFillMutableByteArrayM` instead.+  --+  -- Default type class implementation uses `defaultUnsafeUniformFillMutableByteArray`.+  --+  -- @since 1.3.0+  unsafeUniformFillMutableByteArray ::+       MutableByteArray s+    -- ^ Mutable array to fill with random bytes+    -> Int+    -- ^ Offset into a mutable array from the beginning in number of bytes. Offset must+    -- be non-negative, but this will not be checked+    -> Int+    -- ^ Number of randomly generated bytes to write into the array. Number of bytes+    -- must be non-negative and less then the total size of the array, minus the+    -- offset. This also will be checked.+    -> g+    -> ST s g+  unsafeUniformFillMutableByteArray = defaultUnsafeUniformFillMutableByteArray+  {-# INLINE unsafeUniformFillMutableByteArray #-}+   -- | Yields the range of values returned by 'next'.   --   -- It is required that:@@ -214,13 +269,36 @@   --   -- @since 1.0.0   split :: g -> (g, g)+  default split :: SplitGen g => g -> (g, g)+  split = splitGen +{-# DEPRECATED genShortByteString "In favor of `System.Random.uniformShortByteString`" #-}+{-# DEPRECATED split "In favor of `splitGen`" #-} +-- | Pseudo-random generators that can be split into two separate and independent+-- psuedo-random generators should provide an instance for this type class.+--+-- Historically this functionality was included in the `RandomGen` type class in the+-- `split` function, however, few pseudo-random generators possess this property of+-- splittability. This lead the old `split` function being usually implemented in terms of+-- `error`.+--+-- @since 1.3.0+class RandomGen g => SplitGen g where++  -- | Returns two distinct pseudo-random number generators.+  --+  -- Implementations should take care to ensure that the resulting generators+  -- are not correlated.+  --+  -- @since 1.3.0+  splitGen :: 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) #-}+  {-# MINIMAL uniformWord32|uniformWord64 #-}   -- | @uniformWord32R upperBound g@ generates a 'Word32' that is uniformly   -- distributed over the range @[0, upperBound]@.   --@@ -281,153 +359,245 @@     pure (shiftL (fromIntegral h32) 32 .|. fromIntegral l32)   {-# INLINE uniformWord64 #-} +  -- | @uniformByteArrayM n g@ generates a 'ByteArray' of length @n@+  -- filled with pseudo-random bytes.+  --+  -- @since 1.3.0+  uniformByteArrayM ::+       Bool -- ^ Should `ByteArray` be allocated as pinned memory or not+    -> Int -- ^ Size of the newly created `ByteArray` in number of bytes.+    -> g -- ^ Generator to use for filling in the newly created `ByteArray`+    -> m ByteArray+  default uniformByteArrayM ::+    (RandomGen f, FrozenGen f m, g ~ MutableGen f m) => Bool -> Int -> g -> m ByteArray+  uniformByteArrayM isPinned n g = modifyGen g (uniformByteArray isPinned n)+  {-# INLINE uniformByteArrayM #-}+   -- | @uniformShortByteString n g@ generates a 'ShortByteString' of length @n@   -- filled with pseudo-random bytes.   --   -- @since 1.2.0   uniformShortByteString :: Int -> g -> m ShortByteString-  default uniformShortByteString :: MonadIO m => Int -> g -> m ShortByteString-  uniformShortByteString n = genShortByteStringIO n . uniformWord64+  uniformShortByteString = uniformShortByteStringM   {-# INLINE uniformShortByteString #-}-+{-# DEPRECATED uniformShortByteString "In favor of `uniformShortByteStringM`" #-}  --- | This class is designed for stateful pseudo-random number generators that--- can be saved as and restored from an immutable data type.+-- | This class is designed for mutable pseudo-random number generators that have a frozen+-- imutable counterpart that can be manipulated in pure code. --+-- It also works great with frozen generators that are based on pure generators that have+-- a `RandomGen` instance.+--+-- Here are a few laws, which are important for this type class:+--+-- * Roundtrip and complete destruction on overwrite:+--+-- @+-- overwriteGen mg fg >> freezeGen mg = pure fg+-- @+--+-- * Modification of a mutable generator:+--+-- @+-- overwriteGen mg fg = modifyGen mg (const ((), fg)+-- @+--+-- * Freezing of a mutable generator:+--+-- @+-- freezeGen mg = modifyGen mg (\fg -> (fg, fg))+-- @+-- -- @since 1.2.0 class StatefulGen (MutableGen f m) m => FrozenGen f m where+  {-# MINIMAL (modifyGen|(freezeGen,overwriteGen)) #-}   -- | Represents the state of the pseudo-random number generator for use with   -- 'thawGen' and 'freezeGen'.   --   -- @since 1.2.0-#if __GLASGOW_HASKELL__ >= 800   type MutableGen f m = (g :: Type) | g -> f-#else-  type MutableGen f m :: *-#endif+   -- | Saves the state of the pseudo-random number generator as a frozen seed.   --   -- @since 1.2.0   freezeGen :: MutableGen f m -> m f-  -- | Restores the pseudo-random number generator from its frozen seed.+  freezeGen mg = modifyGen mg (\fg -> (fg, fg))+  {-# INLINE freezeGen #-}++  -- | Apply a pure function to the frozen pseudo-random number generator.   --+  -- @since 1.3.0+  modifyGen :: MutableGen f m -> (f -> (a, f)) -> m a+  modifyGen mg f = do+    fg <- freezeGen mg+    case f fg of+      (a, !fg') -> a <$ overwriteGen mg fg'+  {-# INLINE modifyGen #-}++  -- | Overwrite contents of the mutable pseudo-random number generator with the+  -- supplied frozen one+  --+  -- @since 1.3.0+  overwriteGen :: MutableGen f m -> f -> m ()+  overwriteGen mg fg = modifyGen mg (const ((), fg))+  {-# INLINE overwriteGen #-}++-- | Functionality for thawing frozen generators is not part of the `FrozenGen` class,+-- becase not all mutable generators support functionality of creating new mutable+-- generators, which is what thawing is in its essence. For this reason `StateGen` does+-- not have an instance for this type class, but it has one for `FrozenGen`.+--+-- Here is an important law that relates this type class to `FrozenGen`+--+-- * Roundtrip and independence of mutable generators:+--+-- @+-- traverse thawGen fgs >>= traverse freezeGen = pure fgs+-- @+--+-- @since 1.3.0+class FrozenGen f m => ThawedGen f m where+  -- | Create a new mutable pseudo-random number generator from its frozen state.+  --   -- @since 1.2.0   thawGen :: f -> m (MutableGen f m) --data MBA = MBA (MutableByteArray# RealWorld)+-- | Splits a pseudo-random number generator into two. Overwrites the mutable+-- pseudo-random number generator with one of the immutable pseudo-random number+-- generators produced by a `split` function and returns the other.+--+-- @since 1.3.0+splitGenM :: (SplitGen f, FrozenGen f m) => MutableGen f m -> m f+splitGenM = flip modifyGen splitGen +-- | Splits a pseudo-random number generator into two. Overwrites the mutable wrapper with+-- one of the resulting generators and returns the other as a new mutable generator.+--+-- @since 1.3.0+splitMutableGenM :: (SplitGen f, ThawedGen f m) => MutableGen f m -> m (MutableGen f m)+splitMutableGenM = splitGenM >=> thawGen  -- | Efficiently generates a sequence of pseudo-random bytes in a platform -- independent manner. ----- @since 1.2.0-genShortByteStringIO ::-     MonadIO m-  => Int -- ^ Number of bytes to generate-  -> m Word64 -- ^ IO action that can generate 8 random bytes at a time-  -> m ShortByteString-genShortByteStringIO n0 gen64 = do-  let !n@(I# n#) = max 0 n0-      !n64 = n `quot` 8+-- @since 1.3.0+uniformByteArray ::+     RandomGen g+  => Bool -- ^ Should byte array be allocated in pinned or unpinned memory.+  -> Int -- ^ Number of bytes to generate+  -> g -- ^ Pure pseudo-random numer generator+  -> (ByteArray, g)+uniformByteArray isPinned n0 g =+  runST $ do+    let !n = max 0 n0+    mba <-+      if isPinned+        then newPinnedMutableByteArray n+        else newMutableByteArray n+    g' <- unsafeUniformFillMutableByteArray mba 0 n g+    ba <- freezeMutableByteArray mba+    pure (ba, g')+{-# INLINE uniformByteArray #-}++-- | Using an `ST` action that generates 8 bytes at a time fill in a new `ByteArray` in+-- architecture agnostic manner.+--+-- @since 1.3.0+fillByteArrayST :: Bool -> Int -> ST s Word64 -> ST s ByteArray+fillByteArrayST isPinned n0 action = do+  let !n = max 0 n0+  mba <- if isPinned+    then newPinnedMutableByteArray n+    else newMutableByteArray n+  runIdentityT $ defaultUnsafeFillMutableByteArrayT mba 0 n (lift action)+  freezeMutableByteArray mba+{-# INLINE fillByteArrayST #-}++defaultUnsafeFillMutableByteArrayT ::+     (Monad (t (ST s)), MonadTrans t)+  => MutableByteArray s+  -> Int+  -> Int+  -> t (ST s) Word64+  -> t (ST s) ()+defaultUnsafeFillMutableByteArrayT mba offset n gen64 = do+  let !n64 = n `quot` 8+      !endIx64 = offset + n64 * 8       !nrem = n `rem` 8-  mba@(MBA mba#) <--    liftIO $ IO $ \s# ->-      case newByteArray# n# s# of-        (# s'#, mba# #) -> (# s'#, MBA mba# #)-  let go i =-        when (i < n64) $ do+  let go !i =+        when (i < endIx64) $ do           w64 <- gen64           -- Writing 8 bytes at a time in a Little-endian order gives us           -- platform portability-          liftIO $ writeWord64LE mba i w64-          go (i + 1)-  go 0+          lift $ writeWord64LE mba i w64+          go (i + 8)+  go offset   when (nrem > 0) $ do+    let !endIx = offset + n     w64 <- gen64     -- 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 #-}+    lift $ writeByteSliceWord64LE mba (endIx - nrem) endIx w64+{-# INLINEABLE defaultUnsafeFillMutableByteArrayT #-}+{-# SPECIALIZE defaultUnsafeFillMutableByteArrayT+  :: MutableByteArray s+  -> Int+  -> Int+  -> IdentityT (ST s) Word64+  -> IdentityT (ST s) () #-}+{-# SPECIALIZE defaultUnsafeFillMutableByteArrayT+  :: MutableByteArray s+  -> Int+  -> Int+  -> StateT g (ST s) Word64+  -> StateT g (ST s) () #-} -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 #-}+-- | Efficiently generates a sequence of pseudo-random bytes in a platform+-- independent manner.+--+-- @since 1.2.0+defaultUnsafeUniformFillMutableByteArray ::+     RandomGen g+  => MutableByteArray s+  -> Int -- ^ Starting offset+  -> Int -- ^ Number of random bytes to write into the array+  -> g -- ^ ST action that can generate 8 random bytes at a time+  -> ST s g+defaultUnsafeUniformFillMutableByteArray mba i0 n g =+  flip execStateT g+    $ defaultUnsafeFillMutableByteArrayT mba i0 n (state genWord64)+{-# INLINE defaultUnsafeUniformFillMutableByteArray #-}   -- | 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))+genShortByteStringST n0 action = byteArrayToShortByteString <$> fillByteArrayST False n0 action {-# INLINE genShortByteStringST #-}-+{-# DEPRECATED genShortByteStringST "In favor of `fillByteArrayST`, since `uniformShortByteString`, which it was used for, was also deprecated" #-} --- | Generates a pseudo-random 'ByteString' of the specified size.+-- | Efficiently fills in a new `ShortByteString` in a platform independent manner. -- -- @since 1.2.0-uniformByteStringM :: StatefulGen g m => Int -> g -> m ByteString-uniformByteStringM n g = do-  ba <- uniformShortByteString n g-  pure $-#if __GLASGOW_HASKELL__ < 802-       fromShort ba-#else-    let !(SBS ba#) = ba in-    if isTrue# (isByteArrayPinned# ba#)-      then pinnedByteArrayToByteString ba#-      else fromShort ba-{-# INLINE uniformByteStringM #-}--pinnedByteArrayToByteString :: ByteArray# -> ByteString-pinnedByteArrayToByteString ba# =-  PS (pinnedByteArrayToForeignPtr ba#) 0 (I# (sizeofByteArray# ba#))-{-# INLINE pinnedByteArrayToByteString #-}--pinnedByteArrayToForeignPtr :: ByteArray# -> ForeignPtr a-pinnedByteArrayToForeignPtr ba# =-  ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#))-{-# INLINE pinnedByteArrayToForeignPtr #-}-#endif+genShortByteStringIO ::+     Int -- ^ Number of bytes to generate+  -> IO Word64 -- ^ IO action that can generate 8 random bytes at a time+  -> IO ShortByteString+genShortByteStringIO n ioAction = stToIO $ genShortByteStringST n (ioToST ioAction)+{-# INLINE genShortByteStringIO #-}+{-# DEPRECATED genShortByteStringIO "In favor of `fillByteArrayST`" #-} +-- | @uniformShortByteString n g@ generates a 'ShortByteString' of length @n@+-- filled with pseudo-random bytes.+--+-- @since 1.3.0+uniformShortByteStringM :: StatefulGen g m => Int -> g -> m ShortByteString+uniformShortByteStringM n g = byteArrayToShortByteString <$> uniformByteArrayM False n g+{-# INLINE uniformShortByteStringM #-}  -- | Opaque data type that carries the type of a pure pseudo-random number -- generator.@@ -440,7 +610,7 @@ -- -- @since 1.2.0 newtype StateGen g = StateGen { unStateGen :: g }-  deriving (Eq, Ord, Show, RandomGen, Storable, NFData)+  deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData)  instance (RandomGen g, MonadState g m) => StatefulGen (StateGenM g) m where   uniformWord32R r _ = state (genWord32R r)@@ -455,21 +625,14 @@   {-# 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   freezeGen _ = fmap StateGen get-  thawGen (StateGen g) = StateGenM <$ put g---- | Splits a pseudo-random number generator into two. Updates the state with--- one of the resulting generators and returns the other.------ @since 1.2.0-splitGen :: (MonadState g m, RandomGen g) => m g-splitGen = state split-{-# INLINE splitGen #-}+  modifyGen _ f = state (coerce f)+  {-# INLINE modifyGen #-}+  overwriteGen _ f = put (coerce f)+  {-# INLINE overwriteGen #-}  -- | Runs a monadic generating action in the `State` monad using a pure -- pseudo-random number generator.@@ -551,9 +714,40 @@ {-# INLINE runStateGenST_ #-}  +-- | Generates a list of pseudo-random values.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> g <- newIOGenM pureGen+-- >>> uniformListM 10 g :: IO [Bool]+-- [True,True,True,True,False,True,True,False,False,False]+--+-- @since 1.2.0+uniformListM :: (StatefulGen g m, Uniform a) => Int -> g -> m [a]+uniformListM n gen = replicateM n (uniformM gen)+{-# INLINE uniformListM #-}+++-- | Generates a list of pseudo-random values in a specified range.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> g <- newIOGenM pureGen+-- >>> uniformListRM 10 (20, 30) g :: IO [Int]+-- [23,21,28,25,28,28,26,25,29,27]+--+-- @since 1.3.0+uniformListRM :: (StatefulGen g m, UniformRange a) => Int -> (a, a) -> g -> m [a]+uniformListRM n range gen = replicateM n (uniformRM range gen)+{-# INLINE uniformListRM #-}+ -- | The standard pseudo-random number generator. newtype StdGen = StdGen { unStdGen :: SM.SMGen }-  deriving (Show, RandomGen, NFData)+  deriving (Show, RandomGen, SplitGen, NFData)  instance Eq StdGen where   StdGen x1 == StdGen x2 = SM.unseedSMGen x1 == SM.unseedSMGen x2@@ -565,9 +759,16 @@   {-# INLINE genWord32 #-}   genWord64 = SM.nextWord64   {-# INLINE genWord64 #-}-  split = SM.splitSMGen-  {-# INLINE split #-}+  -- Despite that this is the same default implementation as in the type class definition,+  -- for some mysterious reason without this overwrite, performance of ByteArray generation+  -- slows down by a factor of x4:+  unsafeUniformFillMutableByteArray = defaultUnsafeUniformFillMutableByteArray+  {-# INLINE unsafeUniformFillMutableByteArray #-} +instance SplitGen SM.SMGen where+  splitGen = SM.splitSMGen+  {-# INLINE splitGen #-}+ instance RandomGen SM32.SMGen where   next = SM32.nextInt   {-# INLINE next #-}@@ -575,13 +776,26 @@   {-# INLINE genWord32 #-}   genWord64 = SM32.nextWord64   {-# INLINE genWord64 #-}-  split = SM32.splitSMGen-  {-# INLINE split #-} --- | Constructs a 'StdGen' deterministically.+instance SplitGen SM32.SMGen where+  splitGen = SM32.splitSMGen+  {-# INLINE splitGen #-}++-- | Constructs a 'StdGen' deterministically from an `Int` seed. See `mkStdGen64` for a `Word64`+-- variant that is architecture agnostic. mkStdGen :: Int -> StdGen-mkStdGen = StdGen . SM.mkSMGen . fromIntegral+mkStdGen = mkStdGen64 . fromIntegral +-- | Constructs a 'StdGen' deterministically from a `Word64` seed.+--+-- The difference between `mkStdGen` is that `mkStdGen64` will work the same on 64-bit and+-- 32-bit architectures, while the former can only use 32-bit of information for+-- initializing the psuedo-random number generator on 32-bit operating systems+--+-- @since 1.3.0+mkStdGen64 :: Word64 -> StdGen+mkStdGen64 = StdGen . SM.mkSMGen+ -- | Global mutable veriable with `StdGen` theStdGen :: IORef StdGen theStdGen = unsafePerformIO $ SM.initSMGen >>= newIORef . StdGen@@ -598,7 +812,7 @@   --   -- There is a default implementation via 'Generic':   ---  -- >>> :set -XDeriveGeneric -XDeriveAnyClass+  -- >>> :seti -XDeriveGeneric -XDeriveAnyClass   -- >>> import GHC.Generics (Generic)   -- >>> import System.Random.Stateful   -- >>> data MyBool = MyTrue | MyFalse deriving (Show, Generic, Finite, Uniform)@@ -657,7 +871,7 @@ -- 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+-- >>> :seti -XDeriveGeneric -XDeriveAnyClass -- >>> import GHC.Generics (Generic) -- >>> import System.Random.Stateful -- >>> data Triple = Triple Word8 Word8 Word8 deriving (Show, Generic, Finite)@@ -688,16 +902,121 @@   --   -- > uniformRM (a, b) = uniformRM (b, a)   --+  -- The range is understood as defined by means of 'isInRange', so+  --+  -- > isInRange (a, b) <$> uniformRM (a, b) gen == pure True+  --+  -- but beware of+  -- [floating point number caveats](System-Random-Stateful.html#fpcaveats).+  --+  -- There is a default implementation via 'Generic':+  --+  -- >>> :seti -XDeriveGeneric -XDeriveAnyClass+  -- >>> import GHC.Generics (Generic)+  -- >>> import Data.Word (Word8)+  -- >>> import Control.Monad (replicateM)+  -- >>> import System.Random.Stateful+  -- >>> gen <- newIOGenM (mkStdGen 42)+  -- >>> data Tuple = Tuple Bool Word8 deriving (Show, Generic, UniformRange)+  -- >>> replicateM 10 (uniformRM (Tuple False 100, Tuple True 150) gen)+  -- [Tuple False 102,Tuple True 118,Tuple False 115,Tuple True 113,Tuple True 126,Tuple False 127,Tuple True 130,Tuple False 113,Tuple False 150,Tuple False 125]+  --   -- @since 1.2.0   uniformRM :: StatefulGen g m => (a, a) -> g -> m a +  -- | A notion of (inclusive) ranges prescribed to @a@.+  --+  -- Ranges are symmetric:+  --+  -- > isInRange (lo, hi) x == isInRange (hi, lo) x+  --+  -- Ranges include their endpoints:+  --+  -- > isInRange (lo, hi) lo == True+  --+  -- When endpoints coincide, there is nothing else:+  --+  -- > isInRange (x, x) y == x == y+  --+  -- Endpoints are endpoints:+  --+  -- > isInRange (lo, hi) x ==>+  -- > isInRange (lo, x) hi == x == hi+  --+  -- Ranges are transitive relations:+  --+  -- > isInRange (lo, hi) lo' && isInRange (lo, hi) hi' && isInRange (lo', hi') x+  -- > ==> isInRange (lo, hi) x+  --+  -- There is a default implementation of 'isInRange' via 'Generic'. Other helper function+  -- that can be used for implementing this function are `isInRangeOrd` and+  -- `isInRangeEnum`.+  --+  -- Note that the @isRange@ method from @Data.Ix@ is /not/ a suitable default+  -- implementation of 'isInRange'. Unlike 'isInRange', @isRange@ is not+  -- required to be symmetric, and many @isRange@ implementations are not+  -- symmetric in practice.+  --+  -- @since 1.3.0+  isInRange :: (a, a) -> a -> Bool++  default uniformRM :: (StatefulGen g m, Generic a, GUniformRange (Rep a)) => (a, a) -> g -> m a+  uniformRM (a, b) = fmap to . (`runContT` pure) . guniformRM (from a, from b)+  {-# INLINE uniformRM #-}++  default isInRange :: (Generic a, GUniformRange (Rep a)) => (a, a) -> a -> Bool+  isInRange (a, b) x = gisInRange (from a, from b) (from x)+  {-# INLINE isInRange #-}++class GUniformRange f where+  guniformRM :: StatefulGen g m => (f a, f a) -> g -> ContT r m (f a)+  gisInRange :: (f a, f a) -> f a -> Bool++instance GUniformRange f => GUniformRange (M1 i c f) where+  guniformRM (M1 a, M1 b) = fmap M1 . guniformRM (a, b)+  {-# INLINE guniformRM #-}+  gisInRange (M1 a, M1 b) (M1 x) = gisInRange (a, b) x++instance UniformRange a => GUniformRange (K1 i a) where+  guniformRM (K1 a, K1 b) = fmap K1 . lift . uniformRM (a, b)+  {-# INLINE guniformRM #-}+  gisInRange (K1 a, K1 b) (K1 x) = isInRange (a, b) x++instance GUniformRange U1 where+  guniformRM = const $ const $ return U1+  {-# INLINE guniformRM #-}+  gisInRange = const $ const True++instance (GUniformRange f, GUniformRange g) => GUniformRange (f :*: g) where+  guniformRM (x1 :*: y1, x2 :*: y2) g =+    (:*:) <$> guniformRM (x1, x2) g <*> guniformRM (y1, y2) g+  {-# INLINE guniformRM #-}+  gisInRange (x1 :*: y1, x2 :*: y2) (x3 :*: y3) =+    gisInRange (x1, x2) x3 && gisInRange (y1, y2) y3++-- | Utilize `Ord` instance to decide if a value is within the range. Designed to be used+-- for implementing `isInRange`+--+-- @since 1.3.0+isInRangeOrd :: Ord a => (a, a) -> a -> Bool+isInRangeOrd (a, b) x = min a b <= x && x <= max a b++-- | Utilize `Enum` instance to decide if a value is within the range. Designed to be used+-- for implementing `isInRange`+--+-- @since 1.3.0+isInRangeEnum :: Enum a => (a, a) -> a -> Bool+isInRangeEnum (a, b) x = isInRangeOrd (fromEnum a, fromEnum b) (fromEnum x)+ instance UniformRange Integer where   uniformRM = uniformIntegralM   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance UniformRange Natural where   uniformRM = uniformIntegralM   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Int8 where   uniformM = fmap (fromIntegral :: Word8 -> Int8) . uniformWord8@@ -705,6 +1024,7 @@ instance UniformRange Int8 where   uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Int16 where   uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16@@ -712,6 +1032,7 @@ instance UniformRange Int16 where   uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Int32 where   uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32@@ -719,6 +1040,7 @@ instance UniformRange Int32 where   uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Int64 where   uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64@@ -726,9 +1048,7 @@ instance UniformRange Int64 where   uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int64 -> Word64) fromIntegral   {-# INLINE uniformRM #-}--wordSizeInBits :: Int-wordSizeInBits = finiteBitSize (0 :: Word)+  isInRange = isInRangeOrd  instance Uniform Int where   uniformM@@ -741,6 +1061,7 @@ instance UniformRange Int where   uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int -> Word) fromIntegral   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Word where   uniformM@@ -753,13 +1074,32 @@ instance UniformRange Word where   uniformRM = unsignedBitmaskWithRejectionRM   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd +-- | Architecture specific `Word` generation in the specified lower range+--+-- @since 1.3.0+uniformWordR ::+    StatefulGen g m+  => Word+  -- ^ Maximum value to generate+  -> g+  -- ^ Stateful generator+  -> m Word+uniformWordR r+  | wordSizeInBits == 64 =+    fmap (fromIntegral :: Word64 -> Word) . uniformWord64R ((fromIntegral :: Word -> Word64) r)+  | otherwise =+    fmap (fromIntegral :: Word32 -> Word) . uniformWord32R ((fromIntegral :: Word -> Word32) r)+{-# INLINE uniformWordR #-}+ instance Uniform Word8 where   uniformM = uniformWord8   {-# INLINE uniformM #-} instance UniformRange Word8 where   uniformRM = unbiasedWordMult32RM   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Word16 where   uniformM = uniformWord16@@ -767,6 +1107,7 @@ instance UniformRange Word16 where   uniformRM = unbiasedWordMult32RM   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Word32 where   uniformM  = uniformWord32@@ -774,6 +1115,7 @@ instance UniformRange Word32 where   uniformRM = unbiasedWordMult32RM   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform Word64 where   uniformM  = uniformWord64@@ -781,6 +1123,7 @@ instance UniformRange Word64 where   uniformRM = unsignedBitmaskWithRejectionRM   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  #if __GLASGOW_HASKELL__ >= 802 instance Uniform CBool where@@ -789,6 +1132,7 @@ instance UniformRange CBool where   uniformRM (CBool b, CBool t) = fmap CBool . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd #endif  instance Uniform CChar where@@ -797,6 +1141,7 @@ instance UniformRange CChar where   uniformRM (CChar b, CChar t) = fmap CChar . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CSChar where   uniformM = fmap CSChar . uniformM@@ -804,6 +1149,7 @@ instance UniformRange CSChar where   uniformRM (CSChar b, CSChar t) = fmap CSChar . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CUChar where   uniformM = fmap CUChar . uniformM@@ -811,6 +1157,7 @@ instance UniformRange CUChar where   uniformRM (CUChar b, CUChar t) = fmap CUChar . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CShort where   uniformM = fmap CShort . uniformM@@ -818,6 +1165,7 @@ instance UniformRange CShort where   uniformRM (CShort b, CShort t) = fmap CShort . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CUShort where   uniformM = fmap CUShort . uniformM@@ -825,6 +1173,7 @@ instance UniformRange CUShort where   uniformRM (CUShort b, CUShort t) = fmap CUShort . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CInt where   uniformM = fmap CInt . uniformM@@ -832,6 +1181,7 @@ instance UniformRange CInt where   uniformRM (CInt b, CInt t) = fmap CInt . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CUInt where   uniformM = fmap CUInt . uniformM@@ -839,6 +1189,7 @@ instance UniformRange CUInt where   uniformRM (CUInt b, CUInt t) = fmap CUInt . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CLong where   uniformM = fmap CLong . uniformM@@ -846,6 +1197,7 @@ instance UniformRange CLong where   uniformRM (CLong b, CLong t) = fmap CLong . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CULong where   uniformM = fmap CULong . uniformM@@ -853,6 +1205,7 @@ instance UniformRange CULong where   uniformRM (CULong b, CULong t) = fmap CULong . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CPtrdiff where   uniformM = fmap CPtrdiff . uniformM@@ -860,6 +1213,7 @@ instance UniformRange CPtrdiff where   uniformRM (CPtrdiff b, CPtrdiff t) = fmap CPtrdiff . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CSize where   uniformM = fmap CSize . uniformM@@ -867,6 +1221,7 @@ instance UniformRange CSize where   uniformRM (CSize b, CSize t) = fmap CSize . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CWchar where   uniformM = fmap CWchar . uniformM@@ -874,6 +1229,7 @@ instance UniformRange CWchar where   uniformRM (CWchar b, CWchar t) = fmap CWchar . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CSigAtomic where   uniformM = fmap CSigAtomic . uniformM@@ -881,6 +1237,7 @@ instance UniformRange CSigAtomic where   uniformRM (CSigAtomic b, CSigAtomic t) = fmap CSigAtomic . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CLLong where   uniformM = fmap CLLong . uniformM@@ -888,6 +1245,7 @@ instance UniformRange CLLong where   uniformRM (CLLong b, CLLong t) = fmap CLLong . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CULLong where   uniformM = fmap CULLong . uniformM@@ -895,6 +1253,7 @@ instance UniformRange CULLong where   uniformRM (CULLong b, CULLong t) = fmap CULLong . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CIntPtr where   uniformM = fmap CIntPtr . uniformM@@ -902,6 +1261,7 @@ instance UniformRange CIntPtr where   uniformRM (CIntPtr b, CIntPtr t) = fmap CIntPtr . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CUIntPtr where   uniformM = fmap CUIntPtr . uniformM@@ -909,6 +1269,7 @@ instance UniformRange CUIntPtr where   uniformRM (CUIntPtr b, CUIntPtr t) = fmap CUIntPtr . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CIntMax where   uniformM = fmap CIntMax . uniformM@@ -916,6 +1277,7 @@ instance UniformRange CIntMax where   uniformRM (CIntMax b, CIntMax t) = fmap CIntMax . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform CUIntMax where   uniformM = fmap CUIntMax . uniformM@@ -923,17 +1285,19 @@ instance UniformRange CUIntMax where   uniformRM (CUIntMax b, CUIntMax t) = fmap CUIntMax . uniformRM (b, t)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  -- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). instance UniformRange CFloat where   uniformRM (CFloat l, CFloat h) = fmap CFloat . uniformRM (l, h)   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  -- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats). instance UniformRange CDouble where   uniformRM (CDouble l, CDouble h) = fmap CDouble . uniformRM (l, h)   {-# INLINE uniformRM #-}-+  isInRange = isInRangeOrd  -- The `chr#` and `ord#` are the prim functions that will be called, regardless of which -- way you gonna do the `Char` conversion, so it is better to call them directly and@@ -964,6 +1328,7 @@   uniformRM (l, h) g =     word32ToChar <$> unbiasedWordMult32RM (charToWord32 l, charToWord32 h) g   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  instance Uniform () where   uniformM = const $ pure ()@@ -982,21 +1347,30 @@   uniformRM (True, True)   _g = return True   uniformRM _               g = uniformM g   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd +instance (Finite a, Uniform a) => Uniform (Maybe a)++instance (Finite a, Uniform a, Finite b, Uniform b) => Uniform (Either a b)+ -- | 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+      --    (+Infinity) + (-Infinity) = NaN+      --    (-Infinity) + (+Infinity) = NaN+      --    (+Infinity) + _           = +Infinity+      --    (-Infinity) + _           = -Infinity+      --              _ + (+Infinity) = +Infinity+      --              _ + (-Infinity) = -Infinity       return $! h + l     | otherwise = do-      x <- uniformDouble01M g-      return $ x * l + (1 -x) * h+      w64 <- uniformWord64 g+      pure $! scaleFloating l h w64   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd  -- | Generates uniformly distributed 'Double' in the range \([0, 1]\). --   Numbers are generated by generating uniform 'Word64' and dividing@@ -1032,15 +1406,48 @@     | l == h = return l     | isInfinite l || isInfinite h =       -- Optimisation exploiting absorption:-      --   (-Infinity) + (anything but +Infinity) = -Infinity-      --   (anything but -Infinity) + (+Infinity) = +Infinity-      --                (-Infinity) + (+Infinity) = NaN+      --    (+Infinity) + (-Infinity) = NaN+      --    (-Infinity) + (+Infinity) = NaN+      --    (+Infinity) + _           = +Infinity+      --    (-Infinity) + _           = -Infinity+      --              _ + (+Infinity) = +Infinity+      --              _ + (-Infinity) = -Infinity       return $! h + l     | otherwise = do-      x <- uniformFloat01M g-      return $ x * l + (1 - x) * h+      w32 <- uniformWord32 g+      pure $! scaleFloating l h w32   {-# INLINE uniformRM #-}+  isInRange = isInRangeOrd +-- | This is the function that is used to scale a floating point value from random word range to+-- the custom @[low, high]@ range.+--+-- @since 1.3.0+scaleFloating ::+     forall a w. (RealFloat a, Integral w, Bounded w, FiniteBits w)+  => a+  -- ^ Low+  -> a+  -- ^ High+  -> w+  -- ^ Uniformly distributed unsigned integral value that will be used for converting to a floating+  -- point value and subsequent scaling to the specified range+  -> a+scaleFloating l h w =+  if isInfinite diff+    then let !x = fromIntegral w / m+             !y = x * l + (1 - x) * h+          in max (min y (max l h)) (min l h)+    else let !topMostBit = finiteBitSize w - 1+             !x = fromIntegral (clearBit w topMostBit) / m+          in if testBit w topMostBit+               then l + diff * x+               else h + negate diff * x+  where+    !diff = h - l+    !m = fromIntegral (maxBound :: w) :: a+{-# INLINE scaleFloating #-}+ -- | 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 'UniformRange' instance for 'Float'.@@ -1073,7 +1480,7 @@ -- > data Colors = Red | Green | Blue deriving (Enum, Bounded) -- > instance Uniform Colors where uniformM = uniformEnumM ----- @since 1.2.1+-- @since 1.3.0 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 #-}@@ -1086,7 +1493,7 @@ -- >   uniformRM = uniformEnumRM -- >   inInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x) ----- @since 1.2.1+-- @since 1.3.0 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 #-}@@ -1334,6 +1741,13 @@                <*> uniformM g                <*> uniformM g   {-# INLINE uniformM #-}++instance (UniformRange a, UniformRange b) => UniformRange (a, b)+instance (UniformRange a, UniformRange b, UniformRange c) => UniformRange (a, b, c)+instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d) => UniformRange (a, b, c, d)+instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e) => UniformRange (a, b, c, d, e)+instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e, UniformRange f) => UniformRange (a, b, c, d, e, f)+instance (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e, UniformRange f, UniformRange g) => UniformRange (a, b, c, d, e, f, g)  -- Appendix 1. --

+ src/System/Random/Seed.hs view

@@ -0,0 +1,333 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- |+-- Module      :  System.Random.Seed+-- Copyright   :  (c) Alexey Kuleshevich 2024+-- License     :  BSD-style (see the file LICENSE in the 'random' repository)+-- Maintainer  :  libraries@haskell.org+--++module System.Random.Seed+  ( SeedGen(..)+  , -- ** Seed+    Seed+  , seedSize+  , seedSizeProxy+  , mkSeed+  , unSeed+  , mkSeedFromByteString+  , unSeedToByteString+  , withSeed+  , withSeedM+  , withSeedFile+  , seedGenTypeName+  , nonEmptyToSeed+  , nonEmptyFromSeed+  ) where++import Control.Monad (unless)+import qualified Control.Monad.Fail as F+import Control.Monad.IO.Class+import Control.Monad.ST+import Control.Monad.State.Strict (get, put, runStateT)+import Data.Array.Byte (ByteArray(..))+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short.Internal as SBS (fromShort, toShort)+import Data.Coerce+import Data.Functor.Identity (runIdentity)+import Data.List.NonEmpty as NE (NonEmpty(..), nonEmpty, toList)+import Data.Typeable+import Data.Word+import GHC.Exts (Proxy#, proxy#)+import GHC.TypeLits (Nat, KnownNat, natVal', type (<=))+import System.Random.Internal+import qualified System.Random.SplitMix as SM+import qualified System.Random.SplitMix32 as SM32+++-- | Interface for converting a pure pseudo-random number generator to and from non-empty+-- sequence of bytes. Seeds are stored in Little-Endian order regardless of the platform+-- it is being used on, which provides cross-platform compatibility, while providing+-- optimal performance for the most common platform type.+--+-- Conversion to and from a `Seed` serves as a building block for implementing+-- serialization for any pure or frozen pseudo-random number generator.+--+-- It is not trivial to implement platform independence. For this reason this type class+-- has two alternative ways of creating an instance for this class. The easiest way for+-- constructing a platform indepent seed is by converting the inner state of a generator+-- to and from a list of 64 bit words using `toSeed64` and `fromSeed64` respectively. In+-- that case cross-platform support will be handled automaticaly.+--+-- >>> :set -XDataKinds -XTypeFamilies+-- >>> import Data.Word (Word8, Word32)+-- >>> import Data.Bits ((.|.), shiftR, shiftL)+-- >>> import Data.List.NonEmpty (NonEmpty ((:|)))+-- >>> data FiveByteGen = FiveByteGen Word8 Word32 deriving Show+-- >>> :{+-- instance SeedGen FiveByteGen where+--   type SeedSize FiveByteGen = 5+--   fromSeed64 (w64 :| _) =+--     FiveByteGen (fromIntegral (w64 `shiftR` 32)) (fromIntegral w64)+--   toSeed64 (FiveByteGen x1 x4) =+--     let w64 = (fromIntegral x1 `shiftL` 32) .|. fromIntegral x4+--      in (w64 :| [])+-- :}+--+-- >>> FiveByteGen 0x80 0x01020304+-- FiveByteGen 128 16909060+-- >>> fromSeed (toSeed (FiveByteGen 0x80 0x01020304))+-- FiveByteGen 128 16909060+-- >>> toSeed (FiveByteGen 0x80 0x01020304)+-- Seed [0x04, 0x03, 0x02, 0x01, 0x80]+-- >>> toSeed64 (FiveByteGen 0x80 0x01020304)+-- 549772722948 :| []+--+-- However, when performance is of utmost importance or default handling of cross platform+-- independence is not sufficient, then an adventurous developer can try implementing+-- conversion into bytes directly with `toSeed` and `fromSeed`.+--+-- Properties that must hold:+--+-- @+-- > fromSeed (toSeed gen) == gen+-- @+--+-- @+-- > fromSeed64 (toSeed64 gen) == gen+-- @+--+-- Note, that there is no requirement for every `Seed` to roundtrip, eg. this proprty does+-- not even hold for `StdGen`:+--+-- >>> let seed = nonEmptyToSeed (0xab :| [0xff00]) :: Seed StdGen+-- >>> seed == toSeed (fromSeed seed)+-- False+--+-- @since 1.3.0+class (KnownNat (SeedSize g), 1 <= SeedSize g, Typeable g) => SeedGen g where+  -- | Number of bytes that is required for storing the full state of a pseudo-random+  -- number generator. It should be big enough to satisfy the roundtrip property:+  --+  -- @+  -- > fromSeed (toSeed gen) == gen+  -- @+  --+  type SeedSize g :: Nat+  {-# MINIMAL (fromSeed, toSeed)|(fromSeed64, toSeed64) #-}++  -- | Convert from a binary representation to a pseudo-random number generator+  --+  -- @since 1.3.0+  fromSeed :: Seed g -> g+  fromSeed = fromSeed64 . nonEmptyFromSeed++  -- | Convert to a binary representation of a pseudo-random number generator+  --+  -- @since 1.3.0+  toSeed :: g -> Seed g+  toSeed = nonEmptyToSeed . toSeed64++  -- | Construct pseudo-random number generator from a list of words. Whenever list does+  -- not have enough bytes to satisfy the `SeedSize` requirement, it will be padded with+  -- zeros. On the other hand when it has more than necessary, extra bytes will be dropped.+  --+  -- For example if `SeedSize` is set to 2, then only the lower 16 bits of the first+  -- element in the list will be used.+  --+  -- @since 1.3.0+  fromSeed64 :: NonEmpty Word64 -> g+  fromSeed64 = fromSeed . nonEmptyToSeed++  -- | Convert pseudo-random number generator to a list of words+  --+  -- In case when `SeedSize` is not a multiple of 8, then the upper bits of the last word+  -- in the list will be set to zero.+  --+  -- @since 1.3.0+  toSeed64 :: g -> NonEmpty Word64+  toSeed64 = nonEmptyFromSeed . toSeed++instance SeedGen StdGen where+  type SeedSize StdGen = SeedSize SM.SMGen+  fromSeed = coerce (fromSeed :: Seed SM.SMGen -> SM.SMGen)+  toSeed = coerce (toSeed :: SM.SMGen -> Seed SM.SMGen)++instance SeedGen g => SeedGen (StateGen g) where+  type SeedSize (StateGen g) = SeedSize g+  fromSeed = coerce (fromSeed :: Seed g -> g)+  toSeed = coerce (toSeed :: g -> Seed g)++instance SeedGen SM.SMGen where+  type SeedSize SM.SMGen = 16+  fromSeed (Seed ba) =+    SM.seedSMGen (indexWord64LE ba 0) (indexWord64LE ba 8)+  toSeed g =+    case SM.unseedSMGen g of+      (seed, gamma) -> Seed $ runST $ do+        mba <- newMutableByteArray 16+        writeWord64LE mba 0 seed+        writeWord64LE mba 8 gamma+        freezeMutableByteArray mba++instance SeedGen SM32.SMGen where+  type SeedSize SM32.SMGen = 8+  fromSeed (Seed ba) =+    let x = indexWord64LE ba 0+        seed, gamma :: Word32+        seed = fromIntegral (shiftR x 32)+        gamma = fromIntegral x+    in SM32.seedSMGen seed gamma+  toSeed g =+    let seed, gamma :: Word32+        (seed, gamma) = SM32.unseedSMGen g+    in Seed $ runST $ do+        mba <- newMutableByteArray 8+        let w64 :: Word64+            w64 = shiftL (fromIntegral seed) 32 .|. fromIntegral gamma+        writeWord64LE mba 0 w64+        freezeMutableByteArray mba++instance SeedGen g => Uniform (Seed g) where+  uniformM = fmap Seed . uniformByteArrayM False (seedSize @g)++-- | Get the expected size of the `Seed` in number bytes+--+-- @since 1.3.0+seedSize :: forall g. SeedGen g => Int+seedSize = fromInteger $ natVal' (proxy# :: Proxy# (SeedSize g))++-- | Just like `seedSize`, except it accepts a proxy as an argument.+--+-- @since 1.3.0+seedSizeProxy :: forall proxy g. SeedGen g => proxy g -> Int+seedSizeProxy _px = seedSize @g++-- | Construct a `Seed` from a `ByteArray` of expected length. Whenever `ByteArray` does+-- not match the `SeedSize` specified by the pseudo-random generator, this function will+-- `F.fail`.+--+-- @since 1.3.0+mkSeed :: forall g m. (SeedGen g, F.MonadFail m) => ByteArray -> m (Seed g)+mkSeed ba = do+  unless (sizeOfByteArray ba == seedSize @g) $ do+    F.fail $ "Unexpected number of bytes: "+        ++ show (sizeOfByteArray ba)+        ++ ". Exactly "+        ++ show (seedSize @g)+        ++ " bytes is required by the "+        ++ show (seedGenTypeName @g)+  pure $ Seed ba++-- | Helper function that allows for operating directly on the `Seed`, while supplying a+-- function that uses the pseudo-random number generator that is constructed from that+-- `Seed`.+--+-- ====__Example__+--+-- >>> :set -XTypeApplications+-- >>> import System.Random+-- >>> withSeed (nonEmptyToSeed (pure 2024) :: Seed StdGen) (uniform @Int)+-- (1039666877624726199,Seed [0xe9, 0x07, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00])+--+-- @since 1.3.0+withSeed :: SeedGen g => Seed g -> (g -> (a, g)) -> (a, Seed g)+withSeed seed f = runIdentity (withSeedM seed (pure . f))++-- | Same as `withSeed`, except it is useful with monadic computation and frozen generators.+--+-- See `System.Random.Stateful.withSeedMutableGen` for a helper that also handles seeds+-- for mutable pseduo-random number generators.+--+-- @since 1.3.0+withSeedM :: (SeedGen g, Functor f) => Seed g -> (g -> f (a, g)) -> f (a, Seed g)+withSeedM seed f = fmap toSeed <$> f (fromSeed seed)++-- | This is a function that shows the name of the generator type, which is useful for+-- error reporting.+--+-- @since 1.3.0+seedGenTypeName :: forall g. SeedGen g => String+seedGenTypeName = show (typeOf (Proxy @g))+++-- | Just like `mkSeed`, but uses `ByteString` as argument. Results in a memcopy of the seed.+--+-- @since 1.3.0+mkSeedFromByteString :: (SeedGen g, F.MonadFail m) => BS.ByteString -> m (Seed g)+mkSeedFromByteString = mkSeed . shortByteStringToByteArray . SBS.toShort++-- | Unwrap the `Seed` and get the underlying `ByteArray`+--+-- @since 1.3.0+unSeed :: Seed g -> ByteArray+unSeed (Seed ba) = ba++-- | Just like `unSeed`, but produced a `ByteString`. Results in a memcopy of the seed.+--+-- @since 1.3.0+unSeedToByteString :: Seed g -> BS.ByteString+unSeedToByteString = SBS.fromShort . byteArrayToShortByteString . unSeed+++-- | Read the seed from a file and use it for constructing a pseudo-random number+-- generator. After supplied action has been applied to the constructed generator, the+-- resulting generator will be converted back to a seed and written to the same file.+--+-- @since 1.3.0+withSeedFile :: (SeedGen g, MonadIO m) => FilePath -> (Seed g -> m (a, Seed g)) -> m a+withSeedFile fileName action = do+  bs <- liftIO $ BS.readFile fileName+  seed <- liftIO $ mkSeedFromByteString bs+  (res, seed') <- action seed+  liftIO $ BS.writeFile fileName $ unSeedToByteString seed'+  pure res++-- | Construct a seed from a list of 64-bit words. At most `SeedSize` many bytes will be used.+--+-- @since 1.3.0+nonEmptyToSeed :: forall g. SeedGen g => NonEmpty Word64 -> Seed g+nonEmptyToSeed xs = Seed $ runST $ do+  let n = seedSize @g+  mba <- newMutableByteArray n+  _ <- flip runStateT (NE.toList xs) $ do+    defaultUnsafeFillMutableByteArrayT mba 0 n $ do+      get >>= \case+        [] -> pure 0+        w:ws -> w <$ put ws+  freezeMutableByteArray mba++-- | Convert a `Seed` to a list of 64bit words.+--+-- @since 1.3.0+nonEmptyFromSeed :: forall g. SeedGen g => Seed g -> NonEmpty Word64+nonEmptyFromSeed (Seed ba) =+  case nonEmpty $ reverse $ goWord64 0 [] of+    Just ne -> ne+    Nothing -> -- Seed is at least 1 byte in size, so it can't be empty+      error $ "Impossible: Seed for "+           ++ seedGenTypeName @g+           ++ " must be at least: "+           ++ show (seedSize @g)+           ++ " bytes, but got "+           ++ show n+  where+    n = sizeOfByteArray ba+    n8 = 8 * (n `quot` 8)+    goWord64 i !acc+      | i < n8 = goWord64 (i + 8) (indexWord64LE ba i : acc)+      | i == n = acc+      | otherwise = indexByteSliceWord64LE ba i n : acc

src/System/Random/Stateful.hs view

@@ -1,13 +1,13 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}- -- | -- Module      :  System.Random.Stateful -- Copyright   :  (c) The University of Glasgow 2001@@ -28,19 +28,33 @@    -- * Mutable pseudo-random number generator interfaces   -- $interfaces-  , StatefulGen(..)+  , StatefulGen+      ( uniformWord32R+      , uniformWord64R+      , uniformWord8+      , uniformWord16+      , uniformWord32+      , uniformWord64+      , uniformShortByteString+      )   , FrozenGen(..)-  , RandomGenM(..)+  , ThawedGen(..)   , withMutableGen   , withMutableGen_+  , withSeedMutableGen+  , withSeedMutableGen_   , randomM   , randomRM   , splitGenM+  , splitMutableGenM +  -- ** Deprecated+  , RandomGenM(..)+   -- * Monadic adapters for pure pseudo-random number generators #monadicadapters#   -- $monadicadapters -  -- ** Pure adapter+  -- ** Pure adapter in 'MonadState'   , StateGen(..)   , StateGenM(..)   , runStateGen@@ -49,7 +63,7 @@   , runStateGenT_   , runStateGenST   , runStateGenST_-  -- ** Mutable adapter with atomic operations+  -- ** Mutable thread-safe adapter in 'IO'   , AtomicGen(..)   , AtomicGenM(..)   , newAtomicGenM@@ -67,7 +81,7 @@   , applySTGen   , runSTGen   , runSTGen_-  -- ** Mutable adapter in 'STM'+  -- ** Mutable thread-safe adapter in 'STM'   , TGen(..)   , TGenM(..)   , newTGenM@@ -77,27 +91,45 @@   -- * Pseudo-random values of various types   -- $uniform   , Uniform(..)-  , uniformListM   , uniformViaFiniteM   , UniformRange(..)+  , isInRangeOrd+  , isInRangeEnum -  -- * Generators for sequences of pseudo-random bytes+  -- ** Lists+  , uniformListM+  , uniformListRM+  , uniformShuffleListM++  -- ** Generators for sequences of pseudo-random bytes+  , uniformByteArrayM+  , uniformByteStringM+  , uniformShortByteStringM++  -- * Helper functions for createing instances+  -- ** Sequences of bytes+  , fillByteArrayST   , genShortByteStringIO   , genShortByteStringST-  , uniformByteStringM+  , defaultUnsafeUniformFillMutableByteArray+  -- ** Floating point numbers   , uniformDouble01M   , uniformDoublePositive01M   , uniformFloat01M   , uniformFloatPositive01M+  -- ** Enum types   , uniformEnumM   , uniformEnumRM+  -- ** Word+  , uniformWordR    -- * Appendix    -- ** How to implement 'StatefulGen'-  -- $implementmonadrandom+  -- $implemenstatefulegen    -- ** Floating point number caveats #fpcaveats#+  , scaleFloating   -- $floating    -- * References@@ -105,17 +137,23 @@   ) where  import Control.DeepSeq-import Control.Monad (replicateM) import Control.Monad.IO.Class import Control.Monad.ST import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar) import Control.Monad.State.Strict (MonadState, state)+import Data.ByteString (ByteString)+import Data.Coerce import Data.IORef import Data.STRef import Foreign.Storable-import System.Random+import System.Random hiding (uniformShortByteString)+import System.Random.Array (shuffleListM, shortByteStringToByteString) import System.Random.Internal+#if __GLASGOW_HASKELL__ >= 808+import GHC.IORef (atomicModifyIORef2Lazy)+#endif + -- $introduction -- -- This module provides type classes and instances for the following concepts:@@ -143,32 +181,30 @@ -- In monadic code, use the relevant 'Uniform' and 'UniformRange' instances to -- generate pseudo-random values via 'uniformM' and 'uniformRM', respectively. ----- As an example, @rollsM@ generates @n@ pseudo-random values of @Word@ in the--- range @[1, 6]@ in a 'StatefulGen' context; given a /monadic/ pseudo-random--- number generator, you can run this probabilistic computation as follows:+-- As an example, @rollsM@ generates @n@ pseudo-random values of @Word@ in the range @[1,+-- 6]@ in a 'StatefulGen' context; given a /monadic/ pseudo-random number generator, you+-- can run this probabilistic computation using+-- [@mwc-random@](https://hackage.haskell.org/package/mwc-random) as follows: --+-- >>> import Control.Monad (replicateM) -- >>> :{ -- let rollsM :: StatefulGen g m => Int -> g -> m [Word] --     rollsM n = replicateM n . uniformRM (1, 6)--- in do---     monadicGen <- MWC.create---     rollsM 10 monadicGen :: IO [Word] -- :}--- [3,4,3,1,4,6,1,6,1,4] ----- Given a /pure/ pseudo-random number generator, you can run the monadic--- pseudo-random number computation @rollsM@ in an 'IO' or 'ST' context by--- applying a monadic adapter like 'AtomicGenM', 'IOGenM' or 'STGenM'--- (see [monadic-adapters](#monadicadapters)) to the pure pseudo-random number--- generator.+-- > import qualified System.Random.MWC as MWC+-- > >>> monadicGen <- MWC.create+-- > >>> rollsM 10 monadicGen :: IO [Word]+-- > [3,4,3,1,4,6,1,6,1,4] ----- >>> :{--- let rollsM :: StatefulGen g m => Int -> g -> m [Word]---     rollsM n = replicateM n . uniformRM (1, 6)---     pureGen = mkStdGen 42--- in---     newIOGenM pureGen >>= rollsM 10 :: IO [Word]--- :}+-- Given a /pure/ pseudo-random number generator, you can run the monadic pseudo-random+-- number computation @rollsM@ in 'Control.Monad.State.Strict.StateT', 'IO', 'ST' or 'STM'+-- context by applying a monadic adapter like 'StateGenM', 'AtomicGenM', 'IOGenM',+-- 'STGenM' or 'TGenM' (see [monadic-adapters](#monadicadapters)) to the pure+-- pseudo-random number generator.+--+-- >>> let pureGen = mkStdGen 42+-- >>> newIOGenM pureGen >>= rollsM 10 :: IO [Word] -- [1,1,3,2,4,5,3,4,6,2]  -------------------------------------------------------------------------------@@ -182,10 +218,10 @@ -- ['System.Random.RandomGen': pure pseudo-random number generators] --     See "System.Random" module. ----- ['StatefulGen': monadic pseudo-random number generators] These generators---     mutate their own state as they produce pseudo-random values. They---     generally live in 'ST' or 'IO' or some transformer that implements---     @PrimMonad@.+-- ['StatefulGen': monadic pseudo-random number generators] These generators mutate their+--     own state as they produce pseudo-random values. They generally live in+--     'Control.Monad.State.Strict.StateT', 'ST', 'IO' or 'STM' or some other transformer+--     on top of those monads. --  -------------------------------------------------------------------------------@@ -197,10 +233,10 @@ -- Pure pseudo-random number generators can be used in monadic code via the -- 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---     directly. 'StateGenM' is /not/ safe to use in the presence of exceptions---     and concurrency.+-- * 'StateGenM' can be used in any state monad. With strict+--     'Control.Monad.State.Strict.StateT' there is no performance overhead compared to+--     using the 'RandomGen' instance directly. 'StateGenM' is /not/ safe to use in the+--     presence of exceptions and concurrency. -- -- *   'AtomicGenM' is safe in the presence of exceptions and concurrency since --     it performs all actions atomically.@@ -221,13 +257,8 @@ -- @since 1.2.0 class (RandomGen r, StatefulGen g m) => RandomGenM g r m | g -> r where   applyRandomGenM :: (r -> (a, r)) -> g -> m a---- | Splits a pseudo-random number generator into two. Overwrites the mutable--- wrapper with one of the resulting generators and returns the other.------ @since 1.2.0-splitGenM :: RandomGenM g r m => g -> m r-splitGenM = applyRandomGenM split+{-# DEPRECATED applyRandomGenM "In favor of `modifyGen`" #-}+{-# DEPRECATED RandomGenM "In favor of `FrozenGen`" #-}  instance (RandomGen r, MonadIO m) => RandomGenM (IOGenM r) r m where   applyRandomGenM = applyIOGen@@ -245,6 +276,19 @@   applyRandomGenM = applyTGen  +-- | Shuffle elements of a list in a uniformly random order.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> runStateGen_ (mkStdGen 127) $ uniformShuffleListM "ELVIS"+-- "LIVES"+--+-- @since 1.3.0+uniformShuffleListM :: StatefulGen g m => [a] -> g -> m [a]+uniformShuffleListM xs gen = shuffleListM (`uniformWordR` gen) xs+{-# INLINE uniformShuffleListM #-}+ -- | Runs a mutable pseudo-random number generator from its 'FrozenGen' state. -- -- ====__Examples__@@ -254,7 +298,7 @@ -- ([-74,37,-50,-2,3],IOGen {unIOGen = StdGen {unStdGen = SMGen 4273268533320920145 15251669095119325999}}) -- -- @since 1.2.0-withMutableGen :: FrozenGen f m => f -> (MutableGen f m -> m a) -> m (a, f)+withMutableGen :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m (a, f) withMutableGen fg action = do   g <- thawGen fg   res <- action g@@ -271,37 +315,77 @@ -- 4 -- -- @since 1.2.0-withMutableGen_ :: FrozenGen f m => f -> (MutableGen f m -> m a) -> m a-withMutableGen_ fg action = fst <$> withMutableGen fg action+withMutableGen_ :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m a+withMutableGen_ fg action = thawGen fg >>= action  --- | Generates a list of pseudo-random values.+-- | Just like `withMutableGen`, except uses a `Seed` instead of a frozen generator. -- -- ====__Examples__ ----- >>> import System.Random.Stateful--- >>> let pureGen = mkStdGen 137--- >>> g <- newIOGenM pureGen--- >>> uniformListM 10 g :: IO [Bool]--- [True,True,True,True,False,True,True,False,False,False]+-- Here is good example of how `withSeedMutableGen` can be used with `withSeedFile`, which uses a locally stored seed. ----- @since 1.2.0-uniformListM :: (StatefulGen g m, Uniform a) => Int -> g -> m [a]-uniformListM n gen = replicateM n (uniformM gen)+-- First we define a @reportSeed@ function that will print the contents of a seed file as a list of bytes:+--+-- >>> import Data.ByteString as BS (readFile, writeFile, unpack)+-- >>> :seti -XOverloadedStrings+-- >>> let reportSeed fp = print . ("Seed: " <>) . show . BS.unpack =<< BS.readFile fp+--+-- Given a file path, write an `StdGen` seed into the file:+--+-- >>> :seti -XFlexibleContexts -XScopedTypeVariables+-- >>> let writeInitSeed fp = BS.writeFile fp (unSeedToByteString (toSeed (mkStdGen 2025)))+--+-- Apply a `StatefulGen` monadic action that uses @`IOGen` `StdGen`@, restored from the seed in the given path:+--+-- >>> let withMutableSeedFile fp action = withSeedFile fp (\(seed :: Seed (IOGen StdGen)) -> withSeedMutableGen seed action)+--+-- Given a path and an action initialize the seed file and apply the action using that seed:+--+-- >>> let withInitSeedFile fp action = writeInitSeed fp *> reportSeed fp *> withMutableSeedFile fp action <* reportSeed fp+--+-- For the sake of example we will use a temporary directory for storing the seed. Here we+-- report the contents of the seed file before and after we shuffle a list:+--+-- >>> import UnliftIO.Temporary (withSystemTempDirectory)+-- >>> withSystemTempDirectory "random" (\fp -> withInitSeedFile (fp ++ "/seed.bin") (uniformShuffleListM [1..10]))+-- "Seed: [183,178,143,77,132,163,109,14,157,105,82,99,148,82,109,173]"+-- "Seed: [60,105,117,203,187,138,69,39,157,105,82,99,148,82,109,173]"+-- [7,5,4,3,1,8,10,6,9,2]+--+-- @since 1.3.0+withSeedMutableGen :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m (a, Seed g)+withSeedMutableGen seed f = withSeedM seed (`withMutableGen` f) +-- | Just like `withSeedMutableGen`, except it doesn't return the final generator, only+-- the resulting value. This is slightly more efficient, since it doesn't incur overhead+-- from freezeing the mutable generator+--+-- @since 1.3.0+withSeedMutableGen_ :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m a+withSeedMutableGen_ seed = withMutableGen_ (fromSeed seed)++ -- | Generates a pseudo-random value using monadic interface and `Random` instance. -- -- ====__Examples__ -- -- >>> import System.Random.Stateful--- >>> let pureGen = mkStdGen 137+-- >>> let pureGen = mkStdGen 139 -- >>> g <- newIOGenM pureGen -- >>> randomM g :: IO Double--- 0.5728354935654512+-- 0.33775117339631733 --+-- You can use type applications to disambiguate the type of the generated numbers:+--+-- >>> :seti -XTypeApplications+-- >>> randomM @Double g+-- 0.9156875994165681+-- -- @since 1.2.0-randomM :: (RandomGenM g r m, Random a) => g -> m a-randomM = applyRandomGenM random+randomM :: forall a g m. (Random a, RandomGen g, FrozenGen g m) => MutableGen g m -> m a+randomM = flip modifyGen random+{-# INLINE randomM #-}  -- | Generates a pseudo-random value using monadic interface and `Random` instance. --@@ -313,10 +397,26 @@ -- >>> randomRM (1, 100) g :: IO Int -- 52 --+-- You can use type applications to disambiguate the type of the generated numbers:+--+-- >>> :seti -XTypeApplications+-- >>> randomRM @Int (1, 100) g+-- 2+-- -- @since 1.2.0-randomRM :: (RandomGenM g r m, Random a) => (a, a) -> g -> m a-randomRM r = applyRandomGenM (randomR r)+randomRM :: forall a g m. (Random a, RandomGen g, FrozenGen g m) => (a, a) -> MutableGen g m -> m a+randomRM r = flip modifyGen (randomR r)+{-# INLINE randomRM #-} +-- | Generates a pseudo-random 'ByteString' of the specified size.+--+-- @since 1.2.0+uniformByteStringM :: StatefulGen g m => Int -> g -> m ByteString+uniformByteStringM n g =+  shortByteStringToByteString . byteArrayToShortByteString+    <$> uniformByteArrayM True n g+{-# INLINE uniformByteStringM #-}+ -- | Wraps an 'IORef' that holds a pure pseudo-random number generator. All -- operations are performed atomically. --@@ -332,8 +432,14 @@ -- -- @since 1.2.0 newtype AtomicGen g = AtomicGen { unAtomicGen :: g}-  deriving (Eq, Ord, Show, RandomGen, Storable, NFData)+  deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData) +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families+instance SeedGen g => SeedGen (AtomicGen g) where+  type SeedSize (AtomicGen g) = SeedSize g+  fromSeed = coerce (fromSeed :: Seed g -> g)+  toSeed = coerce (toSeed :: g -> Seed g)+ -- | Creates a new 'AtomicGenM'. -- -- @since 1.2.0@@ -344,6 +450,7 @@ -- | Global mutable standard pseudo-random number generator. This is the same -- generator that was historically used by `randomIO` and `randomRIO` functions. --+-- >>> import Control.Monad (replicateM) -- >>> replicateM 10 (uniformRM ('a', 'z') globalStdGen) -- "tdzxhyfvgr" --@@ -365,12 +472,18 @@   {-# INLINE uniformWord32 #-}   uniformWord64 = applyAtomicGen genWord64   {-# INLINE uniformWord64 #-}-  uniformShortByteString n = applyAtomicGen (genShortByteString n)   instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where   type MutableGen (AtomicGen g) m = AtomicGenM g   freezeGen = fmap AtomicGen . liftIO . readIORef . unAtomicGenM+  modifyGen (AtomicGenM ioRef) f =+    liftIO $ atomicModifyIORefHS ioRef $ \g ->+      case f (AtomicGen g) of+        (a, AtomicGen g') -> (g', a)+  {-# INLINE modifyGen #-}++instance (RandomGen g, MonadIO m) => ThawedGen (AtomicGen g) m where   thawGen (AtomicGen g) = newAtomicGenM g  -- | Atomically applies a pure operation to the wrapped pseudo-random number@@ -387,11 +500,27 @@ -- @since 1.2.0 applyAtomicGen :: MonadIO m => (g -> (a, g)) -> AtomicGenM g -> m a applyAtomicGen op (AtomicGenM gVar) =-  liftIO $ atomicModifyIORef' gVar $ \g ->+  liftIO $ atomicModifyIORefHS gVar $ \g ->     case op g of       (a, g') -> (g', a) {-# INLINE applyAtomicGen #-} +-- HalfStrict version of atomicModifyIORef, i.e. strict in the modifcation of the contents+-- of the IORef, but not in the result produced.+atomicModifyIORefHS :: IORef a -> (a -> (a, b)) -> IO b+atomicModifyIORefHS ref f = do+#if __GLASGOW_HASKELL__ >= 808+  (_old, (_new, res)) <- atomicModifyIORef2Lazy ref $ \old ->+    case f old of+      r@(!_new, _res) -> r+  pure res+#else+  atomicModifyIORef ref $ \old ->+    case f old of+      r@(!_new, _res) -> r+#endif+{-# INLINE atomicModifyIORefHS #-}+ -- | Wraps an 'IORef' that holds a pure pseudo-random number generator. -- -- *   'IOGenM' is safe in the presence of exceptions, but not concurrency.@@ -416,8 +545,13 @@ -- -- @since 1.2.0 newtype IOGen g = IOGen { unIOGen :: g }-  deriving (Eq, Ord, Show, RandomGen, Storable, NFData)+  deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData) +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families+instance SeedGen g => SeedGen (IOGen g) where+  type SeedSize (IOGen g) = SeedSize g+  fromSeed = coerce (fromSeed :: Seed g -> g)+  toSeed = coerce (toSeed :: g -> Seed g)  -- | Creates a new 'IOGenM'. --@@ -440,14 +574,22 @@   {-# INLINE uniformWord32 #-}   uniformWord64 = applyIOGen genWord64   {-# INLINE uniformWord64 #-}-  uniformShortByteString n = applyIOGen (genShortByteString n)   instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where   type MutableGen (IOGen g) m = IOGenM g   freezeGen = fmap IOGen . liftIO . readIORef . unIOGenM-  thawGen (IOGen g) = newIOGenM g+  modifyGen (IOGenM ref) f = liftIO $ do+    g <- readIORef ref+    let (a, IOGen g') = f (IOGen g)+    g' `seq` writeIORef ref g'+    pure a+  {-# INLINE modifyGen #-}+  overwriteGen (IOGenM ref) = liftIO . writeIORef ref . unIOGen+  {-# INLINE overwriteGen #-} +instance (RandomGen g, MonadIO m) => ThawedGen (IOGen g) m where+  thawGen (IOGen g) = newIOGenM g  -- | Applies a pure operation to the wrapped pseudo-random number generator. --@@ -464,7 +606,7 @@ applyIOGen f (IOGenM ref) = liftIO $ do   g <- readIORef ref   case f g of-    (!a, !g') -> a <$ writeIORef ref g'+    (a, !g') -> a <$ writeIORef ref g' {-# INLINE applyIOGen #-}  -- | Wraps an 'STRef' that holds a pure pseudo-random number generator.@@ -479,8 +621,14 @@ -- -- @since 1.2.0 newtype STGen g = STGen { unSTGen :: g }-  deriving (Eq, Ord, Show, RandomGen, Storable, NFData)+  deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData) +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families+instance SeedGen g => SeedGen (STGen g) where+  type SeedSize (STGen g) = SeedSize g+  fromSeed = coerce (fromSeed :: Seed g -> g)+  toSeed = coerce (toSeed :: g -> Seed g)+ -- | Creates a new 'STGenM'. -- -- @since 1.2.0@@ -501,11 +649,20 @@   {-# INLINE uniformWord32 #-}   uniformWord64 = applySTGen genWord64   {-# INLINE uniformWord64 #-}-  uniformShortByteString n = applySTGen (genShortByteString n)  instance RandomGen g => FrozenGen (STGen g) (ST s) where   type MutableGen (STGen g) (ST s) = STGenM g s   freezeGen = fmap STGen . readSTRef . unSTGenM+  modifyGen (STGenM ref) f = do+    g <- readSTRef ref+    let (a, STGen g') = f (STGen g)+    g' `seq` writeSTRef ref g'+    pure a+  {-# INLINE modifyGen #-}+  overwriteGen (STGenM ref) = writeSTRef ref . unSTGen+  {-# INLINE overwriteGen #-}++instance RandomGen g => ThawedGen (STGen g) (ST s) where   thawGen (STGen g) = newSTGenM g  @@ -523,7 +680,7 @@ applySTGen f (STGenM ref) = do   g <- readSTRef ref   case f g of-    (!a, !g') -> a <$ writeSTRef ref g'+    (a, !g') -> a <$ writeSTRef ref g' {-# INLINE applySTGen #-}  -- | Runs a monadic generating action in the `ST` monad using a pure@@ -565,8 +722,14 @@ -- -- @since 1.2.1 newtype TGen g = TGen { unTGen :: g }-  deriving (Eq, Ord, Show, RandomGen, Storable, NFData)+  deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData) +-- Standalone definition due to GHC-8.0 not supporting deriving with associated type families+instance SeedGen g => SeedGen (TGen g) where+  type SeedSize (TGen g) = SeedSize g+  fromSeed = coerce (fromSeed :: Seed g -> g)+  toSeed = coerce (toSeed :: g -> Seed g)+ -- | Creates a new 'TGenM' in `STM`. -- -- @since 1.2.1@@ -595,12 +758,21 @@   {-# 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+  modifyGen (TGenM ref) f = do+    g <- readTVar ref+    let (a, TGen g') = f (TGen g)+    g' `seq` writeTVar ref g'+    pure a+  {-# INLINE modifyGen #-}+  overwriteGen (TGenM ref) = writeTVar ref . unTGen+  {-# INLINE overwriteGen #-}++instance RandomGen g => ThawedGen (TGen g) STM where   thawGen (TGen g) = newTGenM g  @@ -657,82 +829,105 @@  -- $floating --+-- Due to rounding errors, floating point operations are neither associative nor+-- distributive the way the corresponding operations on real numbers are. Additionally,+-- floating point numbers admit special values @NaN@ as well as negative and positive+-- infinity.+-- -- The 'UniformRange' instances for 'Float' and 'Double' use the following--- procedure to generate a random value in a range for @uniformRM (a, b) g@:+-- procedure to generate a random value in a range for @uniformRM (l, h) g@: ----- If \(a = b\), return \(a\). Otherwise:+-- * If @__l == h__@, return: @__l__@.+-- * If @__`isInfinite` l == True__@ or @__`isInfinite` h == True__@, return: @__l + h__@+-- * Otherwise: ----- 1.  Generate \(x\) uniformly such that \(0 \leq x \leq 1\).+--     1.  Generate an unsigned integral of matching width @__w__@ uniformly. -----     The method by which \(x\) is sampled does not cover all representable---     floating point numbers in the unit interval. The method never generates---     denormal floating point numbers, for example.+--     2.  Check whether @__h - l__@ overflows to infinity and, if it does, then convert+--         @__w__@ to a floating point number in @__[0.0, 1.0]__@ range through division+--         of @__w__@ by the highest possible value: ----- 2.  Return \(x \cdot a + (1 - x) \cdot b\).+--         @+--         x = `fromIntegral` w / `fromIntegral` `maxBound`+--         @ -----     Due to rounding errors, floating point operations are neither---     associative nor distributive the way the corresponding operations on---     real numbers are. Additionally, floating point numbers admit special---     values @NaN@ as well as negative and positive infinity.+--         Then we scale and clamp it before returning it: ----- For pathological values, step 2 can yield surprising results.+--         @+--         `max` (`min` (x * l + (1 - x) * h) (`max` l h)) (`min` l h)+--         @ ----- *   The result may be greater than @max a b@.+--         Clamping is necessary, because otherwise it would be possible to run into a+--         degenerate case when a scaled value is outside the specified range due to+--         rounding errors. -----     >>> :{---     let (a, b, x) = (-2.13238e-29, -2.1323799e-29, 0.27736077)---         result = x * a + (1 - x) * b :: Float---     in (result, result > max a b)---     :}---     (-2.1323797e-29,True)+--     3.  Whenever @__h - l__@ does not overflow, we use this common formula for scaling:+--         @__ l + (h - l) * x__@.  However, instead of using @__[0.0, 1.0]__@ range we+--         use the top most bit of @__w__@ to decide whether we will treat the generated+--         floating point value as @__[0.0, 0.5]__@ range or @__[0.5, 1.0]__@ range and+--         use the left over bits to produce a floating point value in the half unit+--         range: ----- *   The result may be smaller than @min a b@.+--         @+--         x = `fromIntegral` (`clearBit` w 31) / `fromIntegral` `maxBound`+--         @ -----     >>> :{---     let (a, b, x) = (-1.9087862, -1.908786, 0.4228573)---         result = x * a + (1 - x) * b :: Float---     in (result, result < min a b)---     :}---     (-1.9087863,True)+--         Further scaling depends on the top most bit: ----- What happens when @NaN@ or @Infinity@ are given to 'uniformRM'? We first+--         @+--         if `testBit` w 31+--            then l + (h - l) * x+--            else h + (l - h) * x+--         @+--+--         Because of this clever technique the result does not need clamping, since+--         scaled values are guaranteed to stay within the specified range. Another reason+--         why this tecnique is used for the common case instead of the one described in+--         @2.@ is because it avoids usage of @__1 - x__@, which consequently reduces loss+--         of randomness due to rounding.+--+--+-- What happens when @__NaN__@ or @__Infinity__@ are given to 'uniformRM'? We first -- define them as constants: -- -- >>> nan = read "NaN" :: Float -- >>> inf = read "Infinity" :: Float+-- >>> g <- newIOGenM (mkStdGen 2024) ----- *   If at least one of \(a\) or \(b\) is @NaN@, the result is @NaN@.+-- *   If at least one of \(l\) or \(h\) is @__NaN__@, the result is @__NaN__@. -----     >>> let (a, b, x) = (nan, 1, 0.5) in x * a + (1 - x) * b+--     >>> uniformRM (nan, 1) g --     NaN---     >>> let (a, b, x) = (-1, nan, 0.5) in x * a + (1 - x) * b+--     >>> uniformRM (-1, nan) g --     NaN ----- *   If \(a\) is @-Infinity@ and \(b\) is @Infinity@, the result is @NaN@.+-- *   If \(l\) and \(h\) are both @__Infinity__@ with opposing signs, then the result is @__NaN__@. -----     >>> let (a, b, x) = (-inf, inf, 0.5) in x * a + (1 - x) * b+--     >>> uniformRM (-inf, inf) g --     NaN+--     >>> uniformRM (inf, -inf) g+--     NaN ----- *   Otherwise, if \(a\) is @Infinity@ or @-Infinity@, the result is \(a\).+-- *   Otherwise, if \(l\) is @__Infinity__@ or @__-Infinity__@, the result is \(l\). -----     >>> let (a, b, x) = (inf, 1, 0.5) in x * a + (1 - x) * b+--     >>> uniformRM (inf, 1) g --     Infinity---     >>> let (a, b, x) = (-inf, 1, 0.5) in x * a + (1 - x) * b+--     >>> uniformRM (-inf, 1) g --     -Infinity ----- *   Otherwise, if \(b\) is @Infinity@ or @-Infinity@, the result is \(b\).+-- *   Otherwise, if \(h\) is @__Infinity__@ or @__-Infinity__@, the result is \(h\). -----     >>> let (a, b, x) = (1, inf, 0.5) in x * a + (1 - x) * b+--     >>> uniformRM (1, inf) g --     Infinity---     >>> let (a, b, x) = (1, -inf, 0.5) in x * a + (1 - x) * b+--     >>> uniformRM (1, -inf) g --     -Infinity -- -- Note that the [GCC 10.1.0 C++ standard library](https://gcc.gnu.org/git/?p=gcc.git;a=blob;f=libstdc%2B%2B-v3/include/bits/random.h;h=19307fbc3ca401976ef6823e8fda893e4a263751;hb=63fa67847628e5f358e7e2e7edb8314f0ee31f30#l1859), -- the [Java 10 standard library](https://docs.oracle.com/javase/10/docs/api/java/util/Random.html#doubles%28double,double%29) -- and [CPython 3.8](https://github.com/python/cpython/blob/3.8/Lib/random.py#L417)--- use the same procedure to generate floating point values in a range.+-- use a similar procedure to generate floating point values in a range. ----- $implementmonadrandom+-- $implemenstatefulegen -- -- Typically, a monadic pseudo-random number generator has facilities to save -- and restore its internal state in addition to generating pseudo-random numbers.@@ -740,33 +935,38 @@ -- Here is an example instance for the monadic pseudo-random number generator -- from the @mwc-random@ package: --+-- > import qualified System.Random.MWC as MWC+-- > import qualified Data.Vector.Generic as G+-- -- > instance (s ~ PrimState m, PrimMonad m) => StatefulGen (MWC.Gen s) m where -- >   uniformWord8 = MWC.uniform -- >   uniformWord16 = MWC.uniform -- >   uniformWord32 = MWC.uniform -- >   uniformWord64 = MWC.uniform--- >   uniformShortByteString n g = unsafeSTToPrim (genShortByteStringST n (MWC.uniform g))+-- >   uniformByteArrayM isPinned n g = stToPrim (fillByteArrayST isPinned n (MWC.uniform g)) -- -- > instance PrimMonad m => FrozenGen MWC.Seed m where -- >   type MutableGen MWC.Seed m = MWC.Gen (PrimState m)--- >   thawGen = MWC.restore -- >   freezeGen = MWC.save+-- >   overwriteGen (Gen mv) (Seed v) = G.copy mv v --+-- > instance PrimMonad m => ThawedGen MWC.Seed m where+-- >   thawGen = MWC.restore+-- -- === @FrozenGen@ ----- `FrozenGen` gives us ability to use any stateful pseudo-random number generator in its--- immutable form, if one exists that is. This concept is commonly known as a seed, which--- allows us to save and restore the actual mutable state of a pseudo-random number--- generator. The biggest benefit that can be drawn from a polymorphic access to a--- stateful pseudo-random number generator in a frozen form is the ability to serialize,--- deserialize and possibly even use the stateful generator in a pure setting without--- knowing the actual type of a generator ahead of time. For example we can write a--- function that accepts a frozen state of some pseudo-random number generator and--- produces a short list with random even integers.+-- `FrozenGen` gives us ability to use most of stateful pseudo-random number generator in+-- its immutable form, if one exists that is.  The biggest benefit that can be drawn from+-- a polymorphic access to a stateful pseudo-random number generator in a frozen form is+-- the ability to serialize, deserialize and possibly even use the stateful generator in a+-- pure setting without knowing the actual type of a generator ahead of time. For example+-- we can write a function that accepts a frozen state of some pseudo-random number+-- generator and produces a short list with random even integers. -- -- >>> import Data.Int (Int8)+-- >>> import Control.Monad (replicateM) -- >>> :{--- myCustomRandomList :: FrozenGen f m => f -> m [Int8]+-- myCustomRandomList :: ThawedGen f m => f -> m [Int8] -- myCustomRandomList f = --   withMutableGen_ f $ \gen -> do --     len <- uniformRM (5, 10) gen@@ -780,12 +980,6 @@ -- >>> print $ runST $ myCustomRandomList (STGen (mkStdGen 217)) -- [-50,-2,4,-8,-58,-40,24,-32,-110,24] ----- or a @Seed@ from @mwc-random@:------ >>> import Data.Vector.Primitive as P--- >>> print $ runST $ myCustomRandomList (MWC.toSeed (P.fromList [1,2,3]))--- [24,40,10,40,-8,48,-78,70,-12]--- -- Alternatively, instead of discarding the final state of the generator, as it happens -- above, we could have used `withMutableGen`, which together with the result would give -- us back its frozen form. This would allow us to store the end state of our generator@@ -801,26 +995,12 @@ -- <https://doi.org/10.1145/2660193.2660195>  -- $setup--- >>> import Control.Monad.Primitive--- >>> import qualified System.Random.MWC as MWC -- >>> writeIORef theStdGen $ mkStdGen 2021 ----- >>> :set -XFlexibleContexts--- >>> :set -XFlexibleInstances--- >>> :set -XMultiParamTypeClasses--- >>> :set -XTypeFamilies--- >>> :set -XUndecidableInstances+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XFlexibleInstances+-- >>> :seti -XMultiParamTypeClasses+-- >>> :seti -XTypeFamilies+-- >>> :seti -XUndecidableInstances ----- >>> :{--- instance (s ~ PrimState m, PrimMonad m) => StatefulGen (MWC.Gen s) m where---   uniformWord8 = MWC.uniform---   uniformWord16 = MWC.uniform---   uniformWord32 = MWC.uniform---   uniformWord64 = MWC.uniform---   uniformShortByteString n g = unsafeSTToPrim (genShortByteStringST n (MWC.uniform g))--- instance PrimMonad m => FrozenGen MWC.Seed m where---   type MutableGen MWC.Seed m = MWC.Gen (PrimState m)---   thawGen = MWC.restore---   freezeGen = MWC.save--- :} --

test-inspection/Spec/Inspection.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP              #-} {-# LANGUAGE DeriveAnyClass   #-} {-# LANGUAGE DeriveGeneric    #-} {-# LANGUAGE TemplateHaskell  #-}@@ -43,7 +44,15 @@   [ $(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), hasNoTypeClasses] 'uniform_MyAction)++#if !MIN_VERSION_base(4,17,0)+  -- Starting from GHC 9.4 and base-4.17+  -- 'error' :: M1 C ('MetaCons "Never" 'PrefixI 'False) ..+  -- survives. This does not really matter, because Never is uninhabited,+  -- but fails inspection testing.+  , $(inspectTest $ hasNoGenerics 'uniform_MyAction)+#endif    , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Word8)   , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Int8)

test/Spec.hs view

@@ -1,31 +1,43 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} module Main (main) where  import Control.Monad (replicateM, forM_)+import Control.Monad.ST (runST) import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS import Data.Int+import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Typeable import Data.Void import Data.Word import Foreign.C.Types import GHC.Generics+import GHC.Exts (fromList) import Numeric.Natural (Natural)-import System.Random.Stateful+import System.Random (uniformShortByteString)+import System.Random.Stateful hiding (uniformShortByteString)+import System.Random.Internal (newMutableByteArray, freezeMutableByteArray, writeWord8) import Test.SmallCheck.Series as SC import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.SmallCheck as SC+#if __GLASGOW_HASKELL__ < 804+import Data.Monoid ((<>))+#endif  import qualified Spec.Range as Range import qualified Spec.Run as Run+import qualified Spec.Seed as Seed import qualified Spec.Stateful as Stateful  main :: IO ()@@ -74,9 +86,13 @@     , integralSpec (Proxy :: Proxy Integer)     , integralSpec (Proxy :: Proxy Natural)     , enumSpec     (Proxy :: Proxy Colors)+    , enumSpec     (Proxy :: Proxy (Int, Int))+    , enumSpec     (Proxy :: Proxy (Bool, Bool, Bool))+    , enumSpec     (Proxy :: Proxy ((), Int, Bool, Word))     , runSpec     , floatTests     , byteStringSpec+    , fillMutableByteArraySpec     , SC.testProperty "uniformRangeWithinExcludedF" $ seeded Range.uniformRangeWithinExcludedF     , SC.testProperty "uniformRangeWithinExcludedD" $ seeded Range.uniformRangeWithinExcludedD     , randomSpec (Proxy :: Proxy (CFloat, CDouble))@@ -91,7 +107,8 @@     , 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+    , Stateful.statefulGenSpec+    , Seed.spec     ]  floatTests :: TestTree@@ -106,35 +123,62 @@     "Does not contain 1.0e-45"   ] -showsType :: forall t . Typeable t => Proxy t -> ShowS-showsType px = showsTypeRep (typeRep px)+showType :: forall t . Typeable t => Proxy t -> String+showType px = show (typeRep px)  byteStringSpec :: TestTree byteStringSpec =   testGroup     "ByteString"-    [ SC.testProperty "genShortByteString" $-      seededWithLen $ \n g -> SBS.length (fst (genShortByteString n g)) == n-    , SC.testProperty "genByteString" $+    [ SC.testProperty "uniformShortByteString" $+      seededWithLen $ \n g -> SBS.length (fst (uniformShortByteString n g)) == n+    , SC.testProperty "uniformByteString" $       seededWithLen $ \n g ->-        SBS.toShort (fst (genByteString n g)) == fst (genShortByteString n g)-    , testCase "genByteString/ShortByteString consistency" $ do+        SBS.toShort (fst (uniformByteString n g)) == fst (uniformShortByteString n g)+    , testCase "uniformByteString/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 <- SBS.unpack <$> runStateGenT_ g (uniformShortByteStringM n)           xs @?= take n bs           ys <- BS.unpack <$> runStateGenT_ g (uniformByteStringM n)           ys @?= xs     ] +fillMutableByteArraySpec :: TestTree+fillMutableByteArraySpec =+  testGroup+    "MutableByteArray"+    [ SC.testProperty "Same as uniformByteArray" $+        forAll $ \isPinned -> seededWithLen $ \n g ->+          let baFilled = runST $ do+                mba <- newMutableByteArray n+                g' <- uniformFillMutableByteArray mba 0 n g+                ba <- freezeMutableByteArray mba+                pure (ba, g')+          in baFilled == uniformByteArray isPinned n g+    , SC.testProperty "Safe uniformFillMutableByteArray" $+        forAll $ \isPinned offset count -> seededWithLen $ \sz g ->+          let (baFilled, gf) = runST $ do+                mba <- newMutableByteArray sz+                forM_ [0 .. sz - 1] (\i -> writeWord8 mba i 0)+                g' <- uniformFillMutableByteArray mba offset count g+                ba <- freezeMutableByteArray mba+                pure (ba, g')+              (baGen, gu) = uniformByteArray isPinned count' g+              offset' = min sz (max 0 offset)+              count' = min (sz - offset') (max 0 count)+              prefix = replicate offset' 0+              suffix = replicate (sz - (count' + offset')) 0+          in gf == gu && baFilled == fromList prefix <> baGen <> fromList suffix+    ]  rangeSpec ::      forall a.      (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a)   => Proxy a -> TestTree rangeSpec px =-  testGroup ("Range (" ++ showsType px ")")+  testGroup ("Range " ++ showType px)   [ SC.testProperty "uniformR" $ seeded $ Range.uniformRangeWithin px   ] @@ -143,7 +187,7 @@      (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a)   => Proxy a -> TestTree integralSpec px =-  testGroup ("(" ++ showsType px ")")+  testGroup (showType px)   [ SC.testProperty "symmetric" $ seeded $ Range.symmetric px   , SC.testProperty "bounded" $ seeded $ Range.bounded px   , SC.testProperty "singleton" $ seeded $ Range.singleton px@@ -162,7 +206,7 @@      (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 ")")+  testGroup (showType 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))@@ -181,30 +225,47 @@   => Proxy a -> TestTree randomSpec px =   testGroup-    ("Random " ++ showsType px ")")+    ("Random " ++ showType 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))+          (range, g') ->+             take len (randomRs range g' :: [a]) ==+               runStateGen_ g' (replicateM len . randomRM range)     ]  uniformSpec ::      forall a.-     (Typeable a, Eq a, Random a, Uniform a, Show a)+     (Typeable a, Eq a, Random a, Uniform a, UniformRange a, Show a)   => Proxy a -> TestTree uniformSpec px =   testGroup-    ("Uniform " ++ showsType px ")")-    [ SC.testProperty "uniformListM" $+    ("Uniform " ++ showType px)+    [ SC.testProperty "uniformList" $       seededWithLen $ \len g ->-        take len (randoms g :: [a]) == runStateGen_ g (uniformListM len)+        take len (randoms g :: [a]) == fst (uniformList len g)+    , SC.testProperty "uniformListR" $+      seededWithLen $ \len g ->+        case uniform g of+          (range, g') ->+            take len (randomRs range g' :: [a]) == fst (uniformListR len range g')+    , SC.testProperty "uniformShuffleList" $+      seededWithLen $ \len g ->+        case uniformList len g of+          (xs, g') ->+            let xs' = zip [0 :: Int ..] (xs :: [a])+            in sortOn fst (fst (uniformShuffleList xs' g')) == xs'+    , SC.testProperty "uniforms" $+      seededWithLen $ \len g ->+        take len (randoms g :: [a]) == take len (uniforms g)+    , SC.testProperty "uniformRs" $+      seededWithLen $ \len g ->+        case uniform g of+          (range, g') ->+            take len (randomRs range g' :: [a]) == take len (uniformRs range g')     ]  runSpec :: TestTree@@ -215,10 +276,10 @@ seeded :: (StdGen -> a) -> Int -> a seeded f = f . mkStdGen --- | Same as `seeded`, but also produces a length in range 0-255 suitable for generating+-- | Same as `seeded`, but also produces a length in range 0-65535 suitable for generating -- lists and such-seededWithLen :: (Int -> StdGen -> a) -> Word8 -> Int -> a-seededWithLen f w8 = seeded (f (fromIntegral w8))+seededWithLen :: (Int -> StdGen -> a) -> Word16 -> Int -> a+seededWithLen f w16 = seeded (f (fromIntegral w16))  data MyBool = MyTrue | MyFalse   deriving (Eq, Ord, Show, Generic, Finite, Uniform)@@ -242,9 +303,15 @@  newtype ConstGen = ConstGen Word64 +instance SeedGen ConstGen where+  type SeedSize ConstGen = 8+  fromSeed64 (w :| _) = ConstGen w+  toSeed64 (ConstGen w) = pure w+ instance RandomGen ConstGen where   genWord64 g@(ConstGen c) = (c, g)-  split g = (g, g)+instance SplitGen ConstGen where+  splitGen g = (g, g)  data Colors = Red | Green | Blue | Purple | Yellow | Black | White | Orange   deriving (Eq, Ord, Show, Generic, Enum, Bounded)@@ -255,3 +322,4 @@  instance UniformRange Colors where   uniformRM = uniformEnumRM+  isInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x)

test/Spec/Range.hs view

@@ -7,29 +7,29 @@   , uniformRangeWithinExcludedD   ) where -import System.Random.Internal import System.Random.Stateful import Data.Proxy -symmetric :: (RandomGen g, UniformRange a, Eq a) => Proxy a -> g -> (a, a) -> Bool-symmetric _ g (l, r) = fst (uniformR (l, r) g) == fst (uniformR (r, l) g)+(===) :: (Eq a, Show a) => a -> a -> Either String String+x === y+  | x == y = Right "OK"+  | otherwise = Left $ "Expected equal, got " ++ show x ++ " /= " ++ show y +symmetric :: (RandomGen g, UniformRange a, Eq a, Show a) => Proxy a -> g -> (a, a) -> Either String String+symmetric _ g (l, r) = fst (uniformR (l, r) g) === fst (uniformR (r, l) g)+ bounded :: (RandomGen g, UniformRange a, Ord a) => Proxy a -> g -> (a, a) -> Bool-bounded _ g (l, r) = bottom <= result && result <= top-  where-    bottom = min l r-    top = max l r-    result = fst (uniformR (l, r) g)+bounded _ g (l, r) = isInRange (l, r) (fst (uniformR (l, r) g)) -singleton :: (RandomGen g, UniformRange a, Eq a) => Proxy a -> g -> a -> Bool-singleton _ g x = result == x+singleton :: (RandomGen g, UniformRange a, Eq a, Show a) => Proxy a -> g -> a -> Either String String+singleton _ g x = result === x   where     result = fst (uniformR (x, x) g)  uniformRangeWithin :: (RandomGen g, UniformRange a, Ord a) => Proxy a -> g -> (a, a) -> Bool uniformRangeWithin _ gen (l, r) =   runStateGen_ gen $ \g ->-    (\result -> min l r <= result && result <= max l r) <$> uniformRM (l, r) g+    isInRange (l, r) <$> uniformRM (l, r) g  uniformRangeWithinExcludedF :: RandomGen g => g -> Bool uniformRangeWithinExcludedF gen =

+ test/Spec/Seed.hs view

@@ -0,0 +1,115 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Spec.Seed where++import Data.Bits+import Data.List.NonEmpty as NE+import Data.Maybe (fromJust)+import Data.Proxy+import Data.Word+import System.Random+import Test.Tasty+import Test.Tasty.SmallCheck as SC+import qualified Data.ByteString as BS+import GHC.TypeLits+import qualified GHC.Exts as GHC (IsList(..))+import Test.SmallCheck.Series hiding (NonEmpty(..))+import Spec.Stateful ()++newtype GenN (n :: Nat) = GenN BS.ByteString+  deriving (Eq, Show)++instance (KnownNat n, Monad m) => Serial m (GenN n) where+  series = GenN . fst . uniformByteString n . mkStdGen <$> series+    where+      n = fromInteger (natVal (Proxy :: Proxy n))++instance (KnownNat n, Monad m) => Serial m (Gen64 n) where+  series =+    Gen64 . dropExtra . fst . uniformList n . mkStdGen <$> series+    where+      (n, r8) =+        case fromInteger (natVal (Proxy :: Proxy n)) `quotRem` 8 of+          (q, 0) -> (q, 0)+          (q, r) -> (q + 1, (8 - r) * 8)+      -- We need to drop extra top most bits in the last generated Word64 in order for+      -- roundtrip to work, because that is exactly what SeedGen will do+      dropExtra xs =+        case NE.reverse (fromJust (NE.nonEmpty xs)) of+          w64 :| rest -> NE.reverse ((w64 `shiftL` r8) `shiftR` r8 :| rest)++instance (1 <= n, KnownNat n) => SeedGen (GenN n) where+  type SeedSize (GenN n) = n+  toSeed (GenN bs) = fromJust . mkSeed . GHC.fromList $ BS.unpack bs+  fromSeed = GenN . BS.pack . GHC.toList . unSeed++newtype Gen64 (n :: Nat) = Gen64 (NonEmpty Word64)+  deriving (Eq, Show)++instance (1 <= n, KnownNat n) => SeedGen (Gen64 n) where+  type SeedSize (Gen64 n) = n+  toSeed64 (Gen64 ws) = ws+  fromSeed64 = Gen64++seedGenSpec ::+     forall g. (SeedGen g, Eq g, Show g, Serial IO g)+  => TestTree+seedGenSpec =+    testGroup (seedGenTypeName @g)+    [ testProperty "fromSeed/toSeed" $+        forAll $ \(g :: g) -> g == fromSeed (toSeed g)+    , testProperty "fromSeed64/toSeed64" $+        forAll $ \(g :: g) -> g == fromSeed64 (toSeed64 g)+    ]+++spec :: TestTree+spec =+  testGroup+    "SeedGen"+    [ seedGenSpec @StdGen+    , seedGenSpec @(GenN 1)+    , seedGenSpec @(GenN 2)+    , seedGenSpec @(GenN 3)+    , seedGenSpec @(GenN 4)+    , seedGenSpec @(GenN 5)+    , seedGenSpec @(GenN 6)+    , seedGenSpec @(GenN 7)+    , seedGenSpec @(GenN 8)+    , seedGenSpec @(GenN 9)+    , seedGenSpec @(GenN 10)+    , seedGenSpec @(GenN 11)+    , seedGenSpec @(GenN 12)+    , seedGenSpec @(GenN 13)+    , seedGenSpec @(GenN 14)+    , seedGenSpec @(GenN 15)+    , seedGenSpec @(GenN 16)+    , seedGenSpec @(GenN 17)+    , seedGenSpec @(Gen64 1)+    , seedGenSpec @(Gen64 2)+    , seedGenSpec @(Gen64 3)+    , seedGenSpec @(Gen64 4)+    , seedGenSpec @(Gen64 5)+    , seedGenSpec @(Gen64 6)+    , seedGenSpec @(Gen64 7)+    , seedGenSpec @(Gen64 8)+    , seedGenSpec @(Gen64 9)+    , seedGenSpec @(Gen64 10)+    , seedGenSpec @(Gen64 11)+    , seedGenSpec @(Gen64 12)+    , seedGenSpec @(Gen64 13)+    , seedGenSpec @(Gen64 14)+    , seedGenSpec @(Gen64 15)+    , seedGenSpec @(Gen64 16)+    , seedGenSpec @(Gen64 17)+    ]+

test/Spec/Stateful.hs view

@@ -7,11 +7,12 @@ module Spec.Stateful where  import Control.Concurrent.STM+import Control.Monad import Control.Monad.ST-import Control.Monad.Trans.State.Strict import Data.Proxy import Data.Typeable-import System.Random.Stateful+import System.Random (uniformShortByteString)+import System.Random.Stateful hiding (uniformShortByteString) import Test.SmallCheck.Series import Test.Tasty import Test.Tasty.SmallCheck as SC@@ -36,78 +37,187 @@   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))+     forall f a sg m. (StatefulGen sg m, RandomGen f, Eq f, Show f, Eq a)+  => (forall g n. StatefulGen g n => g -> n a)+  -> (forall g. RandomGen g => g -> (a, g))+  -> (StdGen -> f)   -> (f -> StdGen)-  -> f+  -> (f -> (sg -> m a) -> IO (a, 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+matchRandomGenSpec genM gen fromStdGen toStdGen runStatefulGen =+  forAll $ \seed -> monadic $ do+    let stdGen = mkStdGen seed+        g = fromStdGen stdGen+        (x1, g1) = gen stdGen+        (x2, g2) = gen g+    (x3, g3) <- runStatefulGen g genM+    pure $ and [x1 == x2, x2 == x3, g1 == toStdGen g2, g1 == toStdGen g3, g2 == g3]  withMutableGenSpec ::-     forall f m. (FrozenGen f m, Eq f, Show f)+     forall f m. (ThawedGen 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+  forAll $ \n -> monadic $ toIO $ do+    let action = uniformListM n+    x@(_, _) :: ([Word], f) <- withMutableGen frozen action+    y@(r, _) <- withMutableGen frozen action+    r' <- withMutableGen_ frozen action+    pure $ x == y && r == r' +overwriteMutableGenSpec ::+     forall f m. (ThawedGen f m, Eq f, Show f)+  => (forall a. m a -> IO a)+  -> f+  -> Property IO+overwriteMutableGenSpec toIO frozen =+  forAll $ \n -> monadic $ toIO $ do+    let action = uniformListM (abs n + 1) -- Non-empty+    ((r1, r2), frozen') :: ((String, String), f) <- withMutableGen frozen $ \mutable -> do+      r1 <- action mutable+      overwriteGen mutable frozen+      r2 <- action mutable+      modifyGen mutable (const ((), frozen))+      pure (r1, r2)+    pure $ r1 == r2 && frozen == frozen' -statefulSpecFor ::-     forall f m. (FrozenGen f m, Eq f, Show f, Serial IO f, Typeable f)+indepMutableGenSpec ::+     forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f)+  => (forall a. m a -> IO a) -> [f] -> Property IO+indepMutableGenSpec toIO fgs =+  monadic $ toIO $ do+    (fgs ==) <$> (mapM freezeGen =<< mapM thawGen fgs)++immutableFrozenGenSpec ::+     forall f m. (RandomGen f, ThawedGen f m, Eq f, Show f)+  => (forall a. m a -> IO a) -> f -> Property IO+immutableFrozenGenSpec toIO frozen =+  forAll $ \n -> monadic $ toIO $ do+    let action = do+          mg <- thawGen frozen+          (,) <$> uniformWord8 mg <*> freezeGen mg+    x <- action+    xs <- replicateM n action+    pure $ all (x ==) xs++splitMutableGenSpec ::+     forall f m. (SplitGen f, ThawedGen f m, Eq f, Show f)   => (forall a. m a -> IO a)-  -> (f -> StdGen)+  -> f+  -> Property IO+splitMutableGenSpec toIO frozen =+  monadic $ toIO $ do+    (sfg1, fg1) <- withMutableGen frozen splitGenM+    (smg2, fg2) <- withMutableGen frozen splitMutableGenM+    sfg3 <- freezeGen smg2+    pure $ fg1 == fg2 && sfg1 == sfg3++thawedGenSpecFor ::+     forall f m. (SplitGen f, ThawedGen f m, Eq f, Show f, Serial IO f, Typeable f)+  => (forall a. m a -> IO a)+  -> Proxy f   -> TestTree-statefulSpecFor toIO toStdGen =+thawedGenSpecFor toIO px =   testGroup-    (showsTypeRep (typeRep (Proxy :: Proxy f)) "")+    (showsTypeRep (typeRep px) "")     [ 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-        ]+    , testProperty "overwriteGen" $+      forAll $ \(f :: f) -> overwriteMutableGenSpec toIO f+    , testProperty "independent mutable generators" $+      forAll $ \(fs :: [f]) -> indepMutableGenSpec toIO fs+    , testProperty "immutable frozen generators" $+      forAll $ \(f :: f) -> immutableFrozenGenSpec toIO f+    , testProperty "splitGen" $+      forAll $ \(f :: f) -> splitMutableGenSpec toIO f     ] +frozenGenSpecFor ::+     forall f sg m. (RandomGen f, StatefulGen sg m, Eq f, Show f, Typeable f)+  => (StdGen -> f)+  -> (f -> StdGen)+  -> (forall a. f -> (sg -> m a) -> IO (a, f))+  -> TestTree+frozenGenSpecFor fromStdGen toStdGen runStatefulGen =+    testGroup (showsTypeRep (typeRep (Proxy :: Proxy f)) "")+    [ testGroup "matchRandomGenSpec"+      [ testProperty "uniformWord8/genWord8" $+          matchRandomGenSpec uniformWord8 genWord8 fromStdGen toStdGen runStatefulGen+      , testProperty "uniformWord16/genWord16" $+          matchRandomGenSpec uniformWord16 genWord16 fromStdGen toStdGen runStatefulGen+      , testProperty "uniformWord32/genWord32" $+          matchRandomGenSpec uniformWord32 genWord32 fromStdGen toStdGen runStatefulGen+      , testProperty "uniformWord64/genWord64" $+          matchRandomGenSpec uniformWord64 genWord64 fromStdGen toStdGen runStatefulGen+      , testProperty "uniformWord32R/genWord32R" $+        forAll $ \w32 ->+          matchRandomGenSpec (uniformWord32R w32) (genWord32R w32) fromStdGen toStdGen runStatefulGen+      , testProperty "uniformWord64R/genWord64R" $+        forAll $ \w64 ->+          matchRandomGenSpec (uniformWord64R w64) (genWord64R w64) fromStdGen toStdGen runStatefulGen+      , testProperty "uniformShortByteStringM/uniformShortByteString" $+        forAll $ \(NonNegative n') ->+          let n = n' `mod` 100000 -- Ensure it is not too big+          in matchRandomGenSpec+               (uniformShortByteStringM n)+               (uniformShortByteString n)+               fromStdGen+               toStdGen+               runStatefulGen+      , testProperty "uniformByteStringM/uniformByteString" $+        forAll $ \(NonNegative n') ->+          let n = n' `mod` 100000 -- Ensure it is not too big+          in matchRandomGenSpec+               (uniformByteStringM n)+               (uniformByteString n)+               fromStdGen+               toStdGen+               runStatefulGen+      , testProperty "uniformByteArrayM/genByteArray" $+        forAll $ \(NonNegative n', isPinned1 :: Bool, isPinned2 :: Bool) ->+          let n = n' `mod` 100000 -- Ensure it is not too big+          in matchRandomGenSpec+               (uniformByteArrayM isPinned1 n)+               (uniformByteArray isPinned2 n)+               fromStdGen+               toStdGen+               runStatefulGen+      ]+    ] -statefulSpec :: TestTree-statefulSpec =++statefulGenSpec :: TestTree+statefulGenSpec =   testGroup-    "Stateful"-    [ statefulSpecFor id unIOGen-    , statefulSpecFor id unAtomicGen-    , statefulSpecFor stToIO unSTGen-    , statefulSpecFor atomically unTGen-    , statefulSpecFor (`evalStateT` mkStdGen 0) unStateGen+    "StatefulGen"+    [ testGroup "ThawedGen"+        [ thawedGenSpecFor id (Proxy :: Proxy (IOGen StdGen))+        , thawedGenSpecFor id (Proxy :: Proxy (AtomicGen StdGen))+        , thawedGenSpecFor stToIO (Proxy :: Proxy (STGen StdGen))+        , thawedGenSpecFor atomically (Proxy :: Proxy (TGen StdGen))+        ]+    , testGroup "FrozenGen"+        [ frozenGenSpecFor StateGen unStateGen runStateGenT+        , frozenGenSpecFor IOGen unIOGen $ \g action -> do+            mg <- newIOGenM (unIOGen g)+            res <- action mg+            g' <- freezeGen mg+            pure (res, g')+        , frozenGenSpecFor AtomicGen unAtomicGen $ \g action -> do+            mg <- newAtomicGenM (unAtomicGen g)+            res <- action mg+            g' <- freezeGen mg+            pure (res, g')+        , frozenGenSpecFor STGen unSTGen $ \g action -> stToIO $ do+            mg <- newSTGenM (unSTGen g)+            res <- action mg+            g' <- freezeGen mg+            pure (res, g')+        , frozenGenSpecFor TGen unTGen $ \g action -> atomically $ do+            mg <- newTGenM (unTGen g)+            res <- action mg+            g' <- freezeGen mg+            pure (res, g')+        ]     ]-

− test/doctests.hs

@@ -1,18 +0,0 @@-{-# LANGUAGE CPP #-}-module Main where--#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ < 810--import Test.DocTest (doctest)--main :: IO ()-main = doctest ["src"]--#else---- Also disabled in cabal file.--- TODO: fix doctest support-main :: IO ()-main = putStrLn "\nDoctests are not supported for older ghc version\n"--#endif