random 1.0.1.3 → 1.3.1
raw patch · 30 files changed
Files
- CHANGELOG.md +178/−0
- README.md +33/−0
- Setup.hs +0/−2
- System/Random.hs +0/−595
- bench-legacy/BinSearch.hs +149/−0
- bench-legacy/SimpleRNGBench.hs +270/−0
- bench/Main.hs +399/−0
- random.cabal +189/−51
- src/System/Random.hs +917/−0
- src/System/Random/Array.hs +362/−0
- src/System/Random/GFinite.hs +281/−0
- src/System/Random/Internal.hs +1815/−0
- src/System/Random/Seed.hs +333/−0
- src/System/Random/Stateful.hs +1006/−0
- test-inspection/Spec.hs +23/−0
- test-inspection/Spec/Inspection.hs +61/−0
- test-legacy/Legacy.hs +15/−0
- test-legacy/Random1283.hs +48/−0
- test-legacy/RangeTest.hs +138/−0
- test-legacy/T7936.hs +15/−0
- test-legacy/TestRandomIOs.hs +21/−0
- test-legacy/TestRandomRs.hs +23/−0
- test/Spec.hs +325/−0
- test/Spec/Range.hs +42/−0
- test/Spec/Run.hs +14/−0
- test/Spec/Seed.hs +115/−0
- test/Spec/Stateful.hs +223/−0
- tests/T7936.hs +0/−14
- tests/TestRandomIOs.hs +0/−20
- tests/TestRandomRs.hs +0/−22
+ CHANGELOG.md view
@@ -0,0 +1,178 @@+# 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)+* Fix performance regression for ghc-9.0 [#101](https://github.com/haskell/random/pull/101)+* Add `uniformEnumM` and `uniformEnumRM`+* Add `initStdGen` [#103](https://github.com/haskell/random/pull/103)+* Add `globalStdGen` [#117](https://github.com/haskell/random/pull/117)+* Add `runStateGenST_`+* Ensure that default implementation of `ShortByteString` generation uses+ unpinned memory. [#116](https://github.com/haskell/random/pull/116)+* Fix [#54](https://github.com/haskell/random/issues/54) with+ [#68](https://github.com/haskell/random/pull/68) - if exactly one value in the+ range of floating point is infinite, then `uniformRM`/`randomR` returns that+ value.+* Add default implementation of `uniformM` that uses `Generic`+ [#70](https://github.com/haskell/random/pull/70)+* `Random` instance for `CBool` [#77](https://github.com/haskell/random/pull/77)+* Addition of `TGen` and `TGenM` [#95](https://github.com/haskell/random/pull/95)+* Addition of tuple instances for `Random` up to 7-tuple+ [#72](https://github.com/haskell/random/pull/72)++# 1.2.0++1. Breaking change which mostly maintains backwards compatibility, see+ "Breaking Changes" below.+2. Support for monadic generators e.g. [mwc-random](https://hackage.haskell.org/package/mwc-random).+3. Monadic adapters for pure generators (providing a uniform monadic+ interface to pure and monadic generators).+4. Faster in all cases except one by more than x18 (N.B. x18 not 18%) and+ some cases (depending on the type) faster by more than x1000 - see+ below for benchmarks.+5. Passes a large number of random number test suites:+ * [dieharder](http://webhome.phy.duke.edu/~rgb/General/dieharder.php "venerable")+ * [TestU01 (SmallCrush, Crush, BigCrush)](http://simul.iro.umontreal.ca/testu01/tu01.html "venerable")+ * [PractRand](http://pracrand.sourceforge.net/ "active")+ * [gjrand](http://gjrand.sourceforge.net/ "active")+ * See [random-quality](https://github.com/tweag/random-quality)+ for details on how to do this yourself.+6. Better quality split as judged by these+ [tests](https://www.cambridge.org/core/journals/journal-of-functional-programming/article/evaluation-of-splittable-pseudorandom-generators/3EBAA9F14939C5BB5560E32D1A132637). Again+ see [random-quality](https://github.com/tweag/random-quality) for+ details on how to do this yourself.+7. Unbiased generation of ranges.+8. Updated tests and benchmarks.+9. [Continuous integration](https://travis-ci.org/github/haskell/random).++### Breaking Changes++Version 1.2.0 introduces these breaking changes:++* requires `base >= 4.8` (GHC-7.10)+* `StdGen` is no longer an instance of `Read`+* `randomIO` and `randomRIO` were extracted from the `Random` class into+ separate functions++In addition, there may be import clashes with new functions, e.g. `uniform` and+`uniformR`.++### Deprecations++Version 1.2.0 introduces `genWord64`, `genWord32` and similar methods to the+`RandomGen` class. The significantly slower method `next` and its companion+`genRange` are now deprecated.++### Issues Addressed++ Issue Number | Description | Comment+--------------|-------------|--------+ [25](https://github.com/haskell/random/issues/25) | The seeds generated by split are not independent | Fixed: changed algorithm to SplitMix, which provides a robust split operation+ [26](https://github.com/haskell/random/issues/26) | Add Random instances for tuples | Addressed: added `Uniform` instances for up to 6-tuples+ [44](https://github.com/haskell/random/issues/44) | Add Random instance for Natural | Addressed: added UniformRange instance for Natural+ [51](https://github.com/haskell/random/issues/51) | Very low throughput | Fixed: see benchmarks below+ [53](https://github.com/haskell/random/issues/53) | incorrect distribution of randomR for floating-point numbers | (\*)+ [55](https://github.com/haskell/random/issues/55) | System/Random.hs:43:1: warning: [-Wtabs] | Fixed: No more tabs+ [58](https://github.com/haskell/random/issues/58) | Why does random for Float and Double produce exactly 24 or 53 bits? | (\*)+ [59](https://github.com/haskell/random/issues/59) | read :: StdGen fails for strings longer than 6 | Addressed: StdGen is no longer an instance of Read++#### Comments++(\*) 1.2 samples more bits but does not sample every `Float` or+`Double`. There are methods to do this but they have some downsides;+see [here](https://github.com/idontgetoutmuch/random/issues/105) for a+fuller discussion.++## Benchmarks++Here are some benchmarks run on a 3.1 GHz Intel Core i7. The full+benchmarks can be run using e.g. `stack bench`. The benchmarks are+measured in milliseconds per 100,000 generations. In some cases, the+performance is over x1000 times better; the minimum performance+increase for the types listed below is more than x36.++ Name | 1.1 Mean | 1.2 Mean+------------|----------|----------+ Float | 27.819 | 0.305+ Double | 50.644 | 0.328+ Integer | 42.332 | 0.332+ Word | 40.739 | 0.027+ Int | 43.847 | 0.028+ Char | 17.009 | 0.462+ Bool | 17.542 | 0.027++# 1.1+ * breaking change to `randomIValInteger` to improve RNG quality and performance+ see https://github.com/haskell/random/pull/4 and+ ghc https://ghc.haskell.org/trac/ghc/ticket/8898+ * correct documentation about generated range of Int32 sized values of type Int+ https://github.com/haskell/random/pull/7+ * fix memory leaks by using strict fields and strict atomicModifyIORef'+ https://github.com/haskell/random/pull/8+ related to ghc trac tickets #7936 and #4218+ * support for base < 4.6 (which doesnt provide strict atomicModifyIORef')+ and integrating Travis CI support.+ https://github.com/haskell/random/pull/12+ * fix C type in test suite https://github.com/haskell/random/pull/9++# 1.0.1.1+bump for overflow bug fixes++# 1.0.1.2+bump for ticket 8704, build fusion++# 1.0.1.0+bump for bug fixes,++# 1.0.0.4+bumped version for float/double range bugfix
+ README.md view
@@ -0,0 +1,33 @@+# The Haskell Standard Library++## Random Number Generation++### Status++| Language | Github Actions | Coveralls |+|:--------:|:--------------:|:---------:|+|  | [](https://github.com/haskell/random/actions/workflows/ci.yaml) | [](https://coveralls.io/github/haskell/random?branch=master)++| Github Repo | Hackage | Nightly | LTS |+|:-------------------|:-------:|:-------:|:---:|+| [`random`](https://github.com/haskell/random)| [](https://hackage.haskell.org/package/random)| [](https://www.stackage.org/nightly/package/random)| [](https://www.stackage.org/lts/package/random)++### Description++This library provides a basic interface for (splittable) pseudo-random number+generators.++The API documentation can be found here:++> http://hackage.haskell.org/package/random/docs/System-Random.html++An [older version][haskell98-version] of this library is included with GHC in+the `haskell98` package. This newer version is included in the [Haskell+Platform][haskell-platform].++Please report bugs in the [GitHub issue tracker][issue-tracker] (no longer in+the GHC trac).++[haskell-platform]: http://www.haskell.org/platform/contents.html+[haskell98-version]: https://downloads.haskell.org/~ghc/7.6.3/docs/html/libraries/haskell98/Random.html+[issue-tracker]: https://github.com/haskell/random/issues
Setup.hs view
@@ -1,5 +1,3 @@-module Main (main) where- import Distribution.Simple main :: IO ()
− System/Random.hs
@@ -1,595 +0,0 @@-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module : System.Random--- Copyright : (c) The University of Glasgow 2001--- License : BSD-style (see the file LICENSE in the 'random' repository)--- --- Maintainer : libraries@haskell.org--- Stability : stable--- Portability : portable------ This library deals with the common task of pseudo-random number--- generation. The library makes it possible to generate repeatable--- results, by starting with a specified initial random number generator,--- or to get different results on each run by using the system-initialised--- generator or by supplying a seed from some other source.------ The library is split into two layers: ------ * A core /random number generator/ provides a supply of bits.--- The class 'RandomGen' provides a common interface to such generators.--- The library provides one instance of 'RandomGen', the abstract--- data type 'StdGen'. Programmers may, of course, supply their own--- instances of 'RandomGen'.------ * The class 'Random' provides a way to extract values of a particular--- type from a random number generator. For example, the 'Float'--- instance of 'Random' allows one to generate random values of type--- 'Float'.------ This implementation uses the Portable Combined Generator of L'Ecuyer--- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by--- Lennart Augustsson. It has a period of roughly 2.30584e18.-----------------------------------------------------------------------------------#include "MachDeps.h"--module System.Random- (-- -- $intro-- -- * Random number generators--#ifdef ENABLE_SPLITTABLEGEN- RandomGen(next, genRange)- , SplittableGen(split)-#else- RandomGen(next, genRange, split)-#endif- -- ** Standard random number generators- , StdGen- , mkStdGen-- -- ** The global random number generator-- -- $globalrng-- , getStdRandom- , getStdGen- , setStdGen- , newStdGen-- -- * Random values of various types- , Random ( random, randomR,- randoms, randomRs,- randomIO, randomRIO )-- -- * References- -- $references-- ) where--import Prelude--import Data.Bits-import Data.Int-import Data.Word-import Foreign.C.Types--#ifdef __NHC__-import CPUTime ( getCPUTime )-import Foreign.Ptr ( Ptr, nullPtr )-import Foreign.C ( CTime, CUInt )-#else-import System.CPUTime ( getCPUTime )-import Data.Time ( getCurrentTime, UTCTime(..) )-import Data.Ratio ( numerator, denominator )-#endif-import Data.Char ( isSpace, chr, ord )-import System.IO.Unsafe ( unsafePerformIO )-import Data.IORef-import Numeric ( readDec )--#ifdef __GLASGOW_HASKELL__-import GHC.Exts ( build )-#else--- | A dummy variant of build without fusion.-{-# INLINE build #-}-build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]-build g = g (:) []-#endif---- The standard nhc98 implementation of Time.ClockTime does not match--- the extended one expected in this module, so we lash-up a quick--- replacement here.-#ifdef __NHC__-foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime-getTime :: IO (Integer, Integer)-getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0)-#else-getTime :: IO (Integer, Integer)-getTime = do- utc <- getCurrentTime- let daytime = toRational $ utctDayTime utc- return $ quotRem (numerator daytime) (denominator daytime)-#endif---- | The class 'RandomGen' provides a common interface to random number--- generators.----#ifdef ENABLE_SPLITTABLEGEN--- Minimal complete definition: 'next'.-#else--- Minimal complete definition: 'next' and 'split'.-#endif--class RandomGen g where-- -- |The 'next' operation returns an 'Int' that is uniformly distributed- -- in the range returned by 'genRange' (including both end points),- -- and a new generator.- next :: g -> (Int, g)-- -- |The 'genRange' operation yields the range of values returned by- -- the generator.- --- -- It is required that:- --- -- * If @(a,b) = 'genRange' g@, then @a < b@.- --- -- * 'genRange' always returns a pair of defined 'Int's.- --- -- The second condition ensures that 'genRange' cannot examine its- -- argument, and hence the value it returns can be determined only by the- -- instance of 'RandomGen'. That in turn allows an implementation to make- -- a single call to 'genRange' to establish a generator's range, without- -- being concerned that the generator returned by (say) 'next' might have- -- a different range to the generator passed to 'next'.- --- -- The default definition spans the full range of 'Int'.- genRange :: g -> (Int,Int)-- -- default method- genRange _ = (minBound, maxBound)--#ifdef ENABLE_SPLITTABLEGEN--- | The class 'SplittableGen' proivides a way to specify a random number--- generator that can be split into two new generators.-class SplittableGen g where-#endif- -- |The 'split' operation allows one to obtain two distinct random number- -- generators. This is very useful in functional programs (for example, when- -- passing a random number generator down to recursive calls), but very- -- little work has been done on statistically robust implementations of- -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"]- -- are the only examples we know of).- split :: g -> (g, g)--{- |-The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits.--The result of repeatedly using 'next' should be at least as statistically-robust as the /Minimal Standard Random Number Generator/ described by-["System.Random\#Park", "System.Random\#Carta"].-Until more is known about implementations of 'split', all we require is-that 'split' deliver generators that are (a) not identical and-(b) independently robust in the sense just given.--The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the-state of a random number generator.-It is required that @'read' ('show' g) == g@.--In addition, 'reads' may be used to map an arbitrary string (not necessarily one-produced by 'show') onto a value of type 'StdGen'. In general, the 'Read'-instance of 'StdGen' has the following properties: --* It guarantees to succeed on any string. --* It guarantees to consume only a finite portion of the string. --* Different argument strings are likely to result in different results.---}--data StdGen - = StdGen !Int32 !Int32--instance RandomGen StdGen where- next = stdNext- genRange _ = stdRange--#ifdef ENABLE_SPLITTABLEGEN-instance SplittableGen StdGen where-#endif- split = stdSplit--instance Show StdGen where- showsPrec p (StdGen s1 s2) = - showsPrec p s1 . - showChar ' ' .- showsPrec p s2--instance Read StdGen where- readsPrec _p = \ r ->- case try_read r of- r'@[_] -> r'- _ -> [stdFromString r] -- because it shouldn't ever fail.- where - try_read r = do- (s1, r1) <- readDec (dropWhile isSpace r)- (s2, r2) <- readDec (dropWhile isSpace r1)- return (StdGen s1 s2, r2)--{-- If we cannot unravel the StdGen from a string, create- one based on the string given.--}-stdFromString :: String -> (StdGen, String)-stdFromString s = (mkStdGen num, rest)- where (cs, rest) = splitAt 6 s- num = foldl (\a x -> x + 3 * a) 1 (map ord cs)---{- |-The function 'mkStdGen' provides an alternative way of producing an initial-generator, by mapping an 'Int' into a generator. Again, distinct arguments-should be likely to produce distinct generators.--}-mkStdGen :: Int -> StdGen -- why not Integer ?-mkStdGen s = mkStdGen32 $ fromIntegral s--{--From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be-initialized to values in the range [1, 2147483562] and [1, 2147483398]-respectively."--}-mkStdGen32 :: Int32 -> StdGen-mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1)- where- -- We want a non-negative number, but we can't just take the abs- -- of sMaybeNegative as -minBound == minBound.- s = sMaybeNegative .&. maxBound- (q, s1) = s `divMod` 2147483562- s2 = q `mod` 2147483398--createStdGen :: Integer -> StdGen-createStdGen s = mkStdGen32 $ fromIntegral s--{- |-With a source of random number supply in hand, the 'Random' class allows the-programmer to extract random values of a variety of types.--Minimal complete definition: 'randomR' and 'random'.---}--class Random a where- -- | Takes a range /(lo,hi)/ and a random number generator- -- /g/, and returns a random value uniformly distributed in the closed- -- interval /[lo,hi]/, together with a new generator. It is unspecified- -- what happens if /lo>hi/. For continuous types there is no requirement- -- that the values /lo/ and /hi/ are ever produced, but they may be,- -- depending on the implementation and the interval.- randomR :: RandomGen g => (a,a) -> g -> (a,g)-- -- | The same as 'randomR', but using a default range determined by the type:- --- -- * For bounded types (instances of 'Bounded', such as 'Char'),- -- the range is normally the whole type.- --- -- * For fractional types, the range is normally the semi-closed interval- -- @[0,1)@.- --- -- * For 'Integer', the range is (arbitrarily) the range of 'Int'.- random :: RandomGen g => g -> (a, g)-- -- | Plural variant of 'randomR', producing an infinite list of- -- random values instead of returning a new generator.- {-# INLINE randomRs #-}- randomRs :: RandomGen g => (a,a) -> g -> [a]- randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g)-- -- | Plural variant of 'random', producing an infinite list of- -- random values instead of returning a new generator.- {-# INLINE randoms #-}- randoms :: RandomGen g => g -> [a]- randoms g = build (\cons _nil -> buildRandoms cons random g)-- -- | A variant of 'randomR' that uses the global random number generator- -- (see "System.Random#globalrng").- randomRIO :: (a,a) -> IO a- randomRIO range = getStdRandom (randomR range)-- -- | A variant of 'random' that uses the global random number generator- -- (see "System.Random#globalrng").- randomIO :: IO a- randomIO = getStdRandom random---- | Produce an infinite list-equivalent of random values.-{-# INLINE buildRandoms #-}-buildRandoms :: RandomGen g- => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion- -> (g -> (a,g)) -- ^ E.g. 'random'- -> g -- ^ A 'RandomGen' instance- -> as-buildRandoms cons rand = go- where- -- The seq fixes part of #4218 and also makes fused Core simpler.- go g = x `seq` (x `cons` go g') where (x,g') = rand g---instance Random Integer where- randomR ival g = randomIvalInteger ival g- random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g--instance Random Int where randomR = randomIvalIntegral; random = randomBounded-instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded-instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded-instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded-instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded--#ifndef __NHC__--- Word is a type synonym in nhc98.-instance Random Word where randomR = randomIvalIntegral; random = randomBounded-#endif-instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded-instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded-instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded-instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded--instance Random CChar where randomR = randomIvalIntegral; random = randomBounded-instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded-instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded-instance Random CShort where randomR = randomIvalIntegral; random = randomBounded-instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded-instance Random CInt where randomR = randomIvalIntegral; random = randomBounded-instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded-instance Random CLong where randomR = randomIvalIntegral; random = randomBounded-instance Random CULong where randomR = randomIvalIntegral; random = randomBounded-instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded-instance Random CSize where randomR = randomIvalIntegral; random = randomBounded-instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded-instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded-instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded-instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded-instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded-instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded-instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded-instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded--instance Random Char where- randomR (a,b) g = - case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of- (x,g') -> (chr x, g')- random g = randomR (minBound,maxBound) g--instance Random Bool where- randomR (a,b) g = - case (randomIvalInteger (bool2Int a, bool2Int b) g) of- (x, g') -> (int2Bool x, g')- where- bool2Int :: Bool -> Integer- bool2Int False = 0- bool2Int True = 1-- int2Bool :: Int -> Bool- int2Bool 0 = False- int2Bool _ = True-- random g = randomR (minBound,maxBound) g--{-# INLINE randomRFloating #-}-randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g)-randomRFloating (l,h) g - | l>h = randomRFloating (h,l) g- | otherwise = let (coef,g') = random g in - (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow--instance Random Double where- randomR = randomRFloating- random rng = - case random rng of - (x,rng') -> - -- We use 53 bits of randomness corresponding to the 53 bit significand:- ((fromIntegral (mask53 .&. (x::Int64)) :: Double) - / fromIntegral twoto53, rng')- where - twoto53 = (2::Int64) ^ (53::Int64)- mask53 = twoto53 - 1- -instance Random Float where- randomR = randomRFloating- random rng = - -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. - case random rng of - (x,rng') -> - -- We use 24 bits of randomness corresponding to the 24 bit significand:- ((fromIntegral (mask24 .&. (x::Int32)) :: Float) - / fromIntegral twoto24, rng')- -- Note, encodeFloat is another option, but I'm not seeing slightly- -- worse performance with the following [2011.06.25]:--- (encodeFloat rand (-24), rng')- where- mask24 = twoto24 - 1- twoto24 = (2::Int32) ^ (24::Int32)---- CFloat/CDouble are basically the same as a Float/Double:-instance Random CFloat where- randomR = randomRFloating- random rng = case random rng of - (x,rng') -> (realToFrac (x::Float), rng')--instance Random CDouble where- randomR = randomRFloating- -- A MYSTERY:- -- Presently, this is showing better performance than the Double instance:- -- (And yet, if the Double instance uses randomFrac then its performance is much worse!)- random = randomFrac- -- random rng = case random rng of - -- (x,rng') -> (realToFrac (x::Double), rng')--mkStdRNG :: Integer -> IO StdGen-mkStdRNG o = do- ct <- getCPUTime- (sec, psec) <- getTime- return (createStdGen (sec * 12345 + psec + ct + o))--randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g)-randomBounded = randomR (minBound, maxBound)---- The two integer functions below take an [inclusive,inclusive] range.-randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)-randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h)--{-# SPECIALIZE randomIvalInteger :: (Num a) =>- (Integer, Integer) -> StdGen -> (a, StdGen) #-}- -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)-randomIvalInteger (l,h) rng- | l > h = randomIvalInteger (h,l) rng- | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')- where- (genlo, genhi) = genRange rng- b = fromIntegral genhi - fromIntegral genlo + 1-- -- Probabilities of the most likely and least likely result- -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen- -- is uniform, of course-- -- On average, log q / log b more random values will be generated- -- than the minimum- q = 1000- k = h - l + 1- magtgt = k * q-- -- generate random values until we exceed the target magnitude - f mag v g | mag >= magtgt = (v, g)- | otherwise = v' `seq`f (mag*b) v' g' where- (x,g') = next g- v' = (v * b + (fromIntegral x - fromIntegral genlo))----- The continuous functions on the other hand take an [inclusive,exclusive) range.-randomFrac :: (RandomGen g, Fractional a) => g -> (a, g)-randomFrac = randomIvalDouble (0::Double,1) realToFrac--randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)-randomIvalDouble (l,h) fromDouble rng - | l > h = randomIvalDouble (h,l) fromDouble rng- | otherwise = - case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of- (x, rng') -> - let- scaled_x = - fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed- fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow- fromIntegral (x::Int32)- in- (scaled_x, rng')--int32Count :: Integer-int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982--stdRange :: (Int,Int)-stdRange = (1, 2147483562)--stdNext :: StdGen -> (Int, StdGen)--- Returns values in the range stdRange-stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'')- where z' = if z < 1 then z + 2147483562 else z- z = s1'' - s2''-- k = s1 `quot` 53668- s1' = 40014 * (s1 - k * 53668) - k * 12211- s1'' = if s1' < 0 then s1' + 2147483563 else s1'- - k' = s2 `quot` 52774- s2' = 40692 * (s2 - k' * 52774) - k' * 3791- s2'' = if s2' < 0 then s2' + 2147483399 else s2'--stdSplit :: StdGen -> (StdGen, StdGen)-stdSplit std@(StdGen s1 s2)- = (left, right)- where- -- no statistical foundation for this!- left = StdGen new_s1 t2- right = StdGen t1 new_s2-- new_s1 | s1 == 2147483562 = 1- | otherwise = s1 + 1-- new_s2 | s2 == 1 = 2147483398- | otherwise = s2 - 1-- StdGen t1 t2 = snd (next std)---- The global random number generator--{- $globalrng #globalrng#--There is a single, implicit, global random number generator of type-'StdGen', held in some global variable maintained by the 'IO' monad. It is-initialised automatically in some system-dependent fashion, for example, by-using the time of day, or Linux's kernel random number generator. To get-deterministic behaviour, use 'setStdGen'.--}---- |Sets the global random number generator.-setStdGen :: StdGen -> IO ()-setStdGen sgen = writeIORef theStdGen sgen---- |Gets the global random number generator.-getStdGen :: IO StdGen-getStdGen = readIORef theStdGen--theStdGen :: IORef StdGen-theStdGen = unsafePerformIO $ do- rng <- mkStdRNG 0- newIORef rng---- |Applies 'split' to the current global random generator,--- updates it with one of the results, and returns the other.-newStdGen :: IO StdGen-newStdGen = atomicModifyIORef' theStdGen split--{- |Uses the supplied function to get a value from the current global-random generator, and updates the global generator with the new generator-returned by the function. For example, @rollDice@ gets a random integer-between 1 and 6:--> rollDice :: IO Int-> rollDice = getStdRandom (randomR (1,6))---}--getStdRandom :: (StdGen -> (a,StdGen)) -> IO a-getStdRandom f = atomicModifyIORef' theStdGen (swap . f)- where swap (v,g) = (g,v)--{- $references--1. FW #Burton# Burton and RL Page, /Distributed random number generation/,-Journal of Functional Programming, 2(2):203-212, April 1992.--2. SK #Park# Park, and KW Miller, /Random number generators --good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201.--3. DG #Carta# Carta, /Two fast implementations of the minimal standard-random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88.--4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/,-Department of Mathematics, University of Salzburg,-<http://random.mat.sbg.ac.at/~peter/pads98.ps>, 1998.--5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random-number generators/, Comm ACM, 31(6), Jun 1988, pp742-749.--The Web site <http://random.mat.sbg.ac.at/> is a great source of information.---}
+ bench-legacy/BinSearch.hs view
@@ -0,0 +1,149 @@++{-+ Binary search over benchmark input sizes.++ There are many good ways to measure the time it takes to perform a+ certain computation on a certain input. However, frequently, it's+ challenging to pick the right input size for all platforms and all+ compilataion modes.++ Sometimes for linear-complexity benchmarks it is better to measure+ /throughput/, i.e. elements processed per second. That is, fixing+ the time of execution and measuring the amount of work done (rather+ than the reverse). This library provides a simple way to search for+ an appropriate input size that results in the desired execution time.++ An alternative approach is to kill the computation after a certain+ amount of time and observe how much work it has completed.+ -}+module BinSearch+ (+ binSearch+ )+where++import Control.Monad+import Data.Time.Clock -- Not in 6.10+import Data.List+import System.IO+import Prelude hiding (min,max,log)++++-- | Binary search for the number of inputs to a computation that+-- results in a specified amount of execution time in seconds. For example:+--+-- > binSearch verbose N (min,max) kernel+--+-- ... will find the right input size that results in a time+-- between min and max, then it will then run for N trials and+-- return the median (input,time-in-seconds) pair.+binSearch :: Bool -> Integer -> (Double,Double) -> (Integer -> IO ()) -> IO (Integer, Double)+binSearch verbose trials (min, max) kernel = do+ when verbose $+ putStrLn $+ "[binsearch] Binary search for input size resulting in time in range " +++ show (min, max)+ let desired_exec_length = 1.0+ good_trial t =+ (toRational t <= toRational max) && (toRational t >= toRational min)+ -- At some point we must give up...+ loop n+ | n > ((2 :: Integer) ^ (100 :: Integer)) =+ error+ "ERROR binSearch: This function doesn't seem to scale in proportion to its last argument."+ -- Not allowed to have "0" size input, bump it back to one:+ loop 0 = loop 1+ loop n = do+ when verbose $ putStr $ "[binsearch:" ++ show n ++ "] "+ time <- timeit $ kernel n+ when verbose $ putStrLn $ "Time consumed: " ++ show time+ let rate = fromIntegral n / time+ -- [2010.06.09] Introducing a small fudge factor to help our guess get over the line:+ let initial_fudge_factor = 1.10+ fudge_factor = 1.01 -- Even in the steady state we fudge a little+ guess = desired_exec_length * rate+ -- TODO: We should keep more history here so that we don't re-explore input space we+ -- have already explored. This is a balancing act because of randomness in+ -- execution time.+ if good_trial time+ then do+ when verbose $+ putStrLn+ "[binsearch] Time in range. LOCKING input size and performing remaining trials."+ print_trial 1 n time+ lockin (trials - 1) n [time]+ else if time < 0.100+ then loop (2 * n)+ else do+ when verbose $+ putStrLn $+ "[binsearch] Estimated rate to be " +++ show (round rate :: Integer) +++ " per second. Trying to scale up..."+ -- Here we've exited the doubling phase, but we're making our+ -- first guess as to how big a real execution should be:+ if time > 0.100 && time < 0.33 * desired_exec_length+ then do+ when verbose $+ putStrLn+ "[binsearch] (Fudging first guess a little bit extra)"+ loop (round $ guess * initial_fudge_factor)+ else loop (round $ guess * fudge_factor)+ -- Termination condition: Done with all trials.+ lockin 0 n log = do+ when verbose $+ putStrLn $+ "[binsearch] Time-per-unit for all trials: " +++ concat+ (intersperse " " (map (show . (/ toDouble n) . toDouble) $ sort log))+ return (n, log !! (length log `quot` 2)) -- Take the median+ lockin trials_left n log = do+ when verbose $+ putStrLn+ "[binsearch]------------------------------------------------------------"+ time <- timeit $ kernel n+ -- hFlush stdout+ print_trial (trials - trials_left + 1) n time+ -- whenverbose$ hFlush stdout+ lockin (trials_left - 1) n (time : log)+ print_trial :: Integer -> Integer -> NominalDiffTime -> IO ()+ print_trial trialnum n time =+ let rate = fromIntegral n / time+ timeperunit = time / fromIntegral n+ in when verbose $+ putStrLn $+ "[binsearch] TRIAL: " +++ show trialnum +++ " secPerUnit: " +++ showTime timeperunit +++ " ratePerSec: " ++ show rate ++ " seconds: " ++ showTime time+ (n, t) <- loop 1+ return (n, fromRational $ toRational t)+++showTime :: NominalDiffTime -> String+showTime t = show ((fromRational $ toRational t) :: Double)++toDouble :: Real a => a -> Double+toDouble = fromRational . toRational+++-- Could use cycle counters here.... but the point of this is to time+-- things on the order of a second.+timeit :: IO () -> IO NominalDiffTime+timeit io = do+ strt <- getCurrentTime+ io+ end <- getCurrentTime+ return (diffUTCTime end strt)+{-+test :: IO (Integer,Double)+test =+ binSearch True 3 (1.0, 1.05)+ (\n ->+ do v <- newIORef 0+ forM_ [1..n] $ \i -> do+ old <- readIORef v+ writeIORef v (old+i))+-}
+ bench-legacy/SimpleRNGBench.hs view
@@ -0,0 +1,270 @@+{-# 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)+import System.Environment+import System.Random+import System.CPUTime (getCPUTime)+import System.CPUTime.Rdtsc+import System.Console.GetOpt++import GHC.Conc+import Control.Concurrent+import Control.Monad+import Control.Exception++import Data.IORef+import Data.Word+import Data.List hiding (last,sum)+import Data.Int+import Data.List.Split hiding (split)+import Text.Printf++import Foreign.Ptr+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Storable (peek,poke)++import Prelude hiding (last,sum)+import BinSearch++----------------------------------------------------------------------------------------------------+-- Miscellaneous helpers:++-- Readable large integer printing:+commaint :: Show a => a -> String+commaint n = reverse $ concat $ intersperse "," $ chunk 3 $ reverse (show n)++padleft :: Int -> String -> String+padleft n str | length str >= n = str+padleft n str | otherwise = take (n - length str) (repeat ' ') ++ str++padright :: Int -> String -> String+padright n str | length str >= n = str+padright n str | otherwise = str ++ take (n - length str) (repeat ' ')++fmt_num :: (RealFrac a, PrintfArg a) => a -> String+fmt_num n =+ if n < 100+ then printf "%.2f" n+ else commaint (round n :: Integer)+++-- Measure clock frequency, spinning rather than sleeping to try to+-- stay on the same core.+measureFreq :: IO Int64+measureFreq = do+ let second = 1000 * 1000 * 1000 * 1000 -- picoseconds are annoying+ t1 <- rdtsc+ start <- getCPUTime+ let loop !n !last = do+ t2 <- rdtsc+ when (t2 < last) $ putStrLn $ "COUNTERS WRAPPED " ++ show (last, t2)+ cput <- getCPUTime+ if cput - start < second+ then loop (n + 1) t2+ else return (n, t2)+ (n, t2) <- loop 0 t1+ putStrLn $ " Approx getCPUTime calls per second: " ++ commaint (n :: Int64)+ when (t2 < t1) $+ putStrLn $+ "WARNING: rdtsc not monotonically increasing, first " +++ show t1 ++ " then " ++ show t2 ++ " on the same OS thread"+ return $ fromIntegral (t2 - t1)++----------------------------------------------------------------------------------------------------++-- Test overheads without actually generating any random numbers:+data NoopRNG = NoopRNG+instance RandomGen NoopRNG where+ next g = (0, g)+ genRange _ = (0, 0)+ split g = (g, g)++-- An RNG generating only 0 or 1:+data BinRNG = BinRNG StdGen+instance RandomGen BinRNG where+ next (BinRNG g) = (x `mod` 2, BinRNG g')+ where+ (x, g') = next g+ genRange _ = (0, 1)+ split (BinRNG g) = (BinRNG g1, BinRNG g2)+ where+ (g1, g2) = split g+++----------------------------------------------------------------------------------------------------+-- Drivers to get random numbers repeatedly.++type Kern = Int -> Ptr Int -> IO ()++-- [2011.01.28] Changing this to take "count" and "accumulator ptr" as arguments:+-- foreign import ccall "cbits/c_test.c" blast_rands :: Kern+-- foreign import ccall "cbits/c_test.c" store_loop :: Kern+-- foreign import ccall unsafe "stdlib.hs" rand :: IO Int++{-# INLINE timeit #-}+timeit :: (Random a, RandomGen g) => Int -> Int64 -> String -> g -> (g -> (a,g)) -> IO ()+timeit numthreads freq msg gen nxt = do+ counters <- forM [1 .. numthreads] (const $ newIORef (1 :: Int64))+ tids <- forM counters $ \counter -> forkIO $ infloop counter (nxt gen)+ threadDelay (1000 * 1000) -- One second+ mapM_ killThread tids+ finals <- mapM readIORef counters+ let mean :: Double =+ fromIntegral (foldl1 (+) finals) / fromIntegral numthreads+ cycles_per :: Double = fromIntegral freq / mean+ printResult (round mean :: Int64) msg cycles_per+ where+ infloop !counter (!_, !g) = do+ incr counter+ infloop counter (nxt g)+ incr !counter+ -- modifyIORef counter (+1) -- Not strict enough!+ = do+ c <- readIORef counter+ let c' = c + 1+ _ <- evaluate c'+ writeIORef counter c'+++-- This function times an IO function on one or more threads. Rather+-- than running a fixed number of iterations, it uses a binary search+-- to find out how many iterations can be completed in a second.+timeit_foreign :: Int -> Int64 -> String -> (Int -> Ptr Int -> IO ()) -> IO Int64+timeit_foreign numthreads freq msg ffn = do+ ptr :: ForeignPtr Int <- mallocForeignPtr+ let kern =+ if numthreads == 1+ then ffn+ else replicate_kernel numthreads ffn+ wrapped n = withForeignPtr ptr (kern $ fromIntegral n)+ (n, t) <- binSearch False 1 (1.0, 1.05) wrapped+ let total_per_second = round $ fromIntegral n * (1 / t)+ cycles_per = fromIntegral freq * t / fromIntegral n+ printResult total_per_second msg cycles_per+ return total_per_second+ -- This lifts a C kernel to operate simultaneously on N threads.+ where+ replicate_kernel :: Int -> Kern -> Kern+ replicate_kernel nthreads kern n ptr = do+ ptrs <- forM [1 .. nthreads] (const mallocForeignPtr)+ tmpchan <- newChan+ -- let childwork = ceiling$ fromIntegral n / fromIntegral nthreads+ let childwork = n -- Keep it the same.. interested in per-thread throughput.+ -- Fork/join pattern:+ forM_ ptrs $ \pt ->+ forkIO $+ withForeignPtr pt $ \p -> do+ kern (fromIntegral childwork) p+ result <- peek p+ writeChan tmpchan result+ results <- forM [1 .. nthreads] $ \_ -> readChan tmpchan+ -- Meaningless semantics here... sum the child ptrs and write to the input one:+ poke ptr (foldl1 (+) results)+++printResult :: Int64 -> String -> Double -> IO ()+printResult total msg cycles_per =+ putStrLn $+ " " +++ padleft 11 (commaint total) +++ " randoms generated " +++ padright 27 ("[" ++ msg ++ "]") +++ " ~ " ++ fmt_num cycles_per ++ " cycles/int"++----------------------------------------------------------------------------------------------------+-- Main Script++data Flag = NoC | Help+ deriving (Show, Eq)++options :: [OptDescr Flag]+options =+ [ Option ['h'] ["help"] (NoArg Help) "print program help"+ , Option [] ["noC"] (NoArg NoC) "omit C benchmarks, haskell only"+ ]++main :: IO ()+main = do+ argv <- getArgs+ let (opts,_,other) = getOpt Permute options argv++ unless (null other) $ do+ putStrLn "ERROR: Unrecognized options: "+ mapM_ putStr other+ exitFailure++ when (Help `elem` opts) $ do+ putStr $ usageInfo "Benchmark random number generation" options+ exitSuccess++ putStrLn "\nHow many random numbers can we generate in a second on one thread?"++ t1 <- rdtsc+ t2 <- rdtsc+ putStrLn (" Cost of rdtsc (ffi call): " ++ show (t2 - t1))++ freq <- measureFreq+ putStrLn $ " Approx clock frequency: " ++ commaint freq++ let randInt = random :: RandomGen g => g -> (Int,g)+ randWord16 = random :: RandomGen g => g -> (Word16,g)+ randFloat = random :: RandomGen g => g -> (Float,g)+ randCFloat = random :: RandomGen g => g -> (CFloat,g)+ randDouble = random :: RandomGen g => g -> (Double,g)+ randCDouble = random :: RandomGen g => g -> (CDouble,g)+ randInteger = random :: RandomGen g => g -> (Integer,g)+ randBool = random :: RandomGen g => g -> (Bool,g)+ randChar = random :: RandomGen g => g -> (Char,g)++ gen = mkStdGen 238523586+ gamut th = do+ putStrLn " First, timing System.Random.next:"+ timeit th freq "constant zero gen" NoopRNG next+ timeit th freq "System.Random stdGen/next" gen next++ putStrLn "\n Second, timing System.Random.random at different types:"+ timeit th freq "System.Random Ints" gen randInt+ timeit th freq "System.Random Word16" gen randWord16+ timeit th freq "System.Random Floats" gen randFloat+ timeit th freq "System.Random CFloats" gen randCFloat+ timeit th freq "System.Random Doubles" gen randDouble+ timeit th freq "System.Random CDoubles" gen randCDouble+ timeit th freq "System.Random Integers" gen randInteger+ timeit th freq "System.Random Bools" gen randBool+ timeit th freq "System.Random Chars" gen randChar++ putStrLn "\n Next timing range-restricted System.Random.randomR:"+ timeit th freq "System.Random Ints" gen (randomR (-100, 100::Int))+ timeit th freq "System.Random Word16s" gen (randomR ( 100, 300::Word16))+ timeit th freq "System.Random Floats" gen (randomR (-100, 100::Float))+ timeit th freq "System.Random CFloats" gen (randomR (-100, 100::CFloat))+ timeit th freq "System.Random Doubles" gen (randomR (-100, 100::Double))+ timeit th freq "System.Random CDoubles" gen (randomR (-100, 100::CDouble))+ timeit th freq "System.Random Integers" gen (randomR (-100, 100::Integer))+ timeit th freq "System.Random Bools" gen (randomR (False, True::Bool))+ timeit th freq "System.Random Chars" gen (randomR ('a', 'z'))+ timeit th freq "System.Random BIG Integers" gen (randomR (0, (2::Integer) ^ (5000::Int)))++ -- when (not$ NoC `elem` opts) $ do+ -- putStrLn$ " Comparison to C's rand():"+ -- timeit_foreign th freq "ptr store in C loop" store_loop+ -- timeit_foreign th freq "rand/store in C loop" blast_rands+ -- timeit_foreign th freq "rand in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> rand )+ -- timeit_foreign th freq "rand/store in Haskell loop" (\n ptr -> forM_ [1..n]$ \_ -> do n <- rand; poke ptr n )+ -- return ()++ -- Test with 1 thread and numCapabilities threads:+ gamut 1+ when (numCapabilities > 1) $ do+ putStrLn $ "\nNow "++ show numCapabilities ++" threads, reporting mean randoms-per-second-per-thread:"+ void $ gamut numCapabilities++ putStrLn "Finished."+
+ bench/Main.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main) where++import Control.Monad+import Control.Monad.State.Strict+import Data.Int+import Data.List (sortOn)+import Data.Proxy+import Data.Typeable+import Data.Word+import Foreign.C.Types+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.Types+import Data.Primitive.PrimArray+#endif++import System.Random.Stateful++seed :: Int+seed = 1337++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)+ setStdGen $ mkStdGen seed+ defaultMain+ [ bgroup "baseline"+ [ env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen ->+ bench "nextWord32" $ whnf (genMany SM.nextWord32 smGen) sz+ , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen ->+ bench "nextWord64" $ whnf (genMany SM.nextWord64 smGen) sz+ , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen ->+ bench "nextInt" $ whnf (genMany SM.nextInt smGen) sz+ , env (pure $ SM.mkSMGen $ fromIntegral seed) $ \smGen ->+ bench "split" $ whnf (genMany SM.splitSMGen smGen) sz+ ]+ , bgroup "pure"+ [ bgroup "random"+ [ pureBench random sz (Proxy :: Proxy Word8)+ , pureBench random sz (Proxy :: Proxy Word16)+ , pureBench random sz (Proxy :: Proxy Word32)+ , pureBench random sz (Proxy :: Proxy Word64)+ , pureBench random sz (Proxy :: Proxy Int8)+ , pureBench random sz (Proxy :: Proxy Int16)+ , pureBench random sz (Proxy :: Proxy Int32)+ , pureBench random sz (Proxy :: Proxy Int64)+ , pureBench random sz (Proxy :: Proxy Bool)+ , pureBench random sz (Proxy :: Proxy Char)+ , pureBench random sz (Proxy :: Proxy Float)+ , pureBench random sz (Proxy :: Proxy Double)+ , pureBench random sz (Proxy :: Proxy Integer)+ ]+ , bgroup "uniform"+ [ pureBench uniform sz (Proxy :: Proxy Word8)+ , pureBench uniform sz (Proxy :: Proxy Word16)+ , pureBench uniform sz (Proxy :: Proxy Word32)+ , pureBench uniform sz (Proxy :: Proxy Word64)+ , pureBench uniform sz (Proxy :: Proxy Int8)+ , pureBench uniform sz (Proxy :: Proxy Int16)+ , pureBench uniform sz (Proxy :: Proxy Int32)+ , pureBench uniform sz (Proxy :: Proxy Int64)+ , pureBench uniform sz (Proxy :: Proxy Bool)+ , pureBench uniform sz (Proxy :: Proxy Char)+ , pureBench uniform sz (Proxy :: Proxy CChar)+ , pureBench uniform sz (Proxy :: Proxy CSChar)+ , pureBench uniform sz (Proxy :: Proxy CUChar)+ , pureBench uniform sz (Proxy :: Proxy CShort)+ , pureBench uniform sz (Proxy :: Proxy CUShort)+ , pureBench uniform sz (Proxy :: Proxy CInt)+ , pureBench uniform sz (Proxy :: Proxy CUInt)+ , pureBench uniform sz (Proxy :: Proxy CLong)+ , pureBench uniform sz (Proxy :: Proxy CULong)+ , pureBench uniform sz (Proxy :: Proxy CPtrdiff)+ , pureBench uniform sz (Proxy :: Proxy CSize)+ , pureBench uniform sz (Proxy :: Proxy CWchar)+ , pureBench uniform sz (Proxy :: Proxy CSigAtomic)+ , pureBench uniform sz (Proxy :: Proxy CLLong)+ , pureBench uniform sz (Proxy :: Proxy CULLong)+ , pureBench uniform sz (Proxy :: Proxy CIntPtr)+ , pureBench uniform sz (Proxy :: Proxy CUIntPtr)+ , pureBench uniform sz (Proxy :: Proxy CIntMax)+ , pureBench uniform sz (Proxy :: Proxy CUIntMax)+ ]+ , bgroup "uniformR"+ [ bgroup "full"+ [ pureUniformRFullBench (Proxy :: Proxy Word8) sz+ , pureUniformRFullBench (Proxy :: Proxy Word16) sz+ , pureUniformRFullBench (Proxy :: Proxy Word32) sz+ , pureUniformRFullBench (Proxy :: Proxy Word64) sz+ , pureUniformRFullBench (Proxy :: Proxy Word) sz+ , pureUniformRFullBench (Proxy :: Proxy Int8) sz+ , pureUniformRFullBench (Proxy :: Proxy Int16) sz+ , pureUniformRFullBench (Proxy :: Proxy Int32) sz+ , pureUniformRFullBench (Proxy :: Proxy Int64) sz+ , pureUniformRFullBench (Proxy :: Proxy Int) sz+ , pureUniformRFullBench (Proxy :: Proxy Char) sz+ , pureUniformRFullBench (Proxy :: Proxy Bool) sz+ , pureUniformRFullBench (Proxy :: Proxy CChar) sz+ , pureUniformRFullBench (Proxy :: Proxy CSChar) sz+ , pureUniformRFullBench (Proxy :: Proxy CUChar) sz+ , pureUniformRFullBench (Proxy :: Proxy CShort) sz+ , pureUniformRFullBench (Proxy :: Proxy CUShort) sz+ , pureUniformRFullBench (Proxy :: Proxy CInt) sz+ , pureUniformRFullBench (Proxy :: Proxy CUInt) sz+ , pureUniformRFullBench (Proxy :: Proxy CLong) sz+ , pureUniformRFullBench (Proxy :: Proxy CULong) sz+ , pureUniformRFullBench (Proxy :: Proxy CPtrdiff) sz+ , pureUniformRFullBench (Proxy :: Proxy CSize) sz+ , pureUniformRFullBench (Proxy :: Proxy CWchar) sz+ , pureUniformRFullBench (Proxy :: Proxy CSigAtomic) sz+ , pureUniformRFullBench (Proxy :: Proxy CLLong) sz+ , pureUniformRFullBench (Proxy :: Proxy CULLong) sz+ , pureUniformRFullBench (Proxy :: Proxy CIntPtr) sz+ , pureUniformRFullBench (Proxy :: Proxy CUIntPtr) sz+ , pureUniformRFullBench (Proxy :: Proxy CIntMax) sz+ , pureUniformRFullBench (Proxy :: Proxy CUIntMax) sz+ ]+ , bgroup "excludeMax"+ [ pureUniformRExcludeMaxBench (Proxy :: Proxy Word8) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Word16) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Word32) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Word64) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Word) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Int8) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Int16) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Int32) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Int64) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Int) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Char) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy Bool) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CChar) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CSChar) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CUChar) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CShort) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CUShort) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CInt) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CUInt) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CLong) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CULong) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CPtrdiff) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CSize) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CWchar) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CSigAtomic) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CLLong) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CULLong) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CIntPtr) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CUIntPtr) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CIntMax) sz+ , pureUniformRExcludeMaxBench (Proxy :: Proxy CUIntMax) sz+ ]+ , bgroup "includeHalf"+ [ pureUniformRIncludeHalfBench (Proxy :: Proxy Word8) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Word16) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Word32) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Word64) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Word) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Int8) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Int16) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Int32) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Int64) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy Int) sz+ , pureUniformRIncludeHalfEnumBench (Proxy :: Proxy Char) sz+ , pureUniformRIncludeHalfEnumBench (Proxy :: Proxy Bool) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CChar) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CSChar) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CUChar) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CShort) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CUShort) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CInt) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CUInt) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CLong) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CULong) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CPtrdiff) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CSize) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CWchar) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CSigAtomic) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CLLong) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CULLong) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CIntPtr) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CUIntPtr) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CIntMax) sz+ , pureUniformRIncludeHalfBench (Proxy :: Proxy CUIntMax) sz+ ]+ , bgroup "unbounded"+ [ pureUniformRBench (Proxy :: Proxy Float) (1.23e-4, 5.67e8) sz+ , pureUniformRBench (Proxy :: Proxy Double) (1.23e-4, 5.67e8) sz+ , let !i = (10 :: Integer) ^ (100 :: Integer)+ !range = (-i - 1, i + 1)+ in pureUniformRBench (Proxy :: Proxy Integer) range sz+ , let !n = (10 :: Natural) ^ (100 :: Natural)+ !range = (1, n - 1)+ in pureUniformRBench (Proxy :: Proxy Natural) range sz+ ]+ , bgroup "floating"+ [+#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))+ ]+ ]+ ,+#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"+ [ 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 "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 ::+ forall a. (Typeable a, UniformRange a, Bounded a)+ => Proxy a+ -> Int+ -> Benchmark+pureUniformRFullBench px =+ let range = (minBound :: a, maxBound :: a)+ in pureUniformRBench px range+{-# INLINE pureUniformRFullBench #-}++pureUniformRExcludeMaxBench ::+ forall a. (Typeable a, UniformRange a, Bounded a, Enum a)+ => Proxy a+ -> Int+ -> Benchmark+pureUniformRExcludeMaxBench px =+ let range = (minBound :: a, pred (maxBound :: a))+ in pureUniformRBench px range+{-# INLINE pureUniformRExcludeMaxBench #-}++pureUniformRIncludeHalfBench ::+ forall a. (Typeable a, UniformRange a, Bounded a, Integral a)+ => Proxy a+ -> Int+ -> Benchmark+pureUniformRIncludeHalfBench px =+ let range = ((minBound :: a) + 1, ((maxBound :: a) `div` 2) + 1)+ in pureUniformRBench px range+{-# INLINE pureUniformRIncludeHalfBench #-}++pureUniformRIncludeHalfEnumBench ::+ forall a. (Typeable a, UniformRange a, Bounded a, Enum a)+ => Proxy a+ -> Int+ -> Benchmark+pureUniformRIncludeHalfEnumBench px =+ let range = (succ (minBound :: a), toEnum ((fromEnum (maxBound :: a) `div` 2) + 1))+ in pureUniformRBench px range+{-# INLINE pureUniformRIncludeHalfEnumBench #-}++pureUniformRBench ::+ forall a. (Typeable a, UniformRange a)+ => Proxy a+ -> (a, a)+ -> Int+ -> Benchmark+pureUniformRBench px range@(!_, !_) sz = pureBench (uniformR range) sz px+{-# INLINE pureUniformRBench #-}++pureBench ::+ forall a. Typeable a+ => (StdGen -> (a, StdGen))+ -> Int+ -> Proxy a+ -> Benchmark+pureBench f sz px =+ env getStdGen $ \gen ->+ bench (showsTypeRep (typeRep px) "") $ whnf (genMany f gen) sz+{-# INLINE pureBench #-}+++genMany :: (g -> (a, g)) -> g -> Int -> a+genMany f g0 n = go 0 $ f g0+ where+ go i (!y, !g)+ | i < n = go (i + 1) $ f g+ | otherwise = y++#if MIN_VERSION_primitive(0,7,1)+fillMutablePrimArrayM ::+ (Prim a, PrimMonad m)+ => (gen -> m a)+ -> MutablePrimArray (PrimState m) a+ -> gen+ -> m (PrimArray a)+fillMutablePrimArrayM f ma g = do+ n <- getSizeofMutablePrimArray ma+ let go i+ | i < n = f g >>= writePrimArray ma i >> go (i + 1)+ | otherwise = pure ()+ go 0+ unsafeFreezePrimArray ma+#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,62 +1,200 @@-name: random-version: 1.0.1.3---- 1.0.1.0 -- bump for bug fixes, but no SplittableGen yet--- 1.0.1.1 -- bump for overflow bug fixes--- 1.0.1.2 -- bump for ticket 8704, build fusion--- 1.0.1.3 -- bump for various bug fixes--license: BSD3-license-file: LICENSE-maintainer: rrnewton@gmail.com-bug-reports: https://github.com/haskell/random/issues-synopsis: random number library-category: System+cabal-version: >=1.10+name: random+version: 1.3.1+license: BSD3+license-file: LICENSE+maintainer: core-libraries-committee@haskell.org+bug-reports: https://github.com/haskell/random/issues+synopsis: Pseudo-random number generation description:- This package provides a basic random number generation- library, including the ability to split random number- generators.-build-type: Simple--- cabal-version 1.8 needed because "the field 'build-depends: random' refers--- to a library which is defined within the same package"-cabal-version: >= 1.8+ This package provides basic pseudo-random number generation, including the+ ability to split random number generators.+ .+ == "System.Random": pure pseudo-random number interface+ .+ In pure code, use 'System.Random.uniform' and 'System.Random.uniformR' from+ "System.Random" to generate pseudo-random numbers with a pure pseudo-random+ number generator like 'System.Random.StdGen'.+ .+ As an example, here is how you can simulate rolls of a six-sided die using+ 'System.Random.uniformR':+ .+ >>> let roll = uniformR (1, 6) :: RandomGen g => g -> (Word, g)+ >>> let rolls = unfoldr (Just . roll) :: RandomGen g => g -> [Word]+ >>> let pureGen = mkStdGen 42+ >>> take 10 (rolls pureGen) :: [Word]+ [1,1,3,2,4,5,3,4,6,2]+ .+ See "System.Random" for more details.+ .+ == "System.Random.Stateful": monadic pseudo-random number interface+ .+ In monadic code, use 'System.Random.Stateful.uniformM' and+ 'System.Random.Stateful.uniformRM' from "System.Random.Stateful" to generate+ pseudo-random numbers with a monadic pseudo-random number generator, or+ using a monadic adapter.+ .+ As an example, here is how you can simulate rolls of a six-sided die using+ 'System.Random.Stateful.uniformRM':+ .+ >>> let rollM = uniformRM (1, 6) :: StatefulGen g m => g -> m Word+ >>> let pureGen = mkStdGen 42+ >>> runStateGen_ pureGen (replicateM 10 . rollM) :: [Word]+ [1,1,3,2,4,5,3,4,6,2]+ .+ The monadic adapter 'System.Random.Stateful.runStateGen_' is used here to lift+ the pure pseudo-random number generator @pureGen@ into the+ 'System.Random.Stateful.StatefulGen' context.+ .+ The monadic interface can also be used with existing monadic pseudo-random+ number generators. In this example, we use the one provided in the+ <https://hackage.haskell.org/package/mwc-random mwc-random> package:+ .+ >>> import System.Random.MWC as MWC+ >>> let rollM = uniformRM (1, 6) :: StatefulGen g m => g -> m Word+ >>> monadicGen <- MWC.create+ >>> replicateM 10 (rollM monadicGen) :: IO [Word]+ [2,3,6,6,4,4,3,1,5,4]+ .+ See "System.Random.Stateful" for more details. +category: System+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md+tested-with: GHC == 8.0.2+ , GHC == 8.2.2+ , GHC == 8.4.4+ , GHC == 8.6.5+ , 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+ location: https://github.com/haskell/random.git -Library++library exposed-modules: System.Random- extensions: CPP- GHC-Options: -O2 - build-depends: base >= 3 && < 5, time+ System.Random.Internal+ System.Random.Stateful+ other-modules:+ System.Random.Array+ System.Random.Seed+ System.Random.GFinite -source-repository head- type: git- location: http://git.haskell.org/packages/random.git+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -Wall+ -Wincomplete-record-updates -Wincomplete-uni-patterns --- To run the Test-Suite:--- $ cabal configure --enable-tests--- $ cabal test --show-details=always --test-options="+RTS -M1M -RTS"+ build-depends:+ 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 < 9.4)+ build-depends: data-array-byte -Test-Suite T7936- type: exitcode-stdio-1.0- main-is: T7936.hs- hs-source-dirs: tests- build-depends: base >= 3 && < 5, random- ghc-options: -rtsopts -O2+test-suite legacy-test+ type: exitcode-stdio-1.0+ main-is: Legacy.hs+ hs-source-dirs: test-legacy+ other-modules:+ T7936+ TestRandomIOs+ TestRandomRs+ Random1283+ RangeTest -Test-Suite TestRandomRs- type: exitcode-stdio-1.0- main-is: TestRandomRs.hs- hs-source-dirs: tests- build-depends: base >= 3 && < 5, random- ghc-options: -rtsopts -O2- -- TODO. Why does the following not work?- --test-options: +RTS -M1M -RTS+ default-language: Haskell2010+ ghc-options:+ -with-rtsopts=-M9M+ -Wno-deprecations+ build-depends:+ base,+ containers >=0.5 && <0.8,+ random -Test-Suite TestRandomIOs- type: exitcode-stdio-1.0- main-is: TestRandomIOs.hs- hs-source-dirs: tests- build-depends: base >= 3 && < 5, random- ghc-options: -rtsopts -O2+test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ other-modules:+ Spec.Range+ Spec.Run+ Spec.Seed+ Spec.Stateful++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base,+ bytestring,+ random,+ smallcheck >=1.2 && <1.3,+ stm,+ tasty >=1.0 && <1.6,+ tasty-smallcheck >=0.8 && <0.9,+ tasty-hunit >=0.10 && <0.11,+ transformers++-- Note. Fails when compiled with coverage:+-- https://github.com/haskell/random/issues/107+test-suite spec-inspection+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test-inspection+ default-language: Haskell2010+ ghc-options: -Wall+ other-modules:+ Spec.Inspection+ build-depends:+ base,+ random,+ tasty >=1.0 && <1.6,+ tasty-inspection-testing+ if impl(ghc >=9.10)+ buildable: False++benchmark legacy-bench+ type: exitcode-stdio-1.0+ main-is: SimpleRNGBench.hs+ hs-source-dirs: bench-legacy+ other-modules: BinSearch+ default-language: Haskell2010+ ghc-options:+ -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -Wno-deprecations++ build-depends:+ base,+ random,+ rdtsc,+ split >=0.2 && <0.3,+ time >=1.4 && <1.13++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench+ default-language: Haskell2010+ ghc-options: -Wall -O2+ build-depends:+ base,+ mtl,+ primitive,+ random,+ splitmix >=0.1 && <0.2,+ tasty-bench
+ src/System/Random.hs view
@@ -0,0 +1,917 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module : System.Random+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file LICENSE in the 'random' repository)+-- Maintainer : libraries@haskell.org+-- Stability : stable+--+-- This library deals with the common task of pseudo-random number generation.+module System.Random+ (+ -- * Introduction+ -- $introduction++ -- * Usage+ -- $usagepure++ -- * Pure number generator interface+ -- $interfaces+ RandomGen+ ( split+ , genWord8+ , genWord16+ , genWord32+ , genWord64+ , genWord32R+ , genWord64R+ , unsafeUniformFillMutableByteArray+ )+ , SplitGen (splitGen)+ , uniform+ , uniformR+ , 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+ -- $globalstdgen+ , getStdRandom+ , getStdGen+ , setStdGen+ , newStdGen+ , randomIO+ , randomRIO++ -- * Compatibility and reproducibility+ -- ** Backwards compatibility and deprecations+ , genRange+ , next+ -- $deprecations++ -- ** Reproducibility+ -- $reproducibility++ -- * Notes for pseudo-random number generator implementors+ -- ** How to implement 'RandomGen'+ -- $implementrandomgen++ -- * References+ -- $references+ ) where++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 hiding (uniformShortByteString)+import System.Random.Seed+import qualified System.Random.SplitMix as SM++-- $introduction+--+-- This module provides type classes and instances for the following concepts:+--+-- [Pure pseudo-random number generators] 'RandomGen' is an interface to pure+-- pseudo-random number generators.+--+-- 'StdGen', the standard pseudo-random number generator provided in this+-- library, is an instance of 'RandomGen'. It uses the SplitMix+-- implementation provided by the+-- <https://hackage.haskell.org/package/splitmix splitmix> package.+-- Programmers may, of course, supply their own instances of 'RandomGen'.+--+-- $usagepure+--+-- In pure code, use 'uniform' and 'uniformR' to generate pseudo-random values+-- with a pure pseudo-random number generator like 'StdGen'.+--+-- >>> :{+-- let rolls :: RandomGen g => Int -> g -> [Word]+-- rolls n = fst . uniformListR n (1, 6)+-- pureGen = mkStdGen 137+-- in+-- rolls 10 pureGen :: [Word]+-- :}+-- [4,2,6,1,6,6,5,1,1,5]+--+-- To run use a /monadic/ pseudo-random computation in pure code with a pure+-- pseudo-random number generator, use 'runStateGen' and its variants.+--+-- >>> :{+-- let rollsM :: StatefulGen g m => Int -> g -> m [Word]+-- rollsM n = uniformListRM n (1, 6)+-- pureGen = mkStdGen 137+-- in+-- runStateGen_ pureGen (rollsM 10) :: [Word]+-- :}+-- [4,2,6,1,6,6,5,1,1,5]++-------------------------------------------------------------------------------+-- Pseudo-random number generator interfaces+-------------------------------------------------------------------------------++-- $interfaces+--+-- Pseudo-random number generators come in two flavours: /pure/ and /monadic/.+--+-- ['RandomGen': pure pseudo-random number generators] These generators produce+-- a new pseudo-random value together with a new instance of the+-- pseudo-random number generator.+--+-- Pure pseudo-random number generators should implement 'split' if they+-- are /splittable/, that is, if there is an efficient method to turn one+-- generator into two. The pseudo-random numbers produced by the two+-- resulting generators should not be correlated. See [1] for some+-- background on splittable pseudo-random generators.+--+-- ['System.Random.Stateful.StatefulGen': monadic pseudo-random number generators]+-- See "System.Random.Stateful" module+--++-- | Generates a value uniformly distributed over all possible values of that+-- type.+--+-- This is a pure version of 'System.Random.Stateful.uniformM'.+--+-- ====__Examples__+--+-- >>> import System.Random+-- >>> let pureGen = mkStdGen 137+-- >>> 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 :: (Uniform a, RandomGen g) => g -> (a, g)+uniform g = runStateGen g uniformM+{-# INLINE uniform #-}++-- | Generates a value uniformly distributed over the provided range, which+-- is interpreted as inclusive in the lower and upper bound.+--+-- * @uniformR (1 :: Int, 4 :: Int)@ generates values uniformly from the set+-- \(\{1,2,3,4\}\)+--+-- * @uniformR (1 :: Float, 4 :: Float)@ generates values uniformly from the+-- set \(\{x\;|\;1 \le x \le 4\}\)+--+-- The following law should hold to make the function always defined:+--+-- > uniformR (a, b) = uniformR (b, a)+--+-- This is a pure version of 'System.Random.Stateful.uniformRM'.+--+-- ====__Examples__+--+-- >>> import System.Random+-- >>> let pureGen = mkStdGen 137+-- >>> 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 :: (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.+--+-- ====__Examples__+--+-- >>> 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 = 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+-- subrange will be selected.+--+-- 'Random' exists primarily for backwards compatibility with version 1.1 of+-- this library. In new code, use the better specified 'Uniform' and+-- 'UniformRange' instead.+--+-- @since 1.0.0+class Random a where++ -- | Takes a range /(lo,hi)/ and a pseudo-random number generator+ -- /g/, and returns a pseudo-random value uniformly distributed over the+ -- closed interval /[lo,hi]/, together with a new generator. It is unspecified+ -- what happens if /lo>hi/, but usually the values will simply get swapped.+ --+ -- >>> let gen = mkStdGen 26+ -- >>> fst $ randomR ('a', 'z') gen+ -- '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.+ --+ -- There is no requirement to follow the @Ord@ instance and the concept of range can be+ -- defined on per type basis. For example product types will treat their values+ -- independently:+ --+ -- >>> fst $ randomR (('a', 5.0), ('z', 10.0)) $ mkStdGen 26+ -- ('z',5.22694980853051)+ --+ -- In case when a lawful range is desired `uniformR` should be used+ -- instead.+ --+ -- @since 1.0.0+ {-# INLINE randomR #-}+ randomR :: RandomGen g => (a, a) -> g -> (a, g)+ default randomR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)+ randomR r g = runStateGen g (uniformRM r)++ -- | The same as 'randomR', but using a default range determined by the type:+ --+ -- * For bounded types (instances of 'Bounded', such as 'Char'),+ -- the range is normally the whole type.+ --+ -- * For floating point types, the range is normally the closed interval @[0,1]@.+ --+ -- * For 'Integer', the range is (arbitrarily) the range of 'Int'.+ --+ -- @since 1.0.0+ {-# INLINE random #-}+ random :: RandomGen g => g -> (a, g)+ default random :: (RandomGen g, Uniform a) => g -> (a, g)+ random g = runStateGen g uniformM++ -- | Plural variant of 'randomR', producing an infinite list of+ -- pseudo-random values instead of returning a new generator.+ --+ -- @since 1.0.0+ {-# INLINE randomRs #-}+ randomRs :: RandomGen g => (a,a) -> g -> [a]+ randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g)++ -- | Plural variant of 'random', producing an infinite list of+ -- pseudo-random values instead of returning a new generator.+ --+ -- @since 1.0.0+ {-# INLINE randoms #-}+ randoms :: RandomGen g => g -> [a]+ randoms g = build (\cons _nil -> buildRandoms cons random g)+++-- | Produce an infinite list-equivalent of pseudo-random values.+--+-- ====__Examples__+--+-- >>> import System.Random+-- >>> let pureGen = mkStdGen 137+-- >>> (take 4 . buildRandoms (:) random $ pureGen) :: [Int]+-- [7879794327570578227,6883935014316540929,-1519291874655152001,2353271688382626589]+--+{-# INLINE buildRandoms #-}+buildRandoms :: RandomGen g+ => (a -> as -> as) -- ^ E.g. @(:)@ but subject to fusion+ -> (g -> (a,g)) -- ^ E.g. 'random'+ -> g -- ^ A 'RandomGen' instance+ -> as+buildRandoms cons rand = go+ where+ -- 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+instance Random Integer where+ random = first (toInteger :: Int -> Integer) . random+ {-# INLINE random #-}+instance Random Int8+instance Random Int16+instance Random Int32+instance Random Int64+instance Random Int+instance Random Word+instance Random Word8+instance Random Word16+instance Random Word32+instance Random Word64+#if __GLASGOW_HASKELL__ >= 802+instance Random CBool+#endif+instance Random CChar+instance Random CSChar+instance Random CUChar+instance Random CShort+instance Random CUShort+instance Random CInt+instance Random CUInt+instance Random CLong+instance Random CULong+instance Random CPtrdiff+instance Random CSize+instance Random CWchar+instance Random CSigAtomic+instance Random CLLong+instance Random CULLong+instance Random CIntPtr+instance Random CUIntPtr+instance Random CIntMax+instance Random CUIntMax+-- | /Note/ - `random` produces values in the closed range @[0,1]@.+instance Random CFloat where+ randomR r = coerce . randomR (coerce r :: (Float, Float))+ {-# INLINE randomR #-}+ random = first CFloat . random+ {-# INLINE random #-}+-- | /Note/ - `random` produces values in the closed range @[0,1]@.+instance Random CDouble where+ randomR r = coerce . randomR (coerce r :: (Double, Double))+ {-# INLINE randomR #-}+ random = first CDouble . random+ {-# INLINE random #-}++instance Random Char+instance Random Bool+-- | /Note/ - `random` produces values in the closed range @[0,1]@.+instance Random Double where+ randomR r g = runStateGen g (uniformRM r)+ {-# INLINE randomR #-}+ -- We return 1 - uniformDouble01M here for backwards compatibility with+ -- v1.2.0. Just return the result of uniformDouble01M in the next major+ -- version.+ random g = runStateGen g (fmap (1 -) . uniformDouble01M)+ {-# INLINE random #-}+-- | /Note/ - `random` produces values in the closed range @[0,1]@.+instance Random Float where+ randomR r g = runStateGen g (uniformRM r)+ {-# INLINE randomR #-}+ -- We return 1 - uniformFloat01M here for backwards compatibility with+ -- v1.2.0. Just return the result of uniformFloat01M in the next major+ -- version.+ random g = runStateGen g (fmap (1 -) . uniformFloat01M)+ {-# INLINE random #-}++++-- | Initialize 'StdGen' using system entropy (i.e. @\/dev\/urandom@) when it is+-- available, while falling back on using system time as the seed.+--+-- @since 1.2.1+initStdGen :: MonadIO m => m StdGen+initStdGen = liftIO (StdGen <$> SM.initSMGen)+++-- | /Note/ - `randomR` treats @a@ and @b@ types independently+instance (Random a, Random b) => Random (a, b) where+ randomR ((al, bl), (ah, bh)) = runState $+ (,) <$> state (randomR (al, ah)) <*> state (randomR (bl, bh))+ {-# INLINE randomR #-}+ random = runState $ (,) <$> state random <*> state random+ {-# INLINE random #-}++-- | /Note/ - `randomR` treats @a@, @b@ and @c@ types independently+instance (Random a, Random b, Random c) => Random (a, b, c) where+ randomR ((al, bl, cl), (ah, bh, ch)) = runState $+ (,,) <$> state (randomR (al, ah))+ <*> state (randomR (bl, bh))+ <*> state (randomR (cl, ch))+ {-# INLINE randomR #-}+ random = runState $ (,,) <$> state random <*> state random <*> state random+ {-# INLINE random #-}++-- | /Note/ - `randomR` treats @a@, @b@, @c@ and @d@ types independently+instance (Random a, Random b, Random c, Random d) => Random (a, b, c, d) where+ randomR ((al, bl, cl, dl), (ah, bh, ch, dh)) = runState $+ (,,,) <$> state (randomR (al, ah))+ <*> state (randomR (bl, bh))+ <*> state (randomR (cl, ch))+ <*> state (randomR (dl, dh))+ {-# INLINE randomR #-}+ random = runState $+ (,,,) <$> state random <*> state random <*> state random <*> state random+ {-# INLINE random #-}++-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@ and @e@ types independently+instance (Random a, Random b, Random c, Random d, Random e) => Random (a, b, c, d, e) where+ randomR ((al, bl, cl, dl, el), (ah, bh, ch, dh, eh)) = runState $+ (,,,,) <$> state (randomR (al, ah))+ <*> state (randomR (bl, bh))+ <*> state (randomR (cl, ch))+ <*> state (randomR (dl, dh))+ <*> state (randomR (el, eh))+ {-# INLINE randomR #-}+ random = runState $+ (,,,,) <$> state random <*> state random <*> state random <*> state random <*> state random+ {-# INLINE random #-}++-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@ and @f@ types independently+instance (Random a, Random b, Random c, Random d, Random e, Random f) =>+ Random (a, b, c, d, e, f) where+ randomR ((al, bl, cl, dl, el, fl), (ah, bh, ch, dh, eh, fh)) = runState $+ (,,,,,) <$> state (randomR (al, ah))+ <*> state (randomR (bl, bh))+ <*> state (randomR (cl, ch))+ <*> state (randomR (dl, dh))+ <*> state (randomR (el, eh))+ <*> state (randomR (fl, fh))+ {-# INLINE randomR #-}+ random = runState $+ (,,,,,) <$> state random+ <*> state random+ <*> state random+ <*> state random+ <*> state random+ <*> state random+ {-# INLINE random #-}++-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@, @f@ and @g@ types independently+instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) =>+ Random (a, b, c, d, e, f, g) where+ randomR ((al, bl, cl, dl, el, fl, gl), (ah, bh, ch, dh, eh, fh, gh)) = runState $+ (,,,,,,) <$> state (randomR (al, ah))+ <*> state (randomR (bl, bh))+ <*> state (randomR (cl, ch))+ <*> state (randomR (dl, dh))+ <*> state (randomR (el, eh))+ <*> state (randomR (fl, fh))+ <*> state (randomR (gl, gh))+ {-# INLINE randomR #-}+ random = runState $+ (,,,,,,) <$> state random+ <*> state random+ <*> state random+ <*> state random+ <*> state random+ <*> state random+ <*> state random+ {-# INLINE random #-}++-------------------------------------------------------------------------------+-- Global pseudo-random number generator+-------------------------------------------------------------------------------++-- $globalstdgen+--+-- There is a single, implicit, global pseudo-random number generator of type+-- 'StdGen', held in a global mutable variable that can be manipulated from+-- within the 'IO' monad. It is also available as+-- 'System.Random.Stateful.globalStdGen', therefore it is recommended to use the+-- new "System.Random.Stateful" interface to explicitly operate on the global+-- pseudo-random number generator.+--+-- It is initialised with 'initStdGen', although it is possible to override its+-- value with 'setStdGen'. All operations on the global pseudo-random number+-- generator are thread safe, however in presence of concurrency they are+-- naturally become non-deterministic. Moreover, relying on the global mutable+-- state makes it hard to know which of the dependent libraries are using it as+-- well, making it unpredictable in the local context. Precisely of this reason,+-- the global pseudo-random number generator is only suitable for uses in+-- applications, test suites, etc. and is advised against in development of+-- reusable libraries.+--+-- It is also important to note that either using 'StdGen' with pure functions+-- from other sections of this module or by relying on+-- 'System.Random.Stateful.runStateGen' from stateful interface does not only+-- give us deterministic behaviour without requiring 'IO', but it is also more+-- efficient.+++-- | Sets the global pseudo-random number generator. Overwrites the contents of+-- 'System.Random.Stateful.globalStdGen'+--+-- @since 1.0.0+setStdGen :: MonadIO m => StdGen -> m ()+setStdGen = liftIO . writeIORef theStdGen++-- | Gets the global pseudo-random number generator. Extracts the contents of+-- 'System.Random.Stateful.globalStdGen'+--+-- @since 1.0.0+getStdGen :: MonadIO m => m StdGen+getStdGen = liftIO $ readIORef theStdGen++-- | Applies 'split' to the current global pseudo-random generator+-- 'System.Random.Stateful.globalStdGen', updates it with one of the results,+-- and returns the other.+--+-- @since 1.0.0+newStdGen :: MonadIO m => m StdGen+newStdGen = liftIO $ atomicModifyIORef' theStdGen splitGen++-- | Uses the supplied function to get a value from the current global+-- random generator, and updates the global generator with the new generator+-- returned by the function. For example, @rollDice@ produces a pseudo-random integer+-- between 1 and 6:+--+-- >>> rollDice = getStdRandom (randomR (1, 6))+-- >>> replicateM 10 (rollDice :: IO Int)+-- [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+-- 'System.Random.Stateful.globalStdGen' if relying on the global state is+-- acceptable.+--+-- >>> import System.Random.Stateful+-- >>> rollDice = applyAtomicGen (uniformR (1, 6)) globalStdGen+-- >>> replicateM 10 (rollDice :: IO Int)+-- [2,1,1,5,4,3,6,6,3,2]+--+-- @since 1.0.0+getStdRandom :: MonadIO m => (StdGen -> (a, StdGen)) -> m a+getStdRandom f = liftIO $ atomicModifyIORef' theStdGen (swap . f)+ where swap (v, g) = (g, v)+++-- | A variant of 'System.Random.Stateful.randomRM' that uses the global+-- pseudo-random number generator 'System.Random.Stateful.globalStdGen'+--+-- >>> randomRIO (2020, 2100) :: IO Int+-- 2028+--+-- Similar to 'randomIO', this function is equivalent to @'getStdRandom'+-- 'randomR'@ and is included in this interface for historical reasons and+-- backwards compatibility. It is recommended to use+-- 'System.Random.Stateful.uniformRM' instead, possibly with the+-- 'System.Random.Stateful.globalStdGen' if relying on the global state is+-- acceptable.+--+-- >>> import System.Random.Stateful+-- >>> uniformRM (2020, 2100) globalStdGen :: IO Int+-- 2044+--+-- @since 1.0.0+randomRIO :: (Random a, MonadIO m) => (a, a) -> m a+randomRIO range = getStdRandom (randomR range)++-- | A variant of 'System.Random.Stateful.randomM' that uses the global+-- pseudo-random number generator 'System.Random.Stateful.globalStdGen'.+--+-- >>> import Data.Int+-- >>> randomIO :: IO Int32+-- 114794456+--+-- This function is equivalent to @'getStdRandom' 'random'@ and is included in+-- this interface for historical reasons and backwards compatibility. It is+-- recommended to use 'System.Random.Stateful.uniformM' instead, possibly with+-- the 'System.Random.Stateful.globalStdGen' if relying on the global state is+-- acceptable.+--+-- >>> import System.Random.Stateful+-- >>> uniformM globalStdGen :: IO Int32+-- -1768545016+--+-- @since 1.0.0+randomIO :: (Random a, MonadIO m) => m a+randomIO = getStdRandom random++-------------------------------------------------------------------------------+-- Notes+-------------------------------------------------------------------------------++-- $implementrandomgen+--+-- Consider these points when writing a 'RandomGen' instance for a given pure+-- pseudo-random number generator:+--+-- * If the pseudo-random number generator has a power-of-2 modulus, that is,+-- it natively outputs @2^n@ bits of randomness for some @n@, implement+-- 'genWord8', 'genWord16', 'genWord32' and 'genWord64'. See below for more+-- details.+--+-- * If the pseudo-random number generator does not have a power-of-2+-- modulus, implement 'next' and 'genRange'. See below for more details.+--+-- * If the pseudo-random number generator is splittable, implement 'split'.+-- If there is no suitable implementation, 'split' should fail with a+-- helpful error message.+--+-- === How to implement 'RandomGen' for a pseudo-random number generator with power-of-2 modulus+--+-- Suppose you want to implement a [permuted congruential+-- generator](https://en.wikipedia.org/wiki/Permuted_congruential_generator).+--+-- >>> data PCGen = PCGen !Word64 !Word64+--+-- It produces a full 'Word32' of randomness per iteration.+--+-- >>> import Data.Bits+-- >>> :{+-- let stepGen :: PCGen -> (Word32, PCGen)+-- stepGen (PCGen state inc) = let+-- newState = state * 6364136223846793005 + (inc .|. 1)+-- xorShifted = fromIntegral (((state `shiftR` 18) `xor` state) `shiftR` 27) :: Word32+-- rot = fromIntegral (state `shiftR` 59) :: Word32+-- out = (xorShifted `shiftR` (fromIntegral rot)) .|. (xorShifted `shiftL` fromIntegral ((-rot) .&. 31))+-- in (out, PCGen newState inc)+-- :}+--+-- >>> fst $ stepGen $ snd $ stepGen (PCGen 17 29)+-- 3288430965+--+-- You can make it an instance of 'RandomGen' as follows:+--+-- >>> :{+-- instance RandomGen PCGen where+-- genWord32 = stepGen+-- split _ = error "PCG is not splittable"+-- :}+--+--+-- === How to implement 'RandomGen' for a pseudo-random number generator without a power-of-2 modulus+--+-- __We do not recommend you implement any new pseudo-random number generators without a power-of-2 modulus.__+--+-- Pseudo-random number generators without a power-of-2 modulus perform+-- /significantly worse/ than pseudo-random number generators with a power-of-2+-- modulus with this library. This is because most functionality in this+-- library is based on generating and transforming uniformly pseudo-random+-- machine words, and generating uniformly pseudo-random machine words using a+-- pseudo-random number generator without a power-of-2 modulus is expensive.+--+-- The pseudo-random number generator from+-- <https://dl.acm.org/doi/abs/10.1145/62959.62969 L’Ecuyer (1988)> natively+-- generates an integer value in the range @[1, 2147483562]@. This is the+-- generator used by this library before it was replaced by SplitMix in version+-- 1.2.+--+-- >>> data LegacyGen = LegacyGen !Int32 !Int32+-- >>> :{+-- let legacyNext :: LegacyGen -> (Int, LegacyGen)+-- legacyNext (LegacyGen s1 s2) = (fromIntegral z', LegacyGen s1'' s2'') where+-- z' = if z < 1 then z + 2147483562 else z+-- z = s1'' - s2''+-- k = s1 `quot` 53668+-- s1' = 40014 * (s1 - k * 53668) - k * 12211+-- s1'' = if s1' < 0 then s1' + 2147483563 else s1'+-- k' = s2 `quot` 52774+-- s2' = 40692 * (s2 - k' * 52774) - k' * 3791+-- s2'' = if s2' < 0 then s2' + 2147483399 else s2'+-- :}+--+-- You can make it an instance of 'RandomGen' as follows:+--+-- >>> :{+-- instance RandomGen LegacyGen where+-- next = legacyNext+-- genRange _ = (1, 2147483562)+-- split _ = error "Not implemented"+-- :}+--+-- $deprecations+--+-- Version 1.2 mostly maintains backwards compatibility with version 1.1. This+-- has a few consequences users should be aware of:+--+-- * The type class 'Random' is only provided for backwards compatibility.+-- New code should use 'Uniform' and 'UniformRange' instead.+--+-- * The methods 'next' and 'genRange' in 'RandomGen' are deprecated and only+-- provided for backwards compatibility. New instances of 'RandomGen' should+-- implement word-based methods instead. See below for more information+-- about how to write a 'RandomGen' instance.+--+-- * This library provides instances for 'Random' for some unbounded types+-- for backwards compatibility. For an unbounded type, there is no way+-- to generate a value with uniform probability out of its entire domain, so+-- the 'random' implementation for unbounded types actually generates a+-- value based on some fixed range.+--+-- For 'Integer', 'random' generates a value in the 'Int' range. For 'Float'+-- and 'Double', 'random' generates a floating point value in the range @[0,+-- 1)@.+--+-- This library does not provide 'Uniform' instances for any unbounded+-- types.+--+-- $reproducibility+--+-- If you have two builds of a particular piece of code against this library,+-- any deterministic function call should give the same result in the two+-- builds if the builds are+--+-- * compiled against the same major version of this library+-- * on the same architecture (32-bit or 64-bit)+--+-- $references+--+-- 1. Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. Fast+-- splittable pseudorandom number generators. In Proceedings of the 2014 ACM+-- International Conference on Object Oriented Programming Systems Languages &+-- Applications (OOPSLA '14). ACM, New York, NY, USA, 453-472. DOI:+-- <https://doi.org/10.1145/2660193.2660195>++-- $setup+--+-- >>> 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
@@ -0,0 +1,281 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# 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(..)+ , GFinite(..)+ ) where++import Data.Bits+import Data.Int+import Data.Void+import Data.Word+import GHC.Exts (Proxy#, proxy#)+import GHC.Generics++-- | Cardinality of a set.+data Cardinality+ = Shift !Int -- ^ Shift n is equivalent to Card (bit n)+ | Card !Integer+ deriving (Eq, Ord, Show)++-- | This is needed only as a superclass of 'Integral'.+instance Enum Cardinality where+ toEnum = fromIntegral+ fromEnum = fromIntegral+ succ = (+ 1)+ pred = subtract 1+ enumFrom x = map fromInteger (enumFrom (toInteger x))+ enumFromThen x y = map fromInteger (enumFromThen (toInteger x) (toInteger y))+ enumFromTo x y = map fromInteger (enumFromTo (toInteger x) (toInteger y))+ enumFromThenTo x y z = map fromInteger (enumFromThenTo (toInteger x) (toInteger y) (toInteger z))++instance Num Cardinality where+ fromInteger 1 = Shift 0 -- ()+ fromInteger 2 = Shift 1 -- Bool+ fromInteger n = Card n+ {-# INLINE fromInteger #-}++ x + y = fromInteger (toInteger x + toInteger y)+ {-# INLINE (+) #-}++ Shift x * Shift y = Shift (x + y)+ Shift x * Card y = Card (y `shiftL` x)+ Card x * Shift y = Card (x `shiftL` y)+ Card x * Card y = Card (x * y)+ {-# INLINE (*) #-}++ abs = Card . abs . toInteger+ signum = Card . signum . toInteger+ negate = Card . negate . toInteger++-- | This is needed only as a superclass of 'Integral'.+instance Real Cardinality where+ toRational = fromIntegral++instance Integral Cardinality where+ toInteger = \case+ Shift n -> bit n+ Card n -> n+ {-# INLINE toInteger #-}++ quotRem x' = \case+ Shift n -> (Card (x `shiftR` n), Card (x .&. (bit n - 1)))+ Card n -> let (q, r) = x `quotRem` n in (Card q, Card r)+ where+ x = toInteger x'+ {-# INLINE quotRem #-}++-- | A type class for data with a finite number of inhabitants. This type class+-- is used in 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.+--+-- >>> :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)+--+class Finite a where+ cardinality :: Proxy# a -> Cardinality+ toFinite :: Integer -> a+ fromFinite :: a -> Integer++ default cardinality :: (Generic a, GFinite (Rep a)) => Proxy# a -> Cardinality+ cardinality _ = gcardinality (proxy# :: Proxy# (Rep a))+ {-# INLINE cardinality #-}++ default toFinite :: (Generic a, GFinite (Rep a)) => Integer -> a+ toFinite = to . toGFinite+ {-# INLINE toFinite #-}++ default fromFinite :: (Generic a, GFinite (Rep a)) => a -> Integer+ fromFinite = fromGFinite . from+ {-# INLINE fromFinite #-}++class GFinite f where+ gcardinality :: Proxy# f -> Cardinality+ toGFinite :: Integer -> f a+ fromGFinite :: f a -> Integer++instance GFinite V1 where+ gcardinality _ = 0+ {-# INLINE gcardinality #-}+ toGFinite = const $ error "GFinite: V1 has no inhabitants"+ {-# INLINE toGFinite #-}+ fromGFinite = const $ error "GFinite: V1 has no inhabitants"+ {-# INLINE fromGFinite #-}++instance GFinite U1 where+ gcardinality _ = 1+ {-# INLINE gcardinality #-}+ toGFinite = const U1+ {-# INLINE toGFinite #-}+ fromGFinite = const 0+ {-# INLINE fromGFinite #-}++instance Finite a => GFinite (K1 _x a) where+ gcardinality _ = cardinality (proxy# :: Proxy# a)+ {-# INLINE gcardinality #-}+ toGFinite = K1 . toFinite+ {-# INLINE toGFinite #-}+ fromGFinite = fromFinite . unK1+ {-# INLINE fromGFinite #-}++instance GFinite a => GFinite (M1 _x _y a) where+ gcardinality _ = gcardinality (proxy# :: Proxy# a)+ {-# INLINE gcardinality #-}+ toGFinite = M1 . toGFinite+ {-# INLINE toGFinite #-}+ fromGFinite = fromGFinite . unM1+ {-# INLINE fromGFinite #-}++instance (GFinite a, GFinite b) => GFinite (a :+: b) where+ gcardinality _ =+ gcardinality (proxy# :: Proxy# a) + gcardinality (proxy# :: Proxy# b)+ {-# INLINE gcardinality #-}++ toGFinite n+ | n < cardA = L1 $ toGFinite n+ | otherwise = R1 $ toGFinite (n - cardA)+ where+ cardA = toInteger (gcardinality (proxy# :: Proxy# a))+ {-# INLINE toGFinite #-}++ fromGFinite = \case+ L1 x -> fromGFinite x+ R1 x -> fromGFinite x + toInteger (gcardinality (proxy# :: Proxy# a))+ {-# INLINE fromGFinite #-}++instance (GFinite a, GFinite b) => GFinite (a :*: b) where+ gcardinality _ =+ gcardinality (proxy# :: Proxy# a) * gcardinality (proxy# :: Proxy# b)+ {-# INLINE gcardinality #-}++ toGFinite n = toGFinite (toInteger q) :*: toGFinite (toInteger r)+ where+ cardB = gcardinality (proxy# :: Proxy# b)+ (q, r) = Card n `quotRem` cardB+ {-# INLINE toGFinite #-}++ fromGFinite (q :*: r) =+ toInteger (gcardinality (proxy# :: Proxy# b) * Card (fromGFinite q)) + fromGFinite r+ {-# INLINE fromGFinite #-}++instance Finite Void+instance Finite ()+instance Finite Bool+instance Finite Ordering++instance Finite Char where+ cardinality _ = Card $ toInteger (fromEnum (maxBound :: Char)) + 1+ {-# INLINE cardinality #-}+ toFinite = toEnum . fromInteger+ {-# INLINE toFinite #-}+ fromFinite = toInteger . fromEnum+ {-# INLINE fromFinite #-}++cardinalityDef :: forall a. (Num a, FiniteBits a) => Proxy# a -> Cardinality+cardinalityDef _ = Shift (finiteBitSize (0 :: a))++toFiniteDef :: forall a. (Num a, FiniteBits a) => Integer -> a+toFiniteDef n+ | isSigned (0 :: a) = fromInteger (n - bit (finiteBitSize (0 :: a) - 1))+ | otherwise = fromInteger n++fromFiniteDef :: (Integral a, FiniteBits a) => a -> Integer+fromFiniteDef x+ | isSigned x = toInteger x + bit (finiteBitSize x - 1)+ | otherwise = toInteger x++instance Finite Word8 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Word16 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Word32 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Word64 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Word where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Int8 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Int16 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Int32 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Int64 where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}+instance Finite Int where+ cardinality = cardinalityDef+ {-# INLINE cardinality #-}+ toFinite = toFiniteDef+ {-# INLINE toFinite #-}+ fromFinite = fromFiniteDef+ {-# INLINE fromFinite #-}++instance Finite a => Finite (Maybe a)+instance (Finite a, Finite b) => Finite (Either a b)+instance (Finite a, Finite b) => Finite (a, b)+instance (Finite a, Finite b, Finite c) => Finite (a, b, c)+instance (Finite a, Finite b, Finite c, Finite d) => Finite (a, b, c, d)+instance (Finite a, Finite b, Finite c, Finite d, Finite e) => Finite (a, b, c, d, e)+instance (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f) => Finite (a, b, c, d, e, f)+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
@@ -0,0 +1,1815 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GHCForeignImportPrim #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# OPTIONS_HADDOCK hide, not-home #-}++-- |+-- Module : System.Random.Internal+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file LICENSE in the 'random' repository)+-- Maintainer : libraries@haskell.org+-- Stability : stable+--+-- This library deals with the common task of pseudo-random number generation.+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(..)+ , runStateGen+ , runStateGen_+ , runStateGenT+ , runStateGenT_+ , runStateGenST+ , runStateGenST_++ -- * Pseudo-random values of various types+ , Uniform(..)+ , uniformViaFiniteM+ , UniformRange(..)+ , 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 (replicateM, when, (>=>))+import Control.Monad.Cont (ContT, runContT)+import Control.Monad.ST+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))+import Data.IORef (IORef, newIORef)+import Data.Int+import Data.Word+import Foreign.C.Types+import Foreign.Storable (Storable)+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.Array+import System.Random.GFinite (Cardinality(..), GFinite(..), Finite)+import qualified System.Random.SplitMix as SM+import qualified System.Random.SplitMix32 as SM32+import Data.Kind++-- | 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.+--+-- 'StdGen' is the standard 'RandomGen' instance provided by this library.+--+-- @since 1.0.0+{-# DEPRECATED next "No longer used" #-}+{-# DEPRECATED genRange "No longer used" #-}+class RandomGen g where+ {-# 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+ -- [here](https://alexey.kuleshevi.ch/blog/2019/12/21/random-benchmarks) for+ -- more details. It is thus deprecated.+ --+ -- @since 1.0.0+ next :: g -> (Int, g)+ next g = runStateGen g (uniformRM (genRange g))++ -- | Returns a 'Word8' that is uniformly distributed over the entire 'Word8'+ -- range.+ --+ -- @since 1.2.0+ genWord8 :: g -> (Word8, g)+ genWord8 = first fromIntegral . genWord32+ {-# INLINE genWord8 #-}++ -- | Returns a 'Word16' that is uniformly distributed over the entire 'Word16'+ -- range.+ --+ -- @since 1.2.0+ genWord16 :: g -> (Word16, g)+ genWord16 = first fromIntegral . genWord32+ {-# INLINE genWord16 #-}++ -- | Returns a 'Word32' that is uniformly distributed over the entire 'Word32'+ -- range.+ --+ -- @since 1.2.0+ genWord32 :: g -> (Word32, g)+ genWord32 = randomIvalIntegral (minBound, maxBound)+ -- Once `next` is removed, this implementation should be used instead:+ -- first fromIntegral . genWord64+ {-# INLINE genWord32 #-}++ -- | Returns a 'Word64' that is uniformly distributed over the entire 'Word64'+ -- range.+ --+ -- @since 1.2.0+ genWord64 :: g -> (Word64, g)+ genWord64 g =+ case genWord32 g of+ (l32, g') ->+ case genWord32 g' of+ (h32, g'') ->+ ((fromIntegral h32 `shiftL` 32) .|. fromIntegral l32, g'')+ {-# INLINE genWord64 #-}++ -- | @genWord32R upperBound g@ returns a 'Word32' that is uniformly+ -- distributed over the range @[0, upperBound]@.+ --+ -- @since 1.2.0+ genWord32R :: Word32 -> g -> (Word32, g)+ genWord32R m g = runStateGen g (unbiasedWordMult32 m)+ {-# INLINE genWord32R #-}++ -- | @genWord64R upperBound g@ returns a 'Word64' that is uniformly+ -- distributed over the range @[0, upperBound]@.+ --+ -- @since 1.2.0+ genWord64R :: Word64 -> g -> (Word64, g)+ genWord64R m g = runStateGen g (unsignedBitmaskWithRejectionM uniformWord64 m)+ {-# INLINE genWord64R #-}++ -- | 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 =+ 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:+ --+ -- * If @(a, b) = 'genRange' g@, then @a < b@.+ -- * 'genRange' must not examine its argument so the value it returns is+ -- determined only by the instance of 'RandomGen'.+ --+ -- The default definition spans the full range of 'Int'.+ --+ -- @since 1.0.0+ genRange :: g -> (Int, Int)+ genRange _ = (minBound, maxBound)++ -- | Returns two distinct pseudo-random number generators.+ --+ -- Implementations should take care to ensure that the resulting generators+ -- are not correlated. Some pseudo-random number generators are not+ -- splittable. In that case, the 'split' implementation should fail with a+ -- descriptive 'error' message.+ --+ -- @since 1.0.0+ split :: g -> (g, g)+ 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 #-}+ -- | @uniformWord32R upperBound g@ generates a 'Word32' that is uniformly+ -- distributed over the range @[0, upperBound]@.+ --+ -- @since 1.2.0+ uniformWord32R :: Word32 -> g -> m Word32+ uniformWord32R = unsignedBitmaskWithRejectionM uniformWord32+ {-# INLINE uniformWord32R #-}++ -- | @uniformWord64R upperBound g@ generates a 'Word64' that is uniformly+ -- distributed over the range @[0, upperBound]@.+ --+ -- @since 1.2.0+ uniformWord64R :: Word64 -> g -> m Word64+ uniformWord64R = unsignedBitmaskWithRejectionM uniformWord64+ {-# INLINE uniformWord64R #-}++ -- | Generates a 'Word8' that is uniformly distributed over the entire 'Word8'+ -- range.+ --+ -- The default implementation extracts a 'Word8' from 'uniformWord32'.+ --+ -- @since 1.2.0+ uniformWord8 :: g -> m Word8+ uniformWord8 = fmap fromIntegral . uniformWord32+ {-# INLINE uniformWord8 #-}++ -- | Generates a 'Word16' that is uniformly distributed over the entire+ -- 'Word16' range.+ --+ -- The default implementation extracts a 'Word16' from 'uniformWord32'.+ --+ -- @since 1.2.0+ uniformWord16 :: g -> m Word16+ uniformWord16 = fmap fromIntegral . uniformWord32+ {-# INLINE uniformWord16 #-}++ -- | Generates a 'Word32' that is uniformly distributed over the entire+ -- 'Word32' range.+ --+ -- The default implementation extracts a 'Word32' from 'uniformWord64'.+ --+ -- @since 1.2.0+ uniformWord32 :: g -> m Word32+ uniformWord32 = fmap fromIntegral . uniformWord64+ {-# INLINE uniformWord32 #-}++ -- | Generates a 'Word64' that is uniformly distributed over the entire+ -- 'Word64' range.+ --+ -- The default implementation combines two 'Word32' from 'uniformWord32' into+ -- one 'Word64'.+ --+ -- @since 1.2.0+ uniformWord64 :: g -> m Word64+ uniformWord64 g = do+ l32 <- uniformWord32 g+ h32 <- uniformWord32 g+ 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+ uniformShortByteString = uniformShortByteStringM+ {-# INLINE uniformShortByteString #-}+{-# DEPRECATED uniformShortByteString "In favor of `uniformShortByteStringM`" #-}+++-- | 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+ type MutableGen f m = (g :: Type) | g -> f++ -- | Saves the state of the pseudo-random number generator as a frozen seed.+ --+ -- @since 1.2.0+ freezeGen :: MutableGen f m -> m f+ 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)++-- | 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.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+ let go !i =+ when (i < endIx64) $ do+ w64 <- gen64+ -- Writing 8 bytes at a time in a Little-endian order gives us+ -- platform portability+ 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.+ 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) () #-}++-- | 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 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" #-}++-- | Efficiently fills in a new `ShortByteString` in a platform independent manner.+--+-- @since 1.2.0+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.+--+-- @since 1.2.0+data StateGenM g = StateGenM++-- | Wrapper for pure state gen, which acts as an immutable seed for the corresponding+-- stateful generator `StateGenM`+--+-- @since 1.2.0+newtype StateGen g = StateGen { unStateGen :: g }+ deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData)++instance (RandomGen g, MonadState g m) => StatefulGen (StateGenM g) m where+ uniformWord32R r _ = state (genWord32R r)+ {-# INLINE uniformWord32R #-}+ uniformWord64R r _ = state (genWord64R r)+ {-# INLINE uniformWord64R #-}+ uniformWord8 _ = state genWord8+ {-# INLINE uniformWord8 #-}+ uniformWord16 _ = state genWord16+ {-# INLINE uniformWord16 #-}+ uniformWord32 _ = state genWord32+ {-# INLINE uniformWord32 #-}+ uniformWord64 _ = state genWord64+ {-# INLINE uniformWord64 #-}++instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m where+ type MutableGen (StateGen g) m = StateGenM g+ freezeGen _ = fmap StateGen get+ 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.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> runStateGen pureGen randomM :: (Int, StdGen)+-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627})+--+-- @since 1.2.0+runStateGen :: RandomGen g => g -> (StateGenM g -> State g a) -> (a, g)+runStateGen g f = runState (f StateGenM) g+{-# INLINE runStateGen #-}++-- | Runs a monadic generating action in the `State` monad using a pure+-- pseudo-random number generator. Returns only the resulting pseudo-random+-- value.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> runStateGen_ pureGen randomM :: Int+-- 7879794327570578227+--+-- @since 1.2.0+runStateGen_ :: RandomGen g => g -> (StateGenM g -> State g a) -> a+runStateGen_ g = fst . runStateGen g+{-# INLINE runStateGen_ #-}++-- | Runs a monadic generating action in the `StateT` monad using a pure+-- pseudo-random number generator.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> runStateGenT pureGen randomM :: IO (Int, StdGen)+-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627})+--+-- @since 1.2.0+runStateGenT :: RandomGen g => g -> (StateGenM g -> StateT g m a) -> m (a, g)+runStateGenT g f = runStateT (f StateGenM) g+{-# INLINE runStateGenT #-}++-- | Runs a monadic generating action in the `StateT` monad using a pure+-- pseudo-random number generator. Returns only the resulting pseudo-random+-- value.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> runStateGenT_ pureGen randomM :: IO Int+-- 7879794327570578227+--+-- @since 1.2.1+runStateGenT_ :: (RandomGen g, Functor f) => g -> (StateGenM g -> StateT g f a) -> f a+runStateGenT_ g = fmap fst . runStateGenT g+{-# INLINE runStateGenT_ #-}++-- | Runs a monadic generating action in the `ST` monad using a pure+-- pseudo-random number generator.+--+-- @since 1.2.0+runStateGenST :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> (a, g)+runStateGenST g action = runST $ runStateGenT g action+{-# INLINE runStateGenST #-}++-- | Runs a monadic generating action in the `ST` monad using a pure+-- pseudo-random number generator. Same as `runStateGenST`, but discards the+-- resulting generator.+--+-- @since 1.2.1+runStateGenST_ :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> a+runStateGenST_ g action = runST $ runStateGenT_ g action+{-# INLINE runStateGenST_ #-}+++-- | 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, SplitGen, NFData)++instance Eq StdGen where+ StdGen x1 == StdGen x2 = SM.unseedSMGen x1 == SM.unseedSMGen x2++instance RandomGen SM.SMGen where+ next = SM.nextInt+ {-# INLINE next #-}+ genWord32 = SM.nextWord32+ {-# INLINE genWord32 #-}+ genWord64 = SM.nextWord64+ {-# INLINE genWord64 #-}+ -- 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 #-}+ genWord32 = SM32.nextWord32+ {-# INLINE genWord32 #-}+ genWord64 = SM32.nextWord64+ {-# INLINE genWord64 #-}++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 = 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+{-# NOINLINE theStdGen #-}+++-- | The class of types for which a uniformly distributed value can be drawn+-- from all possible values of the type.+--+-- @since 1.2.0+class Uniform a where+ -- | Generates a value uniformly distributed over all possible values of that+ -- type.+ --+ -- There is a default implementation via 'Generic':+ --+ -- >>> :seti -XDeriveGeneric -XDeriveAnyClass+ -- >>> import GHC.Generics (Generic)+ -- >>> import System.Random.Stateful+ -- >>> data MyBool = MyTrue | MyFalse deriving (Show, Generic, Finite, Uniform)+ -- >>> data Action = Code MyBool | Eat (Maybe Bool) | Sleep deriving (Show, Generic, Finite, Uniform)+ -- >>> gen <- newIOGenM (mkStdGen 42)+ -- >>> uniformListM 10 gen :: IO [Action]+ -- [Code MyTrue,Code MyTrue,Eat Nothing,Code MyFalse,Eat (Just False),Eat (Just True),Eat Nothing,Eat (Just False),Sleep,Code MyFalse]+ --+ -- @since 1.2.0+ uniformM :: StatefulGen g m => g -> m a++ default uniformM :: (StatefulGen g m, Generic a, GUniform (Rep a)) => g -> m a+ uniformM = fmap to . (`runContT` pure) . guniformM+ {-# INLINE uniformM #-}++-- | Default implementation of 'Uniform' type class for 'Generic' data.+-- It's important to use 'ContT', because without it 'fmap' and '>>=' remain+-- polymorphic too long and GHC fails to inline or specialize it, ending up+-- building full 'Rep' a structure in memory. 'ContT'+-- makes 'fmap' and '>>=' used in 'guniformM' monomorphic, so GHC is able to+-- specialize 'Generic' instance reasonably close to a handwritten one.+class GUniform f where+ guniformM :: StatefulGen g m => g -> ContT r m (f a)++instance GUniform f => GUniform (M1 i c f) where+ guniformM = fmap M1 . guniformM+ {-# INLINE guniformM #-}++instance Uniform a => GUniform (K1 i a) where+ guniformM = fmap K1 . lift . uniformM+ {-# INLINE guniformM #-}++instance GUniform U1 where+ guniformM = const $ return U1+ {-# INLINE guniformM #-}++instance (GUniform f, GUniform g) => GUniform (f :*: g) where+ guniformM g = (:*:) <$> guniformM g <*> guniformM g+ {-# INLINE guniformM #-}++instance (GFinite f, GFinite g) => GUniform (f :+: g) where+ guniformM = lift . finiteUniformM+ {-# INLINE guniformM #-}++finiteUniformM :: forall g m f a. (StatefulGen g m, GFinite f) => g -> m (f a)+finiteUniformM = fmap toGFinite . case gcardinality (proxy# :: Proxy# f) of+ Shift n+ | n <= 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (bit n - 1)+ | otherwise -> boundedByPowerOf2ExclusiveIntegralM n+ Card n+ | n <= bit 64 -> fmap toInteger . unsignedBitmaskWithRejectionM uniformWord64 (fromInteger n - 1)+ | otherwise -> boundedExclusiveIntegralM n+{-# INLINE finiteUniformM #-}++-- | A definition of 'Uniform' for 'System.Random.Finite' types.+-- If your data has several fields of sub-'Word' cardinality,+-- this instance may be more efficient than one, derived via 'Generic' and 'GUniform'.+--+-- >>> :seti -XDeriveGeneric -XDeriveAnyClass+-- >>> import GHC.Generics (Generic)+-- >>> import System.Random.Stateful+-- >>> data Triple = Triple Word8 Word8 Word8 deriving (Show, Generic, Finite)+-- >>> instance Uniform Triple where uniformM = uniformViaFiniteM+-- >>> gen <- newIOGenM (mkStdGen 42)+-- >>> uniformListM 5 gen :: IO [Triple]+-- [Triple 60 226 48,Triple 234 194 151,Triple 112 96 95,Triple 51 251 15,Triple 6 0 208]+--+uniformViaFiniteM :: (StatefulGen g m, Generic a, GFinite (Rep a)) => g -> m a+uniformViaFiniteM = fmap to . finiteUniformM+{-# INLINE uniformViaFiniteM #-}++-- | The class of types for which a uniformly distributed value can be drawn+-- from a range.+--+-- @since 1.2.0+class UniformRange a where+ -- | Generates a value uniformly distributed over the provided range, which+ -- is interpreted as inclusive in the lower and upper bound.+ --+ -- * @uniformRM (1 :: Int, 4 :: Int)@ generates values uniformly from the+ -- set \(\{1,2,3,4\}\)+ --+ -- * @uniformRM (1 :: Float, 4 :: Float)@ generates values uniformly from+ -- the set \(\{x\;|\;1 \le x \le 4\}\)+ --+ -- The following law should hold to make the function always defined:+ --+ -- > 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+ {-# INLINE uniformM #-}+instance UniformRange Int8 where+ uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform Int16 where+ uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16+ {-# INLINE uniformM #-}+instance UniformRange Int16 where+ uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform Int32 where+ uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32+ {-# INLINE uniformM #-}+instance UniformRange Int32 where+ uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform Int64 where+ uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64+ {-# INLINE uniformM #-}+instance UniformRange Int64 where+ uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int64 -> Word64) fromIntegral+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform Int where+ uniformM+ | wordSizeInBits == 64 =+ fmap (fromIntegral :: Word64 -> Int) . uniformWord64+ | otherwise =+ fmap (fromIntegral :: Word32 -> Int) . uniformWord32+ {-# INLINE uniformM #-}++instance UniformRange Int where+ uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int -> Word) fromIntegral+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform Word where+ uniformM+ | wordSizeInBits == 64 =+ fmap (fromIntegral :: Word64 -> Word) . uniformWord64+ | otherwise =+ fmap (fromIntegral :: Word32 -> Word) . uniformWord32+ {-# INLINE uniformM #-}++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+ {-# INLINE uniformM #-}+instance UniformRange Word16 where+ uniformRM = unbiasedWordMult32RM+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform Word32 where+ uniformM = uniformWord32+ {-# INLINE uniformM #-}+instance UniformRange Word32 where+ uniformRM = unbiasedWordMult32RM+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform Word64 where+ uniformM = uniformWord64+ {-# INLINE uniformM #-}+instance UniformRange Word64 where+ uniformRM = unsignedBitmaskWithRejectionRM+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++#if __GLASGOW_HASKELL__ >= 802+instance Uniform CBool where+ uniformM = fmap CBool . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CBool where+ uniformRM (CBool b, CBool t) = fmap CBool . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd+#endif++instance Uniform CChar where+ uniformM = fmap CChar . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CChar where+ uniformRM (CChar b, CChar t) = fmap CChar . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CSChar where+ uniformM = fmap CSChar . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CSChar where+ uniformRM (CSChar b, CSChar t) = fmap CSChar . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CUChar where+ uniformM = fmap CUChar . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CUChar where+ uniformRM (CUChar b, CUChar t) = fmap CUChar . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CShort where+ uniformM = fmap CShort . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CShort where+ uniformRM (CShort b, CShort t) = fmap CShort . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CUShort where+ uniformM = fmap CUShort . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CUShort where+ uniformRM (CUShort b, CUShort t) = fmap CUShort . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CInt where+ uniformM = fmap CInt . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CInt where+ uniformRM (CInt b, CInt t) = fmap CInt . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CUInt where+ uniformM = fmap CUInt . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CUInt where+ uniformRM (CUInt b, CUInt t) = fmap CUInt . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CLong where+ uniformM = fmap CLong . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CLong where+ uniformRM (CLong b, CLong t) = fmap CLong . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CULong where+ uniformM = fmap CULong . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CULong where+ uniformRM (CULong b, CULong t) = fmap CULong . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CPtrdiff where+ uniformM = fmap CPtrdiff . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CPtrdiff where+ uniformRM (CPtrdiff b, CPtrdiff t) = fmap CPtrdiff . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CSize where+ uniformM = fmap CSize . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CSize where+ uniformRM (CSize b, CSize t) = fmap CSize . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CWchar where+ uniformM = fmap CWchar . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CWchar where+ uniformRM (CWchar b, CWchar t) = fmap CWchar . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CSigAtomic where+ uniformM = fmap CSigAtomic . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CSigAtomic where+ uniformRM (CSigAtomic b, CSigAtomic t) = fmap CSigAtomic . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CLLong where+ uniformM = fmap CLLong . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CLLong where+ uniformRM (CLLong b, CLLong t) = fmap CLLong . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CULLong where+ uniformM = fmap CULLong . uniformM+ {-# INLINE uniformM #-}+instance UniformRange CULLong where+ uniformRM (CULLong b, CULLong t) = fmap CULLong . uniformRM (b, t)+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform CIntPtr where+ uniformM = fmap CIntPtr . uniformM+ {-# INLINE uniformM #-}+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+ {-# INLINE uniformM #-}+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+ {-# INLINE uniformM #-}+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+ {-# INLINE uniformM #-}+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+-- bypass all the hoops. Also because `intToChar` and `charToInt` are internal functions+-- and are called on valid character ranges it is impossible to generate an invalid+-- `Char`, therefore it is totally fine to omit all the unnecessary checks involved in+-- other paths of conversion.+word32ToChar :: Word32 -> Char+#if __GLASGOW_HASKELL__ < 902+word32ToChar (W32# w#) = C# (chr# (word2Int# w#))+#else+word32ToChar (W32# w#) = C# (chr# (word2Int# (word32ToWord# w#)))+#endif+{-# INLINE word32ToChar #-}++charToWord32 :: Char -> Word32+#if __GLASGOW_HASKELL__ < 902+charToWord32 (C# c#) = W32# (int2Word# (ord# c#))+#else+charToWord32 (C# c#) = W32# (wordToWord32# (int2Word# (ord# c#)))+#endif+{-# INLINE charToWord32 #-}++instance Uniform Char where+ uniformM g = word32ToChar <$> unbiasedWordMult32 (charToWord32 maxBound) g+ {-# INLINE uniformM #-}+instance UniformRange Char where+ uniformRM (l, h) g =+ word32ToChar <$> unbiasedWordMult32RM (charToWord32 l, charToWord32 h) g+ {-# INLINE uniformRM #-}+ isInRange = isInRangeOrd++instance Uniform () where+ uniformM = const $ pure ()+ {-# INLINE uniformM #-}+instance UniformRange () where+ uniformRM = const $ const $ pure ()+ {-# INLINE uniformRM #-}++instance Uniform Bool where+ uniformM = fmap wordToBool . uniformWord8+ where wordToBool w = (w .&. 1) /= 0+ {-# INLINE wordToBool #-}+ {-# INLINE uniformM #-}+instance UniformRange Bool where+ uniformRM (False, False) _g = return False+ uniformRM (True, True) _g = return True+ uniformRM _ g = uniformM g+ {-# INLINE uniformRM #-}+ 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) + (-Infinity) = NaN+ -- (-Infinity) + (+Infinity) = NaN+ -- (+Infinity) + _ = +Infinity+ -- (-Infinity) + _ = -Infinity+ -- _ + (+Infinity) = +Infinity+ -- _ + (-Infinity) = -Infinity+ return $! h + l+ | otherwise = do+ 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+-- it by \(2^{64}\). It's used to implement 'UniformRange' instance for+-- 'Double'.+--+-- @since 1.2.0+uniformDouble01M :: forall g m. StatefulGen g m => g -> m Double+uniformDouble01M g = do+ w64 <- uniformWord64 g+ return $ fromIntegral w64 / m+ where+ m = fromIntegral (maxBound :: Word64) :: Double+{-# INLINE uniformDouble01M #-}++-- | Generates uniformly distributed 'Double' in the range+-- \((0, 1]\). Number is generated as \(2^{-64}/2+\operatorname{uniformDouble01M}\).+-- Constant is 1\/2 of smallest nonzero value which could be generated+-- by 'uniformDouble01M'.+--+-- @since 1.2.0+uniformDoublePositive01M :: forall g m. StatefulGen g m => g -> m Double+uniformDoublePositive01M g = (+ d) <$> uniformDouble01M g+ where+ -- We add small constant to shift generated value from zero. It's+ -- selected as 1/2 of smallest possible nonzero value+ d = 2.710505431213761e-20 -- 2**(-65)+{-# INLINE uniformDoublePositive01M #-}++-- | See [Floating point number caveats](System-Random-Stateful.html#fpcaveats).+instance UniformRange Float where+ uniformRM (l, h) g+ | l == h = return l+ | isInfinite l || isInfinite h =+ -- Optimisation exploiting absorption:+ -- (+Infinity) + (-Infinity) = NaN+ -- (-Infinity) + (+Infinity) = NaN+ -- (+Infinity) + _ = +Infinity+ -- (-Infinity) + _ = -Infinity+ -- _ + (+Infinity) = +Infinity+ -- _ + (-Infinity) = -Infinity+ return $! h + l+ | otherwise = do+ 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'.+--+-- @since 1.2.0+uniformFloat01M :: forall g m. StatefulGen g m => g -> m Float+uniformFloat01M g = do+ w32 <- uniformWord32 g+ return $ fromIntegral w32 / m+ where+ m = fromIntegral (maxBound :: Word32) :: Float+{-# INLINE uniformFloat01M #-}++-- | Generates uniformly distributed 'Float' in the range+-- \((0, 1]\). Number is generated as \(2^{-32}/2+\operatorname{uniformFloat01M}\).+-- Constant is 1\/2 of smallest nonzero value which could be generated+-- by 'uniformFloat01M'.+--+-- @since 1.2.0+uniformFloatPositive01M :: forall g m. StatefulGen g m => g -> m Float+uniformFloatPositive01M g = (+ d) <$> uniformFloat01M g+ where+ -- See uniformDoublePositive01M+ d = 1.1641532182693481e-10 -- 2**(-33)+{-# INLINE uniformFloatPositive01M #-}++-- | Generates uniformly distributed 'Enum'.+-- One can use it to define a 'Uniform' instance:+--+-- > data Colors = Red | Green | Blue deriving (Enum, Bounded)+-- > instance Uniform Colors where uniformM = uniformEnumM+--+-- @since 1.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 #-}++-- | Generates uniformly distributed 'Enum' in the given range.+-- One can use it to define a 'UniformRange' instance:+--+-- > data Colors = Red | Green | Blue deriving (Enum)+-- > instance UniformRange Colors where+-- > uniformRM = uniformEnumRM+-- > inInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x)+--+-- @since 1.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 #-}++-- The two integer functions below take an [inclusive,inclusive] range.+randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)+randomIvalIntegral (l, h) = randomIvalInteger (toInteger l, toInteger h)++{-# SPECIALIZE randomIvalInteger :: (Num a) =>+ (Integer, Integer) -> StdGen -> (a, StdGen) #-}++randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)+randomIvalInteger (l, h) rng+ | l > h = randomIvalInteger (h,l) rng+ | otherwise = case f 1 0 rng of (v, rng') -> (fromInteger (l + v `mod` k), rng')+ where+ (genlo, genhi) = genRange rng+ b = fromIntegral genhi - fromIntegral genlo + 1 :: Integer++ -- Probabilities of the most likely and least likely result+ -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen+ -- is uniform, of course++ -- On average, log q / log b more pseudo-random values will be generated+ -- than the minimum+ q = 1000 :: Integer+ k = h - l + 1+ magtgt = k * q++ -- generate pseudo-random values until we exceed the target magnitude+ f mag v g | mag >= magtgt = (v, g)+ | otherwise = v' `seq`f (mag*b) v' g' where+ (x,g') = next g+ v' = v * b + (fromIntegral x - fromIntegral genlo)++-- | Generate an integral in the range @[l, h]@ if @l <= h@ and @[h, l]@+-- otherwise.+uniformIntegralM :: forall a g m. (Bits a, Integral a, StatefulGen g m) => (a, a) -> g -> m a+uniformIntegralM (l, h) gen = case l `compare` h of+ LT -> do+ let limit = h - l+ bounded <- case toIntegralSized limit :: Maybe Word64 of+ Just limitAsWord64 ->+ -- Optimisation: if 'limit' fits into 'Word64', generate a bounded+ -- 'Word64' and then convert to 'Integer'+ fromIntegral <$> unsignedBitmaskWithRejectionM uniformWord64 limitAsWord64 gen+ Nothing -> boundedExclusiveIntegralM (limit + 1) gen+ return $ l + bounded+ GT -> uniformIntegralM (h, l) gen+ EQ -> pure l+{-# INLINEABLE uniformIntegralM #-}+{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Integer, Integer) -> g -> m Integer #-}+{-# SPECIALIZE uniformIntegralM :: StatefulGen g m => (Natural, Natural) -> g -> m Natural #-}++-- | Generate an integral in the range @[0, s)@ using a variant of Lemire's+-- multiplication method.+--+-- Daniel Lemire. 2019. Fast Random Integer Generation in an Interval. In ACM+-- Transactions on Modeling and Computer Simulation+-- https://doi.org/10.1145/3230636+--+-- PRECONDITION (unchecked): s > 0+boundedExclusiveIntegralM :: forall a g m . (Bits a, Integral a, StatefulGen g m) => a -> g -> m a+boundedExclusiveIntegralM s gen = go+ where+ n = integralWordSize s+ -- We renamed 'L' from the paper to 'k' here because 'L' is not a valid+ -- variable name in Haskell and 'l' is already used in the algorithm.+ k = wordSizeInBits * n+ twoToK = (1 :: a) `shiftL` k+ modTwoToKMask = twoToK - 1++ t = (twoToK - s) `rem` s -- `rem`, instead of `mod` because `twoToK >= s` is guaranteed+ go :: (Bits a, Integral a, StatefulGen g m) => m a+ go = do+ x <- uniformIntegralWords n gen+ let m = x * s+ -- m .&. modTwoToKMask == m `mod` twoToK+ let l = m .&. modTwoToKMask+ if l < t+ then go+ -- m `shiftR` k == m `quot` twoToK+ else return $ m `shiftR` k+{-# INLINE boundedExclusiveIntegralM #-}++-- | boundedByPowerOf2ExclusiveIntegralM s ~ boundedExclusiveIntegralM (bit s)+boundedByPowerOf2ExclusiveIntegralM ::+ forall a g m. (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a+boundedByPowerOf2ExclusiveIntegralM s gen = do+ let n = (s + wordSizeInBits - 1) `quot` wordSizeInBits+ x <- uniformIntegralWords n gen+ return $ x .&. (bit s - 1)+{-# INLINE boundedByPowerOf2ExclusiveIntegralM #-}++-- | @integralWordSize i@ returns that least @w@ such that+-- @i <= WORD_SIZE_IN_BITS^w@.+integralWordSize :: (Bits a, Num a) => a -> Int+integralWordSize = go 0+ where+ go !acc i+ | i == 0 = acc+ | otherwise = go (acc + 1) (i `shiftR` wordSizeInBits)+{-# INLINE integralWordSize #-}++-- | @uniformIntegralWords n@ is a uniformly pseudo-random integral in the range+-- @[0, WORD_SIZE_IN_BITS^n)@.+uniformIntegralWords :: forall a g m. (Bits a, Integral a, StatefulGen g m) => Int -> g -> m a+uniformIntegralWords n gen = go 0 n+ where+ go !acc i+ | i == 0 = return acc+ | otherwise = do+ (w :: Word) <- uniformM gen+ go ((acc `shiftL` wordSizeInBits) .|. fromIntegral w) (i - 1)+{-# INLINE uniformIntegralWords #-}++-- | Uniformly generate an 'Integral' in an inclusive-inclusive range.+--+-- Only use for integrals size less than or equal to that of 'Word32'.+unbiasedWordMult32RM :: forall a g m. (Integral a, StatefulGen g m) => (a, a) -> g -> m a+unbiasedWordMult32RM (b, t) g+ | b <= t = (+b) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (t - b)) g+ | otherwise = (+t) . fromIntegral <$> unbiasedWordMult32 (fromIntegral (b - t)) g+{-# INLINE unbiasedWordMult32RM #-}++-- | Uniformly generate Word32 in @[0, s]@.+unbiasedWordMult32 :: forall g m. StatefulGen g m => Word32 -> g -> m Word32+unbiasedWordMult32 s g+ | s == maxBound = uniformWord32 g+ | otherwise = unbiasedWordMult32Exclusive (s+1) g+{-# INLINE unbiasedWordMult32 #-}++-- | See [Lemire's paper](https://arxiv.org/pdf/1805.10941.pdf),+-- [O\'Neill's+-- blogpost](https://www.pcg-random.org/posts/bounded-rands.html) and+-- more directly [O\'Neill's github+-- repo](https://github.com/imneme/bounded-rands/blob/3d71f53c975b1e5b29f2f3b05a74e26dab9c3d84/bounded32.cpp#L234).+-- N.B. The range is [0,r) **not** [0,r].+unbiasedWordMult32Exclusive :: forall g m . StatefulGen g m => Word32 -> g -> m Word32+unbiasedWordMult32Exclusive r g = go+ where+ t :: Word32+ t = (-r) `mod` r -- Calculates 2^32 `mod` r!!!+ go :: StatefulGen g m => m Word32+ go = do+ x <- uniformWord32 g+ let m :: Word64+ m = fromIntegral x * fromIntegral r+ l :: Word32+ l = fromIntegral m+ if l >= t then return (fromIntegral $ m `shiftR` 32) else go+{-# INLINE unbiasedWordMult32Exclusive #-}++-- | This only works for unsigned integrals+unsignedBitmaskWithRejectionRM ::+ forall a g m . (FiniteBits a, Num a, Ord a, Uniform a, StatefulGen g m)+ => (a, a)+ -> g+ -> m a+unsignedBitmaskWithRejectionRM (bottom, top) gen+ | bottom == top = pure top+ | otherwise = (b +) <$> unsignedBitmaskWithRejectionM uniformM r gen+ where+ (b, r) = if bottom > top then (top, bottom - top) else (bottom, top - bottom)+{-# INLINE unsignedBitmaskWithRejectionRM #-}++-- | This works for signed integrals by explicit conversion to unsigned and abusing+-- overflow. It uses `unsignedBitmaskWithRejectionM`, therefore it requires functions that+-- take the value to unsigned and back.+signedBitmaskWithRejectionRM ::+ forall a b g m. (Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g m, Uniform a)+ => (b -> a) -- ^ Convert signed to unsigned. @a@ and @b@ must be of the same size.+ -> (a -> b) -- ^ Convert unsigned to signed. @a@ and @b@ must be of the same size.+ -> (b, b) -- ^ Range.+ -> g -- ^ Generator.+ -> m b+signedBitmaskWithRejectionRM toUnsigned fromUnsigned (bottom, top) gen+ | bottom == top = pure top+ | otherwise =+ (b +) . fromUnsigned <$> unsignedBitmaskWithRejectionM uniformM r gen+ -- This works in all cases, see Appendix 1 at the end of the file.+ where+ (b, r) =+ if bottom > top+ then (top, toUnsigned bottom - toUnsigned top)+ else (bottom, toUnsigned top - toUnsigned bottom)+{-# INLINE signedBitmaskWithRejectionRM #-}+++-- | Detailed explanation about the algorithm employed here can be found in this post:+-- http://web.archive.org/web/20200520071940/https://www.pcg-random.org/posts/bounded-rands.html+unsignedBitmaskWithRejectionM ::+ forall a g m. (Ord a, FiniteBits a, Num a, StatefulGen g m) => (g -> m a) -> a -> g -> m a+unsignedBitmaskWithRejectionM genUniformM range gen = go+ where+ mask :: a+ mask = complement zeroBits `shiftR` countLeadingZeros (range .|. 1)+ go = do+ x <- genUniformM gen+ let x' = x .&. mask+ if x' > range+ then go+ else pure x'+{-# INLINE unsignedBitmaskWithRejectionM #-}++-------------------------------------------------------------------------------+-- 'Uniform' instances for tuples+-------------------------------------------------------------------------------++instance (Uniform a, Uniform b) => Uniform (a, b) where+ uniformM g = (,) <$> uniformM g <*> uniformM g+ {-# INLINE uniformM #-}++instance (Uniform a, Uniform b, Uniform c) => Uniform (a, b, c) where+ uniformM g = (,,) <$> uniformM g <*> uniformM g <*> uniformM g+ {-# INLINE uniformM #-}++instance (Uniform a, Uniform b, Uniform c, Uniform d) => Uniform (a, b, c, d) where+ uniformM g = (,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g+ {-# INLINE uniformM #-}++instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e) => Uniform (a, b, c, d, e) where+ uniformM g = (,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g+ {-# INLINE uniformM #-}++instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f) =>+ Uniform (a, b, c, d, e, f) where+ uniformM g = (,,,,,)+ <$> uniformM g+ <*> uniformM g+ <*> uniformM g+ <*> uniformM g+ <*> uniformM g+ <*> uniformM g+ {-# INLINE uniformM #-}++instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f, Uniform g) =>+ Uniform (a, b, c, d, e, f, g) where+ uniformM g = (,,,,,,)+ <$> uniformM g+ <*> uniformM g+ <*> uniformM g+ <*> uniformM g+ <*> uniformM g+ <*> uniformM g+ <*> uniformM g+ {-# 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.+--+-- @top@ and @bottom@ are signed integers of bit width @n@. @toUnsigned@+-- converts a signed integer to an unsigned number of the same bit width @n@.+--+-- range = toUnsigned top - toUnsigned bottom+--+-- This works out correctly thanks to modular arithmetic. Conceptually,+--+-- toUnsigned x | x >= 0 = x+-- toUnsigned x | x < 0 = 2^n + x+--+-- The following combinations are possible:+--+-- 1. @bottom >= 0@ and @top >= 0@+-- 2. @bottom < 0@ and @top >= 0@+-- 3. @bottom < 0@ and @top < 0@+--+-- Note that @bottom >= 0@ and @top < 0@ is impossible because of the+-- invariant @bottom < top@.+--+-- For any signed integer @i@ of width @n@, we have:+--+-- -2^(n-1) <= i <= 2^(n-1) - 1+--+-- Considering each combination in turn, we have+--+-- 1. @bottom >= 0@ and @top >= 0@+--+-- range = (toUnsigned top - toUnsigned bottom) `mod` 2^n+-- --^ top >= 0, so toUnsigned top == top+-- --^ bottom >= 0, so toUnsigned bottom == bottom+-- = (top - bottom) `mod` 2^n+-- --^ top <= 2^(n-1) - 1 and bottom >= 0+-- --^ top - bottom <= 2^(n-1) - 1+-- --^ 0 < top - bottom <= 2^(n-1) - 1+-- = top - bottom+--+-- 2. @bottom < 0@ and @top >= 0@+--+-- range = (toUnsigned top - toUnsigned bottom) `mod` 2^n+-- --^ top >= 0, so toUnsigned top == top+-- --^ bottom < 0, so toUnsigned bottom == 2^n + bottom+-- = (top - (2^n + bottom)) `mod` 2^n+-- --^ summand -2^n cancels out in calculation modulo 2^n+-- = (top - bottom) `mod` 2^n+-- --^ top <= 2^(n-1) - 1 and bottom >= -2^(n-1)+-- --^ top - bottom <= (2^(n-1) - 1) - (-2^(n-1)) = 2^n - 1+-- --^ 0 < top - bottom <= 2^n - 1+-- = top - bottom+--+-- 3. @bottom < 0@ and @top < 0@+--+-- range = (toUnsigned top - toUnsigned bottom) `mod` 2^n+-- --^ top < 0, so toUnsigned top == 2^n + top+-- --^ bottom < 0, so toUnsigned bottom == 2^n + bottom+-- = ((2^n + top) - (2^n + bottom)) `mod` 2^n+-- --^ summand 2^n cancels out in calculation modulo 2^n+-- = (top - bottom) `mod` 2^n+-- --^ top <= -1+-- --^ bottom >= -2^(n-1)+-- --^ top - bottom <= -1 - (-2^(n-1)) = 2^(n-1) - 1+-- --^ 0 < top - bottom <= 2^(n-1) - 1+-- = top - bottom
+ 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
@@ -0,0 +1,1006 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module : System.Random.Stateful+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file LICENSE in the 'random' repository)+-- Maintainer : libraries@haskell.org+-- Stability : stable+--+-- This library deals with the common task of pseudo-random number generation.+module System.Random.Stateful+ (+ -- * Pure Random Generator+ module System.Random+ -- * Monadic Random Generator+ -- $introduction++ -- * Usage+ -- $usagemonadic++ -- * Mutable pseudo-random number generator interfaces+ -- $interfaces+ , StatefulGen+ ( uniformWord32R+ , uniformWord64R+ , uniformWord8+ , uniformWord16+ , uniformWord32+ , uniformWord64+ , uniformShortByteString+ )+ , FrozenGen(..)+ , ThawedGen(..)+ , withMutableGen+ , withMutableGen_+ , withSeedMutableGen+ , withSeedMutableGen_+ , randomM+ , randomRM+ , splitGenM+ , splitMutableGenM++ -- ** Deprecated+ , RandomGenM(..)++ -- * Monadic adapters for pure pseudo-random number generators #monadicadapters#+ -- $monadicadapters++ -- ** Pure adapter in 'MonadState'+ , StateGen(..)+ , StateGenM(..)+ , runStateGen+ , runStateGen_+ , runStateGenT+ , runStateGenT_+ , runStateGenST+ , runStateGenST_+ -- ** Mutable thread-safe adapter in 'IO'+ , AtomicGen(..)+ , AtomicGenM(..)+ , newAtomicGenM+ , applyAtomicGen+ , globalStdGen+ -- ** Mutable adapter in 'IO'+ , IOGen(..)+ , IOGenM(..)+ , newIOGenM+ , applyIOGen+ -- ** Mutable adapter in 'ST'+ , STGen(..)+ , STGenM(..)+ , newSTGenM+ , applySTGen+ , runSTGen+ , runSTGen_+ -- ** Mutable thread-safe adapter in 'STM'+ , TGen(..)+ , TGenM(..)+ , newTGenM+ , newTGenMIO+ , applyTGen++ -- * Pseudo-random values of various types+ -- $uniform+ , Uniform(..)+ , uniformViaFiniteM+ , UniformRange(..)+ , isInRangeOrd+ , isInRangeEnum++ -- ** 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+ , defaultUnsafeUniformFillMutableByteArray+ -- ** Floating point numbers+ , uniformDouble01M+ , uniformDoublePositive01M+ , uniformFloat01M+ , uniformFloatPositive01M+ -- ** Enum types+ , uniformEnumM+ , uniformEnumRM+ -- ** Word+ , uniformWordR++ -- * Appendix++ -- ** How to implement 'StatefulGen'+ -- $implemenstatefulegen++ -- ** Floating point number caveats #fpcaveats#+ , scaleFloating+ -- $floating++ -- * References+ -- $references+ ) where++import Control.DeepSeq+import Control.Monad.IO.Class+import Control.Monad.ST+import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar)+import Control.Monad.State.Strict (MonadState, state)+import Data.ByteString (ByteString)+import Data.Coerce+import Data.IORef+import Data.STRef+import Foreign.Storable+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:+--+-- [Monadic pseudo-random number generators] 'StatefulGen' is an interface to+-- monadic pseudo-random number generators.+--+-- [Monadic adapters] 'StateGenM', 'AtomicGenM', 'IOGenM', 'STGenM` and 'TGenM'+-- turn a 'RandomGen' instance into a 'StatefulGen' instance.+--+-- [Drawing from a range] 'UniformRange' is used to generate a value of a+-- type uniformly within a range.+--+-- This library provides instances of 'UniformRange' for many common+-- numeric types.+--+-- [Drawing from the entire domain of a type] 'Uniform' is used to generate a+-- value of a type uniformly over all possible values of that type.+--+-- This library provides instances of 'Uniform' for many common bounded+-- numeric types.+--+-- $usagemonadic+--+-- 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 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)+-- :}+--+-- > 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]+--+-- 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]++-------------------------------------------------------------------------------+-- Pseudo-random number generator interfaces+-------------------------------------------------------------------------------++-- $interfaces+--+-- Pseudo-random number generators come in two flavours: /pure/ and /monadic/.+--+-- ['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+-- 'Control.Monad.State.Strict.StateT', 'ST', 'IO' or 'STM' or some other transformer+-- on top of those monads.+--++-------------------------------------------------------------------------------+-- Monadic adapters+-------------------------------------------------------------------------------++-- $monadicadapters+--+-- 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+-- '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.+--+-- * 'IOGenM' is a wrapper around an 'IORef' that holds a pure generator.+-- 'IOGenM' is safe in the presence of exceptions, but not concurrency.+--+-- * 'STGenM' is a wrapper around an 'STRef' that holds a pure generator.+-- 'STGenM' is safe in the presence of exceptions, but not concurrency.+--+-- * 'TGenM' is a wrapper around a 'TVar' that holds a pure generator. 'TGenM'+-- can be used in a software transactional memory monad 'STM`. It is not as+-- performant as 'AtomicGenM`, but it can provide stronger guarantees in a+-- concurrent setting.++-- | Interface to operations on 'RandomGen' wrappers like 'IOGenM' and 'StateGenM'.+--+-- @since 1.2.0+class (RandomGen r, StatefulGen g m) => RandomGenM g r m | g -> r where+ applyRandomGenM :: (r -> (a, r)) -> g -> m a+{-# 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++instance (RandomGen r, MonadIO m) => RandomGenM (AtomicGenM r) r m where+ applyRandomGenM = applyAtomicGen++instance (RandomGen r, MonadState r m) => RandomGenM (StateGenM r) r m where+ applyRandomGenM f _ = state f++instance RandomGen r => RandomGenM (STGenM r s) r (ST s) where+ applyRandomGenM = applySTGen++instance RandomGen r => RandomGenM (TGenM r) r STM where+ 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__+--+-- >>> import Data.Int (Int8)+-- >>> withMutableGen (IOGen (mkStdGen 217)) (uniformListM 5) :: IO ([Int8], IOGen StdGen)+-- ([-74,37,-50,-2,3],IOGen {unIOGen = StdGen {unStdGen = SMGen 4273268533320920145 15251669095119325999}})+--+-- @since 1.2.0+withMutableGen :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m (a, f)+withMutableGen fg action = do+ g <- thawGen fg+ res <- action g+ fg' <- freezeGen g+ pure (res, fg')++-- | Same as 'withMutableGen', but only returns the generated value.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> withMutableGen_ (IOGen pureGen) (uniformRM (1 :: Int, 6 :: Int))+-- 4+--+-- @since 1.2.0+withMutableGen_ :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m a+withMutableGen_ fg action = thawGen fg >>= action+++-- | Just like `withMutableGen`, except uses a `Seed` instead of a frozen generator.+--+-- ====__Examples__+--+-- Here is good example of how `withSeedMutableGen` can be used with `withSeedFile`, which uses a locally stored seed.+--+-- 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 139+-- >>> g <- newIOGenM pureGen+-- >>> randomM g :: IO Double+-- 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 :: 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.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> g <- newIOGenM pureGen+-- >>> 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 :: 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.+--+-- * 'AtomicGenM' is safe in the presence of exceptions and concurrency.+-- * 'AtomicGenM' is the slowest of the monadic adapters due to the overhead+-- of its atomic operations.+--+-- @since 1.2.0+newtype AtomicGenM g = AtomicGenM { unAtomicGenM :: IORef g}+++-- | Frozen version of mutable `AtomicGenM` generator+--+-- @since 1.2.0+newtype AtomicGen g = AtomicGen { unAtomicGen :: g}+ 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+newAtomicGenM :: MonadIO m => g -> m (AtomicGenM g)+newAtomicGenM = fmap AtomicGenM . liftIO . newIORef+++-- | Global mutable standard pseudo-random number generator. This is the same+-- generator that was historically used by `randomIO` and `randomRIO` functions.+--+-- >>> import Control.Monad (replicateM)+-- >>> replicateM 10 (uniformRM ('a', 'z') globalStdGen)+-- "tdzxhyfvgr"+--+-- @since 1.2.1+globalStdGen :: AtomicGenM StdGen+globalStdGen = AtomicGenM theStdGen+++instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where+ uniformWord32R r = applyAtomicGen (genWord32R r)+ {-# INLINE uniformWord32R #-}+ uniformWord64R r = applyAtomicGen (genWord64R r)+ {-# INLINE uniformWord64R #-}+ uniformWord8 = applyAtomicGen genWord8+ {-# INLINE uniformWord8 #-}+ uniformWord16 = applyAtomicGen genWord16+ {-# INLINE uniformWord16 #-}+ uniformWord32 = applyAtomicGen genWord32+ {-# INLINE uniformWord32 #-}+ uniformWord64 = applyAtomicGen genWord64+ {-# INLINE uniformWord64 #-}+++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+-- generator.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> g <- newAtomicGenM pureGen+-- >>> applyAtomicGen random g :: IO Int+-- 7879794327570578227+--+-- @since 1.2.0+applyAtomicGen :: MonadIO m => (g -> (a, g)) -> AtomicGenM g -> m a+applyAtomicGen op (AtomicGenM gVar) =+ 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.+-- * 'IOGenM' is slower than 'StateGenM' due to the extra pointer indirection.+-- * 'IOGenM' is faster than 'AtomicGenM' since the 'IORef' operations used by+-- 'IOGenM' are not atomic.+--+-- An example use case is writing pseudo-random bytes into a file:+--+-- >>> import UnliftIO.Temporary (withSystemTempFile)+-- >>> import Data.ByteString (hPutStr)+-- >>> let ioGen g = withSystemTempFile "foo.bin" $ \_ h -> uniformRM (0, 100) g >>= flip uniformByteStringM g >>= hPutStr h+--+-- and then run it:+--+-- >>> newIOGenM (mkStdGen 1729) >>= ioGen+--+-- @since 1.2.0+newtype IOGenM g = IOGenM { unIOGenM :: IORef g }++-- | Frozen version of mutable `IOGenM` generator+--+-- @since 1.2.0+newtype IOGen g = IOGen { unIOGen :: g }+ 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'.+--+-- @since 1.2.0+newIOGenM :: MonadIO m => g -> m (IOGenM g)+newIOGenM = fmap IOGenM . liftIO . newIORef++++instance (RandomGen g, MonadIO m) => StatefulGen (IOGenM g) m where+ uniformWord32R r = applyIOGen (genWord32R r)+ {-# INLINE uniformWord32R #-}+ uniformWord64R r = applyIOGen (genWord64R r)+ {-# INLINE uniformWord64R #-}+ uniformWord8 = applyIOGen genWord8+ {-# INLINE uniformWord8 #-}+ uniformWord16 = applyIOGen genWord16+ {-# INLINE uniformWord16 #-}+ uniformWord32 = applyIOGen genWord32+ {-# INLINE uniformWord32 #-}+ uniformWord64 = applyIOGen genWord64+ {-# INLINE uniformWord64 #-}+++instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where+ type MutableGen (IOGen g) m = IOGenM g+ freezeGen = fmap IOGen . liftIO . readIORef . unIOGenM+ 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.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> g <- newIOGenM pureGen+-- >>> applyIOGen random g :: IO Int+-- 7879794327570578227+--+-- @since 1.2.0+applyIOGen :: MonadIO m => (g -> (a, g)) -> IOGenM g -> m a+applyIOGen f (IOGenM ref) = liftIO $ do+ g <- readIORef ref+ case f g of+ (a, !g') -> a <$ writeIORef ref g'+{-# INLINE applyIOGen #-}++-- | Wraps an 'STRef' that holds a pure pseudo-random number generator.+--+-- * 'STGenM' is safe in the presence of exceptions, but not concurrency.+-- * 'STGenM' is slower than 'StateGenM' due to the extra pointer indirection.+--+-- @since 1.2.0+newtype STGenM g s = STGenM { unSTGenM :: STRef s g }++-- | Frozen version of mutable `STGenM` generator+--+-- @since 1.2.0+newtype STGen g = STGen { unSTGen :: g }+ 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+newSTGenM :: g -> ST s (STGenM g s)+newSTGenM = fmap STGenM . newSTRef+++instance RandomGen g => StatefulGen (STGenM g s) (ST s) where+ uniformWord32R r = applySTGen (genWord32R r)+ {-# INLINE uniformWord32R #-}+ uniformWord64R r = applySTGen (genWord64R r)+ {-# INLINE uniformWord64R #-}+ uniformWord8 = applySTGen genWord8+ {-# INLINE uniformWord8 #-}+ uniformWord16 = applySTGen genWord16+ {-# INLINE uniformWord16 #-}+ uniformWord32 = applySTGen genWord32+ {-# INLINE uniformWord32 #-}+ uniformWord64 = applySTGen genWord64+ {-# INLINE uniformWord64 #-}++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+++-- | Applies a pure operation to the wrapped pseudo-random number generator.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> (runSTGen pureGen (\g -> applySTGen random g)) :: (Int, StdGen)+-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627})+--+-- @since 1.2.0+applySTGen :: (g -> (a, g)) -> STGenM g s -> ST s a+applySTGen f (STGenM ref) = do+ g <- readSTRef ref+ case f g of+ (a, !g') -> a <$ writeSTRef ref g'+{-# INLINE applySTGen #-}++-- | Runs a monadic generating action in the `ST` monad using a pure+-- pseudo-random number generator.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> (runSTGen pureGen (\g -> applySTGen random g)) :: (Int, StdGen)+-- (7879794327570578227,StdGen {unStdGen = SMGen 11285859549637045894 7641485672361121627})+--+-- @since 1.2.0+runSTGen :: RandomGen g => g -> (forall s . STGenM g s -> ST s a) -> (a, g)+runSTGen g action = unSTGen <$> runST (withMutableGen (STGen g) action)++-- | Runs a monadic generating action in the `ST` monad using a pure+-- pseudo-random number generator. Returns only the resulting pseudo-random+-- value.+--+-- ====__Examples__+--+-- >>> import System.Random.Stateful+-- >>> let pureGen = mkStdGen 137+-- >>> (runSTGen_ pureGen (\g -> applySTGen random g)) :: Int+-- 7879794327570578227+--+-- @since 1.2.0+runSTGen_ :: RandomGen g => g -> (forall s . STGenM g s -> ST s a) -> a+runSTGen_ g action = fst $ runSTGen g action+++-- | Wraps a 'TVar' that holds a pure pseudo-random number generator.+--+-- @since 1.2.1+newtype TGenM g = TGenM { unTGenM :: TVar g }++-- | Frozen version of mutable `TGenM` generator+--+-- @since 1.2.1+newtype TGen g = TGen { unTGen :: g }+ deriving (Eq, Ord, Show, RandomGen, 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+newTGenM :: g -> STM (TGenM g)+newTGenM = fmap TGenM . newTVar+++-- | Creates a new 'TGenM' in `IO`.+--+-- @since 1.2.1+newTGenMIO :: MonadIO m => g -> m (TGenM g)+newTGenMIO g = liftIO (TGenM <$> newTVarIO g)+++-- | @since 1.2.1+instance RandomGen g => StatefulGen (TGenM g) STM where+ uniformWord32R r = applyTGen (genWord32R r)+ {-# INLINE uniformWord32R #-}+ uniformWord64R r = applyTGen (genWord64R r)+ {-# INLINE uniformWord64R #-}+ uniformWord8 = applyTGen genWord8+ {-# INLINE uniformWord8 #-}+ uniformWord16 = applyTGen genWord16+ {-# INLINE uniformWord16 #-}+ uniformWord32 = applyTGen genWord32+ {-# INLINE uniformWord32 #-}+ uniformWord64 = applyTGen genWord64+ {-# INLINE uniformWord64 #-}++-- | @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+++-- | Applies a pure operation to the wrapped pseudo-random number generator.+--+-- ====__Examples__+--+-- >>> import Control.Concurrent.STM+-- >>> import System.Random.Stateful+-- >>> import Data.Int (Int32)+-- >>> let pureGen = mkStdGen 137+-- >>> stmGen <- newTGenMIO pureGen+-- >>> atomically $ applyTGen uniform stmGen :: IO Int32+-- 637238067+--+-- @since 1.2.1+applyTGen :: (g -> (a, g)) -> TGenM g -> STM a+applyTGen f (TGenM tvar) = do+ g <- readTVar tvar+ case f g of+ (a, !g') -> a <$ writeTVar tvar g'+{-# INLINE applyTGen #-}++-- $uniform+--+-- This library provides two type classes to generate pseudo-random values:+--+-- * 'UniformRange' is used to generate a value of a type uniformly within a+-- range.+-- * 'Uniform' is used to generate a value of a type uniformly over all+-- possible values of that type.+--+-- Types may have instances for both or just one of 'UniformRange' and+-- 'Uniform'. A few examples illustrate this:+--+-- * 'Int', 'Data.Word.Word16' and 'Bool' are instances of both 'UniformRange' and+-- 'Uniform'.+-- * 'Integer', 'Float' and 'Double' each have an instance for 'UniformRange'+-- but no 'Uniform' instance.+-- * A hypothetical type @Radian@ representing angles by taking values in the+-- range @[0, 2π)@ has a trivial 'Uniform' instance, but no 'UniformRange'+-- instance: the problem is that two given @Radian@ values always span /two/+-- ranges, one clockwise and one anti-clockwise.+-- * It is trivial to construct a @Uniform (a, b)@ instance given+-- @Uniform a@ and @Uniform b@ (and this library provides this tuple+-- instance).+-- * On the other hand, there is no correct way to construct a+-- @UniformRange (a, b)@ instance based on just @UniformRange a@ and+-- @UniformRange b@.++-------------------------------------------------------------------------------+-- Notes+-------------------------------------------------------------------------------++-- $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 (l, h) g@:+--+-- * If @__l == h__@, return: @__l__@.+-- * If @__`isInfinite` l == True__@ or @__`isInfinite` h == True__@, return: @__l + h__@+-- * Otherwise:+--+-- 1. Generate an unsigned integral of matching width @__w__@ uniformly.+--+-- 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:+--+-- @+-- x = `fromIntegral` w / `fromIntegral` `maxBound`+-- @+--+-- Then we scale and clamp it before returning it:+--+-- @+-- `max` (`min` (x * l + (1 - x) * h) (`max` l h)) (`min` l h)+-- @+--+-- 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.+--+-- 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:+--+-- @+-- x = `fromIntegral` (`clearBit` w 31) / `fromIntegral` `maxBound`+-- @+--+-- Further scaling depends on the top most bit:+--+-- @+-- 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 \(l\) or \(h\) is @__NaN__@, the result is @__NaN__@.+--+-- >>> uniformRM (nan, 1) g+-- NaN+-- >>> uniformRM (-1, nan) g+-- NaN+--+-- * If \(l\) and \(h\) are both @__Infinity__@ with opposing signs, then the result is @__NaN__@.+--+-- >>> uniformRM (-inf, inf) g+-- NaN+-- >>> uniformRM (inf, -inf) g+-- NaN+--+-- * Otherwise, if \(l\) is @__Infinity__@ or @__-Infinity__@, the result is \(l\).+--+-- >>> uniformRM (inf, 1) g+-- Infinity+-- >>> uniformRM (-inf, 1) g+-- -Infinity+--+-- * Otherwise, if \(h\) is @__Infinity__@ or @__-Infinity__@, the result is \(h\).+--+-- >>> uniformRM (1, inf) g+-- Infinity+-- >>> 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 a similar procedure to generate floating point values in a range.+--+-- $implemenstatefulegen+--+-- Typically, a monadic pseudo-random number generator has facilities to save+-- and restore its internal state in addition to generating pseudo-random numbers.+--+-- 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+-- > 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)+-- > 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 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 :: ThawedGen f m => f -> m [Int8]+-- myCustomRandomList f =+-- withMutableGen_ f $ \gen -> do+-- len <- uniformRM (5, 10) gen+-- replicateM len $ do+-- x <- uniformM gen+-- pure $ if even x then x else x + 1+-- :}+--+-- and later we can apply it to a frozen version of a stateful generator, such as `STGen`:+--+-- >>> print $ runST $ myCustomRandomList (STGen (mkStdGen 217))+-- [-50,-2,4,-8,-58,-40,24,-32,-110,24]+--+-- 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+-- somewhere for the later reuse.+--+--+-- $references+--+-- 1. Guy L. Steele, Jr., Doug Lea, and Christine H. Flood. 2014. Fast+-- splittable pseudorandom number generators. In Proceedings of the 2014 ACM+-- International Conference on Object Oriented Programming Systems Languages &+-- Applications (OOPSLA '14). ACM, New York, NY, USA, 453-472. DOI:+-- <https://doi.org/10.1145/2660193.2660195>++-- $setup+-- >>> writeIORef theStdGen $ mkStdGen 2021+--+-- >>> :seti -XFlexibleContexts+-- >>> :seti -XFlexibleInstances+-- >>> :seti -XMultiParamTypeClasses+-- >>> :seti -XTypeFamilies+-- >>> :seti -XUndecidableInstances+--+--
+ test-inspection/Spec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+module Main (main) where+#if __GLASGOW_HASKELL__ >= 800++import qualified Spec.Inspection as Inspection+import Test.Tasty++main :: IO ()+main =+ defaultMain $+ testGroup+ "InspectionSpec"+ [ Inspection.inspectionTests+ ]++#else++main :: IO ()+main = putStrLn "\nInspection testing is not supported for pre ghc-8.0 versions\n"++#endif++
+ test-inspection/Spec/Inspection.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-missing-signatures -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}++module Spec.Inspection (inspectionTests) where++import Data.Int+import Data.Void+import Data.Word+import GHC.Generics+import System.Random+import System.Random.Stateful+import Test.Tasty+import Test.Tasty.Inspection++uniform' :: Uniform a => (a, StdGen)+uniform' = uniform (mkStdGen 42)++uniform_Word8 = uniform' @Word8+uniform_Int8 = uniform' @Int8+uniform_Char = uniform' @Char++data MyAction = Code (Maybe Bool) | Never Void | Eat (Bool, Bool) | Sleep ()+ deriving (Eq, Ord, Show, Generic, Finite)+instance Uniform MyAction++uniform_MyAction = uniform' @MyAction++uniformR' :: (Bounded a, UniformRange a) => (a, StdGen)+uniformR' = uniformR (minBound, maxBound) (mkStdGen 42)++uniformR_Word8 = uniformR' @Word8+uniformR_Int8 = uniformR' @Int8+uniformR_Char = uniformR' @Char++uniformR_Double = uniformR (0 :: Double, 1) (mkStdGen 42)++inspectionTests :: TestTree+inspectionTests = testGroup "Inspection" $+ [ $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Word8)+ , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Int8)+ , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniform_Char)+ , $(inspectObligations [(`doesNotUse` 'StateGenM), 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)+ , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Char)+ , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Double)+ ]
+ test-legacy/Legacy.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import qualified Random1283 as Random1283+import qualified RangeTest as RangeTest+import qualified T7936 as T7936+import qualified TestRandomIOs as TestRandomIOs+import qualified TestRandomRs as TestRandomRs++main :: IO ()+main = do+ Random1283.main+ RangeTest.main+ T7936.main+ TestRandomIOs.main+ TestRandomRs.main
+ test-legacy/Random1283.hs view
@@ -0,0 +1,48 @@+module Random1283 (main) where++import Control.Concurrent+import Control.Monad+import Data.Sequence (Seq, ViewL(..), empty, fromList, viewl, (<|), (|>), (><))+import System.Random++-- This test++threads, samples :: Int+threads = 4+samples = 5000++main :: IO ()+main = loopTest threads samples++loopTest :: Int -> Int -> IO ()+loopTest t s = do+ isClean <- testRace t s+ unless isClean $ putStrLn "race condition!"++testRace :: Int -> Int -> IO Bool+testRace t s = do+ ref <- liftM (take (t*s) . randoms) getStdGen+ iss <- threadRandoms t s+ return (isInterleavingOf (ref::[Int]) iss)++threadRandoms :: Random a => Int -> Int -> IO [[a]]+threadRandoms t s = do+ vs <- sequence $ replicate t $ do+ v <- newEmptyMVar+ _ <- forkIO (sequence (replicate s randomIO) >>= putMVar v)+ return v+ mapM takeMVar vs++isInterleavingOf :: Eq a => [a] -> [[a]] -> Bool+isInterleavingOf xs' yss' = iio xs' (viewl $ fromList yss') EmptyL where+ iio (x:xs) ((y:ys) :< yss) zss+ | x /= y = iio (x:xs) (viewl yss) (viewl (fromViewL zss |> (y:ys)))+ | x == y = iio xs (viewl ((ys <| yss) >< fromViewL zss)) EmptyL+ iio xs ([] :< yss) zss = iio xs (viewl yss) zss+ iio [] EmptyL EmptyL = True+ iio _ _ _ = False++fromViewL :: ViewL a -> Seq a+fromViewL EmptyL = empty+fromViewL (x :< xs) = x <| xs+
+ test-legacy/RangeTest.hs view
@@ -0,0 +1,138 @@+module RangeTest (main) where++import Control.Monad+import System.Random+import Data.Int+import Data.Word+import Foreign.C.Types++-- Take many measurements and record the max/min/average random values.+approxBounds ::+ (RandomGen g, Random a, Ord a, Num a) =>+ (g -> (a,g)) -> Int -> a -> (a,a) -> g -> ((a,a,a),g)+-- Here we do a little hack to essentially pass in the type in the last argument:+approxBounds nxt iters unused (explo,exphi) initrng =+ if False+ then ((unused,unused,unused),undefined)+-- else loop initrng iters 100 (-100) 0 -- Oops, can't use minBound/maxBound here.+ else loop initrng iters exphi explo 0+ where+ loop rng 0 mn mx sum' = ((mn,mx,sum'),rng)+ loop rng n mn mx sum' =+ case nxt rng of+ (x, rng') -> loop rng' (n-1) (min x mn) (max x mx) (x+sum')+++-- We check that:+-- (1) all generated numbers are in bounds+-- (2) we get "close" to the bounds+-- The with (2) is that we do enough trials to ensure that we can at+-- least hit the 90% mark.+checkBounds ::+ (Real a, Show a, Ord a) =>+ String -> (Bool, a, a) -> ((a,a) -> StdGen -> ((a, a, t), StdGen)) -> IO ()+checkBounds msg (exclusive,lo,hi) fun = do+ -- (lo,hi) is [inclusive,exclusive)+ putStr $ msg ++ ": "+ (mn,mx,_) <- getStdRandom (fun (lo,hi))+ when (mn < lo) $ error $ "broke lower bound: " ++ show mn+ when (mx > hi) $ error $ "broke upper bound: " ++ show mx+ when (exclusive && mx >= hi)$ error$ "hit upper bound: " ++ show mx++ let epsilon = 0.1 * (toRational hi - toRational lo)++ when (toRational (hi - mx) > epsilon) $ error $ "didn't get close enough to upper bound: "++ show mx+ when (toRational (mn - lo) > epsilon) $ error $ "didn't get close enough to lower bound: "++ show mn+ putStrLn "Passed"++boundedRange :: (Num a, Bounded a) => (Bool, a, a)+boundedRange = ( False, minBound, maxBound )++trials :: Int+trials = 5000++-- Keep in mind here that on some architectures (e.g. ARM) CChar, CWchar, and CSigAtomic+-- are unsigned+main :: IO ()+main =+ do+ checkBounds "Int" boundedRange (approxBounds random trials (undefined::Int))+ checkBounds "Integer" (False, fromIntegral (minBound::Int), fromIntegral (maxBound::Int))+ (approxBounds random trials (undefined::Integer))+ checkBounds "Int8" boundedRange (approxBounds random trials (undefined::Int8))+ checkBounds "Int16" boundedRange (approxBounds random trials (undefined::Int16))+ checkBounds "Int32" boundedRange (approxBounds random trials (undefined::Int32))+ checkBounds "Int64" boundedRange (approxBounds random trials (undefined::Int64))+ checkBounds "Word" boundedRange (approxBounds random trials (undefined::Word))+ checkBounds "Word8" boundedRange (approxBounds random trials (undefined::Word8))+ checkBounds "Word16" boundedRange (approxBounds random trials (undefined::Word16))+ checkBounds "Word32" boundedRange (approxBounds random trials (undefined::Word32))+ checkBounds "Word64" boundedRange (approxBounds random trials (undefined::Word64))+ checkBounds "Double" (False,0.0,1.0) (approxBounds random trials (undefined::Double))+ checkBounds "Float" (False,0.0,1.0) (approxBounds random trials (undefined::Float))++ checkBounds "CChar" boundedRange (approxBounds random trials (undefined:: CChar))+ checkBounds "CSChar" boundedRange (approxBounds random trials (undefined:: CSChar))+ checkBounds "CUChar" boundedRange (approxBounds random trials (undefined:: CUChar))+ checkBounds "CShort" boundedRange (approxBounds random trials (undefined:: CShort))+ checkBounds "CUShort" boundedRange (approxBounds random trials (undefined:: CUShort))+ checkBounds "CInt" boundedRange (approxBounds random trials (undefined:: CInt))+ checkBounds "CUInt" boundedRange (approxBounds random trials (undefined:: CUInt))+ checkBounds "CLong" boundedRange (approxBounds random trials (undefined:: CLong))+ checkBounds "CULong" boundedRange (approxBounds random trials (undefined:: CULong))+ checkBounds "CPtrdiff" boundedRange (approxBounds random trials (undefined:: CPtrdiff))+ checkBounds "CSize" boundedRange (approxBounds random trials (undefined:: CSize))+ checkBounds "CWchar" boundedRange (approxBounds random trials (undefined:: CWchar))+ checkBounds "CSigAtomic" boundedRange (approxBounds random trials (undefined:: CSigAtomic))+ checkBounds "CLLong" boundedRange (approxBounds random trials (undefined:: CLLong))+ checkBounds "CULLong" boundedRange (approxBounds random trials (undefined:: CULLong))+ checkBounds "CIntPtr" boundedRange (approxBounds random trials (undefined:: CIntPtr))+ checkBounds "CUIntPtr" boundedRange (approxBounds random trials (undefined:: CUIntPtr))+ checkBounds "CIntMax" boundedRange (approxBounds random trials (undefined:: CIntMax))+ checkBounds "CUIntMax" boundedRange (approxBounds random trials (undefined:: CUIntMax))++ -- Then check all the range-restricted versions:+ checkBounds "Int R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int))+ checkBounds "Integer R"+ (False,-100000000000000000000,100000000000000000000)+ (approxBounds (randomR (-100000000000000000000,100000000000000000000)) trials (undefined::Integer))+ checkBounds "Int8 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int8))+ checkBounds "Int8 Rsmall" (False,-50,50) (approxBounds (randomR (-50,50)) trials (undefined::Int8))+ checkBounds "Int8 Rmini" (False,3,4) (approxBounds (randomR (3,4)) trials (undefined::Int8))+ checkBounds "Int8 Rtrivial" (False,3,3) (approxBounds (randomR (3,3)) trials (undefined::Int8))++ checkBounds "Int16 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int16))+ checkBounds "Int32 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int32))+ checkBounds "Int64 R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined::Int64))+ checkBounds "Word R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word))+ checkBounds "Word8 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word8))+ checkBounds "Word16 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word16))+ checkBounds "Word32 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word32))+ checkBounds "Word64 R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined::Word64))+ checkBounds "Double R" (False,10.0,77.0) (approxBounds (randomR (10,77)) trials (undefined::Double))+ checkBounds "Float R" (False,10.0,77.0) (approxBounds (randomR (10,77)) trials (undefined::Float))++ checkBounds "CChar R" (False,0,100) (approxBounds (randomR (0,100)) trials (undefined:: CChar))+ checkBounds "CSChar R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CSChar))+ checkBounds "CUChar R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUChar))+ checkBounds "CShort R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CShort))+ checkBounds "CUShort R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUShort))+ checkBounds "CInt R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CInt))+ checkBounds "CUInt R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUInt))+ checkBounds "CLong R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CLong))+ checkBounds "CULong R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CULong))+ checkBounds "CPtrdiff R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CPtrdiff))+ checkBounds "CSize R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CSize))+ checkBounds "CWchar R" (False,0,100) (approxBounds (randomR (0,100)) trials (undefined:: CWchar))+ checkBounds "CSigAtomic R" (False,0,100) (approxBounds (randomR (0,100)) trials (undefined:: CSigAtomic))+ checkBounds "CLLong R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CLLong))+ checkBounds "CULLong R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CULLong))+ checkBounds "CIntPtr R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CIntPtr))+ checkBounds "CUIntPtr R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUIntPtr))+ checkBounds "CIntMax R" (False,-100,100) (approxBounds (randomR (-100,100)) trials (undefined:: CIntMax))+ checkBounds "CUIntMax R" (False,0,200) (approxBounds (randomR (0,200)) trials (undefined:: CUIntMax))++-- Untested:+-- instance Random Char where+-- instance Random Bool where+-- instance Random Integer where
+ test-legacy/T7936.hs view
@@ -0,0 +1,15 @@+-- Test for ticket #7936:+-- https://ghc.haskell.org/trac/ghc/ticket/7936+--+-- Used to fail with:+--+-- $ cabal test T7936 --test-options="+RTS -M1M -RTS"+-- T7936: Heap exhausted;++module T7936 where++import System.Random (newStdGen)+import Control.Monad (replicateM_)++main :: IO ()+main = replicateM_ 100000 newStdGen
+ test-legacy/TestRandomIOs.hs view
@@ -0,0 +1,21 @@+-- Test for ticket #4218 (TestRandomIOs):+-- https://ghc.haskell.org/trac/ghc/ticket/4218+--+-- Used to fail with:+--+-- $ cabal test TestRandomIOs --test-options="+RTS -M1M -RTS"+-- TestRandomIOs: Heap exhausted;++module TestRandomIOs where++import Control.Monad (replicateM)+import System.Random (randomIO)++-- Build a list of 5000 random ints in memory (IO Monad is strict), and print+-- the last one.+-- Should use less than 1Mb of heap space, or we are generating a list of+-- unevaluated thunks.+main :: IO ()+main = do+ rs <- replicateM 5000 randomIO :: IO [Int]+ print $ last rs
+ test-legacy/TestRandomRs.hs view
@@ -0,0 +1,23 @@+-- Test for ticket #4218 (TestRandomRs):+-- https://ghc.haskell.org/trac/ghc/ticket/4218+--+-- Fixed together with ticket #8704+-- https://ghc.haskell.org/trac/ghc/ticket/8704+-- Commit 4695ffa366f659940369f05e419a4f2249c3a776+--+-- Used to fail with:+--+-- $ cabal test TestRandomRs --test-options="+RTS -M1M -RTS"+-- TestRandomRs: Heap exhausted;++module TestRandomRs where++import Control.Monad (liftM)+import System.Random (randomRs, getStdGen)++-- Return the five-thousandth random number:+-- Should run in constant space (< 1Mb heap).+main :: IO ()+main = do+ n <- (last . take 5000 . randomRs (0, 1000000)) `liftM` getStdGen+ print (n::Integer)
+ test/Spec.hs view
@@ -0,0 +1,325 @@+{-# 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 (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 ()+main =+ defaultMain $+ testGroup+ "Spec"+ [ floatingSpec (Proxy :: Proxy Double)+ , floatingSpec (Proxy :: Proxy Float)+ , floatingSpec (Proxy :: Proxy CDouble)+ , floatingSpec (Proxy :: Proxy CFloat)+ , integralSpec (Proxy :: Proxy Word8)+ , integralSpec (Proxy :: Proxy Word16)+ , integralSpec (Proxy :: Proxy Word32)+ , integralSpec (Proxy :: Proxy Word64)+ , integralSpec (Proxy :: Proxy Word)+ , integralSpec (Proxy :: Proxy Int8)+ , integralSpec (Proxy :: Proxy Int16)+ , integralSpec (Proxy :: Proxy Int32)+ , integralSpec (Proxy :: Proxy Int64)+ , integralSpec (Proxy :: Proxy Int)+ , integralSpec (Proxy :: Proxy Char)+ , integralSpec (Proxy :: Proxy Bool)+#if __GLASGOW_HASKELL__ >= 802+ , integralSpec (Proxy :: Proxy CBool)+#endif+ , integralSpec (Proxy :: Proxy CChar)+ , integralSpec (Proxy :: Proxy CSChar)+ , integralSpec (Proxy :: Proxy CUChar)+ , integralSpec (Proxy :: Proxy CShort)+ , integralSpec (Proxy :: Proxy CUShort)+ , integralSpec (Proxy :: Proxy CInt)+ , integralSpec (Proxy :: Proxy CUInt)+ , integralSpec (Proxy :: Proxy CLong)+ , integralSpec (Proxy :: Proxy CULong)+ , integralSpec (Proxy :: Proxy CPtrdiff)+ , integralSpec (Proxy :: Proxy CSize)+ , integralSpec (Proxy :: Proxy CWchar)+ , integralSpec (Proxy :: Proxy CSigAtomic)+ , integralSpec (Proxy :: Proxy CLLong)+ , integralSpec (Proxy :: Proxy CULLong)+ , integralSpec (Proxy :: Proxy CIntPtr)+ , integralSpec (Proxy :: Proxy CUIntPtr)+ , integralSpec (Proxy :: Proxy CIntMax)+ , integralSpec (Proxy :: Proxy CUIntMax)+ , 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))+ , randomSpec (Proxy :: Proxy (Int8, Int16, Int32))+ , randomSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64))+ , randomSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word))+ , randomSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word))+ , randomSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word))+ , uniformSpec (Proxy :: Proxy (Int, Bool))+ , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32))+ , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64))+ , uniformSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word))+ , uniformSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word))+ , uniformSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word))+ , Stateful.statefulGenSpec+ , Seed.spec+ ]++floatTests :: TestTree+floatTests = testGroup "(Float)"+ [ -- Check that https://github.com/haskell/random/issues/53 does not regress++ testCase "Subnormal generation not above upper bound" $+ [] @?= filter (>4.0e-45) (take 100000 $ randomRs (0, 4.0e-45::Float) $ mkStdGen 0)++ , testCase "Subnormal generation includes upper bound" $+ 1.0e-45 `elem` take 100 (randomRs (0, 1.0e-45::Float) $ mkStdGen 0) @?+ "Does not contain 1.0e-45"+ ]++showType :: forall t . Typeable t => Proxy t -> String+showType px = show (typeRep px)++byteStringSpec :: TestTree+byteStringSpec =+ testGroup+ "ByteString"+ [ SC.testProperty "uniformShortByteString" $+ seededWithLen $ \n g -> SBS.length (fst (uniformShortByteString n g)) == n+ , SC.testProperty "uniformByteString" $+ seededWithLen $ \n g ->+ 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 (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 " ++ showType px)+ [ SC.testProperty "uniformR" $ seeded $ Range.uniformRangeWithin px+ ]++integralSpec ::+ forall a.+ (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a)+ => Proxy a -> TestTree+integralSpec 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+ , rangeSpec px+ -- TODO: Add more tests+ ]++enumSpec ::+ forall a.+ (SC.Serial IO a, Typeable a, Ord a, UniformRange a, Show a)+ => Proxy a -> TestTree+enumSpec = integralSpec++floatingSpec ::+ forall a.+ (SC.Serial IO a, Typeable a, Num a, Ord a, Random a, UniformRange a, Read a, Show a)+ => Proxy a -> TestTree+floatingSpec 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))+ , testCase "l = -inf, x = 0" $ negativeInf @?= fst (uniformR (negativeInf, 0) (ConstGen 0))+ , testCase "l = -inf, x = 1" $ negativeInf @?= fst (uniformR (negativeInf, 0) (ConstGen 1))+ -- TODO: Add more tests+ ]+ where+ positiveInf, negativeInf :: a+ positiveInf = read "Infinity"+ negativeInf = read "-Infinity"++randomSpec ::+ forall a.+ (Typeable a, Eq a, Random a, Show a)+ => Proxy a -> TestTree+randomSpec px =+ testGroup+ ("Random " ++ 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+ (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, UniformRange a, Show a)+ => Proxy a -> TestTree+uniformSpec px =+ testGroup+ ("Uniform " ++ showType px)+ [ SC.testProperty "uniformList" $+ seededWithLen $ \len g ->+ 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+runSpec = testGroup "runStateGen_ and runPrimGenIO_"+ [ SC.testProperty "equal outputs" $ seeded $ \g -> monadic $ Run.runsEqual g ]++-- | Create a StdGen instance from an Int and pass it to the given function.+seeded :: (StdGen -> a) -> Int -> a+seeded f = f . mkStdGen++-- | Same as `seeded`, but also produces a length in range 0-65535 suitable for generating+-- lists and such+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)+instance Monad m => Serial m MyBool++data MyAction = Code (Maybe MyBool) | Never Void | Eat (Bool, Bool) | Sleep ()+ deriving (Eq, Ord, Show, Generic, Finite)+instance Monad m => Serial m MyAction+instance Uniform MyAction++data Foo+ = Quux Char+ | Bar Int | Baz Word+ | Bar8 Int8 | Baz8 Word8+ | Bar16 Int16 | Baz16 Word16+ | Bar32 Int32 | Baz32 Word32+ | Bar64 Int64 | Baz64 Word64+ | Final ()+ deriving (Eq, Ord, Show, Generic, Finite, Uniform)+instance Monad m => Serial m Foo++newtype ConstGen = ConstGen Word64++instance 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)+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)+instance Monad m => Serial m Colors++instance Uniform Colors where+ uniformM = uniformEnumM++instance UniformRange Colors where+ uniformRM = uniformEnumRM+ isInRange (lo, hi) x = isInRange (fromEnum lo, fromEnum hi) (fromEnum x)
+ test/Spec/Range.hs view
@@ -0,0 +1,42 @@+module Spec.Range+ ( symmetric+ , bounded+ , singleton+ , uniformRangeWithin+ , uniformRangeWithinExcludedF+ , uniformRangeWithinExcludedD+ ) where++import System.Random.Stateful+import Data.Proxy++(===) :: (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) = isInRange (l, r) (fst (uniformR (l, r) g))++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 ->+ isInRange (l, r) <$> uniformRM (l, r) g++uniformRangeWithinExcludedF :: RandomGen g => g -> Bool+uniformRangeWithinExcludedF gen =+ runStateGen_ gen $ \g ->+ (\result -> 0 < result && result <= 1) <$> uniformFloatPositive01M g++uniformRangeWithinExcludedD :: RandomGen g => g -> Bool+uniformRangeWithinExcludedD gen =+ runStateGen_ gen $ \g ->+ (\result -> 0 < result && result <= 1) <$> uniformDoublePositive01M g
+ test/Spec/Run.hs view
@@ -0,0 +1,14 @@+module Spec.Run (runsEqual) where++import Data.Word (Word64)+import System.Random.Stateful++runsEqual :: RandomGen g => g -> IO Bool+runsEqual g = do+ let pureResult = runStateGen_ g uniformM :: Word64+ stResult = runSTGen_ g uniformM :: Word64+ ioGenM <- newIOGenM g+ ioResult <- uniformM ioGenM+ atomicGenM <- newAtomicGenM g+ atomicResult <- uniformM atomicGenM+ return $ all (pureResult ==) [stResult, ioResult, atomicResult]
+ 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
@@ -0,0 +1,223 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Spec.Stateful where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.ST+import Data.Proxy+import Data.Typeable+import System.Random (uniformShortByteString)+import System.Random.Stateful hiding (uniformShortByteString)+import Test.SmallCheck.Series+import Test.Tasty+import Test.Tasty.SmallCheck as SC++instance Monad m => Serial m StdGen where+ series = mkStdGen <$> series++instance (Monad m, Serial m g) => Serial m (AtomicGen g) where+ series = AtomicGen <$> series++instance (Monad m, Serial m g) => Serial m (IOGen g) where+ series = IOGen <$> series++instance (Monad m, Serial m g) => Serial m (STGen g) where+ series = STGen <$> series++instance (Monad m, Serial m g) => Serial m (TGen g) where+ series = TGen <$> series++instance (Monad m, Serial m g) => Serial m (StateGen g) where+ series = StateGen <$> series+++matchRandomGenSpec ::+ forall 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 -> (sg -> m a) -> IO (a, f))+ -> Property IO+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. (ThawedGen f m, Eq f, Show f)+ => (forall a. m a -> IO a)+ -> f+ -> Property IO+withMutableGenSpec toIO frozen =+ 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'++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+ -> 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+thawedGenSpecFor toIO px =+ testGroup+ (showsTypeRep (typeRep px) "")+ [ testProperty "withMutableGen" $+ forAll $ \(f :: f) -> withMutableGenSpec toIO 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+ ]+ ]+++statefulGenSpec :: TestTree+statefulGenSpec =+ testGroup+ "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')+ ]+ ]
− tests/T7936.hs
@@ -1,14 +0,0 @@--- Test for ticket #7936:--- https://ghc.haskell.org/trac/ghc/ticket/7936------ Used to fail with:------ $ cabal test T7936 --test-options="+RTS -M1M -RTS"--- T7936: Heap exhausted;--module Main where--import System.Random (newStdGen)-import Control.Monad (replicateM_)--main = replicateM_ 100000 newStdGen
− tests/TestRandomIOs.hs
@@ -1,20 +0,0 @@--- Test for ticket #4218 (TestRandomIOs):--- https://ghc.haskell.org/trac/ghc/ticket/4218------ Used to fail with:------ $ cabal test TestRandomIOs --test-options="+RTS -M1M -RTS"--- TestRandomIOs: Heap exhausted;--module Main where--import Control.Monad (replicateM)-import System.Random (randomIO)---- Build a list of 5000 random ints in memory (IO Monad is strict), and print--- the last one.--- Should use less than 1Mb of heap space, or we are generating a list of--- unevaluated thunks.-main = do- rs <- replicateM 5000 randomIO :: IO [Int]- print $ last rs
− tests/TestRandomRs.hs
@@ -1,22 +0,0 @@--- Test for ticket #4218 (TestRandomRs):--- https://ghc.haskell.org/trac/ghc/ticket/4218------ Fixed together with ticket #8704--- https://ghc.haskell.org/trac/ghc/ticket/8704--- Commit 4695ffa366f659940369f05e419a4f2249c3a776------ Used to fail with:------ $ cabal test TestRandomRs --test-options="+RTS -M1M -RTS"--- TestRandomRs: Heap exhausted;--module Main where--import Control.Monad (liftM, replicateM)-import System.Random (randomRs, getStdGen)---- Return the five-thousandth random number:--- Should run in constant space (< 1Mb heap).-main = do- n <- (last . take 5000 . randomRs (0, 1000000)) `liftM` getStdGen- print (n::Integer)