summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorisovector <>2019-07-10 16:51:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-07-10 16:51:00 (GMT)
commit5c5c50a6abaea85d4ce27b879f251631d83c7cad (patch)
treeced3fb64c19d4c99a1958a1256d34502462c28f3
parentef6a0c4eaf85c2171f7aeaba897be67743e43d6d (diff)
version 0.4.0.00.4.0.0
-rw-r--r--ChangeLog.md15
-rw-r--r--README.md2
-rw-r--r--polysemy-zoo.cabal49
-rw-r--r--src/Polysemy/Alias.hs6
-rw-r--r--src/Polysemy/ConstraintAbsorber/MonadState.hs2
-rw-r--r--src/Polysemy/ConstraintAbsorber/MonadWriter.hs11
-rw-r--r--src/Polysemy/Final.hs276
-rw-r--r--src/Polysemy/Final/Async.hs38
-rw-r--r--src/Polysemy/Final/Error.hs61
-rw-r--r--src/Polysemy/Final/Fixpoint.hs22
-rw-r--r--src/Polysemy/Final/MTL.hs94
-rw-r--r--src/Polysemy/Final/Resource.hs45
-rw-r--r--src/Polysemy/Floodgate.hs64
-rw-r--r--src/Polysemy/KVStore.hs77
-rw-r--r--src/Polysemy/Random.hs4
-rw-r--r--src/Polysemy/Redis/Utils.hs24
-rw-r--r--src/Polysemy/SetStore.hs67
-rw-r--r--src/Polysemy/Several.hs18
-rw-r--r--test/ConstraintAbsorberSpec.hs16
-rw-r--r--test/FinalSpec.hs164
-rw-r--r--test/FloodgateSpec.hs31
-rw-r--r--test/SeveralSpec.hs5
22 files changed, 1048 insertions, 43 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 13b4b29..dc404c9 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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.
diff --git a/README.md b/README.md
index 22a6e29..6f5c17e 100644
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/polysemy-zoo.cabal b/polysemy-zoo.cabal
index 4df6bbb..618582e 100644
--- a/polysemy-zoo.cabal
+++ b/polysemy-zoo.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
--
-- 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 @@ source-repository head
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 @@ test-suite polysemy-zoo-test
main-is: Main.hs
other-modules:
ConstraintAbsorberSpec
+ FinalSpec
+ FloodgateSpec
IdempotentLoweringSpec
KVStoreSpec
SeveralSpec
@@ -68,19 +85,23 @@ test-suite polysemy-zoo-test
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
diff --git a/src/Polysemy/Alias.hs b/src/Polysemy/Alias.hs
new file mode 100644
index 0000000..eebf7fd
--- /dev/null
+++ b/src/Polysemy/Alias.hs
@@ -0,0 +1,6 @@
+module Polysemy.Alias where
+
+import Polysemy
+
+type InterpreterOf e r = forall x. Sem (e ': r) x -> Sem r x
+
diff --git a/src/Polysemy/ConstraintAbsorber/MonadState.hs b/src/Polysemy/ConstraintAbsorber/MonadState.hs
index a5c5c91..265bac2 100644
--- a/src/Polysemy/ConstraintAbsorber/MonadState.hs
+++ b/src/Polysemy/ConstraintAbsorber/MonadState.hs
@@ -44,7 +44,7 @@ data StateDict s m = StateDict
-- 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)
diff --git a/src/Polysemy/ConstraintAbsorber/MonadWriter.hs b/src/Polysemy/ConstraintAbsorber/MonadWriter.hs
index a9bd23e..d964802 100644
--- a/src/Polysemy/ConstraintAbsorber/MonadWriter.hs
+++ b/src/Polysemy/ConstraintAbsorber/MonadWriter.hs
@@ -28,13 +28,12 @@ absorbWriter
-- '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)
diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs
new file mode 100644
index 0000000..6d65811
--- /dev/null
+++ b/src/Polysemy/Final.hs
@@ -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
diff --git a/src/Polysemy/Final/Async.hs b/src/Polysemy/Final/Async.hs
new file mode 100644
index 0000000..bf4b56b
--- /dev/null
+++ b/src/Polysemy/Final/Async.hs
@@ -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)
diff --git a/src/Polysemy/Final/Error.hs b/src/Polysemy/Final/Error.hs
new file mode 100644
index 0000000..47a12be
--- /dev/null
+++ b/src/Polysemy/Final/Error.hs
@@ -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)
diff --git a/src/Polysemy/Final/Fixpoint.hs b/src/Polysemy/Final/Fixpoint.hs
new file mode 100644
index 0000000..bd51843
--- /dev/null
+++ b/src/Polysemy/Final/Fixpoint.hs
@@ -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'
diff --git a/src/Polysemy/Final/MTL.hs b/src/Polysemy/Final/MTL.hs
new file mode 100644
index 0000000..149e3fb
--- /dev/null
+++ b/src/Polysemy/Final/MTL.hs
@@ -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)
diff --git a/src/Polysemy/Final/Resource.hs b/src/Polysemy/Final/Resource.hs
new file mode 100644
index 0000000..dd2a020
--- /dev/null
+++ b/src/Polysemy/Final/Resource.hs
@@ -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 #-}
diff --git a/src/Polysemy/Floodgate.hs b/src/Polysemy/Floodgate.hs
new file mode 100644
index 0000000..b2bf0b4
--- /dev/null
+++ b/src/Polysemy/Floodgate.hs
@@ -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
+
diff --git a/src/Polysemy/KVStore.hs b/src/Polysemy/KVStore.hs
index 75e53ba..7d80343 100644
--- a/src/Polysemy/KVStore.hs
+++ b/src/Polysemy/KVStore.hs
@@ -6,17 +6,28 @@ module Polysemy.KVStore
-- * 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 @@ deleteKV k = updateKV k Nothing
{-# 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
@@ -55,3 +105,30 @@ runKVStorePurely
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 #-}
+
diff --git a/src/Polysemy/Random.hs b/src/Polysemy/Random.hs
index 2dbf71c..2d6a437 100644
--- a/src/Polysemy/Random.hs
+++ b/src/Polysemy/Random.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE TemplateHaskell #-}
module Polysemy.Random
@@ -35,7 +34,7 @@ runRandom
=> 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 @@ runRandom q = runState q . reinterpret \case
~(a, q') <- gets @q $ R.randomR r
put q'
pure a
+ )
{-# INLINE runRandom #-}
diff --git a/src/Polysemy/Redis/Utils.hs b/src/Polysemy/Redis/Utils.hs
new file mode 100644
index 0000000..02e1fff
--- /dev/null
+++ b/src/Polysemy/Redis/Utils.hs
@@ -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
+
diff --git a/src/Polysemy/SetStore.hs b/src/Polysemy/SetStore.hs
new file mode 100644
index 0000000..634e46a
--- /dev/null
+++ b/src/Polysemy/SetStore.hs
@@ -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 #-}
+
diff --git a/src/Polysemy/Several.hs b/src/Polysemy/Several.hs
index 02f2ef8..d750877 100644
--- a/src/Polysemy/Several.hs
+++ b/src/Polysemy/Several.hs
@@ -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 @@ data HList a where
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 @@ type family TypeConcat (a :: [t]) (b :: [t]) where
-- > 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
+
diff --git a/test/ConstraintAbsorberSpec.hs b/test/ConstraintAbsorberSpec.hs
index 260c4ce..efe9bef 100644
--- a/test/ConstraintAbsorberSpec.hs
+++ b/test/ConstraintAbsorberSpec.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@@ -15,7 +14,6 @@ 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
@@ -30,8 +28,8 @@ 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
+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 @@ retrieveAndUpdateN n = do
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 @@ spec = describe "ConstraintAbsorber" $ do
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
diff --git a/test/FinalSpec.hs b/test/FinalSpec.hs
new file mode 100644
index 0000000..a82abd3
--- /dev/null
+++ b/test/FinalSpec.hs
@@ -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 ()
diff --git a/test/FloodgateSpec.hs b/test/FloodgateSpec.hs
new file mode 100644
index 0000000..3cd5e25
--- /dev/null
+++ b/test/FloodgateSpec.hs
@@ -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"
+ ]
diff --git a/test/SeveralSpec.hs b/test/SeveralSpec.hs
index e9fcc7c..3e61ae6 100644
--- a/test/SeveralSpec.hs
+++ b/test/SeveralSpec.hs
@@ -47,12 +47,16 @@ inputProgram = do
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 @@ spec = do
it "should be equivalent to composed runConstInput" $ do
run original `shouldBe` run new
+