diff --git a/CHANGELOG.md b/CHANGELOG.md index 47737cfb..1da91192 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/random.cabal b/random.cabal index 8111d80e..a883e29a 100644 --- a/random.cabal +++ b/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 diff --git a/src/System/Random.hs b/src/System/Random.hs index 66313001..c2acf2e3 100644 --- a/src/System/Random.hs +++ b/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 ------------------------------------------------------------------------------- diff --git a/test/Spec.hs b/test/Spec.hs index 5a7cfeb8..8868a6c4 100644 --- a/test/Spec.hs +++ b/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 diff --git a/test/doctests.hs b/test/doctests.hs index 1866dde3..001b3376 100644 --- a/test/doctests.hs +++ b/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"