Infinities as floating point range endpoints

src/System/Random.hs

@@ -301,10 +301,16 @@ instance Random Char
 instance Random Bool
 instance Random Double where
   randomR r g = runStateGen g (uniformRM r)
-  random g = runStateGen g (uniformRM (0, 1))
+  -- 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 (\gen -> (1 -) <$> uniformDouble01M gen)
 instance Random Float where
   randomR r g = runStateGen g (uniformRM r)
-  random g = runStateGen g (uniformRM (0, 1))
+  -- 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 (\gen -> (1 -) <$> uniformFloat01M gen)
 
 -------------------------------------------------------------------------------
 -- Global pseudo-random number generator

src/System/Random/Internal.hs

@@ -430,7 +430,7 @@ runStateGen g f = runState (f StateGenM) g
 --
 -- >>> import System.Random.Stateful
 -- >>> let pureGen = mkStdGen 137
--- >>> runStateGen_ pureGen  randomM :: Int
+-- >>> runStateGen_ pureGen randomM :: Int
 -- 7879794327570578227
 --
 -- @since 1.2.0
@@ -855,6 +855,12 @@ instance UniformRange Bool where
 instance UniformRange Double where
   uniformRM (l, h) g
     | l == h = return l
+    | isInfinite l || isInfinite h =
+      -- Optimisation exploiting absorption:
+      --   (-Infinity) + (anything but +Infinity) = -Infinity
+      --   (anything but -Infinity) + (+Infinity) = +Infinity
+      --                (-Infinity) + (+Infinity) = NaN
+      return $! h + l
     | otherwise = do
       x <- uniformDouble01M g
       return $ x * l + (1 -x) * h
@@ -889,6 +895,12 @@ uniformDoublePositive01M g = (+ d) <$> uniformDouble01M g
 instance UniformRange Float where
   uniformRM (l, h) g
     | l == h = return l
+    | isInfinite l || isInfinite h =
+      -- Optimisation exploiting absorption:
+      --   (-Infinity) + (anything but +Infinity) = -Infinity
+      --   (anything but -Infinity) + (+Infinity) = +Infinity
+      --                (-Infinity) + (+Infinity) = NaN
+      return $! h + l
     | otherwise = do
       x <- uniformFloat01M g
       return $ x * l + (1 - x) * h

test/Spec.hs

@@ -130,13 +130,21 @@ integralSpec px =
 
 floatingSpec ::
      forall a.
-     (SC.Serial IO a, Typeable a, Num a, Ord a, Random a, UniformRange a, Show 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 ("(" ++ showsType 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"
 
 runSpec :: TestTree
 runSpec = testGroup "runStateGen_ and runPrimGenIO_"
@@ -165,3 +173,9 @@ data Foo
   | Final ()
   deriving (Eq, Ord, Show, Generic, Finite, Uniform)
 instance Monad m => Serial m Foo
+
+newtype ConstGen = ConstGen Word64
+
+instance RandomGen ConstGen where
+  genWord64 g@(ConstGen c) = (c, g)
+  split g = (g, g)