Update Polysemy.Random to use the newer System.Random "Uniform" and "UniformRange" interfaces.

package.yaml

@@ -27,7 +27,7 @@ dependencies:
 - exceptions >= 0.10.0 && < 0.11
 - mtl >= 2.0.1.0 && < 3.0.0.0
 - polysemy >= 1.4.0.0
-- random >= 1.1 && < 1.3
+- random >= 1.2.0 && < 1.3
 - reflection >= 2.1.4 && < 3.0.0
 - transformers >= 0.5.2.0 && < 0.6
 - text >= 1.1.0 && < 1.3

polysemy-zoo.cabal

@@ -86,7 +86,7 @@ library
     , ghc-prim >=0.5.2 && <0.9
     , mtl >=2.0.1.0 && <3.0.0.0
     , polysemy >=1.4.0.0
-    , random >=1.1 && <1.3
+    , random >=1.2.0 && <1.3
     , reflection >=2.1.4 && <3.0.0
     , streaming ==0.2.*
     , text >=1.1.0 && <1.3
@@ -103,6 +103,7 @@ test-suite polysemy-zoo-test
       FinalSpec
       FloodgateSpec
       KVStoreSpec
+      RandomSpec
       RevStateSpec
       SeveralSpec
       ShiftSpec
@@ -140,7 +141,7 @@ test-suite polysemy-zoo-test
     , polysemy >=1.2.0.0
     , polysemy-plugin >=0.2
     , polysemy-zoo
-    , random >=1.1 && <1.3
+    , random >=1.2.0 && <1.3
     , reflection >=2.1.4 && <3.0.0
     , streaming ==0.2.*
     , text >=1.1.0 && <1.3

src/Polysemy/Random.hs

@@ -11,20 +11,45 @@ module Polysemy.Random
     -- * Interpretations
   , runRandom
   , runRandomIO
+
+    -- * Helpers
+  , distributed
+  , oneOf
+  , sample
+  , sampleR
+  , weighted
   ) where
 
+import           Data.List (genericReplicate)
+import           Data.List.NonEmpty as NonEmpty ((!!), NonEmpty((:|)))
+import           Numeric.Natural (Natural)
 import           Polysemy
 import           Polysemy.State
 import qualified System.Random as R
 
 ------------------------------------------------------------------------------
 -- | An effect capable of providing 'R.Random' values.
 data Random m a where
-  Random :: R.Random x => Random m x
-  RandomR :: R.Random x => (x, x) -> Random m x
+  Random :: R.Uniform x => Random m x
+  RandomR :: R.UniformRange x => (x, x) -> Random m x
 
-makeSem ''Random
+makeSem_ ''Random
 
+------------------------------------------------------------------------------
+-- | Yield a value, randomly sampled from the uniform distribution over all values of the given type.
+-- /e.g./ 'p <- random @Bool'
+random :: forall x r.
+          (R.Uniform x
+          ,Member Random r) =>
+          Sem r x
+
+------------------------------------------------------------------------------
+-- | Yield a value, randomly sampled from the uniform distribution over the given inclusive range.
+-- /e.g./ 'p <- random @Int (-10, 10)'
+randomR :: forall x r.
+           (R.UniformRange x
+           ,Member Random r) =>
+           (x, x) -> Sem r x
 
 ------------------------------------------------------------------------------
 -- | Run a 'Random' effect with an explicit 'R.RandomGen'.
@@ -36,11 +61,11 @@ runRandom
     -> Sem r (q, a)
 runRandom q = runState q . reinterpret (\case
   Random -> do
-    ~(a, q') <- gets @q R.random
+    ~(a, q') <- gets @q R.uniform
     put q'
     pure a
   RandomR r -> do
-    ~(a, q') <- gets @q $ R.randomR r
+    ~(a, q') <- gets @q $ R.uniformR r
     put q'
     pure a
                                        )
@@ -55,3 +80,55 @@ runRandomIO m = do
   snd <$> runRandom q m
 {-# INLINE runRandomIO #-}
 
+
+------------------------------------------------------------------------------
+-- | Pick (uniformly) randomly from a (finite) non-empty list.
+oneOf :: forall a r.
+         (Member Random r) =>
+         NonEmpty a -> Sem r a
+oneOf xs = do i <- randomR (0, length xs - 1)
+              return $ xs NonEmpty.!! i
+
+------------------------------------------------------------------------------
+-- | Pick randomly from a finite non-empty list, using weight annotations.
+-- Behavior is undefined if all weights are zero.
+weighted :: forall a r.
+            (Member Random r) =>
+            NonEmpty (Natural, a) -> Sem r a
+weighted xs = consume xs <$> randomR (0, (sum $ fst <$> xs) - 1)
+
+------------------------------------------------------------------------------
+-- | Pick randomly from a non-empty possibly-infinite list, using normalized weight annotations.
+-- The requirement that all weights be 0-1 (inclusive) and that they sum to 1 is not checked!
+distributed :: forall a w r.
+               (Num w
+               ,Ord w
+               ,R.UniformRange w
+               ,Member Random r) =>
+               NonEmpty (w, a) -> Sem r a
+distributed xs = consume xs <$> randomR (0, 1)
+
+
+consume :: (Num w, Ord w) => NonEmpty (w, a) -> w -> a
+consume ((_, x) :| []) _ = x
+consume ((weight, x) :| (x' : xs)) threshold | threshold < weight = x
+                                             | otherwise          = consume (x' :| xs) (threshold - weight)
+
+------------------------------------------------------------------------------
+-- | Generate n random values.
+sample :: forall a i r.
+          (Integral i,
+           R.Uniform a,
+           Member Random r) =>
+          i -> Sem r [a]
+sample n = sequence . genericReplicate n $ random
+
+------------------------------------------------------------------------------
+-- | Generate n random values in a range.
+sampleR :: forall a i r.
+           (Integral i,
+            R.UniformRange a,
+            Member Random r) =>
+           i -> (a, a) -> Sem r [a]
+sampleR n r = sequence . genericReplicate n $ randomR r
+

test/RandomSpec.hs

@@ -0,0 +1,42 @@
+module RandomSpec where
+
+import Data.List (nub)
+import Data.List.NonEmpty (NonEmpty((:|)), unfoldr)
+import Data.Word (Word64)
+import Test.Hspec
+import Polysemy
+import Polysemy.Random
+import qualified System.Random as R
+
+spec :: Spec
+spec = describe "Random" $ do
+  it "should transparently mirror the System.Random interface" $ do
+    q0 <- R.initStdGen
+    let (_, ns) = run . runRandom q0 . sequence . replicate 5 $
+                    do int :: Int <- randomR (2, 200)
+                       real :: Double <- randomR (2, 200)
+                       word :: Word64 <- random
+                       return (int, real, word)
+        (reference, _) = foldr (\_ (ns', q') ->
+                                  let (int :: Int, qi) = R.randomR (2, 200) q'
+                                      (real :: Double, qr) = R.randomR (2, 200) qi
+                                      (word :: Word64, qw) = R.random qr
+                                  in ((int, real, word) : ns', qw)
+                               ) ([], q0) (replicate 5 ())
+    ns `shouldBe` reverse reference
+  it "`oneOf` shouldn't crash." $ do
+    five <- (nub <$>) . sequence . replicate 100 . runM . runRandomIO . oneOf $ (5 :: Int) :| []
+    five `shouldBe` [5]
+  it "`weighted` should give the only non-zero value." $ do
+    five <- (nub <$>) . sequence . replicate 100 . runM . runRandomIO . weighted @Int $ (0, 4) :| [(1, 5), (0, 6)]
+    five `shouldBe` [5]
+  it "`distributed` should work on infinite input." $ do
+    five <- (nub <$>) . sequence . replicate 100 . runM . runRandomIO . distributed @Int @Double $ unfoldr (\i -> ((i, 5), Just $ i / 2)) 0.5
+    five `shouldBe` [5]
+  it "`sample` should give the correct number of values" $ do
+    five <- (length <$>) . runM . runRandomIO $ sample @Bool @Int 5
+    five `shouldBe` 5
+  it "`sampleR` should give the correct number of values" $ do
+    five <- (length <$>) . runM . runRandomIO $ sampleR @Float @Int 5 (-10, 10)
+    five `shouldBe` 5
+