polysemy-zoo 0.3.0.0 → 0.4.0.0

raw patch · 22 files changed

+1048/−43 lines, 22 filesdep +asyncdep +binarydep +bytestringdep −textdep ~basedep ~containersdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependencies added: async, binary, bytestring, ghc-prim, hedis

Dependencies removed: text

Dependency ranges changed: base, containers, hspec, polysemy, polysemy-plugin

API changes (from Hackage documentation)

Files

• ChangeLog.md +15/−0
• README.md +1/−1
• polysemy-zoo.cabal +35/−14
• src/Polysemy/Alias.hs +6/−0
• src/Polysemy/ConstraintAbsorber/MonadState.hs +1/−1
• src/Polysemy/ConstraintAbsorber/MonadWriter.hs +5/−6
• src/Polysemy/Final.hs +276/−0
• src/Polysemy/Final/Async.hs +38/−0
• src/Polysemy/Final/Error.hs +61/−0
• src/Polysemy/Final/Fixpoint.hs +22/−0
• src/Polysemy/Final/MTL.hs +94/−0
• src/Polysemy/Final/Resource.hs +45/−0
• src/Polysemy/Floodgate.hs +64/−0
• src/Polysemy/KVStore.hs +77/−0
• src/Polysemy/Random.hs +2/−2
• src/Polysemy/Redis/Utils.hs +24/−0
• src/Polysemy/SetStore.hs +67/−0
• src/Polysemy/Several.hs +8/−10
• test/ConstraintAbsorberSpec.hs +7/−9
• test/FinalSpec.hs +164/−0
• test/FloodgateSpec.hs +31/−0
• test/SeveralSpec.hs +5/−0

@@ -1,5 +1,18 @@ # Changelog for polysemy-zoo +## 0.4.0.0 (2019-07-10)++### Breaking Changes++- The semantics of `absorbWriter` are now aligned with the `MTL` implementation++### New Effects and Interpreters++- Added `SetStore` effect+- Added `Floodgate` effect+- Added `lookupOrThrowKV`, `existsKV` and `modifyKV` actions to `KVStore`+- Added Redis interpretations of `SetStore` and `KVStore`+ ## 0.3.0.0 (2019-06-17)  - Removed `Polysemy.MTL`@@ -31,3 +44,5 @@  ## Unreleased changes +* In AbsorbMonadWriter, re-implemented mtl pass in terms of the new Polysemy.Writer+pass and confirmed all tests.

@@ -1,6 +1,6 @@ # polysemy-zoo -[![Build Status](https://api.travis-ci.org/isovector/polysemy-zoo.svg?branch=master)](https://travis-ci.org/isovector/polysemy-zoo)+[![Build Status](https://api.travis-ci.org/polysemy-research/polysemy-zoo.svg?branch=master)](https://travis-ci.org/polysemy-research/polysemy-zoo) [![Hackage](https://img.shields.io/hackage/v/polysemy-zoo.svg?logo=haskell)](https://hackage.haskell.org/package/polysemy-zoo)  ## Dedication

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 4b8fa26e65b475e244f147260389f8556a05486cc6f16601fe586ce85a9a33f0+-- hash: 2a632f7d2c785cf339754bf2cf1895a7996a6b348cc8704e54e6b45769f39d91  name:           polysemy-zoo-version:        0.3.0.0+version:        0.4.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,29 +29,44 @@  library   exposed-modules:+      Polysemy.Alias       Polysemy.ConstraintAbsorber       Polysemy.ConstraintAbsorber.MonadError       Polysemy.ConstraintAbsorber.MonadReader       Polysemy.ConstraintAbsorber.MonadState       Polysemy.ConstraintAbsorber.MonadWriter+      Polysemy.Final+      Polysemy.Final.Async+      Polysemy.Final.Error+      Polysemy.Final.Fixpoint+      Polysemy.Final.MTL+      Polysemy.Final.Resource+      Polysemy.Floodgate       Polysemy.IdempotentLowering       Polysemy.KVStore       Polysemy.Operators       Polysemy.Random+      Polysemy.Redis.Utils+      Polysemy.SetStore       Polysemy.Several   other-modules:       Paths_polysemy_zoo   hs-source-dirs:       src   default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax-  ghc-options: -fplugin=Polysemy.Plugin+  ghc-options: -fplugin=Polysemy.Plugin -Wall   build-depends:-      base >=4.7 && <5+      async >=2.2 && <3+    , base >=4.9 && <5+    , binary >=0.8.5.1 && <0.9+    , bytestring >=0.10.8.2 && <0.11     , constraints >=0.10.1 && <0.12-    , containers >=0.6 && <0.7+    , containers >=0.5 && <0.7+    , ghc-prim >=0.5.2 && <0.6+    , hedis >=0.10 && <0.13     , mtl >=2.0.1.0 && <3.0.0.0-    , polysemy >=0.4-    , polysemy-plugin+    , polysemy >=0.7.0.0+    , polysemy-plugin >=0.2     , random >=1.1 && <1.2     , reflection >=2.1.4 && <3.0.0   default-language: Haskell2010@@ -61,6 +76,8 @@   main-is: Main.hs   other-modules:       ConstraintAbsorberSpec+      FinalSpec+      FloodgateSpec       IdempotentLoweringSpec       KVStoreSpec       SeveralSpec@@ -68,19 +85,23 @@   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+  ghc-options: -fplugin=Polysemy.Plugin -Wall -threaded -rtsopts -with-rtsopts=-N   build-tool-depends:       hspec-discover:hspec-discover >=2.0   build-depends:-      base >=4.7 && <5+      async >=2.2 && <3+    , base >=4.9 && <5+    , binary >=0.8.5.1 && <0.9+    , bytestring >=0.10.8.2 && <0.11     , constraints >=0.10.1 && <0.12-    , containers >=0.6 && <0.7-    , hspec+    , containers >=0.5 && <0.7+    , ghc-prim >=0.5.2 && <0.6+    , hedis >=0.10 && <0.13+    , hspec >=2.6.0 && <3     , mtl >=2.0.1.0 && <3.0.0.0-    , polysemy >=0.4-    , polysemy-plugin+    , polysemy >=0.7.0.0+    , polysemy-plugin >=0.2     , polysemy-zoo     , random >=1.1 && <1.2     , reflection >=2.1.4 && <3.0.0-    , text   default-language: Haskell2010

@@ -0,0 +1,6 @@+module Polysemy.Alias where++import Polysemy++type InterpreterOf e r = forall x.  Sem (e ': r) x -> Sem r x+

@@ -44,7 +44,7 @@  -- 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 }+newtype Action m s' a = Action (m a)   deriving (Functor, Applicative, Monad)  

@@ -28,13 +28,12 @@        -- 'Sem'. This might be something with type @'S.MonadWriter' w m => m a@.     -> Sem r a absorbWriter =-  let semTell = tell+  let swapTuple (x,y) = (y,x)+      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)+      semListen = fmap swapTuple . listen @w+      semPass :: Member (Writer w) r => Sem r (b, w -> w) -> Sem r b+      semPass = pass @w . fmap swapTuple   in absorbWithSem @(S.MonadWriter _) @Action      (WriterDict semTell semListen semPass)      (Sub Dict)

@@ -0,0 +1,276 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.Final+  (+    -- * Effect+    Final(..)++    -- * Actions+  , withWeaving+  , withStrategic+  , embedFinal++    -- * Combinators for Interpreting to the Final Monad+  , interpretFinal++    -- * Strategy+    -- | Strategy is a domain-specific language very similar to @Tactics@+    -- (see 'Tactical'), and is used to describe how higher-order effects+    -- are threaded down to the final monad.+    --+    -- Much like @Tactics@, computations can be run and threaded+    -- through the use of 'runS' and 'bindS', and first-order constructors+    -- may use 'pureS'. In addition, 'liftS' may be used to+    -- lift actions of the final monad.+    --+    -- Unlike @Tactics@, the final return value within a `Strategic`+    -- must be a monadic value of the target monad+    -- with the functorial state wrapped inside of it.+  , Strategic+  , WithStrategy+  , pureS+  , liftS+  , runS+  , bindS+  , getInspectorS+  , getInitialStateS++    -- * Interpretations+  , runFinal+  , runFinalLift+  , runFinalLiftIO+  ) where++import Data.Functor.Identity++import Polysemy+import Data.Functor.Compose+import Polysemy.Internal+import Polysemy.Internal.Tactics+import Polysemy.Internal.Union+import Control.Monad+import Control.Monad.IO.Class++-----------------------------------------------------------------------------+-- | An effect for embedding higher-order effects in the final target monad+-- of the effect stack.+--+-- This is very useful for writing interpreters that interpret higher-order+-- effects in terms of the final monad - however, these interpreters+-- are subject to very different semantics than regular ones.+-- For more information, see 'interpretFinal'.+data Final m z a where+  WithWeaving :: (forall f.+                      Functor f+                   => f ()+                   -> (forall x. f (z x) -> m (f x))+                   -> (forall x. f x -> Maybe x)+                   -> m (f a)+                 )+              -> Final m z a++makeSem_ ''Final++-----------------------------------------------------------------------------+-- | Allows for embedding higher-order actions of the final monad+-- by providing the means of explicitly threading effects through 'Sem r'+-- to the final monad. Consider using 'withStrategic' instead,+-- as it provides a more user-friendly interface to the same power.+--+-- You are discouraged from using 'withWeaving' directly in application code,+-- as it ties your application code directly to the underlying monad.+withWeaving :: forall m a r+            .   Member (Final m) r+            => (forall f.+                    Functor f+                 => f ()+                 -> (forall x. f (Sem r x) -> m (f x))+                 -> (forall x. f x -> Maybe x)+                 -> m (f a)+               )+            -> Sem r a++-----------------------------------------------------------------------------+-- | 'withWeaving' admits an implementation of 'sendM'.+--+-- Just like 'sendM', you are discouraged from using this in application code.+embedFinal :: Functor m => Member (Final m) r => m a -> Sem r a+embedFinal m = withWeaving $ \s _ _ -> (<$ s) <$> m+++-----------------------------------------------------------------------------+-- | Allows for embedding higher-order actions of the final monad+-- by providing the means of explicitly threading effects through 'Sem r'+-- to the final monad. This is done through the use of the 'Strategic'+-- environment.+--+-- You are discouraged from using 'withStrategic' in application code,+-- as it ties your application code directly to the underlying monad.+withStrategic :: Member (Final m) r => Strategic m (Sem r) a -> Sem r a+withStrategic strat = withWeaving $ \s wv ins -> runStrategy s wv ins strat++------------------------------------------------------------------------------+-- | Like 'interpretH', but may be used to+-- interpret higher-order effects in terms of the final monad.+--+-- /Beware/: Any interpreters built using this (or 'Final' in general)+-- will _not_ respect local/global state semantics based on the order of+-- interpreters run. You should signal interpreters that make use of+-- 'Final' by adding a "-Final" suffix to the names of these.+--+-- State semantics of effects that are _not_+-- interpreted in terms of the final monad will always+-- appear local to effects that are interpreted in terms of the final monad.+--+-- State semantics between effects that are interpreted in terms of the final monad+-- depend on the final monad. I.e. if the final monad is a monad transformer stack,+-- then state semantics will depend on the order monad transformers are stacked.+interpretFinal+    :: forall e m r a+    .  (Member (Final m) r, Functor m)+    => (forall x n. e n x -> Strategic m n x)+    -> Sem (e ': r) a+    -> Sem r a+interpretFinal n =+  let+    go :: Sem (e ': r) x -> Sem r x+    go (Sem sem) = sem $ \u -> case decomp u of+      Right (Weaving e s wv ex ins) ->+        fmap ex $ withWeaving $ \s' wv' ins'+          -> fmap getCompose $+                runStrategy+                  (Compose (s <$ s'))+                  (fmap Compose . wv' . fmap (go . wv) . getCompose)+                  (ins' . getCompose >=> ins)+                  (n e)+      Left g -> liftSem (hoist go g)+    {-# INLINE go #-}+  in+    go+{-# INLINE interpretFinal #-}++------------------------------------------------------------------------------+-- | 'Strategic' is an environment in which you're capable of explicitly+-- threading higher-order effect states to the final monad.+-- This is based upon @Tactics@, (see 'Tactical'), and usage+-- is extremely similar.+type Strategic m n a = forall f. Functor f => Sem (WithStrategy m f n) (m (f a))++type WithStrategy m f n = WithTactics (Lift m) f n '[]++------------------------------------------------------------------------------+-- | Get a natural transformation capable of potentially inspecting values+-- inside of @f@. Binding the result of 'getInspectorS' produces a function that+-- can sometimes peek inside values returned by 'bindS'.+--+-- This is often useful for running callback functions that are not managed by+-- polysemy code.+--+-- See also 'getInspectorT'+getInspectorS :: Sem (WithStrategy m f n) (Inspector f)+getInspectorS = getInspectorT+{-# INLINE getInspectorS #-}++-- | Get the stateful environment of the world at the moment the+-- target monad is to be run.+-- Prefer 'pureS', 'runS' or 'bindS' instead of using this function+-- directly.+getInitialStateS :: Sem (WithStrategy m f n) (f ())+getInitialStateS = getInitialStateT+{-# INLINE getInitialStateS #-}++------------------------------------------------------------------------------+-- Lift a value into 'Strategic'.+pureS :: Applicative m => a -> Strategic m n a+pureS = fmap pure . pureT+{-# INLINE pureS #-}++------------------------------------------------------------------------------+-- Lifts an action of the final monad into 'Strategic'.+--+-- Note: you don't need to use this function if you already have a monadic+-- action with the functorial state woven into it, by the use of+-- 'runS' or 'bindS'.+-- In these cases, you need only use 'pure' to embed the action into the+-- 'Strategic' environment.+liftS :: Functor m => m a -> Strategic m n a+liftS m = do+  s <- getInitialStateS+  pure $ fmap (<$ s) m+{-# INLINE liftS #-}++------------------------------------------------------------------------------+-- | Lifts a monadic action into the stateful environment, in terms+-- of the final monad.+-- The stateful environment will be the same as the one that the target monad+-- is initially run in.+-- Use 'bindS'  if you'd prefer to explicitly manage your stateful environment.+runS :: Monad m => n a -> Sem (WithStrategy m f n) (m (f a))+runS = fmap runM . runT+{-# INLINE runS #-}++------------------------------------------------------------------------------+-- | Lift a kleisli action into the stateful environment, in terms of the final+-- monad. You can use 'bindS' to get an effect parameter of the form @a -> n b@+-- into something that can be used after calling 'runS' on an effect parameter+-- @n a@.+bindS :: Monad m => (a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))+bindS = fmap (runM .) . bindT+{-# INLINE bindS #-}++------------------------------------------------------------------------------+-- | Internal function to process Strategies in terms of 'withWeaving'.+runStrategy :: Functor f+            => f ()+            -> (forall x. f (n x) -> m (f x))+            -> (forall x. f x -> Maybe x)+            -> Sem (WithStrategy m f n) a+            -> a+runStrategy s wv ins (Sem m) = runIdentity $ m $ \u -> case extract u of+  Weaving e s' _ ex' _ -> Identity $ ex' $ (<$ s') $ case e of+    GetInitialState -> s+    HoistInterpretation na -> sendM . wv . fmap na+    GetInspector -> Inspector ins++------------------------------------------------------------------------------+-- Lower a 'Sem' containing only a lifted, final monad into that monad.+-- The appearance of 'Lift' as the final effect+-- is to allow the use of operations that rely on a @'LastMember' ('Lift' m)@+-- constraint.+runFinal :: Monad m => Sem '[Final m, Lift m] a -> m a+runFinal = usingSem $ \u -> case decomp u of+  Right (Weaving (WithWeaving wav) s wv ex ins) ->+    ex <$> wav s (runFinal . wv) ins+  Left g -> case extract g of+    Weaving (Lift m) s _ ex _ -> ex . (<$ s) <$> m++------------------------------------------------------------------------------+-- Lower a 'Sem' containing two lifted monad into the final monad,+-- by interpreting one of the monads in terms of the other one.+--+-- This allows for the use of operations that rely on a @'LastMember' ('Lift' m)@+-- constraint, as long as @m@ can be transformed to the final monad;+-- but be warned, this breaks the implicit contract of @'LastMember' ('Lift' m)@+-- that @m@ _is_ the final monad, so depending on the final monad and operations+-- used, 'runFinalTrans' may become _unsafe_.+--+-- For example, 'runFinalTrans' is unsafe with 'runAsync' if+-- the final monad is non-deterministic, or a continuation+-- monad.+runFinalLift :: Monad m+              => (forall x. n x -> m x)+              -> Sem [Final m, Lift m, Lift n] a+              -> m a+runFinalLift nat = usingSem $ \u -> case decomp u of+  Right (Weaving (WithWeaving wav) s wv ex ins) ->+    ex <$> wav s (runFinalLift nat . wv) ins+  Left g -> case decomp g of+    Right (Weaving (Lift m) s _ ex _) -> ex . (<$ s) <$> m+    Left g' -> case extract g' of+      Weaving (Lift n) s _ ex _ -> ex . (<$ s) <$> nat n++------------------------------------------------------------------------------+-- | 'runFinalTrans', specialized to transform 'IO' to a 'MonadIO'.+runFinalLiftIO :: MonadIO m+               => Sem [Final m, Lift m, Lift IO] a+               -> m a+runFinalLiftIO = runFinalLift liftIO

@@ -0,0 +1,38 @@+module Polysemy.Final.Async+  (+    module Polysemy.Async+  , module Polysemy.Final+  , runAsyncFinal+  ) where++import qualified Control.Concurrent.Async as A++import Polysemy+import Polysemy.Async+import Polysemy.Final++------------------------------------------------------------------------------+-- | Run an 'Async' effect through final 'IO'+--+-- This can be used as an alternative to 'runAsyncInIO'.+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Async' effects+-- interpreted this way. See 'interpretFinal'.+--+-- Notably, unlike 'runAsync', this is not consistent with+-- 'Polysemy.State.State' unless 'Polysemy.State.runStateInIORef' is used.+-- State that seems like it should be threaded globally throughout the `Async`+-- /will not be./+--+-- Prefer 'runAsync' unless its unsafe or inefficient in the context of your+-- application.+runAsyncFinal :: Member (Final IO) r+              => Sem (Async ': r) a+              -> Sem r a+runAsyncFinal = interpretFinal $ \case+  Async m -> do+    ins <- getInspectorS+    m' <- runS m+    liftS $ A.async (inspect ins <$> m')+  Await a -> liftS (A.wait a)

@@ -0,0 +1,61 @@+module Polysemy.Final.Error+  (+    module Polysemy.Error+  , module Polysemy.Final+  , runErrorInIOFinal+  ) where++import           Control.Exception hiding (throw, catch)+import qualified Control.Exception as X+import           Data.Typeable (Typeable, typeRep)+import           Polysemy+import           Polysemy.Final+import           Polysemy.Error++------------------------------------------------------------------------------+-- | Run an 'Error' effect as an 'IO' 'Exception'.+--+-- This can be used as an alternative to 'runErrorInIO'+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Error' effects+-- interpreted this way. See 'interpretFinal'.+runErrorInIOFinal+    :: ( Typeable e+       , Member (Final IO) r+       )+    => Sem (Error e ': r) a+    -> Sem r (Either e a)+runErrorInIOFinal sem = withStrategic $ do+  m' <- runS (runErrorAsExcFinal sem)+  s <- getInitialStateS+  pure $+    either+      ((<$ s) . Left . unwrapExc)+      (fmap Right)+    <$> try m'++runErrorAsExcFinal+    :: forall e r a+    .  ( Typeable e+       , Member (Final IO) r+       )+    => Sem (Error e ': r) a+    -> Sem r a+runErrorAsExcFinal = interpretFinal $ \case+  Throw e   -> pure $ throwIO $ WrappedExc e+  Catch m h -> do+    m' <- runS m+    h' <- bindS h+    s  <- getInitialStateS+    pure $ X.catch m' $ \(se :: WrappedExc e) ->+      h' (unwrapExc se <$ s)+++newtype WrappedExc e = WrappedExc { unwrapExc :: e }+  deriving (Typeable)++instance Typeable e => Show (WrappedExc e) where+  show = mappend "WrappedExc: " . show . typeRep++instance (Typeable e) => Exception (WrappedExc e)

@@ -0,0 +1,22 @@+module Polysemy.Final.Fixpoint+  (+    module Polysemy.Fixpoint+  , module Polysemy.Final+  , runFixpointFinal+  ) where++import Polysemy+import Polysemy.Final+import Polysemy.Fixpoint++import Control.Monad.Fix++-----------------------------------------------------------------------------+-- | Run a 'Fixpoint' effect through a final 'MonadFix'+runFixpointFinal :: (Member (Final m) r, MonadFix m)+                 => Sem (Fixpoint ': r) a+                 -> Sem r a+runFixpointFinal = interpretFinal $ \case+  Fixpoint f -> do+    f' <- bindS f+    pure $ mfix f'

@@ -0,0 +1,94 @@+module Polysemy.Final.MTL+  (+    module Polysemy.Final+  , runErrorFinal+  , runReaderFinal+  , runStateFinal+  , runWriterFinal+  ) where++import Control.Monad.Error.Class hiding (Error)+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Writer.Class++import Polysemy+import Polysemy.Final+import Polysemy.Error hiding (throw, catch)+import Polysemy.Reader hiding (ask, local)+import Polysemy.State hiding (get, put)+import Polysemy.Writer hiding (tell, listen, pass)++-----------------------------------------------------------------------------+-- | Run an 'Error' effect through a final 'MonadError'+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'Error' effects+-- interpreted this way. See 'interpretFinal'.+runErrorFinal :: (Member (Final m) r, MonadError e m)+              => Sem (Error e ': r) a+              -> Sem r a+runErrorFinal = interpretFinal $ \case+  Throw e   -> pure $ throwError e+  Catch m h -> do+    m' <- runS m+    h' <- bindS h+    s <- getInitialStateS+    pure $ m' `catchError` (h' . (<$ s))+++-----------------------------------------------------------------------------+-- | Run a 'Reader' effect through a final 'MonadReader'+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'Reader' effects+-- interpreted this way. See 'interpretFinal'.+runReaderFinal :: (Member (Final m) r, MonadReader i m)+               => Sem (Reader i ': r) a+               -> Sem r a+runReaderFinal = interpretFinal $ \case+  Ask       -> liftS ask+  Local f m -> do+    m' <- runS m+    pure $ local f m'++-----------------------------------------------------------------------------+-- | Run a 'State' effect through a 'MonadState'+--+-- Despite the name, the target monad need not actually be the final+-- monad. The "-Final" suffix reflects that this interpreter+-- has the unusual semantics of interpreters that runs+-- effects by embedding them into another monad.+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'State' effects+-- interpreted this way. See 'interpretFinal'.+runStateFinal :: (Member (Lift m) r, MonadState s m)+               => Sem (State s ': r) a+               -> Sem r a+runStateFinal = interpret $ \case+  Get   -> sendM get+  Put s -> sendM (put s)++-----------------------------------------------------------------------------+-- | Run a 'Writer' effect through a final 'MonadWriter'+--+-- /Beware/: Effects that aren't interpreted in terms of the final+-- monad will have local state semantics in regards to 'Writer' effects+-- interpreted this way. See 'interpretFinal'.+runWriterFinal :: (Member (Final m) r, MonadWriter o m)+               => Sem (Writer o ': r) a+               -> Sem r a+runWriterFinal = interpretFinal $ \case+  Tell s    -> liftS (tell s)+  Listen m -> do+    m' <- runS m+    pure $+      (\ ~(s, o) -> (,) o <$> s) <$> listen m'+  Pass m -> do+    m'  <- runS m+    ins <- getInspectorS+    pure $ pass $ do+      t <- m'+      let f = maybe id fst (inspect ins t)+      pure (fmap snd t, f)

@@ -0,0 +1,45 @@+module Polysemy.Final.Resource+  (+    module Polysemy.Resource+  , module Polysemy.Final+  , runResourceFinal+  ) where++import qualified Control.Exception as X+import           Polysemy+import           Polysemy.Resource+import           Polysemy.Final+++------------------------------------------------------------------------------+-- | Run a 'Resource' effect in terms of 'X.bracket' through final 'IO'+--+-- This can be used as an alternative to 'runResourceInIO'+--+-- /Beware/: Effects that aren't interpreted in terms of 'IO'+-- will have local state semantics in regards to 'Resource' effects+-- interpreted this way. See 'interpretFinal'.+--+-- Notably, unlike 'runResourceBase', this is not consistent with+-- 'Polysemy.State.State' unless 'Polysemy.State.runStateInIORef' is used.+-- State that seems like it should be threaded globally throughout 'bracket's+-- /will not be./+--+-- Prefer 'runResourceBase' unless its unsafe or inefficient in the context of+-- your application.+runResourceFinal :: Member (Final IO) r+                 => Sem (Resource ': r) a+                 -> Sem r a+runResourceFinal = interpretFinal $ \case+  Bracket alloc dealloc use -> do+    a <- runS  alloc+    d <- bindS dealloc+    u <- bindS use+    pure $ X.bracket a d u++  BracketOnError alloc dealloc use -> do+    a <- runS  alloc+    d <- bindS dealloc+    u <- bindS use+    pure $ X.bracketOnError a d u+{-# INLINE runResourceFinal #-}

@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.Floodgate+  ( -- * Effect+    Floodgate (..)+    -- * Actions+  , hold+  , release++    -- * Interpretations+  , runFloodgate+  , runFloodgateDry+  ) where++import Control.Monad+import GHC.Types+import Polysemy+import Polysemy.State+import Unsafe.Coerce++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+data Floodgate m a where+  Hold    :: m () -> Floodgate m ()+  Release :: Floodgate m ()++makeSem ''Floodgate+++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+runFloodgate+    :: Sem (Floodgate ': r) a+    -> Sem r a+runFloodgate = fmap snd . runState @[Any] [] . reinterpretH+  ( \case+      Hold m -> do+        m' <- fmap void $ runT m+        -- These 'Any's are here because the monadic action references 'r', and+        -- if we exposed that, 'r' would be an infinite type+        modify (unsafeCoerce @_ @Any (raise $ runFloodgate m') :)+        getInitialStateT++      Release -> do+        ms' <- gets (fmap unsafeCoerce . reverse)+        sequence_ ms'+        getInitialStateT+  )+++------------------------------------------------------------------------------+-- | Like 'runFloodgate', but will do a final flush to 'release' anything that+-- might still be behind the floodgate.+--+-- @since 0.3.1.0+runFloodgateDry+    :: Sem (Floodgate ': r) a+    -> Sem r a+runFloodgateDry m = runFloodgate $ m <* release+

@@ -6,17 +6,28 @@      -- * Actions   , lookupKV+  , lookupOrThrowKV+  , existsKV   , writeKV   , deleteKV   , updateKV+  , modifyKV      -- * Interpretations   , runKVStoreAsState   , runKVStorePurely+  , runKVStoreInRedis   ) where +import           Control.Monad+import           Data.Binary (Binary)+import           Data.ByteString (ByteString) import qualified Data.Map as M+import           Data.Maybe (isJust)+import qualified Database.Redis as R import           Polysemy+import           Polysemy.Error+import           Polysemy.Redis.Utils import           Polysemy.State  @@ -40,6 +51,45 @@ {-# INLINE deleteKV #-}  +------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+lookupOrThrowKV+    :: Members '[ KVStore k v+                , Error e+                ] r+    => (k -> e)+    -> k+    -> Sem r v+lookupOrThrowKV f k =+  fromEither . maybe (Left $ f k) Right =<< lookupKV k+++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+existsKV :: Member (KVStore k v) r => k -> Sem r Bool+existsKV = fmap isJust . lookupKV+++------------------------------------------------------------------------------+-- |+--+-- @since 0.3.1.0+modifyKV+    :: Member (KVStore k v) r+    => v  -- ^ Default value if the key isn't present+    -> (v -> v)+    -> k+    -> Sem r ()+modifyKV d f k =+  lookupKV k >>= \case+    Just v  -> writeKV k $ f v+    Nothing -> writeKV k $ f d++ runKVStoreAsState :: Ord k => Sem (KVStore k v ': r) a -> Sem (State (M.Map k v) ': r) a runKVStoreAsState = reinterpret $ \case   LookupKV k   -> gets $ M.lookup k@@ -54,4 +104,31 @@     -> Sem r (M.Map k v, a) runKVStorePurely m = runState m . runKVStoreAsState {-# INLINE runKVStorePurely #-}+++runKVStoreInRedis+    :: ( Member (Lift R.Redis) r+       , Member (Error R.Reply) r+       , Binary k+       , Binary v+       )+    => (k -> ByteString)+    -> Sem (KVStore k v ': r) a+    -> Sem r a+runKVStoreInRedis pf = interpret $ \case+  LookupKV k -> do+    res <- fromEitherM $ R.hget (pf k) $ putForRedis k+    pure $ fmap getFromRedis res++  UpdateKV k Nothing ->+    void . fromEitherM+         . R.hdel (pf k)+         . pure+         $ putForRedis k++  UpdateKV k (Just v) ->+    void . fromEitherM+         . R.hset (pf k) (putForRedis k)+         $ putForRedis v+{-# INLINE runKVStoreInRedis #-} 

@@ -1,4 +1,3 @@-{-# LANGUAGE BlockArguments  #-} {-# LANGUAGE TemplateHaskell #-}  module Polysemy.Random@@ -35,7 +34,7 @@     => q     -> Sem (Random ': r) a     -> Sem r (q, a)-runRandom q = runState q . reinterpret \case+runRandom q = runState q . reinterpret (\case   Random -> do     ~(a, q') <- gets @q R.random     put q'@@ -44,6 +43,7 @@     ~(a, q') <- gets @q $ R.randomR r     put q'     pure a+                                       ) {-# INLINE runRandom #-}  

@@ -0,0 +1,24 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Polysemy.Redis.Utils where++import           Data.Binary (Binary)+import qualified Data.Binary as B+import           Data.Binary.Get (runGet)+import           Data.Binary.Put (runPut)+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy.Char8 as L+import           GHC.Exts+++newtype Path = Path { getPath :: ByteString }+  deriving (Eq, Ord, Show, IsString)+++putForRedis :: Binary a => a -> ByteString+putForRedis = L.toStrict . runPut . B.put+++getFromRedis :: Binary a => ByteString -> a+getFromRedis = runGet B.get . L.fromStrict+

@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell #-}++module Polysemy.SetStore where++import           Control.Monad+import           Data.Binary (Binary)+import           Data.Foldable+import qualified Data.Set as S+import qualified Database.Redis as R+import           Polysemy+import           Polysemy.Alias+import           Polysemy.Error+import           Polysemy.KVStore+import           Polysemy.Redis.Utils++++data SetStore k v m a where+  AddS :: k -> v -> SetStore k v m ()+  DelS :: k -> v -> SetStore k v m ()+  MemberS :: k -> v -> SetStore k v m Bool++makeSem ''SetStore+++runSetStoreAsKVStore+    :: ( Member (KVStore k (S.Set v)) r+       , Ord v+       )+    => InterpreterOf (SetStore k v) r+runSetStoreAsKVStore = interpret $ \case+  AddS k v ->+    lookupKV k >>= \case+      Just s  -> writeKV k $ S.insert v s+      Nothing -> writeKV k $ S.singleton v+  DelS k v -> do+    ms <- lookupKV k+    for_ ms $ writeKV k . S.delete v+  MemberS k v ->+    pure . maybe False (S.member v) =<< lookupKV k+{-# INLINE runSetStoreAsKVStore #-}+++runSetStoreInRedis+    :: ( Member (Lift R.Redis) r+       , Member (Error R.Reply) r+       , Binary k+       , Binary v+       )+    => (k -> Path)+    -> InterpreterOf (SetStore k v) r+runSetStoreInRedis pf = interpret $ \case+  AddS k v -> void+            . fromEitherM+            . R.sadd (getPath $ pf k)+            . pure+            $ putForRedis v+  DelS k v -> void+            . fromEitherM+            . R.srem (getPath $ pf k)+            . pure+            $ putForRedis v+  MemberS k v -> fromEitherM+               . R.sismember (getPath $ pf k)+               $ putForRedis v+{-# INLINE runSetStoreInRedis #-}+

@@ -1,14 +1,12 @@-{-# LANGUAGE BlockArguments  #-} {-# LANGUAGE TemplateHaskell #-}  module Polysemy.Several-        ( -- * Data-          HList(..)-        , TypeMap-        , TypeConcat-        , runSeveral-        )-where+  ( -- * Data+    HList(..)+  , TypeMap+  , TypeConcat+  , runSeveral+  ) where  import Polysemy import Data.Kind@@ -24,7 +22,6 @@     HNil  :: HList '[]     (:::) :: a -> HList (b :: [Type]) -> HList (a ': b) -type Eff = (Type -> Type) -> Type -> Type ------------------------------------------------------------------------------ -- | A map function over type level lists. For example, the following two -- lines are equivalent:@@ -65,9 +62,10 @@ -- > runStates :: HList t -> Sem (TypeConcat (TypeMap State t) r) a -> Sem r a -- > runStates = runSeveral (fmap (fmap snd) . runState) runSeveral-    :: (forall r k x. k -> Sem (e k ': r) x -> Sem r x)+    :: (forall r' k x. k -> Sem (e k ': r') x -> Sem r' x)     -> HList t     -> Sem (TypeConcat (TypeMap e t) r) a     -> Sem r a runSeveral f (a ::: as) = runSeveral f as . f a runSeveral _ HNil       = id+

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-} @@ -15,7 +14,6 @@ import           Polysemy.ConstraintAbsorber.MonadWriter import           Polysemy.ConstraintAbsorber.MonadError -import qualified Data.Text                     as T import           Test.Hspec import           Control.Monad                 as M @@ -30,8 +28,8 @@ 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+getEnvLength :: S.MonadReader String m => m Int+getEnvLength = S.ask >>= return . length  replicateTell :: S.MonadWriter [Int] m => Int -> Int -> m () replicateTell n m = M.replicateM_ n $ S.tell [m]@@ -43,14 +41,14 @@   return m  -- this one is exceptionally boring-throwOnZero :: S.MonadError T.Text m => Int -> m Int+throwOnZero :: S.MonadError String 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+  :: (S.MonadReader String m, S.MonadWriter [Int] m, S.MonadState Int m)+  => m String someOfAll = do   n <- S.get   S.tell [n]@@ -99,9 +97,9 @@     flip shouldBe (Left "Zero!") . run . runError $ absorbError $ throwOnZero 0    let runRWS-        :: T.Text+        :: String         -> Int-        -> Sem '[Reader T.Text, State Int, Writer [Int]] a+        -> Sem '[Reader String, State Int, Writer [Int]] a         -> ([Int], (Int, a))       runRWS env0 s0 = run . runWriter . runState s0 . runReader env0 

@@ -0,0 +1,164 @@+{-# LANGUAGE RecursiveDo #-}+module FinalSpec where++import Test.Hspec++import Control.Monad.State  hiding (MonadState(..), modify)+import Control.Monad.Except hiding (MonadError(..))+import Control.Monad.Writer hiding (MonadWriter(..), censor)++import Data.Either+import Data.IORef++import Polysemy++import Polysemy.Trace+import Polysemy.State++import Polysemy.Final.Async+import Polysemy.Final.Fixpoint+import Polysemy.Final.Error++import Polysemy.Reader+import Polysemy.Writer+import Polysemy.Final.MTL++data Node a = Node a (IORef (Node a))++mkNode :: (Member (Lift IO) r, Member Fixpoint r)+       => a+       -> Sem r (Node a)+mkNode a = mdo+  let nd = Node a p+  p <- sendM $ newIORef nd+  return nd++linkNode :: Member (Lift IO) r+         => Node a+         -> Node a+         -> Sem r ()+linkNode (Node _ r) b =+  sendM $ writeIORef r b++readNode :: Node a -> a+readNode (Node a _) = a++follow :: Member (Lift IO) r+       => Node a+       -> Sem r (Node a)+follow (Node _ ref) = sendM $ readIORef ref++test1 :: IO (Either Int (String, Int, Maybe Int))+test1 = do+  ref <- newIORef "abra"+  runFinal+    . runStateInIORef ref -- Order of these interpreters don't matter+    . runErrorInIOFinal+    . runFixpointFinal+    . runAsyncFinal+     $ do+     n1 <- mkNode 1+     n2 <- mkNode 2+     linkNode n2 n1+     aw <- async $ do+       linkNode n1 n2+       modify (++"hadabra")+       n2' <- follow n2+       throw (readNode n2')+     m <- await aw `catch` (\s -> return $ Just s)+     n1' <- follow n1+     s <- get+     return (s, readNode n1', m)++test2 :: IO ([String], Either () ())+test2 =+    runFinal+  . runTraceAsList+  . runErrorInIOFinal+  . runAsyncFinal+  $ do+  fut <- async $ do+    trace "Global state semantics?"+  catch (trace "What's that?" *> throw ()) (\_ -> return ())+  _ <- await fut+  trace "Nothing at all."++test3 :: Int -> (Either Bool (([String], Int), Int), [Int])+test3 i =+  let+    g = do+      j  <- ask+      j' <- get+      tell [j, j']+      put (j' + 7)+      trace "message"+      when (j' == 1) $ throw True+      when (j' == 2) $ throw False+      return j+  in+    ($ i)+  . runWriterT+  . runExceptT+  . (`runStateT` 0)+  . runFinal+  . runTraceAsList -- Order of these interpreters don't matter+  . runWriterFinal+  . runStateFinal+  . runErrorFinal+  . runReaderFinal+  $ do+    ask >>= put+    res <-+      censor (++[777]) (local (+1) g)+      `catch`+      (\e -> trace "not" *> if e then throw e else return (-1))+    trace "received"+    j' <- get+    tell [j']+    return res++spec :: Spec+spec = do+  describe "Final on IO" $ do+    it "should terminate successfully, with no exceptions,\+        \ and have global state semantics on State." $ do+      res1 <- test1+      res1 `shouldSatisfy` isRight+      case res1 of+        Right (s, i, j) -> do+          i `shouldBe` 2+          j `shouldBe` Just 1+          s `shouldBe` "abrahadabra"+        _ -> pure ()++    it "should treat trace with local state semantics" $ do+      res2 <- test2+      res2 `shouldBe` (["Nothing at all."], Right ())++  describe "Final with MTL" $ do+    it "should all work without issue" $ do+      let (r, written) = test3 0+      written `shouldBe` [1,0,777,7]+      r `shouldSatisfy` isRight+      case r of+        Right ((lg, ret), st) -> do+          lg `shouldBe` ["message", "received"]+          ret `shouldBe` 1+          st `shouldBe` 7+        _ -> pure ()++    it "should fail, dropping trace, state, and censoring" $ do+      let (r, written) = test3 1+      r `shouldBe` Left True+      written `shouldBe` [2, 1]++    it "should catch exception, locally dropping trace and state, and not censor" $ do+      let (r, written) = test3 2+      written `shouldBe` [3,2,2]+      r `shouldSatisfy` isRight+      case r of+        Right ((lg, ret), st) -> do+          lg `shouldBe` ["not", "received"]+          ret `shouldBe` (-1)+          st `shouldBe` 2+        _ -> pure ()

@@ -0,0 +1,31 @@+module FloodgateSpec where++import Test.Hspec+import Polysemy+import Polysemy.Floodgate+import Polysemy.Trace++spec :: Spec+spec = describe "Floodgate" $ do+  it "should delay held traces until release" $ do+    let (ts, n) = run . runTraceAsList . runFloodgate $ do+          hold $ trace "first1"+          hold $ trace "first2"+          trace "not held"+          hold $ trace "second"+          trace "not held again"+          hold $ trace "third"+          release+          trace "finished"+          pure $ id @Int 17++    n `shouldBe` 17+    ts `shouldBe`+      [ "not held"+      , "not held again"+      , "first1"+      , "first2"+      , "second"+      , "third"+      , "finished"+      ]

@@ -47,12 +47,16 @@   pure $ (a, b, c)  +runReaders :: HList t -> Sem (TypeConcat (TypeMap Reader t) r) a -> Sem r a runReaders = runSeveral runReader +runStates :: HList t -> Sem (TypeConcat (TypeMap State t) r) a -> Sem r a runStates = runSeveral (fmap (fmap snd) . runState) +runConstInputs :: HList t -> Sem (TypeConcat (TypeMap Input t) r) a -> Sem r a runConstInputs = runSeveral runConstInput +spec :: Spec spec = do   describe "runReaders" $ do     let original = runReader 5 . runReader "test" . runReader True $ readerProgram@@ -76,3 +80,4 @@      it "should be equivalent to composed runConstInput" $ do       run original `shouldBe` run new+