polysemy-zoo 0.2.0.0 → 0.3.0.0

raw patch · 11 files changed

+495/−382 lines, 11 filesdep ~polysemyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: polysemy

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−1
• README.md +9/−0
• polysemy-zoo.cabal +12/−6
• src/Polysemy/ConstraintAbsorber.hs +44/−0
• src/Polysemy/ConstraintAbsorber/MonadError.hs +62/−0
• src/Polysemy/ConstraintAbsorber/MonadReader.hs +63/−0
• src/Polysemy/ConstraintAbsorber/MonadState.hs +62/−0
• src/Polysemy/ConstraintAbsorber/MonadWriter.hs +78/−0
• src/Polysemy/MTL.hs +0/−222
• test/ConstraintAbsorberSpec.hs +157/−0
• test/MTLSpec.hs +0/−153

@@ -1,8 +1,15 @@ # Changelog for polysemy-zoo +## 0.3.0.0 (2019-06-17)++- Removed `Polysemy.MTL`+- The machinery for MTL absorption is now monomorphized in+    `Polysemy.ConstraintAbsorber`. See the documentation there and in submodules+    for more information.+ ## 0.2.0.0 (2019-06-14) -- Remove `Polysemy.RandomFu`, which is moving to its own package+- Removed `Polysemy.RandomFu`, which is moving to its own package - Add explicit cabal bounds for dependencies of `polysemy-zoo`  ## 0.1.2.1 (2019-06-12)

@@ -20,3 +20,12 @@ `polysemy` proper, or `polysemy-contrib` (the less experimental version of the zoo.) ++## Polysemy in the Wild++The Zoo isn't the only place to find great user-contributions to `polysemy`!+Here is a curated list of other great effects and interops:++* [kowainik/co-log](https://github.com/kowainik/co-log/tree/master/co-log-polysemy)+* [adamConnerSax/polysemy-RandomFu](https://hackage.haskell.org/package/polysemy-RandomFu)+

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: be5a00f62e6365b8c06031d6b6bba39891290626e69ab7d0a78f1861f2dd035d+-- hash: 4b8fa26e65b475e244f147260389f8556a05486cc6f16601fe586ce85a9a33f0  name:           polysemy-zoo-version:        0.2.0.0+version:        0.3.0.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@@ -29,9 +29,13 @@  library   exposed-modules:+      Polysemy.ConstraintAbsorber+      Polysemy.ConstraintAbsorber.MonadError+      Polysemy.ConstraintAbsorber.MonadReader+      Polysemy.ConstraintAbsorber.MonadState+      Polysemy.ConstraintAbsorber.MonadWriter       Polysemy.IdempotentLowering       Polysemy.KVStore-      Polysemy.MTL       Polysemy.Operators       Polysemy.Random       Polysemy.Several@@ -46,7 +50,7 @@     , constraints >=0.10.1 && <0.12     , containers >=0.6 && <0.7     , mtl >=2.0.1.0 && <3.0.0.0-    , polysemy >=0.3+    , polysemy >=0.4     , polysemy-plugin     , random >=1.1 && <1.2     , reflection >=2.1.4 && <3.0.0@@ -56,15 +60,17 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      ConstraintAbsorberSpec       IdempotentLoweringSpec       KVStoreSpec-      MTLSpec       SeveralSpec       Paths_polysemy_zoo   hs-source-dirs:       test   default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax   ghc-options: -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover >=2.0   build-depends:       base >=4.7 && <5     , constraints >=0.10.1 && <0.12

@@ -0,0 +1,44 @@+{-# LANGUAGE AllowAmbiguousTypes         #-}+{-# LANGUAGE ConstraintKinds             #-}++module Polysemy.ConstraintAbsorber+  ( -- * Absorb builder+    absorbWithSem++    -- * Re-exports+  , Reifies+  , (:-) (Sub)+  , Dict (Dict)+  , reflect+  , Proxy (Proxy)+  ) where++import           Data.Constraint (Dict(Dict), (:-)(Sub), (\\))+import qualified Data.Constraint as C+import qualified Data.Constraint.Unsafe as C+import           Data.Kind (Type, Constraint)+import           Data.Proxy (Proxy (..))+import           Data.Reflection (Reifies, reflect)+import qualified Data.Reflection as R+import           Polysemy++------------------------------------------------------------------------------+-- | This function can be used to locally introduce typeclass instances for+-- 'Sem'. See 'Polysemy.ConstraintAbsorber.MonadState' for an example of how to+-- use it.+--+-- @since 0.3.0.0+absorbWithSem+    :: forall -- Constraint to be absorbed+              (p :: (Type -> Type) -> Constraint)+              -- Wrapper to avoid orphan instances+              (x :: (Type -> Type) -> Type -> Type -> Type)+              d r a+     . d  -- ^ Reified dictionary+    -> (forall s. R.Reifies s d :- p (x (Sem r) s))  -- ^ This parameter should always be @'Sub' 'Dict'@+    -> (p (Sem r) => Sem r a)+    -> Sem r a+absorbWithSem d i m =  R.reify d $ \(_ :: Proxy (s :: Type)) -> m \\ C.trans+  (C.unsafeCoerceConstraint :: ((p (x m s) :- p m))) i+{-# INLINEABLE absorbWithSem #-}+

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadError+  ( absorbError+  ) where++import qualified Control.Monad.Error.Class as S+import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.Error+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadError' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbError+    :: Member (Error e) r+    => (S.MonadError e (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadError' for+       -- 'Sem'. This might be something with type @'S.MonadError' e m => m a@.+    -> Sem r a+absorbError = absorbWithSem @(S.MonadError _) @Action+  (ErrorDict throw catch)+  (Sub Dict)+{-# INLINEABLE absorbError #-}+++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Error+data ErrorDict e m = ErrorDict+  { throwError_ :: forall a. e -> m a+  , catchError_ :: forall a. m a -> (e -> m a) -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s' a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Error dictionary,+-- we can make an instance of @MonadError@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (ErrorDict e m)+         ) => S.MonadError e (Action m s') where+  throwError e = Action $ throwError_ (reflect $ Proxy @s') e+  {-# INLINEABLE throwError #-}+  catchError x f = Action $ catchError_ (reflect $ Proxy @s') (action x) (action . f)+  {-# INLINEABLE catchError #-}

@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadReader+  ( absorbReader+  ) where++import qualified Control.Monad.Reader.Class as S+import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.Reader+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadReader' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbReader+    :: Member (Reader i) r+    => (S.MonadReader i (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadReader' for+       -- 'Sem'. This might be something with type @'S.MonadReader' r m => m a@.+    -> Sem r a+absorbReader = absorbWithSem @(S.MonadReader _) @Action+  (ReaderDict ask local)+  (Sub Dict)+{-# INLINEABLE absorbReader #-}+++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Reader+data ReaderDict i m = ReaderDict+  { ask_ :: m i+  , local_ :: forall a. (i -> i) -> m a -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Reader dictionary,+-- we can make an instance of @MonadReader@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (ReaderDict i m)+         ) => S.MonadReader i (Action m s') where+  ask = Action $ ask_ $ reflect $ Proxy @s'+  {-# INLINEABLE ask #-}+  local f m = Action $ local_ (reflect $ Proxy @s') f $ action m+  {-# INLINEABLE local #-}+

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadState+  ( absorbState+  ) where++import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.State+import qualified Control.Monad.State.Class as S+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadState' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbState+    :: Member (State s) r+    => (S.MonadState s (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadState' for+       -- 'Sem'. This might be something with type @'S.MonadState' s m => m a@.+    -> Sem r a+absorbState = absorbWithSem @(S.MonadState _) @Action+  (StateDict get put)+  (Sub Dict)+{-# INLINEABLE absorbState #-}+++------------------------------------------------------------------------------+-- | A Dictionary of the functions we need to supply+-- to make an instance of State+data StateDict s m = StateDict+  { get_ :: m s+  , put_ :: s -> m ()+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom type parameter for reflection.++-- Locally defined so that the instance we are going to build with reflection+-- must be coherent, that is there cannot be orphans.+newtype Action m s' a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl State dictionary,+-- we can make an instance of @MonadState@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Reifies s' (StateDict s m)+         ) => S.MonadState s (Action m s') where+  get = Action $ get_ $ reflect $ Proxy @s'+  {-# INLINEABLE get #-}+  put s = Action $ put_ (reflect $ Proxy @s') s+  {-# INLINEABLE put #-}+

@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE MultiParamTypeClasses       #-}+{-# LANGUAGE UndecidableInstances        #-}++module Polysemy.ConstraintAbsorber.MonadWriter+  ( absorbWriter+  ) where++import qualified Control.Monad.Writer.Class as S+import           Polysemy+import           Polysemy.ConstraintAbsorber+import           Polysemy.Writer+++------------------------------------------------------------------------------+-- | Introduce a local 'S.MonadWriter' constraint on 'Sem' --- allowing it to+-- interop nicely with MTL.+--+-- @since 0.3.0.0+absorbWriter+    :: forall w r a+     . ( Monoid w+       , Member (Writer w) r+       )+    => (S.MonadWriter w (Sem r) => Sem r a)+       -- ^ A computation that requires an instance of 'S.MonadWriter' for+       -- 'Sem'. This might be something with type @'S.MonadWriter' w m => m a@.+    -> Sem r a+absorbWriter =+  let semTell = tell+      semListen :: Member (Writer w) r => Sem r b -> Sem r (b, w)+      semListen = fmap (\(x,y) -> (y,x)) . listen @w+      semPass ::  Member (Writer w) r => Sem r (b, w -> w) -> Sem r b+      semPass x = do+        (w, (a, f)) <- listen x+        censor f (tell w >> pure a)+  in absorbWithSem @(S.MonadWriter _) @Action+     (WriterDict semTell semListen semPass)+     (Sub Dict)+{-# INLINEABLE absorbWriter #-}+++------------------------------------------------------------------------------+-- | A dictionary of the functions we need to supply+-- to make an instance of Writer+data WriterDict w m = WriterDict+  { tell_ :: w -> m ()+  , listen_ :: forall a. m a -> m (a, w)+  , pass_ :: forall a. m (a, w -> w) -> m a+  }+++------------------------------------------------------------------------------+-- | Wrapper for a monadic action with phantom+-- type parameter for reflection.+-- Locally defined so that the instance we are going+-- to build with reflection must be coherent, that is+-- there cannot be orphans.+newtype Action m s' a = Action { action :: m a }+  deriving (Functor, Applicative, Monad)+++------------------------------------------------------------------------------+-- | Given a reifiable mtl Writer dictionary,+-- we can make an instance of @MonadWriter@ for the action+-- wrapped in @Action@.+instance ( Monad m+         , Monoid w+         , Reifies s' (WriterDict w m)+         ) => S.MonadWriter w (Action m s') where+  tell w = Action $ tell_ (reflect $ Proxy @s') w+  {-# INLINEABLE tell #-}+  listen x = Action $ listen_ (reflect $ Proxy @s') (action x)+  {-# INLINEABLE listen #-}+  pass x = Action $ pass_ (reflect $ Proxy @s') (action x)+  {-# INLINEABLE pass #-}+

@@ -1,222 +0,0 @@-{-# 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,157 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module ConstraintAbsorberSpec where++import           Polysemy+import           Polysemy.Reader+import           Polysemy.Writer+import           Polysemy.State+import           Polysemy.Error++import           Polysemy.ConstraintAbsorber.MonadReader+import           Polysemy.ConstraintAbsorber.MonadState+import           Polysemy.ConstraintAbsorber.MonadWriter+import           Polysemy.ConstraintAbsorber.MonadError++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 "ConstraintAbsorber" $ 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

@@ -1,153 +0,0 @@-{-# 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