polysemy-zoo 0.1.1.0 → 0.1.2.0

raw patch · 8 files changed

+703/−4 lines, 8 filesdep +constraintsdep +mtldep +randomdep ~polysemyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: constraints, mtl, random, random-fu, random-source, reflection, text

Dependency ranges changed: polysemy

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• polysemy-zoo.cabal +22/−4
• src/Polysemy/IdempotentLowering.hs +36/−0
• src/Polysemy/MTL.hs +222/−0
• src/Polysemy/Random.hs +57/−0
• src/Polysemy/RandomFu.hs +137/−0
• test/MTLSpec.hs +152/−0
• test/RandomFuSpec.hs +68/−0

@@ -1,8 +1,17 @@ # Changelog for polysemy-zoo +## 0.1.2.0 (2019-06-01)++- Added `Polysemy.MTL` for inter-op with MTL (thanks to @adamConnerSax)+- Moved `Polysemy.Random` from `polysemy`+- Added `Polysemy.RandomFu` (thanks to @adamConnerSax)+- Added `fixedNat` and `fixedNat'` to `Polysemy.IdempotentLowering` for working+    with higher-order effects.+ ## 0.1.1.0 (2019-05-22)  - Added `Polysemy.IdempotentLowering`   ## Unreleased changes+

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 1c51b9ddcd467cc5950fc9a4c63030c540dc98d4a3f594ef63ac0a3a95d7fc41+-- hash: 07f2fe507c2afe8ef70bcc42b26d3eaa3541eee97656ce45a5afa9ea207334cc  name:           polysemy-zoo-version:        0.1.1.0+version:        0.1.2.0 synopsis:       Experimental, user-contributed effects and interpreters for polysemy description:    Please see the README on GitHub at <https://github.com/isovector/polysemy-zoo#readme> category:       Polysemy@@ -31,7 +31,10 @@   exposed-modules:       Polysemy.IdempotentLowering       Polysemy.KVStore+      Polysemy.MTL       Polysemy.Operators+      Polysemy.Random+      Polysemy.RandomFu   other-modules:       Paths_polysemy_zoo   hs-source-dirs:@@ -40,9 +43,15 @@   ghc-options: -fplugin=Polysemy.Plugin   build-depends:       base >=4.7 && <5+    , constraints     , containers-    , polysemy+    , mtl >=2.0.1.0 && <3.0.0.0+    , polysemy >=0.3     , polysemy-plugin+    , random >=1.1 && <1.2+    , random-fu+    , random-source+    , reflection   default-language: Haskell2010  test-suite polysemy-zoo-test@@ -51,6 +60,8 @@   other-modules:       IdempotentLoweringSpec       KVStoreSpec+      MTLSpec+      RandomFuSpec       Paths_polysemy_zoo   hs-source-dirs:       test@@ -58,9 +69,16 @@   ghc-options: -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N   build-depends:       base >=4.7 && <5+    , constraints     , containers     , hspec-    , polysemy+    , mtl >=2.0.1.0 && <3.0.0.0+    , polysemy >=0.3     , polysemy-plugin     , polysemy-zoo+    , random >=1.1 && <1.2+    , random-fu+    , random-source+    , reflection+    , text   default-language: Haskell2010

@@ -4,9 +4,11 @@   ( (.@!)   , nat   , liftNat+  , fixedNat   , (.@@!)   , nat'   , liftNat'+  , fixedNat'   ) where  import Polysemy@@ -132,4 +134,38 @@   => (forall x. (forall y. f y -> g y) -> m x -> n (f x))   -> (forall y. f y -> g y) -> base (forall x. m x -> n (f x)) liftNat' z a = nat' $ z a+++------------------------------------------------------------------------------+-- | Like 'nat', but for higher-order interpreters that need access to+-- themselves.+--+-- For example:+--+-- @+-- 'fixedNat' $ \me -> 'Polysemy.interpretH' $ \case+--   SomeEffect -> ...+-- @+fixedNat+    :: forall m n base+     . Applicative base+    => ((forall x. m x -> n x) -> (forall x. m x -> n x))+    -> base (forall x. m x -> n x)+fixedNat f =+  let x :: (forall x. m x -> n x)+      x = f x+   in nat x+++------------------------------------------------------------------------------+-- | 'fixedNat'' is to 'fixedNat' as 'nat'' is to 'nat'.+fixedNat'+    :: forall m n f base+     . Applicative base+    => ((forall x. m x -> n (f x)) -> (forall x. m x -> n (f x)))+    -> base (forall x. m x -> n (f x))+fixedNat' f =+  let x :: (forall x. m x -> n (f x))+      x = f x+   in nat' x 

@@ -0,0 +1,222 @@+{-# LANGUAGE AllowAmbiguousTypes         #-}+{-# LANGUAGE ConstraintKinds             #-}+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE ScopedTypeVariables         #-}+{-# LANGUAGE TypeFamilies                #-}+{-# LANGUAGE UndecidableInstances        #-}+{-# LANGUAGE UndecidableSuperClasses     #-}+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}++module Polysemy.MTL+  (+    -- * Types+    CanonicalEffect+  , ConstrainedAction (..)+  , ReifiableConstraint1 (..)+  , IsCanonicalEffect (..)++    -- * constraint-polymorphic absorber+  , absorb+  +    -- * constraint-monomorphic absorbers+  , absorbReader+  , absorbState+  , absorbWriter+  , absorbError++    -- * Re-exports+  , Reifies+  , (:-)(Sub)+  , Dict(Dict)+  , reflect+  , Proxy (Proxy)+  )+where+++import qualified Control.Monad.Reader.Class as S+import qualified Control.Monad.State.Class as S+import qualified Control.Monad.Writer.Class as S+import qualified Control.Monad.Error.Class as S+import qualified Data.Constraint as C+import           Data.Constraint (Dict(Dict),(:-)(Sub),(\\))+import qualified Data.Constraint.Unsafe as C+import           Data.Proxy (Proxy (..))+import qualified Data.Reflection as R+import           Data.Reflection (Reifies, reflect) +import           Data.Kind (Type, Constraint)++import           Polysemy+import           Polysemy.Reader+import           Polysemy.Writer+import           Polysemy.State+import           Polysemy.Error++------------------------------------------------------------------------------+-- | Open type-family mapping a single constraint of the form+-- @(Type -> Type) -> Constraint@, e.g., @MonadState s@,+-- to a polysemy effect which can be used to re-interpret+-- that constraint, e.g., 'State s'.+type family CanonicalEffect (p :: (Type -> Type) -> Constraint) :: (Type -> Type) -> Type -> Type++type instance  CanonicalEffect (S.MonadReader env) = Reader env+type instance  CanonicalEffect (S.MonadWriter w)   = Writer w+type instance  CanonicalEffect (S.MonadState s)    = State s+type instance  CanonicalEffect (S.MonadError e)    = Error e+++-- | A newtype wrapper for a monadic action, parameterized by+-- a constraint, @p@ on a @(Type -> Type)@ (e.g., a monad); @m@, a specific+-- @(Type -> Type)@; and a polysemy effect type-list @r@. With "Data.Reflection"+-- we can create instances of @p (ConstrainedAction p m r)@ using functions from+-- @Sem r@.+newtype ConstrainedAction (p :: (Type -> Type) -> Constraint)+                          (m :: Type -> Type)+                          (s :: Type)+                          (x :: Type)+  = ConstrainedAction+    { action :: m x+    } deriving (Functor, Applicative, Monad)++-- | For a constraint to be "absorbable" by @Sem r@,+-- there needs to be an instance of this class,+-- containing the dictionary signatures as a record of functions and the+-- reflected entailment of @p (ConstrainedAction p m r)@ from the reified dictionary.+class ReifiableConstraint1 p where+  data Dict1 (p :: (Type -> Type) -> Constraint) (m :: Type -> Type)+  reifiedInstance :: Monad m => R.Reifies s (Dict1 p m) :- p (ConstrainedAction p m s)++-- | This class contains an instance of the dictionary for some set of effects+-- parameterized by a polysemy effect list @r@.+-- Typically, you would write this instance for any @r@+-- satisfying the constraint that the "canonical" effect is a member.  But you+-- could also use it to discharge constraints which require multiple polysemy effects.+class ReifiableConstraint1 p => IsCanonicalEffect p r where+  canonicalDictionary :: Dict1 p (Sem r)++-- | Given a reifiable constraint, and a dictionary to use, discharge the constraint.+using :: forall p m a. (Monad m, ReifiableConstraint1 p)+  => Dict1 p m -> (p m => m a) -> m a+using d m =+  R.reify d $ \(_ :: Proxy s) -> m \\ C.trans+  (C.unsafeCoerceConstraint :: ((p (ConstrainedAction p m s) :- p m))) reifiedInstance+{-# INLINEABLE using #-}++-- | Given a "canonical" dictionary for @p@ using the polysemy effects in @r@,+-- discharge the constraint @p@.+absorb :: forall p r a. IsCanonicalEffect p r => (p (Sem r) => Sem r a) -> Sem r a+absorb = using @p canonicalDictionary+{-# INLINEABLE absorb #-}++------------------------------------------------------------------------------+absorbReader :: Member (Reader i) r+  => (S.MonadReader i (Sem r) => Sem r a) -> Sem r a+absorbReader = absorb @(S.MonadReader _)+{-# INLINEABLE absorbReader #-}++instance ReifiableConstraint1 (S.MonadReader i) where+  data Dict1 (S.MonadReader i) m = MonadReader+    { ask_ :: m i+    , local_ :: forall a. (i -> i) -> m a -> m a+    }+  reifiedInstance = Sub Dict++instance ( Monad m+         , R.Reifies s' (Dict1 (S.MonadReader i) m)+         ) => S.MonadReader i (ConstrainedAction (S.MonadReader i) m s') where+  ask = ConstrainedAction $ ask_ $ R.reflect $ Proxy @s'+  {-# INLINEABLE ask #-}+  local f m = ConstrainedAction $ local_ (R.reflect $ Proxy @s') f $ action m+  {-# INLINEABLE local #-}+  +instance Member (Reader i) r => IsCanonicalEffect (S.MonadReader i) r where+  canonicalDictionary = MonadReader ask local+  {-# INLINEABLE canonicalDictionary #-}+------------------------------------------------------------------------------+absorbState :: Member (State s) r+  => (S.MonadState s (Sem r) => Sem r a) -> Sem r a+absorbState = absorb @(S.MonadState _)+{-# INLINEABLE absorbState #-}++instance ReifiableConstraint1 (S.MonadState s) where+  data Dict1 (S.MonadState s) m = MonadState+    { get_ :: m s+    , put_ :: s -> m ()+    }+  reifiedInstance = Sub Dict++instance ( Monad m+         , R.Reifies s' (Dict1 (S.MonadState s) m)+         ) => S.MonadState s (ConstrainedAction (S.MonadState s) m s') where+  get = ConstrainedAction $ get_ $ R.reflect $ Proxy @s'+  {-# INLINEABLE get #-}  +  put s = ConstrainedAction $ put_ (R.reflect $ Proxy @s') s+  {-# INLINEABLE put #-}++instance Member (State s) r => IsCanonicalEffect (S.MonadState s) r where+  canonicalDictionary = MonadState get put+  {-# INLINEABLE canonicalDictionary #-}+  +--------------------------------------------------------------------------------+absorbWriter :: (Monoid w, Member (Writer w) r)+  => (S.MonadWriter w (Sem r) => Sem r a) -> Sem r a+absorbWriter = absorb @(S.MonadWriter _)+{-# INLINEABLE absorbWriter #-}++instance Monoid w => ReifiableConstraint1 (S.MonadWriter w) where+  data Dict1 (S.MonadWriter w) m = MonadWriter+    { tell_ :: w -> m ()+    , listen_ :: forall a. m a -> m (a, w)+    , pass_ :: forall a. m (a, w -> w) -> m a +    }+  reifiedInstance = Sub Dict++instance ( Monad m+         , Monoid w+         , R.Reifies s' (Dict1 (S.MonadWriter w) m)+         ) => S.MonadWriter w (ConstrainedAction (S.MonadWriter w) m s') where+  tell w = ConstrainedAction $ tell_ (R.reflect $ Proxy @s') w+  {-# INLINEABLE tell #-}  +  listen x = ConstrainedAction $ listen_ (R.reflect $ Proxy @s') (action x)+  {-# INLINEABLE listen #-}  +  pass x = ConstrainedAction $ pass_ (R.reflect $ Proxy @s') (action x)+  {-# INLINEABLE pass #-}  ++{- This one requires a little work since the polysemy writer is a bit different from the+mtl-standard one+-} +instance (Monoid w, Member (Writer w) r) => IsCanonicalEffect (S.MonadWriter w) r where+  canonicalDictionary = MonadWriter tell semListen semPass where+    semListen = fmap (\(x,y) -> (y,x)) . listen+    semPass :: Member (Writer w) r => Sem r (a, w -> w) -> Sem r a +    semPass x = do+      (w, (a, f)) <- listen x+      censor f (tell w >> pure a)+  {-# INLINEABLE canonicalDictionary #-}+  +--------------------------------------------------------------------------------+absorbError :: forall e r a. Member (Error e) r+  => (S.MonadError e (Sem r) => Sem r a) -> Sem r a+absorbError = absorb @(S.MonadError e)+{-# INLINEABLE absorbError #-}++instance ReifiableConstraint1 (S.MonadError e) where+  data Dict1 (S.MonadError e) m = MonadError+    { throwError_ :: forall a. e -> m a+    , catchError_ :: forall a. m a -> (e -> m a) -> m a+    }+  reifiedInstance = Sub Dict++instance ( Monad m+         , R.Reifies s' (Dict1 (S.MonadError e) m)+         ) => S.MonadError e (ConstrainedAction (S.MonadError e) m s') where+  throwError e = ConstrainedAction $ throwError_ (R.reflect $ Proxy @s') e+  {-# INLINEABLE throwError #-}+  catchError x f = ConstrainedAction $ catchError_ (R.reflect $ Proxy @s') (action x) (action . f)+  {-# INLINEABLE catchError #-}+  +instance Member (Error e) r => IsCanonicalEffect (S.MonadError e) r where+  canonicalDictionary = MonadError throw catch +  {-# INLINEABLE canonicalDictionary #-}

@@ -0,0 +1,57 @@+{-# LANGUAGE BlockArguments  #-}+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Random+  ( -- * Effect+    Random (..)++    -- * Actions+  , random+  , randomR++    -- * Interpretations+  , runRandom+  , runRandomIO+  ) where++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++makeSem ''Random+++------------------------------------------------------------------------------+-- | Run a 'Random' effect with an explicit 'R.RandomGen'.+runRandom+    :: forall q r a+     . R.RandomGen q+    => q+    -> Sem (Random ': r) a+    -> Sem r (q, a)+runRandom q = runState q . reinterpret \case+  Random -> do+    ~(a, q') <- gets @q R.random+    put q'+    pure a+  RandomR r -> do+    ~(a, q') <- gets @q $ R.randomR r+    put q'+    pure a+{-# INLINE runRandom #-}+++------------------------------------------------------------------------------+-- | Run a 'Random' effect by using the 'IO' random generator.+runRandomIO :: Member (Lift IO) r => Sem (Random ': r) a -> Sem r a+runRandomIO m = do+  q <- sendM R.newStdGen+  snd <$> runRandom q m+{-# INLINE runRandomIO #-}+

@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE UndecidableInstances  #-}+{-|+Module      : Polysemy.RandomFu+Description : Polysemy random-fu effect++Polysemy "random-fu" effect.+This can be run in a few ways:+1. Directly in 'IO'+2. Using any 'Data.Random.RandomSource' from "random-fu"+3. In 'IO', using a given 'Data.Random.Source.PureMT' source.+('IO' is used to put the source in an 'IORef')++This module also contains the type-class instances to enable "absorbing"+MonadRandom, ala Polysemy.MTL.  See the tests for MTL or RandomFu for+examples of that in use.+-}++module Polysemy.RandomFu+  (+    -- * Effect+    RandomFu (..)++    -- * Actions+  , sampleRVar+  , getRandomPrim+  , sampleDist++    -- * Interpretations+  , runRandomSource+  , runRandomIO+  , runRandomIOPureMT++    -- * Constraint absorber+  , absorbMonadRandom+  )+where++import           Polysemy+import           Polysemy.MTL++import           Data.IORef                     ( newIORef )+import qualified Data.Random                   as R+import qualified Data.Random.Source            as R+import qualified Data.Random.Internal.Source   as R+import qualified Data.Random.Source.PureMT     as R+import           Control.Monad.IO.Class         ( MonadIO(..) )+++------------------------------------------------------------------------------+{- | An effect capable of sampling from a "random-fu" RVar or generating a+single random-variate of any type, @t@ with a+@Data.Random.Prim t@ constructor, currently one of @Word8@, @Word16@,+@Word32@, @Word64@, @Double@ or N-byte integer.+-}+data RandomFu m r where+  SampleRVar ::  R.RVar t -> RandomFu m t+  GetRandomPrim :: R.Prim t -> RandomFu m t++makeSem ''RandomFu++------------------------------------------------------------------------------+-- | use the 'RandomFu` effect to sample from a "random-fu" @Distribution@.+sampleDist+  :: (Member RandomFu r, R.Distribution d t) => d t -> Sem r t+sampleDist = sampleRVar . R.rvar+{-# INLINEABLE sampleDist #-}++------------------------------------------------------------------------------+-- | Run a 'Random' effect using a given 'R.RandomSource'+runRandomSource+  :: forall s r a+   . R.RandomSource (Sem r) s+  => s+  -> Sem (RandomFu ': r) a+  -> Sem r a+runRandomSource source = interpret $ \case+    SampleRVar    rv -> R.runRVar (R.sample rv) source+    GetRandomPrim pt -> R.runRVar (R.getRandomPrim pt) source+{-# INLINEABLE runRandomSource #-}++------------------------------------------------------------------------------+-- | Run a 'Random` effect by using the default "random-fu" 'IO' source+runRandomIO+  :: forall r a+   . MonadIO (Sem r)+  => Sem (RandomFu ': r) a+  -> Sem r a+runRandomIO = interpret $ \case+    SampleRVar    rv -> liftIO $ R.sample rv+    GetRandomPrim pt -> liftIO $ R.getRandomPrim pt+{-# INLINEABLE runRandomIO #-}++------------------------------------------------------------------------------+-- | Run in 'IO', using the given 'R.PureMT' source, stored in an 'IORef'+runRandomIOPureMT+  :: MonadIO (Sem r)+  => R.PureMT+  -> Sem (RandomFu ': r) a+  -> Sem r a+runRandomIOPureMT source re =+  liftIO (newIORef source) >>= flip runRandomSource re+{-# INLINEABLE runRandomIOPureMT #-}++------------------------------------------------------------------------------+-- | "Absorb" an 'R.MonadRandom' constraint.+-- That is, use a @Member RandomFu r@ constraint to satisfy  the @MonadRandom@+-- constraint in a @(forall m. MonadRandom m => m a), returning a @Sem r a@.+-- See 'Polysemy.MTL' for details.+absorbMonadRandom+  :: Member RandomFu r => (R.MonadRandom (Sem r) => Sem r a) -> Sem r a+absorbMonadRandom = absorb @R.MonadRandom+{-# INLINEABLE absorbMonadRandom #-}++instance ReifiableConstraint1 (R.MonadRandom) where+  data Dict1 R.MonadRandom m = MonadRandom+    {+      getRandomPrim_ :: forall t. R.Prim t -> m t+    }+  reifiedInstance = Sub Dict+++$(R.monadRandom [d|+      instance ( Monad m+               , Reifies s' (Dict1 R.MonadRandom m)+               ) => R.MonadRandom (ConstrainedAction R.MonadRandom m s') where+          getRandomPrim t = ConstrainedAction+            $ getRandomPrim_ (reflect $ Proxy @s') t+          {-# INLINEABLE getRandomPrim #-}+  |])++instance Member RandomFu r => IsCanonicalEffect R.MonadRandom r where+  canonicalDictionary = MonadRandom getRandomPrim+  {-# INLINEABLE canonicalDictionary #-}

@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+module MTLSpec where++import           Polysemy+import           Polysemy.Reader+import           Polysemy.Writer+import           Polysemy.State+import           Polysemy.Error+import           Polysemy.MTL++import qualified Data.Text                     as T+import           Test.Hspec+import           Control.Monad                 as M++import qualified Control.Monad.Reader.Class    as S+import qualified Control.Monad.Writer.Class    as S+import qualified Control.Monad.State.Class     as S+import qualified Control.Monad.Error.Class     as S+++{-+We could re-write these to use polysemy directly.  Imagine, though+that these come from external libraries so you can't so easily+re-write them.+-}+getEnvLength :: S.MonadReader T.Text m => m Int+getEnvLength = S.ask >>= return . T.length++replicateTell :: S.MonadWriter [Int] m => Int -> Int -> m ()+replicateTell n m = M.replicateM_ n $ S.tell [m]++retrieveAndUpdateN :: S.MonadState Int m => Int -> m Int+retrieveAndUpdateN n = do+  m <- S.get+  S.put n+  return m++-- this one is exceptionally boring+throwOnZero :: S.MonadError T.Text m => Int -> m Int+throwOnZero n = do+  M.when (n == 0) $ S.throwError "Zero!"+  return n++someOfAll+  :: (S.MonadReader T.Text m, S.MonadWriter [Int] m, S.MonadState Int m)+  => m T.Text+someOfAll = do+  n <- S.get+  S.tell [n]+  S.ask+------------------------------------------------------------------------------++spec :: Spec+spec = describe "MTL" $ do+  it+      (  "should absorb reader twice, thus returning 9, "+      ++ "the sum of lengths of the strings provided to run (\"Text\")"+      ++ " and then to local (\"Text2\")"+      )+    $ do+        flip shouldBe 9 . run . runReader "Text" $ do+          a <- absorbReader getEnvLength+          b <- local (const "Text2") $ absorbReader getEnvLength+          return (a + b)++  it+      (  "should return the sum, after censoring, of all things told."+      ++ " In this case, 16, the sum of \"init [1,5,5,5,5]\""+      )+    $ do+        flip shouldBe 16 . sum . fst . run . runWriter $ do+          tell [1]+          absorbWriter $ replicateTell 2 5+          censor init $ absorbWriter $ replicateTell 2 5++  it "same as above but with absorbWriter on the outside of the do block" $ do+    flip shouldBe 16 . sum . fst . run . runWriter $ absorbWriter $ do+      S.tell [1]+      replicateTell 2 5+      S.pass $ do+        x <- replicateTell 2 5+        return (x, init)++  it "Should return 0 (since 10 - (20 `div` 2) = 0)" $ do+    flip shouldBe 0 . fst . run . runState 0 $ do+      put 20+      n <- absorbState $ retrieveAndUpdateN 10+      modify (\m -> m - (n `div` 2))+      return ()++  it "should return (Left \"Zero!\")." $ do+    flip shouldBe (Left "Zero!") . run . runError $ absorbError $ throwOnZero 0++  let runRWS+        :: T.Text+        -> Int+        -> Sem '[Reader T.Text, State Int, Writer [Int]] a+        -> ([Int], (Int, a))+      runRWS env0 s0 = run . runWriter . runState s0 . runReader env0++  it "All of them, singly" $ do+    flip shouldBe ([20, 20], (10, 6)) . runRWS "RunAll" 0 $ do+      put 20+      n <- absorbState $ retrieveAndUpdateN 10+      absorbWriter $ replicateTell 2 n+      a <- absorbReader getEnvLength+      return a++  let+    absorbRWS+      :: (Monoid w, Members '[Reader env, Writer w, State s] r)+      => (  ( S.MonadReader env (Sem r)+           , S.MonadWriter w (Sem r)+           , S.MonadState s (Sem r)+           )+         => Sem r a+         )+      -> Sem r a+    absorbRWS x = absorbReader $ absorbWriter $ absorbState x++  it "All of them, one absorber" $ do+    flip shouldBe ([20, 20], (10, 6)) . runRWS "RunAll" 0 $ do+      put 20+      n <- absorbRWS $ retrieveAndUpdateN 10+      absorbRWS $ replicateTell 2 n+      a <- absorbRWS getEnvLength+      return a++  it "All of them, one absorber, absorbRWS outside do block." $ do+    flip shouldBe ([20, 20], (10, 6)) . runRWS "RunAll" 0 $ absorbRWS $ do+      S.put 20+      n <- retrieveAndUpdateN 10+      replicateTell 2 n+      a <- getEnvLength+      return a++  it "absorb a stack" $ do+    flip shouldBe ([10, 20], (20, "RunAll")) . runRWS "RunAll" 0 $ do+      put 20+      tell [10]+      absorbRWS someOfAll++  it "absorb a stack, absorb outside do." $ do+    flip shouldBe ([10, 20], (20, "RunAll"))+      . runRWS "RunAll" 0+      $ absorbRWS+      $ do+          S.put 20+          S.tell [10]+          someOfAll

@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+module RandomFuSpec where++import           Polysemy+import           Polysemy.RandomFu++import           Test.Hspec+import           Control.Monad                 as M+import           Control.Monad.IO.Class         ( liftIO )++import qualified Data.Random                   as R+import qualified Data.Random.Source.PureMT     as R++getRandomInts :: Member RandomFu r => Int -> Sem r [Int]+getRandomInts nDraws =+  sampleRVar $ M.replicateM nDraws (R.uniform 0 (100 :: Int))++getRandomIntsMR :: R.MonadRandom m => Int -> m [Int]+getRandomIntsMR nDraws =+  R.sample $ M.replicateM nDraws (R.uniform 0 (100 :: Int))++randomListsDifferent :: Member RandomFu r => Int -> Sem r Bool+randomListsDifferent nDraws = do+  a <- getRandomInts nDraws+  b <- getRandomInts nDraws+  return (a /= b)++randomListsDifferentMR :: R.MonadRandom m => Int -> m Bool+randomListsDifferentMR nDraws = do+  a <- getRandomIntsMR nDraws+  b <- getRandomIntsMR nDraws+  return (a /= b)++------------------------------------------------------------------------------++spec :: Spec+spec = describe "RandomFu" $ do+  it+      "Should produce [3, 78, 53, 41, 56], 5 psuedo-random Ints seeded from the same seed on each test."+    $ do+        result <- runM . runRandomIOPureMT (R.pureMT 1) $ getRandomInts 5+        result `shouldBe` [3, 78, 53, 41, 56]++  it+      "Should produce [3, 78, 53, 41, 56], 5 psuedo-random Ints seeded from the same seed on each test. Absorbing MonadRandom."+    $ do+        result <-+          runM+          . runRandomIOPureMT (R.pureMT 1)+          $ absorbMonadRandom+          $ getRandomIntsMR 5++        result `shouldBe` [3, 78, 53, 41, 56]+++  it "Should produce two distinct sets of psuedo-random Ints." $ do+    result <- runM . runRandomIO $ randomListsDifferent 5+    result `shouldBe` True++  it+      "Should produce two distinct sets of psuedo-random Ints (absorber version)."+    $ do+        result <-+          runM . runRandomIO $ absorbMonadRandom $ randomListsDifferentMR 5+        result `shouldBe` True+