Tuple instances random

CHANGELOG.md

@@ -5,6 +5,7 @@
 * Addition of `runStateGenST_`
 * Ensure that default implementation of `ShortByteString` generation uses unpinned memory.
 * Addition of `TGen` and `TGenM`
+* Addition of tuple instances for `Random` up to 7-tuple
 
 # 1.2.0
 

random.cabal

@@ -137,13 +137,15 @@ test-suite doctests
     default-language: Haskell2010
     build-depends:
         base,
-        doctest >=0.15 && <0.19,
-        mwc-random >=0.13 && <0.16,
-        primitive >=0.6 && <0.8,
-        random,
-        stm,
-        unliftio >=0.2 && <0.3,
-        vector >= 0.10 && <0.14
+        doctest >=0.15 && <0.19
+    if impl(ghc >= 8.2) && impl(ghc < 8.10)
+        build-depends:
+            mwc-random >=0.13 && <0.16,
+            primitive >=0.6 && <0.8,
+            random,
+            stm,
+            unliftio >=0.2 && <0.3,
+            vector >= 0.10 && <0.14
 
 test-suite spec
     type:             exitcode-stdio-1.0

src/System/Random.hs

@@ -60,6 +60,7 @@ module System.Random
 
 import Control.Arrow
 import Control.Monad.IO.Class
+import Control.Monad.State.Strict
 import Data.ByteString (ByteString)
 import Data.Int
 import Data.IORef
@@ -203,8 +204,10 @@ genByteString :: RandomGen g => Int -> g -> (ByteString, g)
 genByteString n g = runStateGenST g (uniformByteStringM n)
 {-# INLINE genByteString #-}
 
--- | The class of types for which uniformly distributed values can be
--- generated.
+-- | The class of types for which random values can be generated. Most
+-- instances of `Random` will produce values that are uniformly distributed on the full
+-- range, but for those types without a well-defined "full range" some sensible default
+-- subrange will be selected.
 --
 -- 'Random' exists primarily for backwards compatibility with version 1.1 of
 -- this library. In new code, use the better specified 'Uniform' and
@@ -216,9 +219,26 @@ class Random a where
   -- | Takes a range /(lo,hi)/ and a pseudo-random number generator
   -- /g/, and returns a pseudo-random value uniformly distributed over the
   -- closed interval /[lo,hi]/, together with a new generator. It is unspecified
-  -- what happens if /lo>hi/. For continuous types there is no requirement
-  -- that the values /lo/ and /hi/ are ever produced, but they may be,
-  -- depending on the implementation and the interval.
+  -- what happens if /lo>hi/, but usually the values will simply get swapped.
+  --
+  -- >>> let gen = mkStdGen 2021
+  -- >>> fst $ randomR ('a', 'z') gen
+  -- 't'
+  -- >>> fst $ randomR ('z', 'a') gen
+  -- 't'
+  --
+  -- For continuous types there is no requirement that the values /lo/ and /hi/ are ever
+  -- produced, but they may be, depending on the implementation and the interval.
+  --
+  -- There is no requirement to follow the @Ord@ instance and the concept of range can be
+  -- defined on per type basis. For example product types will treat their values
+  -- independently:
+  --
+  -- >>> fst $ randomR (('a', 5.0), ('z', 10.0)) $ mkStdGen 2021
+  -- ('t',6.240232662366563)
+  --
+  -- In case when a lawful range is desired `uniformR` should be used
+  -- instead.
   --
   -- @since 1.0.0
   {-# INLINE randomR #-}
@@ -231,8 +251,7 @@ class Random a where
   -- * For bounded types (instances of 'Bounded', such as 'Char'),
   --   the range is normally the whole type.
   --
-  -- * For fractional types, the range is normally the semi-closed interval
-  -- @[0,1)@.
+  -- * For floating point types, the range is normally the closed interval @[0,1]@.
   --
   -- * For 'Integer', the range is (arbitrarily) the range of 'Int'.
   --
@@ -279,7 +298,7 @@ buildRandoms cons rand = go
     -- The seq fixes part of #4218 and also makes fused Core simpler.
     go g = x `seq` (x `cons` go g') where (x,g') = rand g
 
--- | 'random' generates values in the 'Int' range
+-- | /Note/ - `random` generates values in the `Int` range
 instance Random Integer where
   random = first (toInteger :: Int -> Integer) . random
   {-# INLINE random #-}
@@ -315,19 +334,22 @@ 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 (CFloat l, CFloat h) = first CFloat . randomR (l, h)
+  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 (CDouble l, CDouble h) = first CDouble . randomR (l, h)
+  randomR r = coerce . randomR (coerce r :: (Double, Double))
   {-# INLINE randomR #-}
   random = first CDouble . random
   {-# INLINE random #-}
 
 instance Random Char
 instance Random Bool
+-- | /Note/ - `random` produces values in the closed range @[0,1]@.
 instance Random Double where
   randomR r g = runStateGen g (uniformRM r)
   {-# INLINE randomR #-}
@@ -336,6 +358,7 @@ instance Random Double where
   -- 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 #-}
@@ -355,6 +378,91 @@ initStdGen :: MonadIO m => m StdGen
 initStdGen = liftIO (StdGen <$> SM.initSMGen)
 
 
+-- | /Note/ - `randomR` treats @a@ and @b@ types independently
+instance (Random a, Random b) => Random (a, b) where
+  randomR ((al, bl), (ah, bh)) = runState $
+    (,) <$> state (randomR (al, ah)) <*> state (randomR (bl, bh))
+  {-# INLINE randomR #-}
+  random = runState $ (,) <$> state random <*> state random
+  {-# INLINE random #-}
+
+-- | /Note/ - `randomR` treats @a@, @b@ and @c@ types independently
+instance (Random a, Random b, Random c) => Random (a, b, c) where
+  randomR ((al, bl, cl), (ah, bh, ch)) = runState $
+    (,,) <$> state (randomR (al, ah))
+         <*> state (randomR (bl, bh))
+         <*> state (randomR (cl, ch))
+  {-# INLINE randomR #-}
+  random = runState $ (,,) <$> state random <*> state random <*> state random
+  {-# INLINE random #-}
+
+-- | /Note/ - `randomR` treats @a@, @b@, @c@ and @d@ types independently
+instance (Random a, Random b, Random c, Random d) => Random (a, b, c, d) where
+  randomR ((al, bl, cl, dl), (ah, bh, ch, dh)) = runState $
+    (,,,) <$> state (randomR (al, ah))
+          <*> state (randomR (bl, bh))
+          <*> state (randomR (cl, ch))
+          <*> state (randomR (dl, dh))
+  {-# INLINE randomR #-}
+  random = runState $
+    (,,,) <$> state random <*> state random <*> state random <*> state random
+  {-# INLINE random #-}
+
+-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@ and @e@ types independently
+instance (Random a, Random b, Random c, Random d, Random e) => Random (a, b, c, d, e) where
+  randomR ((al, bl, cl, dl, el), (ah, bh, ch, dh, eh)) = runState $
+    (,,,,) <$> state (randomR (al, ah))
+           <*> state (randomR (bl, bh))
+           <*> state (randomR (cl, ch))
+           <*> state (randomR (dl, dh))
+           <*> state (randomR (el, eh))
+  {-# INLINE randomR #-}
+  random = runState $
+    (,,,,) <$> state random <*> state random <*> state random <*> state random <*> state random
+  {-# INLINE random #-}
+
+-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@ and @f@ types independently
+instance (Random a, Random b, Random c, Random d, Random e, Random f) =>
+  Random (a, b, c, d, e, f) where
+  randomR ((al, bl, cl, dl, el, fl), (ah, bh, ch, dh, eh, fh)) = runState $
+    (,,,,,) <$> state (randomR (al, ah))
+            <*> state (randomR (bl, bh))
+            <*> state (randomR (cl, ch))
+            <*> state (randomR (dl, dh))
+            <*> state (randomR (el, eh))
+            <*> state (randomR (fl, fh))
+  {-# INLINE randomR #-}
+  random = runState $
+    (,,,,,) <$> state random
+            <*> state random
+            <*> state random
+            <*> state random
+            <*> state random
+            <*> state random
+  {-# INLINE random #-}
+
+-- | /Note/ - `randomR` treats @a@, @b@, @c@, @d@, @e@, @f@ and @g@ types independently
+instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) =>
+  Random (a, b, c, d, e, f, g) where
+  randomR ((al, bl, cl, dl, el, fl, gl), (ah, bh, ch, dh, eh, fh, gh)) = runState $
+    (,,,,,,) <$> state (randomR (al, ah))
+             <*> state (randomR (bl, bh))
+             <*> state (randomR (cl, ch))
+             <*> state (randomR (dl, dh))
+             <*> state (randomR (el, eh))
+             <*> state (randomR (fl, fh))
+             <*> state (randomR (gl, gh))
+  {-# INLINE randomR #-}
+  random = runState $
+    (,,,,,,) <$> state random
+             <*> state random
+             <*> state random
+             <*> state random
+             <*> state random
+             <*> state random
+             <*> state random
+  {-# INLINE random #-}
+
 -------------------------------------------------------------------------------
 -- Global pseudo-random number generator
 -------------------------------------------------------------------------------

test/Spec.hs

@@ -8,7 +8,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Main (main) where
 
-import Control.Monad (forM_)
+import Control.Monad (replicateM, forM_)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as SBS
 import Data.Int
@@ -18,7 +18,6 @@ import Data.Word
 import Foreign.C.Types
 import GHC.Generics
 import Numeric.Natural (Natural)
-import System.Random
 import System.Random.Stateful
 import Test.SmallCheck.Series as SC
 import Test.Tasty
@@ -83,6 +82,18 @@ main =
     , byteStringSpec
     , 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.statefulSpec
     ]
 
@@ -105,13 +116,11 @@ byteStringSpec :: TestTree
 byteStringSpec =
   testGroup
     "ByteString"
-    [ SC.testProperty "genShortByteString" $ \(seed, n8) ->
-        let n = fromIntegral (n8 :: Word8) -- no need to generate huge collection of bytes
-         in SBS.length (fst (seeded (genShortByteString n) seed)) == n
-    , SC.testProperty "genByteString" $ \(seed, n8) ->
-        let n = fromIntegral (n8 :: Word8)
-         in SBS.toShort (fst (seeded (genByteString n) seed)) ==
-            fst (seeded (genShortByteString n) seed)
+    [ SC.testProperty "genShortByteString" $
+      seededWithLen $ \n g -> SBS.length (fst (genShortByteString n g)) == n
+    , SC.testProperty "genByteString" $
+      seededWithLen $ \n g ->
+        SBS.toShort (fst (genByteString n g)) == fst (genShortByteString n g)
     , testCase "genByteString/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]
@@ -169,6 +178,38 @@ floatingSpec px =
     positiveInf = read "Infinity"
     negativeInf = read "-Infinity"
 
+randomSpec ::
+     forall a.
+     (Typeable a, Eq a, Random a, Show a)
+  => Proxy a -> TestTree
+randomSpec px =
+  testGroup
+    ("Random " ++ showsType px ")")
+    [ SC.testProperty "randoms" $
+      seededWithLen $ \len g ->
+        take len (randoms g :: [a]) == runStateGen_ g (replicateM len . randomM)
+    , SC.testProperty "randomRs" $
+      seededWithLen $ \len g ->
+        case random g of
+          (l, g') ->
+            case random g' of
+              (h, g'') ->
+                take len (randomRs (l, h) g'' :: [a]) ==
+                runStateGen_ g'' (replicateM len . randomRM (l, h))
+    ]
+
+uniformSpec ::
+     forall a.
+     (Typeable a, Eq a, Random a, Uniform a, Show a)
+  => Proxy a -> TestTree
+uniformSpec px =
+  testGroup
+    ("Uniform " ++ showsType px ")")
+    [ SC.testProperty "uniformListM" $
+      seededWithLen $ \len g ->
+        take len (randoms g :: [a]) == runStateGen_ g (uniformListM len)
+    ]
+
 runSpec :: TestTree
 runSpec = testGroup "runStateGen_ and runPrimGenIO_"
     [ SC.testProperty "equal outputs" $ seeded $ \g -> monadic $ Run.runsEqual g ]
@@ -177,6 +218,11 @@ runSpec = testGroup "runStateGen_ and runPrimGenIO_"
 seeded :: (StdGen -> a) -> Int -> a
 seeded f = f . mkStdGen
 
+-- | Same as `seeded`, but also produces a length in range 0-255 suitable for generating
+-- lists and such
+seededWithLen :: (Int -> StdGen -> a) -> Word8 -> Int -> a
+seededWithLen f w8 = seeded (f (fromIntegral w8))
+
 data MyBool = MyTrue | MyFalse
   deriving (Eq, Ord, Show, Generic, Finite, Uniform)
 instance Monad m => Serial m MyBool

test/doctests.hs

@@ -10,6 +10,7 @@ main = doctest ["src"]
 
 #else
 
+-- Also disabled in cabal file.
 -- TODO: fix doctest support
 main :: IO ()
 main = putStrLn "\nDoctests are not supported for older ghc version\n"