diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 20f2e4c2..d5287c8f 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -23,8 +23,6 @@ jobs: include: # Linux # haskell-actions/setup is having trouble installing from hvr/ppa for ghc-8.0 and 8.2 - # - { os: ubuntu-latest, ghc: "8.0.2" } - # - { os: ubuntu-latest, ghc: "8.2.2" } - { os: ubuntu-latest, ghc: "8.4.4" } - { os: ubuntu-latest, ghc: "8.6.5" } - { os: ubuntu-latest, ghc: "8.8.4" } @@ -32,13 +30,11 @@ jobs: - { os: ubuntu-latest, ghc: "9.0.2" } - { os: ubuntu-latest, ghc: "9.2.8" } - { os: ubuntu-latest, ghc: "9.4.8" } - - { os: ubuntu-latest, ghc: "9.6.6" } + - { os: ubuntu-latest, ghc: "9.6.7" } - { os: ubuntu-latest, ghc: "9.8.4" } - - { os: ubuntu-latest, ghc: "9.10.1" } - - { os: ubuntu-latest, ghc: "9.12.1" } + - { os: ubuntu-latest, ghc: "9.10.2" } + - { os: ubuntu-latest, ghc: "9.12.2" } # MacOS - # - { os: macOS-latest, ghc: "8.0.2" } - # - { os: macOS-latest, ghc: "8.2.2" } - { os: macOS-latest, ghc: "8.4.4" } - { os: macOS-latest, ghc: "8.6.5" } - { os: macOS-latest, ghc: "8.8.4" } @@ -46,13 +42,11 @@ jobs: - { os: macOS-latest, ghc: "9.0.2" } - { os: macOS-latest, ghc: "9.2.8" } - { os: macOS-latest, ghc: "9.4.8" } - - { os: macOS-latest, ghc: "9.6.6" } + - { os: macOS-latest, ghc: "9.6.7" } - { os: macOS-latest, ghc: "9.8.4" } - - { os: macOS-latest, ghc: "9.10.1" } - - { os: macOS-latest, ghc: "9.12.1" } + - { os: macOS-latest, ghc: "9.10.2" } + - { os: macOS-latest, ghc: "9.12.2" } # Windows - # - { os: windows-latest, ghc: "8.0.2" } - # - { os: windows-latest, ghc: "8.2.2" } - { os: windows-latest, ghc: "8.4.4" } - { os: windows-latest, ghc: "8.6.5" } - { os: windows-latest, ghc: "8.8.4" } @@ -60,10 +54,10 @@ jobs: - { os: windows-latest, ghc: "9.0.2" } - { os: windows-latest, ghc: "9.2.8" } - { os: windows-latest, ghc: "9.4.8" } - - { os: windows-latest, ghc: "9.6.6" } + - { os: windows-latest, ghc: "9.6.7" } - { os: windows-latest, ghc: "9.8.4" } - - { os: windows-latest, ghc: "9.10.1" } - - { os: windows-latest, ghc: "9.12.1" } + - { os: windows-latest, ghc: "9.10.2" } + - { os: windows-latest, ghc: "9.12.2" } steps: - uses: actions/checkout@v4 @@ -94,6 +88,7 @@ jobs: cabal $EXTRA_FLAGS build all --write-ghc-environment-files=always - name: Doctest + if: matrix.ghc != '8.4.4' run: | cabal install doctest --ignore-project --overwrite-policy=always ./scripts/doctest.sh @@ -133,7 +128,7 @@ jobs: ghc: '9.4.8' stack-yaml: stack.yaml - resolver: lts-22 - ghc: '9.6.6' + ghc: '9.6.7' stack-yaml: stack.yaml - resolver: nightly stack-yaml: stack.yaml @@ -148,7 +143,7 @@ jobs: stack-yaml: stack.yaml - resolver: lts-22 os: macos-13 - ghc: '9.6.6' + ghc: '9.6.7' stack-yaml: stack.yaml # Windows-latest - resolver: lts-14 @@ -165,11 +160,12 @@ jobs: stack-yaml: stack.yaml - resolver: lts-22 os: windows-latest - ghc: '9.6.6' + ghc: '9.6.7' stack-yaml: stack.yaml env: STACK_YAML: '${{ matrix.stack-yaml }}' STACK_ARGS: '--resolver ${{ matrix.resolver }}' + HADDOCK: ${{ (matrix.resolver == 'lts-9' || matrix.resolver == 'lts-11' || matrix.resolver == 'lts-12') && '--no-haddock' || '--haddock --no-haddock-deps' }} cache-version: v5 # bump up this version to invalidate currently stored cache steps: - uses: actions/checkout@v4 @@ -217,9 +213,9 @@ jobs: set -ex if [ "${{ matrix.os }}.${{ matrix.resolver }}" == "ubuntu-latest.lts-19" ] && [ -n "${COVERALLS_TOKEN}" ]; then # Inspection tests aren't compatible with coverage - stack $STACK_ARGS build :spec :legacy-test --coverage --test --no-run-tests --haddock --no-haddock-deps + stack $STACK_ARGS build :spec :legacy-test --coverage --test --no-run-tests $HADDOCK else - stack $STACK_ARGS build --test --no-run-tests --bench --no-run-benchmarks --haddock --no-haddock-deps + stack $STACK_ARGS build --test --no-run-tests --bench --no-run-benchmarks $HADDOCK fi - name: Test @@ -309,3 +305,28 @@ jobs: ./legacy ghc --make -isrc:test -o spec test/Spec.hs ./spec + fourmolu: + runs-on: ubuntu-latest + + defaults: + run: + shell: bash + + strategy: + fail-fast: false + + steps: + - uses: actions/checkout@v4 + + - name: Install fourmolu + run: | + FOURMOLU_VERSION="0.18.0.0" + BINDIR=$HOME/.local/bin + mkdir -p "$BINDIR" + curl -sSfL "https://github.com/fourmolu/fourmolu/releases/download/v${FOURMOLU_VERSION}/fourmolu-${FOURMOLU_VERSION}-linux-x86_64" -o "$BINDIR/fourmolu" + chmod a+x "$BINDIR/fourmolu" + echo "$BINDIR" >> $GITHUB_PATH + + - name: Run fourmolu + run: ./scripts/fourmolize.sh + diff --git a/.gitignore b/.gitignore index ecd83243..bd22d9f0 100644 --- a/.gitignore +++ b/.gitignore @@ -2,3 +2,4 @@ /stack.yaml.lock /.stack-work/ /cabal.project.local +/test-legacy/test diff --git a/bench-legacy/BinSearch.hs b/bench-legacy/BinSearch.hs index 81a57930..0741462b 100644 --- a/bench-legacy/BinSearch.hs +++ b/bench-legacy/BinSearch.hs @@ -1,4 +1,3 @@ - {- Binary search over benchmark input sizes. @@ -16,19 +15,15 @@ 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 +module BinSearch ( + binSearch, +) where import Control.Monad -import Data.Time.Clock -- Not in 6.10 import Data.List +import Data.Time.Clock import System.IO -import Prelude hiding (min,max,log) - - +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: @@ -38,28 +33,28 @@ import Prelude hiding (min,max,log) -- ... 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 :: 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) + "[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... + -- 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: + 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: + -- [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 @@ -73,62 +68,64 @@ binSearch verbose trials (min, max) kernel = do "[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. + 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)) + "[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 + -- hFlush stdout print_trial (trials - trials_left + 1) n time - -- whenverbose$ hFlush stdout + -- 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 + 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 :: 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 @@ -137,6 +134,7 @@ timeit io = do io end <- getCurrentTime return (diffUTCTime end strt) + {- test :: IO (Integer,Double) test = diff --git a/bench-legacy/SimpleRNGBench.hs b/bench-legacy/SimpleRNGBench.hs index dfffeb86..c1d46e21 100644 --- a/bench-legacy/SimpleRNGBench.hs +++ b/bench-legacy/SimpleRNGBench.hs @@ -6,32 +6,28 @@ -- | A simple script to do some very basic timing of the RNGs. module Main where -import System.Exit (exitSuccess, exitFailure) -import System.Environment -import System.Random -import System.CPUTime (getCPUTime) -import System.CPUTime.Rdtsc -import System.Console.GetOpt - -import GHC.Conc +import BinSearch import Control.Concurrent -import Control.Monad import Control.Exception - +import Control.Monad import Data.IORef -import Data.Word -import Data.List hiding (last,sum) import Data.Int -import Data.List.Split hiding (split) -import Text.Printf - -import Foreign.Ptr +import Data.List hiding (last, sum) +import Data.List.Split hiding (split) +import Data.Word import Foreign.C.Types import Foreign.ForeignPtr -import Foreign.Storable (peek,poke) - -import Prelude hiding (last,sum) -import BinSearch +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: @@ -42,11 +38,11 @@ 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 +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 ' ') +padright n str | otherwise = str ++ take (n - length str) (repeat ' ') fmt_num :: (RealFrac a, PrintfArg a) => a -> String fmt_num n = @@ -54,7 +50,6 @@ fmt_num n = 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 @@ -73,14 +68,18 @@ measureFreq = do 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" + "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) @@ -88,6 +87,7 @@ instance RandomGen NoopRNG where -- An RNG generating only 0 or 1: data BinRNG = BinRNG StdGen + instance RandomGen BinRNG where next (BinRNG g) = (x `mod` 2, BinRNG g') where @@ -97,7 +97,6 @@ instance RandomGen BinRNG where where (g1, g2) = split g - ---------------------------------------------------------------------------------------------------- -- Drivers to get random numbers repeatedly. @@ -109,7 +108,7 @@ type Kern = Int -> Ptr Int -> IO () -- 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 :: (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) @@ -124,14 +123,13 @@ timeit numthreads freq msg gen nxt = do 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' - + 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 @@ -149,34 +147,36 @@ timeit_foreign numthreads freq msg ffn = do cycles_per = fromIntegral freq * t / fromIntegral n printResult total_per_second msg cycles_per return total_per_second - -- This lifts a C kernel to operate simultaneously on N threads. where + -- 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 = ceiling$ fromIntegral n / fromIntegral nthreads let childwork = n -- Keep it the same.. interested in per-thread throughput. - -- Fork/join pattern: + -- Fork/join pattern: forM_ ptrs $ \pt -> forkIO $ - withForeignPtr pt $ \p -> do - kern (fromIntegral childwork) p - result <- peek p - writeChan tmpchan result + 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: + -- Meaningless semantics here... sum the child ptrs and write to the input one: poke ptr (foldl1 (+) results) - -printResult :: Int64 -> String -> Double -> IO () +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" + " " + ++ padleft 11 (commaint total) + ++ " randoms generated " + ++ padright 27 ("[" ++ msg ++ "]") + ++ " ~ " + ++ fmt_num cycles_per + ++ " cycles/int" ---------------------------------------------------------------------------------------------------- -- Main Script @@ -186,14 +186,14 @@ data Flag = NoC | Help options :: [OptDescr Flag] options = - [ Option ['h'] ["help"] (NoArg Help) "print program help" - , Option [] ["noC"] (NoArg NoC) "omit C benchmarks, haskell only" - ] + [ 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 + let (opts, _, other) = getOpt Permute options argv unless (null other) $ do putStrLn "ERROR: Unrecognized options: " @@ -213,58 +213,58 @@ main = do 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) + 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 + 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 + 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 () + 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:" + putStrLn $ + "\nNow " ++ show numCapabilities ++ " threads, reporting mean randoms-per-second-per-thread:" void $ gamut numCapabilities putStrLn "Finished." - diff --git a/bench/Main.hs b/bench/Main.hs index b17b89f8..3a499963 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} + module Main (main) where import Control.Monad @@ -36,336 +37,370 @@ main = do 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 + "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 "uniformR" - [ bgroup "full" - [ pureUniformRFullBench (Proxy :: Proxy Word8) sz - , pureUniformRFullBench (Proxy :: Proxy Word16) sz - , pureUniformRFullBench (Proxy :: Proxy Word32) sz - , pureUniformRFullBench (Proxy :: Proxy Word64) sz - , pureUniformRFullBench (Proxy :: Proxy Word) sz - , pureUniformRFullBench (Proxy :: Proxy Int8) sz - , pureUniformRFullBench (Proxy :: Proxy Int16) sz - , pureUniformRFullBench (Proxy :: Proxy Int32) sz - , pureUniformRFullBench (Proxy :: Proxy Int64) sz - , pureUniformRFullBench (Proxy :: Proxy Int) sz - , pureUniformRFullBench (Proxy :: Proxy Char) sz - , pureUniformRFullBench (Proxy :: Proxy Bool) sz - , pureUniformRFullBench (Proxy :: Proxy CChar) sz - , pureUniformRFullBench (Proxy :: Proxy CSChar) sz - , pureUniformRFullBench (Proxy :: Proxy CUChar) sz - , pureUniformRFullBench (Proxy :: Proxy CShort) sz - , pureUniformRFullBench (Proxy :: Proxy CUShort) sz - , pureUniformRFullBench (Proxy :: Proxy CInt) sz - , pureUniformRFullBench (Proxy :: Proxy CUInt) sz - , pureUniformRFullBench (Proxy :: Proxy CLong) sz - , pureUniformRFullBench (Proxy :: Proxy CULong) sz - , pureUniformRFullBench (Proxy :: Proxy CPtrdiff) sz - , pureUniformRFullBench (Proxy :: Proxy CSize) sz - , pureUniformRFullBench (Proxy :: Proxy CWchar) sz - , pureUniformRFullBench (Proxy :: Proxy CSigAtomic) sz - , pureUniformRFullBench (Proxy :: Proxy CLLong) sz - , pureUniformRFullBench (Proxy :: Proxy CULLong) sz - , pureUniformRFullBench (Proxy :: Proxy CIntPtr) sz - , pureUniformRFullBench (Proxy :: Proxy CUIntPtr) sz - , pureUniformRFullBench (Proxy :: Proxy CIntMax) sz - , pureUniformRFullBench (Proxy :: Proxy CUIntMax) sz - ] - , bgroup "excludeMax" - [ pureUniformRExcludeMaxBench (Proxy :: Proxy Word8) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Word16) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Word32) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Word64) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Word) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Int8) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Int16) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Int32) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Int64) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Int) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Char) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy Bool) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CChar) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CSChar) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CUChar) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CShort) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CUShort) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CInt) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CUInt) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CLong) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CULong) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CPtrdiff) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CSize) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CWchar) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CSigAtomic) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CLLong) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CULLong) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CIntPtr) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CUIntPtr) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CIntMax) sz - , pureUniformRExcludeMaxBench (Proxy :: Proxy CUIntMax) sz - ] - , bgroup "includeHalf" - [ pureUniformRIncludeHalfBench (Proxy :: Proxy Word8) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Word16) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Word32) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Word64) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Word) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Int8) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Int16) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Int32) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Int64) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy Int) sz - , pureUniformRIncludeHalfEnumBench (Proxy :: Proxy Char) sz - , pureUniformRIncludeHalfEnumBench (Proxy :: Proxy Bool) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CChar) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CSChar) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CUChar) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CShort) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CUShort) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CInt) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CUInt) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CLong) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CULong) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CPtrdiff) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CSize) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CWchar) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CSigAtomic) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CLLong) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CULLong) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CIntPtr) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CUIntPtr) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CIntMax) sz - , pureUniformRIncludeHalfBench (Proxy :: Proxy CUIntMax) sz - ] - , bgroup "unbounded" - [ pureUniformRBench (Proxy :: Proxy Float) (1.23e-4, 5.67e8) sz - , pureUniformRBench (Proxy :: Proxy Double) (1.23e-4, 5.67e8) sz - , let !i = (10 :: Integer) ^ (100 :: Integer) - !range = (-i - 1, i + 1) - in pureUniformRBench (Proxy :: Proxy Integer) range sz - , let !n = (10 :: Natural) ^ (100 :: Natural) - !range = (1, n - 1) - in pureUniformRBench (Proxy :: Proxy Natural) range sz - ] - , bgroup "floating" - [ -#if MIN_VERSION_primitive(0,7,1) - bgroup "IO" - [ bgroup "Float" - [ env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> - bench "uniformRM" $ - nfIO (runStateGenT gen (fillMutablePrimArrayM (uniformRM (0 :: Float, 1.1)) ma)) - , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> - bench "uniformFloat01M" $ - nfIO (runStateGenT gen (fillMutablePrimArrayM uniformFloat01M ma)) - , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> - bench "uniformFloatPositive01M" $ - nfIO (runStateGenT gen (fillMutablePrimArrayM uniformFloatPositive01M ma)) - ] - , bgroup "Double" - [ env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> - bench "uniformRM" $ - nfIO (runStateGenT gen (fillMutablePrimArrayM (uniformRM (0 :: Double, 1.1)) ma)) - , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> - bench "uniformDouble01M" $ - nfIO (runStateGenT gen (fillMutablePrimArrayM uniformDouble01M ma)) - , env ((,) <$> getStdGen <*> newAlignedPinnedPrimArray sz) $ \ ~(gen, ma) -> - bench "uniformDoublePositive01M" $ - nfIO (runStateGenT gen (fillMutablePrimArrayM uniformDoublePositive01M ma)) - ] + , 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) ] - , -#endif - bgroup "State" - [ bgroup "Float" - [ env getStdGen $ - bench "uniformRM" . nf (`runStateGen` (replicateM_ sz . uniformRM (0.1 :: Float, 1.1))) - , env getStdGen $ - bench "uniformFloat01M" . nf (`runStateGen` (replicateM_ sz . uniformFloat01M)) - , env getStdGen $ - bench "uniformFloatPositive01M" . - nf (`runStateGen` (replicateM_ sz . uniformFloatPositive01M)) - ] - , bgroup "Double" - [ env getStdGen $ - bench "uniformRM" . nf (`runStateGen` (replicateM_ sz . uniformRM (0.1 :: Double, 1.1))) - , env getStdGen $ - bench "uniformDouble01M" . nf (`runStateGen` (replicateM_ sz . uniformDouble01M)) - , env getStdGen $ - bench "uniformDoublePositive01M" . - nf (`runStateGen` (replicateM_ sz . uniformDoublePositive01M)) - ] + , bgroup + "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 "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 + "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 ] - ] - ] - , 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 (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 + 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 + 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 + 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 + in pureUniformRBench px range {-# INLINE pureUniformRIncludeHalfBench #-} pureUniformRIncludeHalfEnumBench :: - forall a. (Typeable a, UniformRange a, Bounded a, Enum a) - => Proxy a - -> Int - -> Benchmark + 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 + in pureUniformRBench px range {-# INLINE pureUniformRIncludeHalfEnumBench #-} pureUniformRBench :: - forall a. (Typeable a, UniformRange a) - => Proxy a - -> (a, a) - -> Int - -> Benchmark + 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 + 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 @@ -389,7 +424,6 @@ fillMutablePrimArrayM f ma g = do unsafeFreezePrimArray ma #endif - naiveShuffleListM :: StatefulGen g m => [a] -> g -> m [a] naiveShuffleListM xs gen = do is <- uniformListM n gen diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..6a9d7394 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,16 @@ +indentation: 2 +function-arrows: trailing +comma-style: leading +import-export-style: diff-friendly +indent-wheres: true +record-brace-space: true +newlines-between-decls: 1 +haddock-style: single-line +haddock-style-module: +let-style: auto +in-style: right-align +unicode: never +respectful: false +fixities: [] +single-constraint-parens: never +column-limit: 100 diff --git a/random.cabal b/random.cabal index e3365518..627fc0f6 100644 --- a/random.cabal +++ b/random.cabal @@ -72,10 +72,10 @@ tested-with: GHC == 8.0.2 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 - , GHC == 9.6.6 + , GHC == 9.6.7 , GHC == 9.8.4 - , GHC == 9.10.1 - , GHC == 9.12.1 + , GHC == 9.10.2 + , GHC == 9.12.2 source-repository head type: git diff --git a/scripts/fourmolize.sh b/scripts/fourmolize.sh new file mode 100755 index 00000000..71f7620b --- /dev/null +++ b/scripts/fourmolize.sh @@ -0,0 +1,22 @@ +#!/usr/bin/env bash + +set -euo pipefail + +if [[ $# -gt 0 ]]; then + case "$1" in + --changes) + # Run fourmolu on changes compared to `master`. + git diff --diff-filter=MA --name-only origin/master HEAD -- '*.hs' + ;; + *) + echo "Invalid option: $1" >&2 + exit 1 + ;; + esac +else + git ls-files -- '*.hs' +fi \ + | { grep -v Setup.hs || true; } \ + | xargs -r fourmolu -m inplace + +git diff --exit-code diff --git a/src/System/Random.hs b/src/System/Random.hs index c9f474e0..2de6bf2f 100644 --- a/src/System/Random.hs +++ b/src/System/Random.hs @@ -12,8 +12,7 @@ -- Stability : stable -- -- This library deals with the common task of pseudo-random number generation. -module System.Random - ( +module System.Random ( -- * Introduction -- $introduction @@ -22,82 +21,89 @@ module System.Random -- * Pure number generator interface -- $interfaces - RandomGen - ( split - , genWord8 - , genWord16 - , genWord32 - , genWord64 - , genWord32R - , genWord64R - , unsafeUniformFillMutableByteArray - ) - , SplitGen (splitGen) - , uniform - , uniformR - , Random(..) - , Uniform - , UniformRange - , Finite + RandomGen ( + split, + genWord8, + genWord16, + genWord32, + genWord64, + genWord32R, + genWord64R, + unsafeUniformFillMutableByteArray + ), + SplitGen (splitGen), + uniform, + uniformR, + Random (..), + Uniform, + UniformRange, + Finite, + -- ** Seed - , module System.Random.Seed + module System.Random.Seed, + -- * Generators for sequences of pseudo-random bytes + -- ** Lists - , uniforms - , uniformRs - , uniformList - , uniformListR - , uniformShuffleList + uniforms, + uniformRs, + uniformList, + uniformListR, + uniformShuffleList, + -- ** Bytes - , uniformByteArray - , uniformByteString - , uniformShortByteString - , uniformFillMutableByteArray + uniformByteArray, + uniformByteString, + uniformShortByteString, + uniformFillMutableByteArray, + -- *** Deprecated - , genByteString - , genShortByteString + genByteString, + genShortByteString, -- ** Standard pseudo-random number generator - , StdGen - , mkStdGen - , mkStdGen64 - , initStdGen + StdGen, + mkStdGen, + mkStdGen64, + initStdGen, -- ** Global standard pseudo-random number generator -- $globalstdgen - , getStdRandom - , getStdGen - , setStdGen - , newStdGen - , randomIO - , randomRIO + getStdRandom, + getStdGen, + setStdGen, + newStdGen, + randomIO, + randomRIO, -- * Compatibility and reproducibility + -- ** Backwards compatibility and deprecations - , genRange - , next + genRange, + next, -- $deprecations -- ** Reproducibility -- $reproducibility -- * Notes for pseudo-random number generator implementors + -- ** How to implement 'RandomGen' -- $implementrandomgen -- * References -- $references - ) where +) where import Control.Arrow import Control.Monad.IO.Class -import Control.Monad.State.Strict import Control.Monad.ST (ST) -import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Control.Monad.State.Strict +import Data.Array.Byte (ByteArray (..), MutableByteArray (..)) import Data.ByteString (ByteString) -import Data.ByteString.Short.Internal (ShortByteString(..)) -import Data.Int +import Data.ByteString.Short.Internal (ShortByteString (..)) import Data.IORef +import Data.Int import Data.Word import Foreign.C.Types import GHC.Exts @@ -119,7 +125,7 @@ import qualified System.Random.SplitMix as SM -- implementation provided by the -- package. -- Programmers may, of course, supply their own instances of 'RandomGen'. --- + -- $usagepure -- -- In pure code, use 'uniform' and 'uniformR' to generate pseudo-random values @@ -166,7 +172,6 @@ import qualified System.Random.SplitMix as SM -- -- ['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. @@ -377,17 +382,17 @@ uniformShortByteString n g = -- -- @since 1.3.0 uniformFillMutableByteArray :: - RandomGen g - => MutableByteArray s - -- ^ Mutable array to fill with random bytes - -> Int - -- ^ Offset into a mutable array from the beginning in number of bytes. Offset will be + 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 + Int -> + -- | Number of randomly generated bytes to write into the array. This number will be -- clamped between 0 and the total size of the array without the offset. - -> g - -> ST s g + Int -> + g -> + ST s g uniformFillMutableByteArray mba i0 n g = do !sz <- getSizeOfMutableByteArray mba let !offset = max 0 (min sz i0) @@ -406,7 +411,6 @@ uniformFillMutableByteArray mba i0 n g = do -- -- @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 @@ -448,7 +452,7 @@ class Random a where -- -- @since 1.0.0 {-# INLINE random #-} - random :: RandomGen g => g -> (a, g) + random :: RandomGen g => g -> (a, g) default random :: (RandomGen g, Uniform a) => g -> (a, g) random g = runStateGen g uniformM @@ -457,7 +461,7 @@ class Random a where -- -- @since 1.0.0 {-# INLINE randomRs #-} - randomRs :: RandomGen g => (a,a) -> g -> [a] + 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 @@ -465,9 +469,8 @@ class Random a where -- -- @since 1.0.0 {-# INLINE randoms #-} - randoms :: RandomGen g => g -> [a] - randoms g = build (\cons _nil -> buildRandoms cons random g) - + randoms :: RandomGen g => g -> [a] + randoms g = build (\cons _nil -> buildRandoms cons random g) -- | Produce an infinite list-equivalent of pseudo-random values. -- @@ -477,61 +480,93 @@ class Random a where -- >>> let pureGen = mkStdGen 137 -- >>> (take 4 . buildRandoms (:) random $ pureGen) :: [Int] -- [7879794327570578227,6883935014316540929,-1519291874655152001,2353271688382626589] --- {-# INLINE buildRandoms #-} -buildRandoms :: RandomGen g - => (a -> as -> as) -- ^ E.g. @(:)@ but subject to fusion - -> (g -> (a,g)) -- ^ E.g. 'random' - -> g -- ^ A 'RandomGen' instance - -> as +buildRandoms :: + -- | 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 + 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)) @@ -540,28 +575,31 @@ instance Random CDouble where {-# 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. -- @@ -569,90 +607,110 @@ instance Random Float where 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)) + 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)) + 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)) + 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 + 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)) + 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 + 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)) +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 + 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)) +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 + random = + runState $ + (,,,,,,) + <$> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random + <*> state random {-# INLINE random #-} ------------------------------------------------------------------------------- @@ -684,7 +742,6 @@ instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) -- 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' -- @@ -729,8 +786,8 @@ newStdGen = liftIO $ atomicModifyIORef' theStdGen splitGen -- @since 1.0.0 getStdRandom :: MonadIO m => (StdGen -> (a, StdGen)) -> m a getStdRandom f = liftIO $ atomicModifyIORef' theStdGen (swap . f) - where swap (v, g) = (g, v) - + where + swap (v, g) = (g, v) -- | A variant of 'System.Random.Stateful.randomRM' that uses the global -- pseudo-random number generator 'System.Random.Stateful.globalStdGen' @@ -866,7 +923,7 @@ randomIO = getStdRandom random -- genRange _ = (1, 2147483562) -- split _ = error "Not implemented" -- :} --- + -- $deprecations -- -- Version 1.2 mostly maintains backwards compatibility with version 1.1. This @@ -892,7 +949,7 @@ randomIO = getStdRandom random -- -- 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, @@ -901,7 +958,7 @@ randomIO = getStdRandom random -- -- * 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 diff --git a/src/System/Random/Array.hs b/src/System/Random/Array.hs index 046bbf94..89e109f8 100644 --- a/src/System/Random/Array.hs +++ b/src/System/Random/Array.hs @@ -3,52 +3,54 @@ {-# 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 +module System.Random.Array ( + -- * Helper array functionality + ioToST, + wordSizeInBits, + + -- ** MutableByteArray + newMutableByteArray, + newPinnedMutableByteArray, + freezeMutableByteArray, + writeWord8, + writeWord64LE, + writeByteSliceWord64LE, + indexWord8, + indexWord64LE, + indexByteSliceWord64LE, + sizeOfByteArray, + shortByteStringToByteArray, + byteArrayToShortByteString, + getSizeOfMutableByteArray, + shortByteStringToByteString, + -- ** MutableArray - , Array (..) - , MutableArray (..) - , newMutableArray - , freezeMutableArray - , writeArray - , shuffleListM - , shuffleListST - ) where - -import Control.Monad.Trans (lift, MonadTrans) + Array (..), + MutableArray (..), + newMutableArray, + freezeMutableArray, + writeArray, + shuffleListM, + shuffleListST, +) where + import Control.Monad (when) import Control.Monad.ST -import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Control.Monad.Trans (MonadTrans, lift) +import Data.Array.Byte (ByteArray (..), MutableByteArray (..)) import Data.Bits -import Data.ByteString.Short.Internal (ShortByteString(SBS)) +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.IO (IO (..)) +import GHC.ST (ST (..)) import GHC.Word #if __GLASGOW_HASKELL__ >= 802 import Data.ByteString.Internal (ByteString(PS)) @@ -114,17 +116,19 @@ writeByteSliceWord64LE mba fromByteIx toByteIx = go fromByteIx {-# INLINE writeByteSliceWord64LE #-} indexWord8 :: - ByteArray - -> Int -- ^ Offset into immutable byte array in number of bytes - -> Word8 + 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 - -> Int -- ^ Offset into immutable byte array in number of bytes - -> Word64 + 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 @@ -138,10 +142,12 @@ indexWord64LE (ByteArray ba#) (I# i#) {-# INLINE indexWord64LE #-} indexByteSliceWord64LE :: - ByteArray - -> Int -- ^ Starting offset in number of bytes - -> Int -- ^ Ending offset in number of bytes - -> Word64 + 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 @@ -157,10 +163,12 @@ indexByteSliceWord64LE ba fromByteIx toByteIx = goWord8 fromByteIx 0 -- also must fallback to writing one byte a time. Such fallback results in about 3 times -- slow down, which is not the end of the world. writeWord64LE :: - MutableByteArray s - -> Int -- ^ Offset into mutable byte array in number of bytes - -> Word64 -- ^ 8 bytes that will be written into the supplied array - -> ST s () + 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 @@ -176,12 +184,13 @@ writeWord64LE (MutableByteArray mba#) (I# i#) w64@(W64# w64#) {-# INLINE writeWord64LE #-} getSizeOfMutableByteArray :: MutableByteArray s -> ST s Int -getSizeOfMutableByteArray (MutableByteArray mba#) = #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 #-} @@ -197,10 +206,10 @@ byteArrayToShortByteString (ByteArray ba#) = SBS ba# -- | Convert a ShortByteString to ByteString by casting, whenever memory is pinned, -- otherwise make a copy into a new pinned ByteString shortByteStringToByteString :: ShortByteString -> ByteString -shortByteStringToByteString ba = #if __GLASGOW_HASKELL__ < 802 - SBS.fromShort ba +shortByteStringToByteString ba = SBS.fromShort ba #else +shortByteStringToByteString ba = let !(SBS ba#) = ba in if isTrue# (isByteArrayPinned# ba#) then pinnedByteArrayToByteString ba# @@ -266,7 +275,7 @@ 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 + go i (x : xs) = writeArray ma i x >> go (i + 1) xs {-# INLINE fillMutableArrayFromList #-} readListFromMutableArray :: MutableArray s a -> ST s [a] @@ -274,13 +283,12 @@ 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 + | 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: -- -- @ @@ -293,13 +301,13 @@ readListFromMutableArray ma = go (len - 1) [] -- , (0, 1) -- ] -- @ -genSwapIndices - :: Monad m - => (Word -> m Word) - -- ^ Action that generates a Word in the supplied range. - -> Word - -- ^ Number of index swaps to generate. - -> m [Int] +genSwapIndices :: + 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 @@ -310,7 +318,6 @@ genSwapIndices genWordR n = go 1 [] 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 @@ -319,17 +326,17 @@ 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 + 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 + -- 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 + readListFromMutableArray ma where len = length ls {-# INLINE shuffleListM #-} @@ -345,18 +352,18 @@ shuffleListST :: (Monad (t (ST s)), MonadTrans t) => (Word -> t (ST s) Word) -> 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 + 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 #-} diff --git a/src/System/Random/GFinite.hs b/src/System/Random/GFinite.hs index d179a0ba..ec9acd5a 100644 --- a/src/System/Random/GFinite.hs +++ b/src/System/Random/GFinite.hs @@ -1,21 +1,20 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : System.Random.GFinite -- Copyright : (c) Andrew Lelechenko 2020 -- License : BSD-style (see the file LICENSE in the 'random' repository) -- Maintainer : libraries@haskell.org --- -module System.Random.GFinite - ( Cardinality(..) - , Finite(..) - , GFinite(..) - ) where +module System.Random.GFinite ( + Cardinality (..), + Finite (..), + GFinite (..), +) where import Data.Bits import Data.Int @@ -26,8 +25,9 @@ import GHC.Generics -- | Cardinality of a set. data Cardinality - = Shift !Int -- ^ Shift n is equivalent to Card (bit n) - | Card !Integer + = -- | 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'. @@ -36,14 +36,14 @@ instance Enum Cardinality where 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)) + 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 1 = Shift 0 -- () + fromInteger 2 = Shift 1 -- Bool fromInteger n = Card n {-# INLINE fromInteger #-} @@ -51,12 +51,12 @@ instance Num Cardinality where {-# 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) + 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 + abs = Card . abs . toInteger signum = Card . signum . toInteger negate = Card . negate . toInteger @@ -67,12 +67,12 @@ instance Real Cardinality where instance Integral Cardinality where toInteger = \case Shift n -> bit n - Card n -> 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) + Card n -> let (q, r) = x `quotRem` n in (Card q, Card r) where x = toInteger x' {-# INLINE quotRem #-} @@ -87,7 +87,6 @@ instance Integral Cardinality where -- >>> 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 @@ -155,8 +154,8 @@ instance (GFinite a, GFinite b) => GFinite (a :+: b) where {-# INLINE toGFinite #-} fromGFinite = \case - L1 x -> fromGFinite x - R1 x -> fromGFinite x + toInteger (gcardinality (proxy# :: Proxy# a)) + L1 x -> fromGFinite x + R1 x -> fromGFinite x + toInteger (gcardinality (proxy# :: Proxy# a)) {-# INLINE fromGFinite #-} instance (GFinite a, GFinite b) => GFinite (a :*: b) where @@ -175,8 +174,11 @@ instance (GFinite a, GFinite b) => GFinite (a :*: b) where {-# INLINE fromGFinite #-} instance Finite Void + instance Finite () + instance Finite Bool + instance Finite Ordering instance Finite Char where @@ -192,13 +194,13 @@ 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 + | 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 + | isSigned x = toInteger x + bit (finiteBitSize x - 1) + | otherwise = toInteger x instance Finite Word8 where cardinality = cardinalityDef @@ -207,6 +209,7 @@ instance Finite Word8 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Word16 where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -214,6 +217,7 @@ instance Finite Word16 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Word32 where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -221,6 +225,7 @@ instance Finite Word32 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Word64 where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -228,6 +233,7 @@ instance Finite Word64 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Word where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -235,6 +241,7 @@ instance Finite Word where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Int8 where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -242,6 +249,7 @@ instance Finite Int8 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Int16 where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -249,6 +257,7 @@ instance Finite Int16 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Int32 where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -256,6 +265,7 @@ instance Finite Int32 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Int64 where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -263,6 +273,7 @@ instance Finite Int64 where {-# INLINE toFinite #-} fromFinite = fromFiniteDef {-# INLINE fromFinite #-} + instance Finite Int where cardinality = cardinalityDef {-# INLINE cardinality #-} @@ -272,10 +283,19 @@ instance Finite Int where {-# 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) + +instance + (Finite a, Finite b, Finite c, Finite d, Finite e, Finite f, Finite g) => + Finite (a, b, c, d, e, f, g) diff --git a/src/System/Random/Internal.hs b/src/System/Random/Internal.hs index 422c2ef8..a3f4c4a6 100644 --- a/src/System/Random/Internal.hs +++ b/src/System/Random/Internal.hs @@ -10,8 +10,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UnliftedFFITypes #-} {-# OPTIONS_HADDOCK hide, not-home #-} @@ -24,102 +24,105 @@ -- 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(..) +module System.Random.Internal ( + -- * Pure and monadic pseudo-random number generator interfaces + RandomGen (..), + SplitGen (..), + Seed (..), + -- * Stateful - , StatefulGen(..) - , FrozenGen(..) - , ThawedGen(..) - , splitGenM - , splitMutableGenM + StatefulGen (..), + FrozenGen (..), + ThawedGen (..), + splitGenM, + splitMutableGenM, -- ** Standard pseudo-random number generator - , StdGen(..) - , mkStdGen - , mkStdGen64 - , theStdGen + StdGen (..), + mkStdGen, + mkStdGen64, + theStdGen, -- * Monadic adapters for pure pseudo-random number generators + -- ** Pure adapter - , StateGen(..) - , StateGenM(..) - , runStateGen - , runStateGen_ - , runStateGenT - , runStateGenT_ - , runStateGenST - , runStateGenST_ + StateGen (..), + StateGenM (..), + runStateGen, + runStateGen_, + runStateGenT, + runStateGenT_, + runStateGenST, + runStateGenST_, -- * Pseudo-random values of various types - , Uniform(..) - , uniformViaFiniteM - , UniformRange(..) - , uniformWordR - , uniformDouble01M - , uniformDoublePositive01M - , uniformFloat01M - , uniformFloatPositive01M - , uniformEnumM - , uniformEnumRM - , uniformListM - , uniformListRM - , isInRangeOrd - , isInRangeEnum - , scaleFloating + Uniform (..), + uniformViaFiniteM, + UniformRange (..), + uniformWordR, + uniformDouble01M, + uniformDoublePositive01M, + uniformFloat01M, + uniformFloatPositive01M, + uniformEnumM, + uniformEnumRM, + uniformListM, + uniformListRM, + isInRangeOrd, + isInRangeEnum, + scaleFloating, -- * Generators for sequences of pseudo-random bytes - , uniformShortByteStringM - , uniformByteArray - , fillByteArrayST - , genShortByteStringIO - , genShortByteStringST - , defaultUnsafeFillMutableByteArrayT - , defaultUnsafeUniformFillMutableByteArray + uniformShortByteStringM, + uniformByteArray, + fillByteArrayST, + genShortByteStringIO, + genShortByteStringST, + defaultUnsafeFillMutableByteArrayT, + defaultUnsafeUniformFillMutableByteArray, + -- ** Helpers for dealing with MutableByteArray - , newMutableByteArray - , newPinnedMutableByteArray - , freezeMutableByteArray - , writeWord8 - , writeWord64LE - , indexWord8 - , indexWord64LE - , indexByteSliceWord64LE - , sizeOfByteArray - , shortByteStringToByteArray - , byteArrayToShortByteString - ) where + newMutableByteArray, + newPinnedMutableByteArray, + freezeMutableByteArray, + writeWord8, + writeWord64LE, + indexWord8, + indexWord64LE, + indexByteSliceWord64LE, + sizeOfByteArray, + shortByteStringToByteArray, + byteArrayToShortByteString, +) where import Control.Arrow import Control.DeepSeq (NFData) import Control.Monad (replicateM, when, (>=>)) import Control.Monad.Cont (ContT, runContT) import Control.Monad.ST -import Control.Monad.State.Strict (MonadState(..), State, StateT(..), execStateT, runState) -import Control.Monad.Trans (lift, MonadTrans) +import Control.Monad.State.Strict (MonadState (..), State, StateT (..), execStateT, runState) +import Control.Monad.Trans (MonadTrans, lift) import Control.Monad.Trans.Identity (IdentityT (runIdentityT)) -import Data.Array.Byte (ByteArray(..), MutableByteArray(..)) +import Data.Array.Byte (ByteArray (..), MutableByteArray (..)) import Data.Bits -import Data.ByteString.Short.Internal (ShortByteString(SBS)) +import Data.ByteString.Short.Internal (ShortByteString (SBS)) import Data.IORef (IORef, newIORef) import Data.Int +import Data.Kind import Data.Word import Foreign.C.Types import Foreign.Storable (Storable) import GHC.Exts import GHC.Generics -import GHC.IO (IO(..)) -import GHC.ST (ST(..)) +import GHC.IO (IO (..)) +import GHC.ST (ST (..)) import GHC.Word import Numeric.Natural (Natural) import System.IO.Unsafe (unsafePerformIO) import System.Random.Array -import System.Random.GFinite (Cardinality(..), GFinite(..), Finite) +import System.Random.GFinite (Cardinality (..), Finite, GFinite (..)) import qualified System.Random.SplitMix as SM import qualified System.Random.SplitMix32 as SM32 -import Data.Kind -- | This is a binary form of pseudo-random number generator's state. It is designed to be -- safe and easy to use for input/output operations like restoring from file, transmitting @@ -134,16 +137,18 @@ import Data.Kind newtype Seed g = Seed ByteArray deriving (Eq, Ord, Show) - -- | 'RandomGen' is an interface to pure pseudo-random number generators. -- -- 'StdGen' is the standard 'RandomGen' instance provided by this library. -- -- @since 1.0.0 {-# DEPRECATED next "No longer used" #-} + {-# DEPRECATED genRange "No longer used" #-} + class RandomGen g where - {-# MINIMAL (genWord32|genWord64|(next,genRange)) #-} + {-# 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 @@ -232,17 +237,17 @@ class RandomGen g where -- -- @since 1.3.0 unsafeUniformFillMutableByteArray :: - MutableByteArray s - -- ^ Mutable array to fill with random bytes - -> Int - -- ^ Offset into a mutable array from the beginning in number of bytes. Offset must + -- | 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 + Int -> + -- | Number of randomly generated bytes to write into the array. Number of bytes -- must be non-negative and less then the total size of the array, minus the -- offset. This also will be checked. - -> g - -> ST s g + Int -> + g -> + ST s g unsafeUniformFillMutableByteArray = defaultUnsafeUniformFillMutableByteArray {-# INLINE unsafeUniformFillMutableByteArray #-} @@ -273,6 +278,7 @@ class RandomGen g where split = splitGen {-# DEPRECATED genShortByteString "In favor of `System.Random.uniformShortByteString`" #-} + {-# DEPRECATED split "In favor of `splitGen`" #-} -- | Pseudo-random generators that can be split into two separate and independent @@ -285,7 +291,6 @@ class RandomGen g where -- -- @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 @@ -298,7 +303,8 @@ class RandomGen g => SplitGen g where -- -- @since 1.2.0 class Monad m => StatefulGen g m where - {-# MINIMAL uniformWord32|uniformWord64 #-} + {-# MINIMAL uniformWord32 | uniformWord64 #-} + -- | @uniformWord32R upperBound g@ generates a 'Word32' that is uniformly -- distributed over the range @[0, upperBound]@. -- @@ -364,10 +370,13 @@ class Monad m => StatefulGen g m where -- -- @since 1.3.0 uniformByteArrayM :: - Bool -- ^ Should `ByteArray` be allocated as pinned memory or not - -> Int -- ^ Size of the newly created `ByteArray` in number of bytes. - -> g -- ^ Generator to use for filling in the newly created `ByteArray` - -> m ByteArray + -- | 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 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) @@ -380,8 +389,8 @@ class Monad m => StatefulGen g m where uniformShortByteString :: Int -> g -> m ShortByteString uniformShortByteString = uniformShortByteStringM {-# INLINE uniformShortByteString #-} -{-# DEPRECATED uniformShortByteString "In favor of `uniformShortByteStringM`" #-} +{-# 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. @@ -411,7 +420,8 @@ class Monad m => StatefulGen g m where -- -- @since 1.2.0 class StatefulGen (MutableGen f m) m => FrozenGen f m where - {-# MINIMAL (modifyGen|(freezeGen,overwriteGen)) #-} + {-# MINIMAL (modifyGen | (freezeGen, overwriteGen)) #-} + -- | Represents the state of the pseudo-random number generator for use with -- 'thawGen' and 'freezeGen'. -- @@ -483,11 +493,14 @@ splitMutableGenM = splitGenM >=> thawGen -- -- @since 1.3.0 uniformByteArray :: - RandomGen g - => Bool -- ^ Should byte array be allocated in pinned or unpinned memory. - -> Int -- ^ Number of bytes to generate - -> g -- ^ Pure pseudo-random numer generator - -> (ByteArray, g) + 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 @@ -507,20 +520,21 @@ uniformByteArray isPinned n0 g = 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 + 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) () + (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 @@ -542,51 +556,60 @@ defaultUnsafeFillMutableByteArrayT mba offset n gen64 = do -- 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) () #-} +{-# SPECIALIZE defaultUnsafeFillMutableByteArrayT :: + MutableByteArray s -> + Int -> + Int -> + IdentityT (ST s) Word64 -> + IdentityT (ST s) () + #-} +{-# SPECIALIZE defaultUnsafeFillMutableByteArrayT :: + MutableByteArray s -> + Int -> + Int -> + StateT g (ST s) Word64 -> + StateT g (ST s) () + #-} -- | Efficiently generates a sequence of pseudo-random bytes in a platform -- independent manner. -- -- @since 1.2.0 defaultUnsafeUniformFillMutableByteArray :: - RandomGen g - => MutableByteArray s - -> Int -- ^ Starting offset - -> Int -- ^ Number of random bytes to write into the array - -> g -- ^ ST action that can generate 8 random bytes at a time - -> ST s g + 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) + 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" #-} +{-# DEPRECATED + genShortByteStringST + "In favor of `fillByteArrayST`, since `uniformShortByteString`, which it was used for, was also deprecated" + #-} -- | Efficiently fills in a new `ShortByteString` in a platform independent manner. -- -- @since 1.2.0 genShortByteStringIO :: - Int -- ^ Number of bytes to generate - -> IO Word64 -- ^ IO action that can generate 8 random bytes at a time - -> IO ShortByteString + -- | 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`" #-} @@ -609,7 +632,7 @@ data StateGenM g = StateGenM -- stateful generator `StateGenM` -- -- @since 1.2.0 -newtype StateGen g = StateGen { unStateGen :: g } +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 @@ -700,7 +723,7 @@ runStateGenT_ g = fmap fst . runStateGenT g -- pseudo-random number generator. -- -- @since 1.2.0 -runStateGenST :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> (a, g) +runStateGenST :: RandomGen g => g -> (forall s. StateGenM g -> StateT g (ST s) a) -> (a, g) runStateGenST g action = runST $ runStateGenT g action {-# INLINE runStateGenST #-} @@ -709,11 +732,10 @@ runStateGenST g action = runST $ runStateGenT g action -- resulting generator. -- -- @since 1.2.1 -runStateGenST_ :: RandomGen g => g -> (forall s . StateGenM g -> StateT g (ST s) a) -> a +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__ @@ -729,7 +751,6 @@ 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__ @@ -746,7 +767,7 @@ uniformListRM n range gen = replicateM n (uniformRM range gen) {-# INLINE uniformListRM #-} -- | The standard pseudo-random number generator. -newtype StdGen = StdGen { unStdGen :: SM.SMGen } +newtype StdGen = StdGen {unStdGen :: SM.SMGen} deriving (Show, RandomGen, SplitGen, NFData) instance Eq StdGen where @@ -759,6 +780,7 @@ instance RandomGen SM.SMGen where {-# 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: @@ -801,7 +823,6 @@ 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. -- @@ -823,7 +844,6 @@ class Uniform a where -- -- @since 1.2.0 uniformM :: StatefulGen g m => g -> m a - default uniformM :: (StatefulGen g m, Generic a, GUniform (Rep a)) => g -> m a uniformM = fmap to . (`runContT` pure) . guniformM {-# INLINE uniformM #-} @@ -858,13 +878,14 @@ instance (GFinite f, GFinite g) => GUniform (f :+: g) where {-# 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 +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. @@ -879,7 +900,6 @@ finiteUniformM = fmap toGFinite . case gcardinality (proxy# :: Proxy# f) of -- >>> 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 #-} @@ -1021,6 +1041,7 @@ instance UniformRange Natural where instance Uniform Int8 where uniformM = fmap (fromIntegral :: Word8 -> Int8) . uniformWord8 {-# INLINE uniformM #-} + instance UniformRange Int8 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int8 -> Word8) fromIntegral {-# INLINE uniformRM #-} @@ -1029,6 +1050,7 @@ instance UniformRange Int8 where instance Uniform Int16 where uniformM = fmap (fromIntegral :: Word16 -> Int16) . uniformWord16 {-# INLINE uniformM #-} + instance UniformRange Int16 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int16 -> Word16) fromIntegral {-# INLINE uniformRM #-} @@ -1037,6 +1059,7 @@ instance UniformRange Int16 where instance Uniform Int32 where uniformM = fmap (fromIntegral :: Word32 -> Int32) . uniformWord32 {-# INLINE uniformM #-} + instance UniformRange Int32 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int32 -> Word32) fromIntegral {-# INLINE uniformRM #-} @@ -1045,6 +1068,7 @@ instance UniformRange Int32 where instance Uniform Int64 where uniformM = fmap (fromIntegral :: Word64 -> Int64) . uniformWord64 {-# INLINE uniformM #-} + instance UniformRange Int64 where uniformRM = signedBitmaskWithRejectionRM (fromIntegral :: Int64 -> Word64) fromIntegral {-# INLINE uniformRM #-} @@ -1053,9 +1077,9 @@ instance UniformRange Int64 where instance Uniform Int where uniformM | wordSizeInBits == 64 = - fmap (fromIntegral :: Word64 -> Int) . uniformWord64 + fmap (fromIntegral :: Word64 -> Int) . uniformWord64 | otherwise = - fmap (fromIntegral :: Word32 -> Int) . uniformWord32 + fmap (fromIntegral :: Word32 -> Int) . uniformWord32 {-# INLINE uniformM #-} instance UniformRange Int where @@ -1066,9 +1090,9 @@ instance UniformRange Int where instance Uniform Word where uniformM | wordSizeInBits == 64 = - fmap (fromIntegral :: Word64 -> Word) . uniformWord64 + fmap (fromIntegral :: Word64 -> Word) . uniformWord64 | otherwise = - fmap (fromIntegral :: Word32 -> Word) . uniformWord32 + fmap (fromIntegral :: Word32 -> Word) . uniformWord32 {-# INLINE uniformM #-} instance UniformRange Word where @@ -1080,22 +1104,23 @@ instance UniformRange Word where -- -- @since 1.3.0 uniformWordR :: - StatefulGen g m - => Word - -- ^ Maximum value to generate - -> g - -- ^ Stateful generator - -> m Word + 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) + fmap (fromIntegral :: Word64 -> Word) . uniformWord64R ((fromIntegral :: Word -> Word64) r) | otherwise = - fmap (fromIntegral :: Word32 -> Word) . uniformWord32R ((fromIntegral :: Word -> Word32) r) + 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 #-} @@ -1104,22 +1129,25 @@ instance UniformRange Word8 where instance Uniform Word16 where uniformM = uniformWord16 {-# INLINE uniformM #-} + instance UniformRange Word16 where uniformRM = unbiasedWordMult32RM {-# INLINE uniformRM #-} isInRange = isInRangeOrd instance Uniform Word32 where - uniformM = uniformWord32 + uniformM = uniformWord32 {-# INLINE uniformM #-} + instance UniformRange Word32 where uniformRM = unbiasedWordMult32RM {-# INLINE uniformRM #-} isInRange = isInRangeOrd instance Uniform Word64 where - uniformM = uniformWord64 + uniformM = uniformWord64 {-# INLINE uniformM #-} + instance UniformRange Word64 where uniformRM = unsignedBitmaskWithRejectionRM {-# INLINE uniformRM #-} @@ -1138,6 +1166,7 @@ instance UniformRange CBool where 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 #-} @@ -1146,6 +1175,7 @@ instance UniformRange CChar where 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 #-} @@ -1154,6 +1184,7 @@ instance UniformRange CSChar where 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 #-} @@ -1162,6 +1193,7 @@ instance UniformRange CUChar where 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 #-} @@ -1170,6 +1202,7 @@ instance UniformRange CShort where 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 #-} @@ -1178,6 +1211,7 @@ instance UniformRange CUShort where 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 #-} @@ -1186,6 +1220,7 @@ instance UniformRange CInt where 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 #-} @@ -1194,6 +1229,7 @@ instance UniformRange CUInt where 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 #-} @@ -1202,6 +1238,7 @@ instance UniformRange CLong where 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 #-} @@ -1210,6 +1247,7 @@ instance UniformRange CULong where 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 #-} @@ -1218,6 +1256,7 @@ instance UniformRange CPtrdiff where 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 #-} @@ -1226,6 +1265,7 @@ instance UniformRange CSize where 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 #-} @@ -1234,6 +1274,7 @@ instance UniformRange CWchar where 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 #-} @@ -1242,6 +1283,7 @@ instance UniformRange CSigAtomic where 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 #-} @@ -1250,6 +1292,7 @@ instance UniformRange CLLong where 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 #-} @@ -1258,6 +1301,7 @@ instance UniformRange CULLong where 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 #-} @@ -1266,6 +1310,7 @@ instance UniformRange CIntPtr where 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 #-} @@ -1274,6 +1319,7 @@ instance UniformRange CUIntPtr where 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 #-} @@ -1282,6 +1328,7 @@ instance UniformRange CIntMax where 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 #-} @@ -1324,6 +1371,7 @@ charToWord32 (C# c#) = W32# (wordToWord32# (int2Word# (ord# c#))) 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 @@ -1333,19 +1381,22 @@ instance UniformRange Char where 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 #-} + 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 + uniformRM (True, True) _g = return True + uniformRM _ g = uniformM g {-# INLINE uniformRM #-} isInRange = isInRangeOrd @@ -1358,17 +1409,17 @@ 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 + -- 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 + w64 <- uniformWord64 g + pure $! scaleFloating l h w64 {-# INLINE uniformRM #-} isInRange = isInRangeOrd @@ -1405,17 +1456,17 @@ 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 + -- 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 + w32 <- uniformWord32 g + pure $! scaleFloating l h w32 {-# INLINE uniformRM #-} isInRange = isInRangeOrd @@ -1424,25 +1475,28 @@ instance UniformRange Float where -- -- @since 1.3.0 scaleFloating :: - forall a w. (RealFloat a, Integral w, Bounded w, FiniteBits w) - => a - -- ^ Low - -> a - -- ^ High - -> w - -- ^ Uniformly distributed unsigned integral value that will be used for converting to a floating + 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 - -> a + 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 + 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 @@ -1502,32 +1556,32 @@ uniformEnumRM (l, h) g = toEnum <$> uniformRM (fromEnum l, fromEnum h) g 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) #-} - +{-# 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) + | 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. @@ -1556,7 +1610,7 @@ uniformIntegralM (l, h) gen = case l `compare` h of -- 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 :: forall a g m. (Bits a, Integral a, StatefulGen g m) => a -> g -> m a boundedExclusiveIntegralM s gen = go where n = integralWordSize s @@ -1606,8 +1660,8 @@ uniformIntegralWords n gen = go 0 n go !acc i | i == 0 = return acc | otherwise = do - (w :: Word) <- uniformM gen - go ((acc `shiftL` wordSizeInBits) .|. fromIntegral w) (i - 1) + (w :: Word) <- uniformM gen + go ((acc `shiftL` wordSizeInBits) .|. fromIntegral w) (i - 1) {-# INLINE uniformIntegralWords #-} -- | Uniformly generate an 'Integral' in an inclusive-inclusive range. @@ -1615,15 +1669,15 @@ uniformIntegralWords n gen = go 0 n -- 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 + | 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 + | otherwise = unbiasedWordMult32Exclusive (s + 1) g {-# INLINE unbiasedWordMult32 #-} -- | See [Lemire's paper](https://arxiv.org/pdf/1805.10941.pdf), @@ -1632,7 +1686,7 @@ unbiasedWordMult32 s g -- 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 :: forall g m. StatefulGen g m => Word32 -> g -> m Word32 unbiasedWordMult32Exclusive r g = go where t :: Word32 @@ -1649,10 +1703,11 @@ unbiasedWordMult32Exclusive r g = go -- | 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 + 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 @@ -1664,17 +1719,22 @@ unsignedBitmaskWithRejectionRM (bottom, top) gen -- overflow. It uses `unsignedBitmaskWithRejectionM`, therefore it requires functions that -- take the value to unsigned and back. signedBitmaskWithRejectionRM :: - forall a b g m. (Num a, Num b, Ord b, Ord a, FiniteBits a, StatefulGen g m, Uniform a) - => (b -> a) -- ^ Convert signed to unsigned. @a@ and @b@ must be of the same size. - -> (a -> b) -- ^ Convert unsigned to signed. @a@ and @b@ must be of the same size. - -> (b, b) -- ^ Range. - -> g -- ^ Generator. - -> m b + 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 = - (b +) . fromUnsigned <$> unsignedBitmaskWithRejectionM uniformM r gen - -- This works in all cases, see Appendix 1 at the end of the file. + -- 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 @@ -1682,7 +1742,6 @@ signedBitmaskWithRejectionRM toUnsigned fromUnsigned (bottom, top) gen 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 :: @@ -1719,35 +1778,59 @@ instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e) => Uniform (a, uniformM g = (,,,,) <$> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g <*> uniformM g {-# INLINE uniformM #-} -instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f) => - Uniform (a, b, c, d, e, f) where - uniformM g = (,,,,,) - <$> uniformM g - <*> uniformM g - <*> uniformM g - <*> uniformM g - <*> uniformM g - <*> uniformM g +instance + (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f) => + Uniform (a, b, c, d, e, f) + where + uniformM g = + (,,,,,) + <$> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g {-# INLINE uniformM #-} -instance (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f, Uniform g) => - Uniform (a, b, c, d, e, f, g) where - uniformM g = (,,,,,,) - <$> uniformM g - <*> uniformM g - <*> uniformM g - <*> uniformM g - <*> uniformM g - <*> uniformM g - <*> uniformM g +instance + (Uniform a, Uniform b, Uniform c, Uniform d, Uniform e, Uniform f, Uniform g) => + Uniform (a, b, c, d, e, f, g) + where + uniformM g = + (,,,,,,) + <$> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g + <*> uniformM g {-# INLINE uniformM #-} 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) + +instance + (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e) => + UniformRange (a, b, c, d, e) + +instance + (UniformRange a, UniformRange b, UniformRange c, UniformRange d, UniformRange e, UniformRange f) => + UniformRange (a, b, c, d, e, f) + +instance + ( UniformRange a + , UniformRange b + , UniformRange c + , UniformRange d + , UniformRange e + , UniformRange f + , UniformRange g + ) => + UniformRange (a, b, c, d, e, f, g) -- Appendix 1. -- diff --git a/src/System/Random/Seed.hs b/src/System/Random/Seed.hs index 0be3709e..3bbf877c 100644 --- a/src/System/Random/Seed.hs +++ b/src/System/Random/Seed.hs @@ -12,52 +12,51 @@ {-# 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 (..), -module System.Random.Seed - ( SeedGen(..) - , -- ** Seed - Seed - , seedSize - , seedSizeProxy - , mkSeed - , unSeed - , mkSeedFromByteString - , unSeedToByteString - , withSeed - , withSeedM - , withSeedFile - , seedGenTypeName - , nonEmptyToSeed - , nonEmptyFromSeed - ) where + -- ** 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.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.List.NonEmpty as NE (NonEmpty (..), nonEmpty, toList) import Data.Typeable import Data.Word import GHC.Exts (Proxy#, proxy#) -import GHC.TypeLits (Nat, KnownNat, natVal', type (<=)) +import GHC.TypeLits (KnownNat, Nat, natVal', type (<=)) import System.Random.Internal import qualified System.Random.SplitMix as SM import qualified System.Random.SplitMix32 as SM32 - -- | Interface for converting a pure pseudo-random number generator to and from non-empty -- sequence of bytes. Seeds are stored in Little-Endian order regardless of the platform -- it is being used on, which provides cross-platform compatibility, while providing @@ -125,9 +124,9 @@ class (KnownNat (SeedSize g), 1 <= SeedSize g, Typeable g) => SeedGen g where -- @ -- > fromSeed (toSeed gen) == gen -- @ - -- type SeedSize g :: Nat - {-# MINIMAL (fromSeed, toSeed)|(fromSeed64, toSeed64) #-} + + {-# MINIMAL (fromSeed, toSeed) | (fromSeed64, toSeed64) #-} -- | Convert from a binary representation to a pseudo-random number generator -- @@ -190,16 +189,16 @@ instance SeedGen SM32.SMGen where seed, gamma :: Word32 seed = fromIntegral (shiftR x 32) gamma = fromIntegral x - in SM32.seedSMGen seed gamma + 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 + 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) @@ -224,7 +223,8 @@ seedSizeProxy _px = seedSize @g 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: " + F.fail $ + "Unexpected number of bytes: " ++ show (sizeOfByteArray ba) ++ ". Exactly " ++ show (seedSize @g) @@ -263,7 +263,6 @@ withSeedM seed f = fmap toSeed <$> f (fromSeed seed) 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 @@ -282,7 +281,6 @@ unSeed (Seed ba) = ba 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. @@ -307,7 +305,7 @@ nonEmptyToSeed xs = Seed $ runST $ do defaultUnsafeFillMutableByteArrayT mba 0 n $ do get >>= \case [] -> pure 0 - w:ws -> w <$ put ws + w : ws -> w <$ put ws freezeMutableByteArray mba -- | Convert a `Seed` to a list of 64bit words. @@ -317,13 +315,15 @@ 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 + 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) diff --git a/src/System/Random/Stateful.hs b/src/System/Random/Stateful.hs index f1562db8..71e5e149 100644 --- a/src/System/Random/Stateful.hs +++ b/src/System/Random/Stateful.hs @@ -8,6 +8,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + -- | -- Module : System.Random.Stateful -- Copyright : (c) The University of Glasgow 2001 @@ -16,8 +17,7 @@ -- Stability : stable -- -- This library deals with the common task of pseudo-random number generation. -module System.Random.Stateful - ( +module System.Random.Stateful ( -- * Monadic Random Generator -- $introduction @@ -26,100 +26,108 @@ module System.Random.Stateful -- * Mutable pseudo-random number generator interfaces -- $interfaces - StatefulGen - ( uniformWord32R - , uniformWord64R - , uniformWord8 - , uniformWord16 - , uniformWord32 - , uniformWord64 - , uniformShortByteString - ) - , FrozenGen(..) - , ThawedGen(..) - , withMutableGen - , withMutableGen_ - , withSeedMutableGen - , withSeedMutableGen_ - , randomM - , randomRM - , splitGenM - , splitMutableGenM + StatefulGen ( + uniformWord32R, + uniformWord64R, + uniformWord8, + uniformWord16, + uniformWord32, + uniformWord64, + uniformShortByteString + ), + FrozenGen (..), + ThawedGen (..), + withMutableGen, + withMutableGen_, + withSeedMutableGen, + withSeedMutableGen_, + randomM, + randomRM, + splitGenM, + splitMutableGenM, -- ** Deprecated - , RandomGenM(..) + RandomGenM (..), -- * Monadic adapters for pure pseudo-random number generators #monadicadapters# -- $monadicadapters -- ** Pure adapter in 'MonadState' - , StateGen(..) - , StateGenM(..) - , runStateGen - , runStateGen_ - , runStateGenT - , runStateGenT_ - , runStateGenST - , runStateGenST_ + StateGen (..), + StateGenM (..), + runStateGen, + runStateGen_, + runStateGenT, + runStateGenT_, + runStateGenST, + runStateGenST_, + -- ** Mutable thread-safe adapter in 'IO' - , AtomicGen(..) - , AtomicGenM(..) - , newAtomicGenM - , applyAtomicGen - , globalStdGen + AtomicGen (..), + AtomicGenM (..), + newAtomicGenM, + applyAtomicGen, + globalStdGen, + -- ** Mutable adapter in 'IO' - , IOGen(..) - , IOGenM(..) - , newIOGenM - , applyIOGen + IOGen (..), + IOGenM (..), + newIOGenM, + applyIOGen, + -- ** Mutable adapter in 'ST' - , STGen(..) - , STGenM(..) - , newSTGenM - , applySTGen - , runSTGen - , runSTGen_ + STGen (..), + STGenM (..), + newSTGenM, + applySTGen, + runSTGen, + runSTGen_, + -- ** Mutable thread-safe adapter in 'STM' - , TGen(..) - , TGenM(..) - , newTGenM - , newTGenMIO - , applyTGen + TGen (..), + TGenM (..), + newTGenM, + newTGenMIO, + applyTGen, -- * Pseudo-random values of various types -- $uniform - , Uniform(..) - , uniformViaFiniteM - , UniformRange(..) - , isInRangeOrd - , isInRangeEnum + Uniform (..), + uniformViaFiniteM, + UniformRange (..), + isInRangeOrd, + isInRangeEnum, -- ** Lists - , uniformListM - , uniformListRM - , uniformShuffleListM + uniformListM, + uniformListRM, + uniformShuffleListM, -- ** Generators for sequences of pseudo-random bytes - , uniformByteArrayM - , uniformByteStringM - , uniformShortByteStringM + uniformByteArrayM, + uniformByteStringM, + uniformShortByteStringM, -- * Helper functions for createing instances + -- ** Sequences of bytes - , fillByteArrayST - , genShortByteStringIO - , genShortByteStringST - , defaultUnsafeUniformFillMutableByteArray + fillByteArrayST, + genShortByteStringIO, + genShortByteStringST, + defaultUnsafeUniformFillMutableByteArray, + -- ** Floating point numbers - , uniformDouble01M - , uniformDoublePositive01M - , uniformFloat01M - , uniformFloatPositive01M + uniformDouble01M, + uniformDoublePositive01M, + uniformFloat01M, + uniformFloatPositive01M, + -- ** Enum types - , uniformEnumM - , uniformEnumRM + uniformEnumM, + uniformEnumRM, + -- ** Word - , uniformWordR + uniformWordR, -- * Appendix @@ -127,34 +135,33 @@ module System.Random.Stateful -- $implemenstatefulegen -- ** Floating point number caveats #fpcaveats# - , scaleFloating + scaleFloating, -- $floating -- * References -- $references -- * Pure Random Generator - , module System.Random - ) where + module System.Random, +) where import Control.DeepSeq import Control.Monad.IO.Class import Control.Monad.ST -import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar) import Control.Monad.State.Strict (MonadState, state) import Data.ByteString (ByteString) import Data.Coerce import Data.IORef import Data.STRef import Foreign.Storable +import GHC.Conc.Sync (STM, TVar, newTVar, newTVarIO, readTVar, writeTVar) import System.Random hiding (uniformShortByteString) -import System.Random.Array (shuffleListM, shortByteStringToByteString) +import System.Random.Array (shortByteStringToByteString, shuffleListM) import System.Random.Internal #if __GLASGOW_HASKELL__ >= 808 import GHC.IORef (atomicModifyIORef2Lazy) #endif - -- $introduction -- -- This module provides type classes and instances for the following concepts: @@ -176,7 +183,7 @@ import GHC.IORef (atomicModifyIORef2Lazy) -- -- This library provides instances of 'Uniform' for many common bounded -- numeric types. --- + -- $usagemonadic -- -- In monadic code, use the relevant 'Uniform' and 'UniformRange' instances to @@ -223,7 +230,6 @@ import GHC.IORef (atomicModifyIORef2Lazy) -- 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 @@ -258,7 +264,9 @@ import GHC.IORef (atomicModifyIORef2Lazy) -- @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 @@ -276,7 +284,6 @@ instance RandomGen r => RandomGenM (STGenM r s) r (ST s) where instance RandomGen r => RandomGenM (TGenM r) r STM where applyRandomGenM = applyTGen - -- | Shuffle elements of a list in a uniformly random order. -- -- ====__Examples__ @@ -319,7 +326,6 @@ withMutableGen fg action = do withMutableGen_ :: ThawedGen f m => f -> (MutableGen f m -> m a) -> m a withMutableGen_ fg action = thawGen fg >>= action - -- | Just like `withMutableGen`, except uses a `Seed` instead of a frozen generator. -- -- ====__Examples__ @@ -355,7 +361,8 @@ withMutableGen_ fg action = thawGen fg >>= action -- [7,5,4,3,1,8,10,6,9,2] -- -- @since 1.3.0 -withSeedMutableGen :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m (a, Seed g) +withSeedMutableGen :: + (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m (a, Seed g) withSeedMutableGen seed f = withSeedM seed (`withMutableGen` f) -- | Just like `withSeedMutableGen`, except it doesn't return the final generator, only @@ -366,7 +373,6 @@ withSeedMutableGen seed f = withSeedM seed (`withMutableGen` f) withSeedMutableGen_ :: (SeedGen g, ThawedGen g m) => Seed g -> (MutableGen g m -> m a) -> m a withSeedMutableGen_ seed = withMutableGen_ (fromSeed seed) - -- | Generates a pseudo-random value using monadic interface and `Random` instance. -- -- ====__Examples__ @@ -426,13 +432,12 @@ uniformByteStringM n g = -- of its atomic operations. -- -- @since 1.2.0 -newtype AtomicGenM g = AtomicGenM { unAtomicGenM :: IORef g} - +newtype AtomicGenM g = AtomicGenM {unAtomicGenM :: IORef g} -- | Frozen version of mutable `AtomicGenM` generator -- -- @since 1.2.0 -newtype AtomicGen g = AtomicGen { unAtomicGen :: g} +newtype AtomicGen g = AtomicGen {unAtomicGen :: g} deriving (Eq, Ord, Show, RandomGen, SplitGen, Storable, NFData) -- Standalone definition due to GHC-8.0 not supporting deriving with associated type families @@ -447,7 +452,6 @@ instance SeedGen g => SeedGen (AtomicGen g) where 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. -- @@ -459,7 +463,6 @@ newAtomicGenM = fmap AtomicGenM . liftIO . newIORef globalStdGen :: AtomicGenM StdGen globalStdGen = AtomicGenM theStdGen - instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where uniformWord32R r = applyAtomicGen (genWord32R r) {-# INLINE uniformWord32R #-} @@ -474,7 +477,6 @@ instance (RandomGen g, MonadIO m) => StatefulGen (AtomicGenM g) m where uniformWord64 = applyAtomicGen genWord64 {-# INLINE uniformWord64 #-} - instance (RandomGen g, MonadIO m) => FrozenGen (AtomicGen g) m where type MutableGen (AtomicGen g) m = AtomicGenM g freezeGen = fmap AtomicGen . liftIO . readIORef . unAtomicGenM @@ -540,12 +542,12 @@ atomicModifyIORefHS ref f = do -- >>> newIOGenM (mkStdGen 1729) >>= ioGen -- -- @since 1.2.0 -newtype IOGenM g = IOGenM { unIOGenM :: IORef g } +newtype IOGenM g = IOGenM {unIOGenM :: IORef g} -- | Frozen version of mutable `IOGenM` generator -- -- @since 1.2.0 -newtype IOGen g = IOGen { unIOGen :: g } +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 @@ -560,8 +562,6 @@ instance SeedGen g => SeedGen (IOGen g) where 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 #-} @@ -576,7 +576,6 @@ instance (RandomGen g, MonadIO m) => StatefulGen (IOGenM g) m where uniformWord64 = applyIOGen genWord64 {-# INLINE uniformWord64 #-} - instance (RandomGen g, MonadIO m) => FrozenGen (IOGen g) m where type MutableGen (IOGen g) m = IOGenM g freezeGen = fmap IOGen . liftIO . readIORef . unIOGenM @@ -616,12 +615,12 @@ applyIOGen f (IOGenM ref) = liftIO $ do -- * 'STGenM' is slower than 'StateGenM' due to the extra pointer indirection. -- -- @since 1.2.0 -newtype STGenM g s = STGenM { unSTGenM :: STRef s g } +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 } +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 @@ -636,7 +635,6 @@ instance SeedGen g => SeedGen (STGen g) where 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 #-} @@ -666,7 +664,6 @@ instance RandomGen g => FrozenGen (STGen g) (ST s) where instance RandomGen g => ThawedGen (STGen g) (ST s) where thawGen (STGen g) = newSTGenM g - -- | Applies a pure operation to the wrapped pseudo-random number generator. -- -- ====__Examples__ @@ -695,7 +692,7 @@ applySTGen f (STGenM ref) = do -- (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 :: 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 @@ -710,19 +707,18 @@ runSTGen g action = unSTGen <$> runST (withMutableGen (STGen g) action) -- 7879794327570578227 -- -- @since 1.2.0 -runSTGen_ :: RandomGen g => g -> (forall s . STGenM g s -> ST s a) -> a +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 } +newtype TGenM g = TGenM {unTGenM :: TVar g} -- | Frozen version of mutable `TGenM` generator -- -- @since 1.2.1 -newtype TGen g = TGen { unTGen :: g } +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 @@ -737,14 +733,12 @@ instance SeedGen g => SeedGen (TGen g) where 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) @@ -776,7 +770,6 @@ instance RandomGen g => FrozenGen (TGen g) STM where instance RandomGen g => ThawedGen (TGen g) STM where thawGen (TGen g) = newTGenM g - -- | Applies a pure operation to the wrapped pseudo-random number generator. -- -- ====__Examples__ @@ -927,7 +920,7 @@ applyTGen f (TGenM tvar) = do -- 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 @@ -985,8 +978,7 @@ applyTGen f (TGenM tvar) = do -- 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 @@ -1003,5 +995,3 @@ applyTGen f (TGenM tvar) = do -- >>> :seti -XMultiParamTypeClasses -- >>> :seti -XTypeFamilies -- >>> :seti -XUndecidableInstances --- --- diff --git a/test-inspection/Spec.hs b/test-inspection/Spec.hs index a468c7e7..172add79 100644 --- a/test-inspection/Spec.hs +++ b/test-inspection/Spec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Main (main) where #if __GLASGOW_HASKELL__ >= 800 @@ -19,5 +20,3 @@ main :: IO () main = putStrLn "\nInspection testing is not supported for pre ghc-8.0 versions\n" #endif - - diff --git a/test-inspection/Spec/Inspection.hs b/test-inspection/Spec/Inspection.hs index 0e0b07bd..06b4d4fc 100644 --- a/test-inspection/Spec/Inspection.hs +++ b/test-inspection/Spec/Inspection.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} +{-# 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 @@ -21,11 +20,14 @@ uniform' :: Uniform a => (a, StdGen) uniform' = uniform (mkStdGen 42) uniform_Word8 = uniform' @Word8 -uniform_Int8 = uniform' @Int8 -uniform_Char = uniform' @Char + +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 @@ -34,28 +36,33 @@ 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_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) - +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. - , $(inspectTest $ hasNoGenerics 'uniform_MyAction) + -- 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 - - , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Word8) - , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Int8) - , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Char) - , $(inspectObligations [(`doesNotUse` 'StateGenM), hasNoGenerics, hasNoTypeClasses] 'uniformR_Double) - ] diff --git a/test-legacy/Legacy.hs b/test-legacy/Legacy.hs index f4660fdc..607ce015 100644 --- a/test-legacy/Legacy.hs +++ b/test-legacy/Legacy.hs @@ -8,8 +8,8 @@ import qualified TestRandomRs as TestRandomRs main :: IO () main = do - Random1283.main - RangeTest.main - T7936.main - TestRandomIOs.main - TestRandomRs.main + Random1283.main + RangeTest.main + T7936.main + TestRandomIOs.main + TestRandomRs.main diff --git a/test-legacy/Random1283.hs b/test-legacy/Random1283.hs index 239e29d1..dd5fe8b2 100644 --- a/test-legacy/Random1283.hs +++ b/test-legacy/Random1283.hs @@ -2,7 +2,7 @@ module Random1283 (main) where import Control.Concurrent import Control.Monad -import Data.Sequence (Seq, ViewL(..), empty, fromList, viewl, (<|), (|>), (><)) +import Data.Sequence (Seq, ViewL (..), empty, fromList, viewl, (<|), (><), (|>)) import System.Random -- This test @@ -21,9 +21,9 @@ loopTest t s = do testRace :: Int -> Int -> IO Bool testRace t s = do - ref <- liftM (take (t*s) . randoms) getStdGen + ref <- liftM (take (t * s) . randoms) getStdGen iss <- threadRandoms t s - return (isInterleavingOf (ref::[Int]) iss) + return (isInterleavingOf (ref :: [Int]) iss) threadRandoms :: Random a => Int -> Int -> IO [[a]] threadRandoms t s = do @@ -34,15 +34,15 @@ threadRandoms t s = do 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 +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 - diff --git a/test-legacy/RangeTest.hs b/test-legacy/RangeTest.hs index 74cc62f7..b44c95ee 100644 --- a/test-legacy/RangeTest.hs +++ b/test-legacy/RangeTest.hs @@ -1,27 +1,26 @@ module RangeTest (main) where import Control.Monad -import System.Random 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) + (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') - +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 @@ -30,23 +29,27 @@ approxBounds nxt iters unused (explo,exphi) initrng = -- 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 + 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)) + (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 + 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 + 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 ) +boundedRange = (False, minBound, maxBound) trials :: Int trials = 5000 @@ -55,82 +58,187 @@ trials = 5000 -- 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)) + 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)) + 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)) + -- 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 + "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)) + 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 diff --git a/test-legacy/T7936.hs b/test-legacy/T7936.hs index 47b30d1c..d90ca32e 100644 --- a/test-legacy/T7936.hs +++ b/test-legacy/T7936.hs @@ -1,15 +1,20 @@ --- Test for ticket #7936: +-- | Test for ticket #7936: -- https://ghc.haskell.org/trac/ghc/ticket/7936 -- -- Used to fail with: -- --- $ cabal test T7936 --test-options="+RTS -M1M -RTS" --- T7936: Heap exhausted; - +-- @ +-- $ 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' to increase it. +-- @ module T7936 where -import System.Random (newStdGen) import Control.Monad (replicateM_) +import System.Random (newStdGen) main :: IO () main = replicateM_ 100000 newStdGen diff --git a/test-legacy/TestRandomIOs.hs b/test-legacy/TestRandomIOs.hs index 4af2ddcd..c5756bf5 100644 --- a/test-legacy/TestRandomIOs.hs +++ b/test-legacy/TestRandomIOs.hs @@ -1,11 +1,16 @@ --- Test for ticket #4218 (TestRandomIOs): +-- | Test for ticket #4218 (TestRandomIOs): -- https://ghc.haskell.org/trac/ghc/ticket/4218 -- -- Used to fail with: -- --- $ cabal test TestRandomIOs --test-options="+RTS -M1M -RTS" --- TestRandomIOs: Heap exhausted; - +-- @ +-- $ 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' to increase it. +-- @ module TestRandomIOs where import Control.Monad (replicateM) @@ -17,5 +22,5 @@ import System.Random (randomIO) -- unevaluated thunks. main :: IO () main = do - rs <- replicateM 5000 randomIO :: IO [Int] - print $ last rs + rs <- replicateM 5000 randomIO :: IO [Int] + print $ last rs diff --git a/test-legacy/TestRandomRs.hs b/test-legacy/TestRandomRs.hs index 90145f21..0256d32a 100644 --- a/test-legacy/TestRandomRs.hs +++ b/test-legacy/TestRandomRs.hs @@ -1,4 +1,4 @@ --- Test for ticket #4218 (TestRandomRs): +-- | Test for ticket #4218 (TestRandomRs): -- https://ghc.haskell.org/trac/ghc/ticket/4218 -- -- Fixed together with ticket #8704 @@ -7,17 +7,22 @@ -- -- Used to fail with: -- --- $ cabal test TestRandomRs --test-options="+RTS -M1M -RTS" --- TestRandomRs: Heap exhausted; - +-- @ +-- $ 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' to increase it. +-- @ module TestRandomRs where import Control.Monad (liftM) -import System.Random (randomRs, getStdGen) +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::Integer) + n <- (last . take 5000 . randomRs (0, 1000000)) `liftM` getStdGen + print (n :: Int) diff --git a/test/Spec.hs b/test/Spec.hs index 808f1150..a96edf50 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,25 +8,26 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Control.Monad (replicateM, forM_) +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.List.NonEmpty (NonEmpty (..)) import Data.Typeable import Data.Void import Data.Word import Foreign.C.Types -import GHC.Generics 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 System.Random.Internal (newMutableByteArray, freezeMutableByteArray, writeWord8) import Test.SmallCheck.Series as SC import Test.Tasty import Test.Tasty.HUnit @@ -42,88 +43,93 @@ 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) + 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 - , integralSpec (Proxy :: Proxy CBool) + ghc_8_2_spec = [integralSpec (Proxy :: Proxy CBool)] +#else + ghc_8_2_spec = [] #endif - , integralSpec (Proxy :: Proxy CChar) - , integralSpec (Proxy :: Proxy CSChar) - , integralSpec (Proxy :: Proxy CUChar) - , integralSpec (Proxy :: Proxy CShort) - , integralSpec (Proxy :: Proxy CUShort) - , integralSpec (Proxy :: Proxy CInt) - , integralSpec (Proxy :: Proxy CUInt) - , integralSpec (Proxy :: Proxy CLong) - , integralSpec (Proxy :: Proxy CULong) - , integralSpec (Proxy :: Proxy CPtrdiff) - , integralSpec (Proxy :: Proxy CSize) - , integralSpec (Proxy :: Proxy CWchar) - , integralSpec (Proxy :: Proxy CSigAtomic) - , integralSpec (Proxy :: Proxy CLLong) - , integralSpec (Proxy :: Proxy CULLong) - , integralSpec (Proxy :: Proxy CIntPtr) - , integralSpec (Proxy :: Proxy CUIntPtr) - , integralSpec (Proxy :: Proxy CIntMax) - , integralSpec (Proxy :: Proxy CUIntMax) - , integralSpec (Proxy :: Proxy Integer) - , integralSpec (Proxy :: Proxy Natural) - , enumSpec (Proxy :: Proxy Colors) - , enumSpec (Proxy :: Proxy (Int, Int)) - , enumSpec (Proxy :: Proxy (Bool, Bool, Bool)) - , enumSpec (Proxy :: Proxy ((), Int, Bool, Word)) - , runSpec - , floatTests - , byteStringSpec - , fillMutableByteArraySpec - , SC.testProperty "uniformRangeWithinExcludedF" $ seeded Range.uniformRangeWithinExcludedF - , SC.testProperty "uniformRangeWithinExcludedD" $ seeded Range.uniformRangeWithinExcludedD - , randomSpec (Proxy :: Proxy (CFloat, CDouble)) - , randomSpec (Proxy :: Proxy (Int8, Int16, Int32)) - , randomSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64)) - , randomSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word)) - , randomSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word)) - , randomSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word)) - , uniformSpec (Proxy :: Proxy (Int, Bool)) - , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32)) - , uniformSpec (Proxy :: Proxy (Int8, Int16, Int32, Int64)) - , uniformSpec (Proxy :: Proxy (Word8, Word16, Word32, Word64, Word)) - , uniformSpec (Proxy :: Proxy (Int8, Word8, Word16, Word32, Word64, Word)) - , uniformSpec (Proxy :: Proxy (Int8, Int16, Word8, Word16, Word32, Word64, Word)) - , Stateful.statefulGenSpec - , Seed.spec - ] floatTests :: TestTree -floatTests = testGroup "(Float)" - [ -- Check that https://github.com/haskell/random/issues/53 does not regress - - testCase "Subnormal generation not above upper bound" $ - [] @?= filter (>4.0e-45) (take 100000 $ randomRs (0, 4.0e-45::Float) $ mkStdGen 0) +floatTests = + testGroup + "(Float)" + [ -- Check that https://github.com/haskell/random/issues/53 does not regress - , 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" - ] + 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 :: forall t. Typeable t => Proxy t -> String showType px = show (typeRep px) byteStringSpec :: TestTree @@ -131,14 +137,15 @@ byteStringSpec = testGroup "ByteString" [ SC.testProperty "uniformShortByteString" $ - seededWithLen $ \n g -> SBS.length (fst (uniformShortByteString n g)) == n + 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) + 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 + 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) @@ -156,7 +163,7 @@ fillMutableByteArraySpec = g' <- uniformFillMutableByteArray mba 0 n g ba <- freezeMutableByteArray mba pure (ba, g') - in baFilled == uniformByteArray isPinned n g + in baFilled == uniformByteArray isPinned n g , SC.testProperty "Safe uniformFillMutableByteArray" $ forAll $ \isPinned offset count -> seededWithLen $ \sz g -> let (baFilled, gf) = runST $ do @@ -170,107 +177,112 @@ fillMutableByteArraySpec = 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 + 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 + 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 - ] + 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 + 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 - ] + 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 + 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 + 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 - ] + 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 + 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) + 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) + 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 + 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) + 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') + 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' + 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) + 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') + 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 ] +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 @@ -283,22 +295,31 @@ 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 + | 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 @@ -310,11 +331,13 @@ instance SeedGen ConstGen where 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 diff --git a/test/Spec/Range.hs b/test/Spec/Range.hs index f10fa9c2..af69eb9a 100644 --- a/test/Spec/Range.hs +++ b/test/Spec/Range.hs @@ -1,27 +1,29 @@ -module Spec.Range - ( symmetric - , bounded - , singleton - , uniformRangeWithin - , uniformRangeWithinExcludedF - , uniformRangeWithinExcludedD - ) where +module Spec.Range ( + symmetric, + bounded, + singleton, + uniformRangeWithin, + uniformRangeWithinExcludedF, + uniformRangeWithinExcludedD, +) where -import System.Random.Stateful 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 :: + (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 :: + (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) diff --git a/test/Spec/Seed.hs b/test/Spec/Seed.hs index 8d31ffd3..36bec66f 100644 --- a/test/Spec/Seed.hs +++ b/test/Spec/Seed.hs @@ -9,21 +9,22 @@ {-# 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 -import qualified Data.ByteString as BS -import GHC.TypeLits -import qualified GHC.Exts as GHC (IsList(..)) -import Test.SmallCheck.Series hiding (NonEmpty(..)) -import Spec.Stateful () newtype GenN (n :: Nat) = GenN BS.ByteString deriving (Eq, Show) @@ -61,17 +62,20 @@ instance (1 <= n, KnownNat n) => SeedGen (Gen64 n) where fromSeed64 = Gen64 seedGenSpec :: - forall g. (SeedGen g, Eq g, Show g, Serial IO g) - => TestTree + forall g. + (SeedGen g, Eq g, Show g, Serial IO g) => + TestTree seedGenSpec = - testGroup (seedGenTypeName @g) + testGroup + (seedGenTypeName @g) [ testProperty "fromSeed/toSeed" $ - forAll $ \(g :: g) -> g == fromSeed (toSeed g) + forAll $ + \(g :: g) -> g == fromSeed (toSeed g) , testProperty "fromSeed64/toSeed64" $ - forAll $ \(g :: g) -> g == fromSeed64 (toSeed64 g) + forAll $ + \(g :: g) -> g == fromSeed64 (toSeed64 g) ] - spec :: TestTree spec = testGroup @@ -112,4 +116,3 @@ spec = , seedGenSpec @(Gen64 16) , seedGenSpec @(Gen64 17) ] - diff --git a/test/Spec/Stateful.hs b/test/Spec/Stateful.hs index 454b66e9..f01b829a 100644 --- a/test/Spec/Stateful.hs +++ b/test/Spec/Stateful.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Spec.Stateful where import Control.Concurrent.STM @@ -35,15 +36,15 @@ instance (Monad m, Serial m g) => Serial m (TGen g) where 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 + 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 @@ -54,10 +55,11 @@ matchRandomGenSpec genM gen fromStdGen toStdGen runStatefulGen = 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 + 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 @@ -67,10 +69,11 @@ withMutableGenSpec toIO frozen = 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 + 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 @@ -83,15 +86,17 @@ overwriteMutableGenSpec toIO frozen = 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 + 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 + 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 @@ -102,10 +107,11 @@ immutableFrozenGenSpec toIO frozen = 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 + 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 @@ -114,90 +120,100 @@ splitMutableGenSpec toIO frozen = 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 + 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 + forAll $ + \(f :: f) -> withMutableGenSpec toIO f , testProperty "overwriteGen" $ - forAll $ \(f :: f) -> overwriteMutableGenSpec toIO f + forAll $ + \(f :: f) -> overwriteMutableGenSpec toIO f , testProperty "independent mutable generators" $ - forAll $ \(fs :: [f]) -> indepMutableGenSpec toIO fs + forAll $ + \(fs :: [f]) -> indepMutableGenSpec toIO fs , testProperty "immutable frozen generators" $ - forAll $ \(f :: f) -> immutableFrozenGenSpec toIO f + forAll $ + \(f :: f) -> immutableFrozenGenSpec toIO f , testProperty "splitGen" $ - forAll $ \(f :: f) -> splitMutableGenSpec toIO f + 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 + 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 - ] + 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" + [ 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" + , testGroup + "FrozenGen" [ frozenGenSpecFor StateGen unStateGen runStateGenT , frozenGenSpecFor IOGen unIOGen $ \g action -> do mg <- newIOGenM (unIOGen g)