random-mhs (empty) → 1.3.1
raw patch · 27 files changed
+7696/−0 lines, 27 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, data-array-byte, deepseq, mtl, primitive, random, rdtsc, smallcheck, split, splitmix, stm, tasty, tasty-bench, tasty-hunit, tasty-inspection-testing, tasty-smallcheck, time, transformers
Files
- CHANGELOG.md +183/−0
- LICENSE +63/−0
- README.md +28/−0
- Setup.hs +4/−0
- bench-legacy/BinSearch.hs +147/−0
- bench-legacy/SimpleRNGBench.hs +270/−0
- bench/Main.hs +433/−0
- random-mhs.cabal +202/−0
- src/System/Random.hs +981/−0
- src/System/Random/Array.hs +433/−0
- src/System/Random/GFinite.hs +309/−0
- src/System/Random/Internal.hs +2071/−0
- src/System/Random/Seed.hs +377/−0
- src/System/Random/Stateful.hs +959/−0
- test-inspection/Spec.hs +22/−0
- test-inspection/Spec/Inspection.hs +68/−0
- test-legacy/Legacy.hs +15/−0
- test-legacy/Random1283.hs +48/−0
- test-legacy/RangeTest.hs +246/−0
- test-legacy/T7936.hs +20/−0
- test-legacy/TestRandomIOs.hs +26/−0
- test-legacy/TestRandomRs.hs +28/−0
- test/Spec.hs +348/−0
- test/Spec/Range.hs +44/−0
- test/Spec/Run.hs +14/−0
- test/Spec/Seed.hs +118/−0
- test/Spec/Stateful.hs +239/−0
+ CHANGELOG.md view
@@ -0,0 +1,183 @@+# 1.3.2++* Fix `setStdGen` not being threadsafe: [#190](https://github.com/haskell/random/pull/190)+* Make `getStdRandom` lazy in the value being generated: [#190](https://github.com/haskell/random/pull/190)++# 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
+ LICENSE view
@@ -0,0 +1,63 @@+This library (libraries/base) is derived from code from two+sources: ++ * Code from the GHC project which is largely (c) The University of+ Glasgow, and distributable under a BSD-style license (see below),++ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+ and freely redistributable (but see the full license for+ restrictions).++The full text of these licenses is reproduced below. Both of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------++Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++ Copyright (c) 2002 Simon Peyton Jones++ The authors intend this Report to belong to the entire Haskell+ community, and so we grant permission to copy and distribute it for+ any purpose, provided that it is reproduced in its entirety,+ including this Notice. Modified versions of this Report may also be+ copied and distributed for any purpose, provided that the modified+ version is clearly presented as such, and that it does not claim to+ be a definition of the Haskell 98 Language.++-----------------------------------------------------------------------------
+ README.md view
@@ -0,0 +1,28 @@+# The Haskell Standard Library++## Random Number Generation++### MHS version+This a fork of the `random` package to be able to compile it with MicroHs.+The `random` package maintainers do not want to make these changes.+The package still works with GHC.++### 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
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ bench-legacy/BinSearch.hs view
@@ -0,0 +1,147 @@+{-+ 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.List+import Data.Time.Clock+import System.IO+import Prelude hiding (log, max, min)++-- | 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 BinSearch+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.IORef+import Data.Int+import Data.List hiding (last, sum)+import Data.List.Split hiding (split)+import Data.Word+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable (peek, poke)+import GHC.Conc+import System.CPUTime (getCPUTime)+import System.CPUTime.Rdtsc+import System.Console.GetOpt+import System.Environment+import System.Exit (exitFailure, exitSuccess)+import System.Random+import Text.Printf+import Prelude hiding (last, sum)++----------------------------------------------------------------------------------------------------+-- 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+ where+ -- This lifts a C kernel to operate simultaneously on N threads.++ 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,433 @@+{-# 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" $+ fillFloating sz+ ++ [ 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)+ ]+ ]+ where+#if MIN_VERSION_primitive(0,7,1)+ fillFloating sz =+ [ 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))+ ]+ ]+ ]+#else+ fillFloating _ = []+#endif++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-mhs.cabal view
@@ -0,0 +1,202 @@+cabal-version: >=1.10+name: random-mhs+version: 1.3.1+license: BSD3+license-file: LICENSE+maintainer: lennart@augustsson.net+bug-reports: https://github.com/augustss/random-mhs/issues+synopsis: Pseudo-random number generation+description:+ == This package is a fork of 'random' with changes to make it compile with MicroHs.+ .+ 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.7+ , GHC == 9.8.4+ , GHC == 9.10.2+ , GHC == 9.12.2++source-repository head+ type: git+ location: https://github.com/augustss/random-mhs.git+++library+ exposed-modules:+ System.Random+ System.Random.Internal+ System.Random.Stateful+ other-modules:+ System.Random.Array+ System.Random.Seed+ System.Random.GFinite++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -Wall+ -Wincomplete-record-updates -Wincomplete-uni-patterns++ 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 >= 0.1 && < 9.9++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++ default-language: Haskell2010+ ghc-options:+ -with-rtsopts=-M9M+ -Wno-deprecations+ build-depends:+ base >=4.9 && <5,+ containers >=0.5 && <0.8,+ random++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 >=4.9 && <5,+ 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 >=4.9 && <5,+ 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 >=4.9 && <5,+ 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 >=4.9 && <5,+ mtl,+ primitive,+ random,+ splitmix >=0.1 && <0.2,+ tasty-bench
+ src/System/Random.hs view
@@ -0,0 +1,981 @@+{-# 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,+#if !defined(__MHS__)+ Finite,+#endif /* !defined(__MHS__) */++ -- ** 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.ST (ST)+import Control.Monad.State.Strict+import Data.Array.Byte (ByteArray (..), MutableByteArray (..))+import Data.ByteString (ByteString)+import Data.ByteString.Short.Internal (ShortByteString (..))+import Data.Coerce+import Data.IORef+import Data.Int+import Data.Word+import Foreign.C.Types+import GHC.Exts+import System.Random.Array (getSizeOfMutableByteArray, shortByteStringToByteString, shuffleListST)+#if !defined(__MHS__)+import System.Random.GFinite (Finite)+#endif /* !defined(__MHS__) */+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+#if !defined(__MHS__)+ (ByteArray ba#, g') -> (SBS ba#, g')+{-# INLINE uniformShortByteString #-}+#else /* defined(__MHS__) */+ (ba, g') -> (byteArrayToShortByteString ba, g')+#endif /* defined(__MHS__) */++-- | 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 =>+ -- | Mutable array to fill with random bytes+ MutableByteArray s ->+ -- | 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.+ Int ->+ 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 ::+ -- | E.g. @(:)@ but subject to fusion+ (a -> as -> as) ->+ -- | E.g. 'random'+ (g -> (a, g)) ->+ -- | A 'RandomGen' instance+ g ->+ 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 g = getStdRandom (const ((), g))++-- | 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 = modifyGen globalStdGen (coerce f)++-- | 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,433 @@+{-# 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 (when)+import Control.Monad.ST+import Control.Monad.Trans (MonadTrans, lift)+#if !defined(__MHS__)+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 #-}++indexWord8 ::+ ByteArray ->+ -- | Offset into immutable byte array in number of bytes+ Int ->+ Word8+indexWord8 (ByteArray ba#) (I# i#) =+ W8# (indexWord8Array# ba# i#)+{-# INLINE indexWord8 #-}++indexWord64LE ::+ ByteArray ->+ -- | Offset into immutable byte array in number of bytes+ Int ->+ 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 #-}++-- 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 ->+ -- | Offset into mutable byte array in number of bytes+ Int ->+ -- | 8 bytes that will be written into the supplied array+ Word64 ->+ 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+#if __GLASGOW_HASKELL__ >=802+getSizeOfMutableByteArray (MutableByteArray mba#) =+ ST $ \s ->+ case getSizeofMutableByteArray# mba# s of+ (# s', n# #) -> (# s', I# n# #)+#else+getSizeOfMutableByteArray (MutableByteArray mba#) =+ 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+#if __GLASGOW_HASKELL__ < 802+shortByteStringToByteString ba = SBS.fromShort ba+#else+shortByteStringToByteString ba =+ 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 #-}++#else /* !defined(__MHS__) */+import qualified Data.Array as A+import Data.Array.Byte+import Data.Bits+import Data.ByteString(ByteString)+import Data.ByteString.Short.Internal+import qualified Data.STArray as SA+import Data.Word+import GHC.Exts(unsafeIOToST)++wordSizeInBits :: Int+wordSizeInBits = _wordSize++ioToST :: IO a -> ST s a+ioToST = unsafeIOToST++-- newMutableArray++newPinnedMutableByteArray :: Int -> ST s (MutableByteArray s)+newPinnedMutableByteArray = newMutableByteArray++-- freezeMutableArray+-- writeWord8+-- indexWord8++indexWord64LE :: ByteArray -> Int -> Word64+indexWord64LE ba i = indexByteSliceWord64LE ba i (i+8)++writeWord64LE :: MutableByteArray s -> Int -> Word64 -> ST s ()+writeWord64LE ba i w = writeByteSliceWord64LE ba i (i+8) w++getSizeOfMutableByteArray :: MutableByteArray s -> ST s Int+getSizeOfMutableByteArray = sizeOfMutableByteArray++shortByteStringToByteArray :: ShortByteString -> ByteArray+shortByteStringToByteArray = byteStringToByteArray . fromShort+byteArrayToShortByteString :: ByteArray -> ShortByteString+byteArrayToShortByteString = toShort . byteArrayToByteString+shortByteStringToByteString :: ShortByteString -> ByteString+shortByteStringToByteString = fromShort++--------++type Array a = A.Array Int a+type MutableArray s a = SA.STArray s a++newMutableArray :: Int -> a -> ST s (MutableArray s a)+newMutableArray = SA.newSTArray++freezeMutableArray :: MutableArray s a -> ST s (Array a)+freezeMutableArray = SA.freezeSTArray++sizeOfMutableArray :: MutableArray s a -> Int+sizeOfMutableArray = SA.sizeSTArray++readArray :: MutableArray s a -> Int -> ST s a+readArray = SA.readSTArray++writeArray :: MutableArray s a -> Int -> a -> ST s ()+writeArray = SA.writeSTArray++#endif /* !defined(__MHS__) */++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 #-}++indexByteSliceWord64LE ::+ ByteArray ->+ -- | Starting offset in number of bytes+ Int ->+ -- | Ending offset in number of bytes+ Int ->+ 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 #-}++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 =>+ -- | Action that generates a Word in the supplied range.+ (Word -> m Word) ->+ -- | Number of index swaps to generate.+ Word ->+ 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,309 @@+{-# LANGUAGE CPP #-}+{-# 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 (..),+#if !defined(__MHS__)+ Finite (..),+ GFinite (..),+#endif /* !defined(x__MHS__) */+) where++import Data.Bits+import Data.Int+import Data.Void+import Data.Word+#if !defined(__MHS__)+import GHC.Exts (Proxy#, proxy#)+import GHC.Generics+#endif /* !defined(__MHS__) */++-- | Cardinality of a set.+data Cardinality+ = -- | Shift n is equivalent to Card (bit n)+ Shift !Int+ | 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 #-}++#if !defined(__MHS__)+-- | 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)++#endif /* !defined(__MHS__) */
+ src/System/Random/Internal.hs view
@@ -0,0 +1,2071 @@+{-# 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 TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# 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,++ -- * Atomic and Global+ AtomicGen (..),+ AtomicGenM (..),+ newAtomicGenM,+ applyAtomicGen,+ globalStdGen,++ -- ** 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 (..),+#if !defined(__MHS__)+ uniformViaFiniteM,+#endif /* !defined(__MHS__) */+ 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.IO.Class+import Control.Monad.ST+import Control.Monad.State.Strict (MonadState (..), State, StateT (..), execStateT, runState, runStateT)+import Control.Monad.Trans (MonadTrans, lift)+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+import Data.Int+import Data.Kind+import Data.Word+import Foreign.C.Types+import Foreign.Storable (Storable)+import GHC.Exts+#if !defined(__MHS__)+import GHC.Generics+import GHC.IO (IO (..))+import GHC.ST (ST (..))+import GHC.Word+#else /* !defined(__MHS__) */+import Data.Coerce+#endif /* !defined(__MHS__) */+import Numeric.Natural (Natural)+import System.IO.Unsafe (unsafePerformIO)+import System.Random.Array+#if !defined(__MHS__)+import System.Random.GFinite (Cardinality (..), Finite, GFinite (..))+#endif /* __MHS__ */+import qualified System.Random.SplitMix as SM+import qualified System.Random.SplitMix32 as SM32+#if __GLASGOW_HASKELL__ >= 808+import GHC.IORef (atomicModifyIORef2Lazy)+#endif++-- | 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+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+#if !defined(__MHS__)+ (ByteArray ba#, g') -> (SBS ba#, g')+ {-# INLINE genShortByteString #-}+#else+ (ba, g') -> (byteArrayToShortByteString ba, g')+#endif /* !defined(__MHS__) */++ -- | 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 ::+ -- | Mutable array to fill with random bytes+ MutableByteArray s ->+ -- | 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.+ Int ->+ 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 next "No longer used" #-}++{-# DEPRECATED genRange "No longer used" #-}++{-# DEPRECATED split "In favor of `splitGen`" #-}++{-# DEPRECATED genShortByteString "In favor of `System.Random.uniformShortByteString`" #-}++-- | 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 ::+ -- | Should `ByteArray` be allocated as pinned memory or not+ Bool ->+ -- | Size of the newly created `ByteArray` in number of bytes.+ Int ->+ -- | Generator to use for filling in the newly created `ByteArray`+ g ->+ m ByteArray+#if !defined(__MHS__)+ 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)+#endif /* !defined(__MHS__) */+ {-# 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+#if !defined(__MHS__)+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 #-}+#else+class StatefulGen mutableGen m => FrozenGen f m mutableGen | mutableGen -> f where+ freezeGen :: mutableGen -> m f+ freezeGen mg = modifyGen mg (\fg -> (fg, fg))+ modifyGen :: mutableGen -> (f -> (a, f)) -> m a+ modifyGen mg f = do+ fg <- freezeGen mg+ case f fg of+ (a, !fg') -> a <$ overwriteGen mg fg'+ overwriteGen :: mutableGen -> f -> m ()+ overwriteGen mg fg = modifyGen mg (const ((), fg))+#endif /* !defined(__MHS__) */++-- | 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+#if !defined(__MHS__)+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++#else /* !defined(__MHS__) */++class FrozenGen f m mutableGen => ThawedGen f m mutableGen where+ thawGen :: f -> m mutableGen++splitGenM :: (SplitGen f, FrozenGen f m mutableGen) => mutableGen -> m f+splitGenM = flip modifyGen splitGen++splitMutableGenM :: (SplitGen f, ThawedGen f m mutableGen) => mutableGen -> m mutableGen+splitMutableGenM = splitGenM >=> thawGen+#endif /* !defined(__MHS__) */++-- | Efficiently generates a sequence of pseudo-random bytes in a platform+-- independent manner.+--+-- @since 1.3.0+uniformByteArray ::+ RandomGen g =>+ -- | Should byte array be allocated in pinned or unpinned memory.+ Bool ->+ -- | Number of bytes to generate+ Int ->+ -- | Pure pseudo-random numer generator+ g ->+ (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 ->+ -- | Starting offset+ Int ->+ -- | Number of random bytes to write into the array+ Int ->+ -- | ST action that can generate 8 random bytes at a time+ g ->+ 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 ::+ -- | Number of bytes to generate+ Int ->+ -- | IO action that can generate 8 random bytes at a time+ IO Word64 ->+ 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 #-}++#if !defined(__MHS__)+instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m where+ type MutableGen (StateGen g) m = StateGenM g+#else /* !defined(__MHS__) */+instance (RandomGen g, MonadState g m) => FrozenGen (StateGen g) m (StateGenM g) where+#endif /* !defined(__MHS__) */+ 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+#if !defined(__MHS__)+ default uniformM :: (StatefulGen g m, Generic a, GUniform (Rep a)) => g -> m a+ uniformM = fmap to . (`runContT` pure) . guniformM+ {-# INLINE uniformM #-}+#endif /* !defined(__MHS__) */++#if !defined(__MHS__)+-- | 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 #-}+#endif /* !defined(__MHS__) */++-- | 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++#if !defined(__MHS__)+ 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+#endif /* !defined(__MHS__) */++-- | 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 =>+ -- | Maximum value to generate+ Word ->+ -- | Stateful generator+ g ->+ 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 !defined(__MHS__)+#if __GLASGOW_HASKELL__ < 902+word32ToChar (W32# w#) = C# (chr# (word2Int# w#))+#else+word32ToChar (W32# w#) = C# (chr# (word2Int# (word32ToWord# w#)))+#endif+#else /* !defined(__MHS__) */+word32ToChar = toEnum . fromIntegral+#endif /* !defined(__MHS__) */+{-# INLINE word32ToChar #-}++charToWord32 :: Char -> Word32+#if !defined(__MHS__)+#if __GLASGOW_HASKELL__ < 902+charToWord32 (C# c#) = W32# (int2Word# (ord# c#))+#else+charToWord32 (C# c#) = W32# (wordToWord32# (int2Word# (ord# c#)))+#endif+#else /* !defined(__MHS__) */+charToWord32 = fromIntegral . fromEnum+#endif /* !defined(__MHS__) */+{-# 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++#if !defined(__MHS__)+instance (Finite a, Uniform a) => Uniform (Maybe a)++instance (Finite a, Uniform a, Finite b, Uniform b) => Uniform (Either a b)+#endif /* !defined(__MHS__) */++-- | 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) =>+ -- | Low+ a ->+ -- | High+ a ->+ -- | Uniformly distributed unsigned integral value that will be used for converting to a floating+ -- point value and subsequent scaling to the specified range+ w ->+ 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) =>+ -- | Convert signed to unsigned. @a@ and @b@ must be of the same size.+ (b -> a) ->+ -- | Convert unsigned to signed. @a@ and @b@ must be of the same size.+ (a -> b) ->+ -- | Range.+ (b, b) ->+ -- | Generator.+ g ->+ m b+signedBitmaskWithRejectionRM toUnsigned fromUnsigned (bottom, top) gen+ | bottom == top = pure top+ | otherwise =+ -- This works in all cases, see Appendix 1 at the end of the file.+ (b +) . fromUnsigned <$> unsignedBitmaskWithRejectionM uniformM r gen+ 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)++-- | 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)++-- | 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)+-- "..."+--+-- @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 #-}++#if !defined(__MHS__)+instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where+ type MutableGen (AtomicGen g) m = AtomicGenM g+#else /* __MHS__ */+instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m (AtomicGenM g) where+#endif /* __MHS__ */+ 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 #-}++#if !defined(__MHS__)+instance (RandomGen g, MonadIO m) => ThawedGen (AtomicGen g) m where+#else /* __MHS__ */+instance (RandomGen g, MonadIO m) => ThawedGen (AtomicGen g) m (AtomicGenM g) where+#endif /* __MHS__ */+ 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 #-}++-- 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,377 @@+{-# LANGUAGE CPP #-}+{-# 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+#if !defined(__MHS__)+import GHC.Exts (Proxy#, proxy#)+import GHC.TypeLits (KnownNat, Nat, natVal', type (<=))+#endif /* !defined(__MHS__) */+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 (+#if !defined(__MHS__)+ KnownNat (SeedSize g), 1 <= SeedSize g,+#endif /* !defined(__MHS__) */+ 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+ -- @+#if !defined(__MHS__)+ type SeedSize g :: Nat+#else /* !defined(__MHS__) */+ _seedSize :: Int+#endif /* !defined(__MHS__) */++ {-# 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+#if !defined(__MHS__)+ type SeedSize StdGen = SeedSize SM.SMGen+#else /* !defined(__MHS__) */+ _seedSize = _seedSize @SM.SMGen+#endif /* !defined(__MHS__) */+ fromSeed = coerce (fromSeed :: Seed SM.SMGen -> SM.SMGen)+ toSeed = coerce (toSeed :: SM.SMGen -> Seed SM.SMGen)++-- Standalone definitions due to GHC-8.0 not supporting deriving with associated type families++instance SeedGen g => SeedGen (StateGen g) where+#if !defined(__MHS__)+ type SeedSize (StateGen g) = SeedSize g+#else /* !defined(__MHS__) */+ _seedSize = _seedSize @g+#endif /* !defined(__MHS__) */+ fromSeed = coerce (fromSeed :: Seed g -> g)+ toSeed = coerce (toSeed :: g -> Seed g)++instance SeedGen g => SeedGen (AtomicGen g) where+#if !defined(__MHS__)+ type SeedSize (AtomicGen g) = SeedSize g+#else /* !defined(__MHS__) */+ _seedSize = _seedSize @g+#endif /* !defined(__MHS__) */+ fromSeed = coerce (fromSeed :: Seed g -> g)+ toSeed = coerce (toSeed :: g -> Seed g)++instance SeedGen SM.SMGen where+#if !defined(__MHS__)+ type SeedSize SM.SMGen = 16+#else /* !defined(__MHS__) */+ _seedSize = 16+#endif /* !defined(__MHS__) */+ 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+#if !defined(__MHS__)+ type SeedSize SM32.SMGen = 8+#else /* !defined(__MHS__) */+ _seedSize = 8+#endif /* !defined(__MHS__) */+ 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 =+#if !defined(__MHS__)+ fromInteger $ natVal' (proxy# :: Proxy# (SeedSize g))+#else /* !defined(__MHS__) */+ _seedSize @g+#endif /* !defined(__MHS__) */+++-- | 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,959 @@+{-# 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 (+ -- * Monadic Random Generator+ -- $introduction++ -- * Usage+ -- $usagemonadic++ -- * Mutable pseudo-random number generator interfaces+ -- $interfaces+ StatefulGen (+ uniformWord32R,+ uniformWord64R,+ uniformWord8,+ uniformWord16,+ uniformWord32,+ uniformWord64+#if !defined(__MHS__)+ ,uniformShortByteString+#endif /* !defined(__MHS__) */+ ),+ 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 (..),+#if !defined(__MHS__)+ uniformViaFiniteM,+#endif /* !defined(__MHS__) */+ 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++ -- * Pure Random Generator+ module System.Random,+) where++import Control.DeepSeq+import Control.Monad.IO.Class+import Control.Monad.ST+import Control.Monad.State.Strict (MonadState, state)+import Data.ByteString (ByteString)+import Data.Coerce+import Data.IORef+import Data.STRef+import Foreign.Storable+import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar)+import System.Random hiding (uniformShortByteString)+import System.Random.Array (shortByteStringToByteString, shuffleListM)+import System.Random.Internal++-- $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+#if !defined(__MHS__)+withMutableGen :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m (a, f)+#else /* !defined(__MHS__) */+withMutableGen :: ThawedGen f m mutableGen => f -> (mutableGen -> m a) -> m (a, f)+#endif /* !defined(__MHS__) */+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+#if !defined(__MHS__)+withMutableGen_ :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m a+#else /* !defined(__MHS__) */+withMutableGen_ :: ThawedGen f m mutableGen => f -> (mutableGen -> m a) -> m a+#endif /* !defined(__MHS__) */+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+#if !defined(__MHS__)+withSeedMutableGen ::+ (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m (a, Seed g)+#else /* !defined(__MHS__) */+withSeedMutableGen ::+ (SeedGen g, ThawedGen g m mutableGen) => Seed g -> (mutableGen -> m a) -> m (a, Seed g)+#endif /* !defined(__MHS__) */+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+#if !defined(__MHS__)+withSeedMutableGen_ :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m a+#else /* !defined(__MHS__) */+withSeedMutableGen_ :: (SeedGen g, ThawedGen g m mutableGen) => Seed g -> (mutableGen -> m a) -> m a+#endif /* !defined(__MHS__) */+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+#if !defined(__MHS__)+randomM :: forall a g m. (Random a, RandomGen g, FrozenGen g m) => MutableGen g m -> m a+#else /* !defined(__MHS__) */+randomM :: (Random a, RandomGen g, FrozenGen g m mutableGen) => mutableGen -> m a+#endif /* !defined(__MHS__) */+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+#if !defined(__MHS__)+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)+#else /* !defined(__MHS__) */+randomRM :: (Random a, RandomGen g, FrozenGen g m mutableGen) => (a, a) -> mutableGen -> m a+#endif /* !defined(__MHS__) */+{-# 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.+--+-- * '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+#if !defined(__MHS__)+ type SeedSize (IOGen g) = SeedSize g+#else /* !defined(__MHS__) */+ _seedSize = _seedSize @g+#endif /* !defined(__MHS__) */+ 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 #-}++#if !defined(__MHS__)+instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where+ type MutableGen (IOGen g) m = IOGenM g+#else /* !defined(__MHS__) */+instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m (IOGenM g) where+#endif /* !defined(__MHS__) */+ 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 #-}++#if !defined(__MHS__)+instance (RandomGen g, MonadIO m) => ThawedGen (IOGen g) m where+#else /* !defined(__MHS__) */+instance (RandomGen g, MonadIO m) => ThawedGen (IOGen g) m (IOGenM g) where+#endif /* !defined(__MHS__) */+ 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+#if !defined(__MHS__)+ type SeedSize (STGen g) = SeedSize g+#else /* !defined(__MHS__) */+ _seedSize = _seedSize @g+#endif /* !defined(__MHS__) */+ 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 #-}++#if !defined(__MHS__)+instance RandomGen g => FrozenGen (STGen g) (ST s) where+ type MutableGen (STGen g) (ST s) = STGenM g s+#else /* !defined(__MHS__) */+instance RandomGen g => FrozenGen (STGen g) (ST s) (STGenM g s) where+#endif /* !defined(__MHS__) */+ 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 #-}++#if !defined(__MHS__)+instance RandomGen g => ThawedGen (STGen g) (ST s) where+#else /* !defined(__MHS__) */+instance RandomGen g => ThawedGen (STGen g) (ST s) (STGenM g s) where+#endif /* !defined(__MHS__) */+ 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+#if !defined(__MHS__)+ type SeedSize (TGen g) = SeedSize g+#else /* !defined(__MHS__) */+ _seedSize = _seedSize @g+#endif /* !defined(__MHS__) */+ 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+#if !defined(__MHS__)+instance RandomGen g => FrozenGen (TGen g) STM where+ type MutableGen (TGen g) STM = TGenM g+#else /* !defined(__MHS__) */+instance RandomGen g => FrozenGen (TGen g) STM (TGenM g) where+#endif /* !defined(__MHS__) */+ 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 #-}++#if !defined(__MHS__)+instance RandomGen g => ThawedGen (TGen g) STM where+#else /* !defined(__MHS__) */+instance RandomGen g => ThawedGen (TGen g) STM (TGenM g) where+#endif /* !defined(__MHS__) */+ 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,22 @@+{-# 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,68 @@+{-# 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)+ , $(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)+ ]+ ++ base_pre_4_17_spec+ where+#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.+ base_pre_4_17_spec = [$(inspectTest $ hasNoGenerics 'uniform_MyAction)]+#else+ base_pre_4_17_spec = []+#endif
+ 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,246 @@+module RangeTest (main) where++import Control.Monad+import Data.Int+import Data.Word+import Foreign.C.Types+import System.Random++-- 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,20 @@+-- | Test for ticket #7936:+-- https://ghc.haskell.org/trac/ghc/ticket/7936+--+-- Used to fail with:+--+-- @+-- $ cabal build+-- $ cabal exec -- ghc -O1 -fforce-recomp -rtsopts -main-is T7936 test-legacy/T7936.hs -o test-legacy/test+-- $ test-legacy/test +RTS -M1M -A1M -RTS+-- test: Heap exhausted;+-- test: Current maximum heap size is 1048576 bytes (1 MB).+-- test: Use `+RTS -M<size>' to increase it.+-- @+module T7936 where++import Control.Monad (replicateM_)+import System.Random (newStdGen)++main :: IO ()+main = replicateM_ 100000 newStdGen
+ test-legacy/TestRandomIOs.hs view
@@ -0,0 +1,26 @@+-- | Test for ticket #4218 (TestRandomIOs):+-- https://ghc.haskell.org/trac/ghc/ticket/4218+--+-- Used to fail with:+--+-- @+-- $ cabal build+-- $ cabal exec -- ghc -O1 -fforce-recomp -rtsopts -main-is TestRandomIOs test-legacy/TestRandomIOs.hs -o test-legacy/test+-- $ test-legacy/test +RTS -M1M -A1M -RTS+-- test: Heap exhausted;+-- test: Current maximum heap size is 1048576 bytes (1 MB).+-- test: Use `+RTS -M<size>' to increase it.+-- @+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,28 @@+-- | 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 build+-- $ cabal exec -- ghc -O1 -fforce-recomp -rtsopts -main-is TestRandomRs test-legacy/TestRandomRs.hs -o test-legacy/test+-- $ test-legacy/test +RTS -M1M -A1M -RTS+-- test: Heap exhausted;+-- test: Current maximum heap size is 1048576 bytes (1 MB).+-- test: Use `+RTS -M<size>' to increase it.+-- @+module TestRandomRs where++import Control.Monad (liftM)+import System.Random (getStdGen, randomRs)++-- 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 :: Int)
+ test/Spec.hs view
@@ -0,0 +1,348 @@+{-# 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 (forM_, replicateM)+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.Exts (fromList)+import GHC.Generics+import Numeric.Natural (Natural)+import System.Random (uniformShortByteString)+import System.Random.Internal (freezeMutableByteArray, newMutableByteArray, writeWord8)+import System.Random.Stateful hiding (uniformShortByteString)+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)+ , 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+ ]+ ++ ghc_8_2_spec+ where+#if __GLASGOW_HASKELL__ >= 802+ ghc_8_2_spec = [integralSpec (Proxy :: Proxy CBool)]+#else+ ghc_8_2_spec = []+#endif++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,44 @@+module Spec.Range (+ symmetric,+ bounded,+ singleton,+ uniformRangeWithin,+ uniformRangeWithinExcludedF,+ uniformRangeWithinExcludedD,+) where++import Data.Proxy+import System.Random.Stateful++(===) :: (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,118 @@+{-# 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 qualified Data.ByteString as BS+import Data.List.NonEmpty as NE+import Data.Maybe (fromJust)+import Data.Proxy+import Data.Word+import qualified GHC.Exts as GHC (IsList (..))+import GHC.TypeLits+import Spec.Stateful ()+import System.Random+import Test.SmallCheck.Series hiding (NonEmpty (..))+import Test.Tasty+import Test.Tasty.SmallCheck as SC++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,239 @@+{-# 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')+ ]+ ]