From 7effb39414eea578a04d8daf31ba7a5c0da08266 Mon Sep 17 00:00:00 2001
From: Alexey Kuleshevich <alexey@kuleshevi.ch>
Date: Tue, 28 Apr 2020 20:51:55 +0300
Subject: [PATCH] Add MonadThrow to UnfiformRange

---
 System/Random.hs          | 18 +++++++++++-------
 System/Random/Internal.hs |  6 ++++--
 System/Random/Monad.hs    |  6 +++---
 bench/Main.hs             |  3 ++-
 random.cabal              |  3 ++-
 test/Spec/Range.hs        |  5 +++--
 6 files changed, 25 insertions(+), 16 deletions(-)

diff --git a/System/Random.hs b/System/Random.hs
index 4141aa356..2e8a43859 100644
--- a/System/Random.hs
+++ b/System/Random.hs
@@ -33,6 +33,8 @@ module System.Random
   , getStdGen
   , setStdGen
   , newStdGen
+  -- * Re-exports
+  , MonadThrow(..)
 
   -- * Compatibility and reproducibility
   -- ** Backwards compatibility and deprecations
@@ -50,6 +52,8 @@ module System.Random
   ) where
 
 import Control.Arrow
+import Control.Exception (throw)
+import Control.Monad.Catch (MonadThrow(..))
 import Data.ByteString (ByteString)
 import Data.Int
 import Data.IORef
@@ -106,8 +110,8 @@ uniform g = runGenState g uniformM
 -- | Pure version of `uniformRM` that works with instances of `RandomGen`
 --
 -- @since 1.2
-uniformR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
-uniformR r g = runGenState g (uniformRM r)
+uniformR :: (RandomGen g, UniformRange a, MonadThrow m) => (a, a) -> g -> m (a, g)
+uniformR r g = runGenStateT g (uniformRM r)
 
 -- | Generates a 'ByteString' of the specified size using a pure pseudo-random
 -- number generator. See 'uniformByteString' for the monadic version.
@@ -136,7 +140,7 @@ class Random a where
   {-# INLINE randomR #-}
   randomR :: RandomGen g => (a, a) -> g -> (a, g)
   default randomR :: (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
-  randomR r g = runGenState g (uniformRM r)
+  randomR r g = either throw id $ runGenStateT g (uniformRM r)
 
   -- | The same as 'randomR', but using a default range determined by the type:
   --
@@ -229,11 +233,11 @@ instance Random CDouble where
 instance Random Char
 instance Random Bool
 instance Random Double where
-  randomR r g = runGenState g (uniformRM r)
-  random g = runGenState g (uniformRM (0, 1))
+  randomR r g = either throw id $ runGenStateT g (uniformRM r)
+  random = randomR (0, 1)
 instance Random Float where
-  randomR r g = runGenState g (uniformRM r)
-  random g = runGenState g (uniformRM (0, 1))
+  randomR r g = either throw id $ runGenStateT g (uniformRM r)
+  random = randomR (0, 1)
 
 -------------------------------------------------------------------------------
 -- Global pseudo-random number generator
diff --git a/System/Random/Internal.hs b/System/Random/Internal.hs
index cb95b44c5..06d9d5e56 100644
--- a/System/Random/Internal.hs
+++ b/System/Random/Internal.hs
@@ -56,8 +56,10 @@ module System.Random.Internal
   ) where
 
 import Control.Arrow
+import Control.Exception (throw)
 import Control.Monad.IO.Class
 import Control.Monad.ST
+import Control.Monad.Catch (MonadThrow)
 import Control.Monad.ST.Unsafe
 import Control.Monad.State.Strict
 import Data.Bits
@@ -92,7 +94,7 @@ class RandomGen g where
   -- [here](https://alexey.kuleshevi.ch/blog/2019/12/21/random-benchmarks) for
   -- more details. It is thus deprecated.
   next :: g -> (Int, g)
-  next g = runGenState g (uniformRM (genRange g))
+  next g = either throw id $ runGenStateT g (uniformRM (genRange g))
 
   -- | Returns a 'Word8' that is uniformly distributed over the entire 'Word8'
   -- range.
@@ -455,7 +457,7 @@ class UniformRange a where
   -- > uniformRM (a, b) = uniformRM (b, a)
   --
   -- @since 1.2<Paste>
-  uniformRM :: MonadRandom g s m => (a, a) -> g s -> m a
+  uniformRM :: (MonadRandom g s m, MonadThrow m) => (a, a) -> g s -> m a
 
 instance UniformRange Integer where
   uniformRM = uniformIntegerM
diff --git a/System/Random/Monad.hs b/System/Random/Monad.hs
index 309e8bfad..6ba404c5c 100644
--- a/System/Random/Monad.hs
+++ b/System/Random/Monad.hs
@@ -118,7 +118,7 @@ import System.Random.Internal
 -- range @[1, 6]@.
 --
 -- >>> :{
--- let rolls :: MonadRandom g s m => Int -> g s -> m [Word8]
+-- let rolls :: (MonadRandom g s m, MonadThrow m) => Int -> g s -> m [Word8]
 --     rolls n = replicateM n . uniformRM (1, 6)
 -- :}
 --
@@ -144,8 +144,8 @@ import System.Random.Internal
 -- number generator.
 --
 -- >>> let pureGen = mkStdGen 41
--- >>> runGenState_ pureGen (rolls 10) :: [Word8]
--- [6,4,5,1,1,3,2,4,5,5]
+-- >>> runGenStateT_ pureGen (rolls 10) :: Maybe [Word8]
+-- Just [6,4,5,1,1,3,2,4,5,5]
 
 -------------------------------------------------------------------------------
 -- Pseudo-random number generator interfaces
diff --git a/bench/Main.hs b/bench/Main.hs
index 0f1b8eaf4..886b915b0 100644
--- a/bench/Main.hs
+++ b/bench/Main.hs
@@ -7,6 +7,7 @@
 
 module Main (main) where
 
+import Control.Exception (throw)
 import Data.Int
 import Data.Proxy
 import Data.Typeable
@@ -207,7 +208,7 @@ pureUniformRIncludeHalfEnumBench =
 pureUniformRBench :: forall a. (Typeable a, UniformRange a) => (a, a) -> Int -> Benchmark
 pureUniformRBench range =
   let !stdGen = mkStdGen 1337
-  in pureBench @a (genMany (uniformR range) stdGen)
+  in pureBench @a (genMany (either throw id . uniformR range) stdGen)
 
 pureBench :: forall a. (Typeable a) => (Int -> ()) -> Int -> Benchmark
 pureBench f sz = bench (showsTypeRep (typeRep (Proxy :: Proxy a)) "") $ nf f sz
diff --git a/random.cabal b/random.cabal
index a8350727f..a036d6086 100644
--- a/random.cabal
+++ b/random.cabal
@@ -86,7 +86,8 @@ library
         base >=4.10 && <5,
         bytestring >=0.10 && <0.11,
         mtl >=2.2 && <2.3,
-        splitmix >=0.0.3 && <0.1
+        splitmix >=0.0.3 && <0.1,
+        exceptions
 
 test-suite legacy-test
     type:             exitcode-stdio-1.0
diff --git a/test/Spec/Range.hs b/test/Spec/Range.hs
index a48ac2b4a..4383ffa77 100644
--- a/test/Spec/Range.hs
+++ b/test/Spec/Range.hs
@@ -6,6 +6,7 @@ module Spec.Range
   , uniformRangeWithinExcluded
   ) where
 
+import Control.Exception (throw)
 import System.Random.Monad
 
 symmetric :: (RandomGen g, Random a, Eq a) => g -> (a, a) -> Bool
@@ -25,10 +26,10 @@ singleton g x = result == x
 
 uniformRangeWithin :: (RandomGen g, UniformRange a, Ord a) => g -> (a, a) -> Bool
 uniformRangeWithin gen (l, r) =
-  runGenState_ gen $ \g ->
+  either throw id $ runGenStateT_ gen $ \g ->
     (\result -> min l r <= result && result <= max l r) <$> uniformRM (l, r) g
 
 uniformRangeWithinExcluded :: (RandomGen g, UniformRange a, Ord a) => g -> (a, a) -> Bool
 uniformRangeWithinExcluded gen (l, r) =
-  runGenState_ gen $ \g ->
+  either throw id $ runGenStateT_ gen $ \g ->
     (\result -> min l r <= result && (l == r || result < max l r)) <$> uniformRM (l, r) g