polysemy-zoo 0.4.0.1 → 0.5.0.0
raw patch · 23 files changed
+1229/−55 lines, 23 files
Files
- ChangeLog.md +5/−0
- polysemy-zoo.cabal +10/−2
- src/Polysemy/Capture.hs +145/−0
- src/Polysemy/Cont.hs +109/−0
- src/Polysemy/Cont/Internal.hs +98/−0
- src/Polysemy/Final.hs +16/−14
- src/Polysemy/Final/Async.hs +3/−3
- src/Polysemy/Final/MTL.hs +3/−3
- src/Polysemy/Final/Resource.hs +1/−1
- src/Polysemy/IdempotentLowering.hs +1/−1
- src/Polysemy/KVStore.hs +1/−1
- src/Polysemy/Operators.hs +9/−9
- src/Polysemy/Random.hs +2/−2
- src/Polysemy/SetStore.hs +1/−1
- src/Polysemy/Shift.hs +315/−0
- src/Polysemy/Shift/Internal.hs +97/−0
- test/CaptureSpec.hs +115/−0
- test/ContSpec.hs +154/−0
- test/FinalSpec.hs +9/−9
- test/FloodgateSpec.hs +1/−1
- test/IdempotentLoweringSpec.hs +3/−3
- test/SeveralSpec.hs +5/−5
- test/ShiftSpec.hs +126/−0
ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for polysemy-zoo +## 0.5.0.0 (2019-07-24)++- Added Continuation effects (thanks to @KingoftheHomeless)+- Update to `polysemy-1.0.0.0`'s new names+ ## 0.4.0.1 (2019-07-10) - Fixed an erroneous lower bound in the tests
polysemy-zoo.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9c68e7c2421eb030fe99a14dcd7cc393f3aaf7a1f3874b559a2222ba3073e8ae+-- hash: b5948d18149d91c0146fbe5d3157841cde0905f00af5918f7a69c432059e6db1 name: polysemy-zoo-version: 0.4.0.1+version: 0.5.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@@ -30,11 +30,14 @@ library exposed-modules: Polysemy.Alias+ Polysemy.Capture Polysemy.ConstraintAbsorber Polysemy.ConstraintAbsorber.MonadError Polysemy.ConstraintAbsorber.MonadReader Polysemy.ConstraintAbsorber.MonadState Polysemy.ConstraintAbsorber.MonadWriter+ Polysemy.Cont+ Polysemy.Cont.Internal Polysemy.Final Polysemy.Final.Async Polysemy.Final.Error@@ -49,6 +52,8 @@ Polysemy.Redis.Utils Polysemy.SetStore Polysemy.Several+ Polysemy.Shift+ Polysemy.Shift.Internal other-modules: Paths_polysemy_zoo hs-source-dirs:@@ -75,12 +80,15 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules:+ CaptureSpec ConstraintAbsorberSpec+ ContSpec FinalSpec FloodgateSpec IdempotentLoweringSpec KVStoreSpec SeveralSpec+ ShiftSpec Paths_polysemy_zoo hs-source-dirs: test
+ src/Polysemy/Capture.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.Capture+ (-- * Effect+ Capture(..)++ -- * Actions+ , reify+ , reflect+ , delimit+ , delimit'+ , capture++ -- * Interpretations+ , runCapture+ , runCaptureWithC++ -- * Prompt types+ , Ref(..)+ ) where++import Control.Monad+import Control.Monad.Cont (ContT(..))++import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Union++import Polysemy.Cont.Internal(Ref(..))++-----------------------------------------------------------------------------+-- | A less powerful variant of 'Polysemy.Shift.Shift' that may always be+-- interpreted safely. Unlike 'Polysemy.Shift.Shift',+-- continuations can't leave the scope in which they are provided.+--+-- __Note__: Any computation used in a higher-order effect will+-- be delimited.+--+-- Activating polysemy-plugin is highly recommended when using this effect+-- in order to avoid ambiguous types.+data Capture ref m a where+ Reify :: (forall s. ref s a -> m s) -> Capture ref m a+ Reflect :: ref s a -> a -> Capture ref m s+ Delimit :: m a -> Capture ref m a+ Delimit' :: m a -> Capture ref m (Maybe a)++makeSem ''Capture++-----------------------------------------------------------------------------+-- | Reifies the current continuation in the form of a prompt, and passes it to+-- the first argument.+-- reify :: forall ref a r+-- . Member (Capture ref) r+-- => (forall s. ref s a -> Sem r s)+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Provide an answer to a prompt, jumping to its reified continuation.+-- This will not abort the current continuation, and the+-- reified computation will return its final result when finished.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases. To do so,+-- use 'delimit\'' together with 'reflect' (the reified continuation+-- is already delimited).+-- reflect :: forall ref a x r+-- . Member (Capture ref) r+-- => ref a x+-- -> x+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Delimits any continuations+-- delimit :: forall ref a r+-- . Member (Capture ref) r+-- => Sem r a+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Delimits any continuations, and detects if any subcontinuation+-- has failed locally.+-- delimit' :: forall ref a r+-- . Member (Capture ref) r+-- => Sem r a+-- -> Sem r (Maybe a)++-----------------------------------------------------------------------------+-- | A restricted version of 'Polysemy.Shift.shift'.+-- Executing the provided continuation will not abort execution.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases, in+-- which case such failure may be detected by using 'delimit\'' together+-- with the provided continuation (the provided continuation+-- is already delimited).+capture :: Member (Capture ref) r+ => (forall s. (a -> Sem r s) -> Sem r s)+ -> Sem r a+capture cc = reify (\ref -> cc (reflect ref))+{-# INLINE capture #-}++-----------------------------------------------------------------------------+-- | Runs a 'Capture' effect by providing 'pure '.' Just' as the final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+runCapture :: Sem (Capture (Ref (Sem r))': r) a -> Sem r (Maybe a)+runCapture = runCaptureWithC (pure . Just)+{-# INLINE runCapture #-}++-----------------------------------------------------------------------------+-- | Runs a 'Capture' effect by explicitly providing a final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+runCaptureWithC :: (a -> Sem r (Maybe s))+ -> Sem (Capture (Ref (Sem r)) ': r) a+ -> Sem r (Maybe s)+runCaptureWithC c (Sem m) = (`runContT` c) $ m $ \u ->+ case decomp u of+ Right (Weaving e s wv ex ins) ->+ ContT $ \c' ->+ case e of+ Reflect ref a ->+ runRef ref a+ >>= c' . ex . (<$ s)+ Reify main ->+ runCaptureWithC+ (pure . join . ins)+ (wv (main (Ref (c' . ex . (<$ s))) <$ s))+ Delimit main ->+ runCaptureWithC+ (pure . Just)+ (wv (main <$ s))+ >>= maybe (pure Nothing) (c' . ex)+ Delimit' main ->+ runCaptureWithC+ (pure . Just)+ (wv (main <$ s))+ >>= maybe (c' (ex (Nothing <$ s))) (c' . ex . fmap Just)+ Left g -> ContT $ \c' ->+ liftSem (weave (Just ()) (maybe (pure Nothing) runCapture) id g)+ >>= maybe (pure Nothing) c'+{-# INLINE runCaptureWithC #-}
+ src/Polysemy/Cont.hs view
@@ -0,0 +1,109 @@+module Polysemy.Cont+ (-- * Effect+ Cont(..)++ -- * Actions+ , jump+ , subst+ , callCC++ -- * Interpretations+ , runContPure+ , runContM+ , runContFinal++ -- * Unsafe Interpretations+ , runContUnsafe++ -- * Prompt types+ , Ref(..)+ , ExitRef(..)+ ) where++import Data.Void++import Polysemy+import Polysemy.Final++import Polysemy.Cont.Internal++import Control.Monad.Cont (MonadCont())+import qualified Control.Monad.Cont as C (callCC)++-----------------------------------------------------------------------------+-- | Call with current continuation.+-- Executing the provided continuation will abort execution.+--+-- Using the provided continuation+-- will rollback all effectful state back to the point where 'callCC' was invoked,+-- unless such state is interpreted in terms of the final+-- monad, /or/ the associated interpreter of the effectful state+-- is run after 'runContUnsafe', which may be done if the effect isn't+-- higher-order.+--+-- Higher-order effects do not interact with the continuation in any meaningful+-- way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does not affect+-- it, and 'Polysemy.Error.catch' will fail to catch any of its exceptions.+-- The only exception to this is if you interpret such effects /and/ 'Cont'+-- in terms of the final monad, and the final monad can perform such interactions+-- in a meaningful manner.+callCC :: forall ref a r.+ Member (Cont ref) r+ => ((forall b. a -> Sem r b) -> Sem r a)+ -> Sem r a+callCC cc = subst (\ref -> cc (jump ref)) pure+{-# INLINE callCC #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.+--+-- This is a safe variant of 'runContUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runContPure :: Sem '[Cont (Ref (Sem '[]) a)] a -> Sem '[] a+runContPure = runContUnsafe+{-# INLINE runContPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.+--+-- This is a safe variant of 'runContUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runContM :: Sem '[Cont (Ref (Sem '[Embed m]) a), Embed m] a -> Sem '[Embed m] a+runContM = runContUnsafe+{-# INLINE runContM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect in terms of a final 'MonadCont'+--+-- /Beware/: Effects that aren't interpreted in terms of the final monad+-- will have local state semantics in regards to 'Cont' effects+-- interpreted this way. See 'interpretFinal'.+runContFinal :: (Member (Final m) r, MonadCont m)+ => Sem (Cont (ExitRef m) ': r) a+ -> Sem r a+runContFinal = interpretFinal $ \case+ Jump ref a -> pure $ enterExit ref a+ Subst main cb -> do+ main' <- bindS main+ cb' <- bindS cb+ s <- getInitialStateS+ pure $ C.callCC $ \exit ->+ main' (ExitRef (\a -> cb' (a <$ s) >>= vacuous . exit) <$ s)+{-# INLINE runContFinal #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing 'pure' as the final continuation.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runContUnsafe' /after/ running all interpreters for+-- your higher-order effects.__+--+-- Note that 'Final' is a higher-order effect, and thus 'runContUnsafe' can't+-- safely be used together with 'runFinal'.+runContUnsafe :: Sem (Cont (Ref (Sem r) a) ': r) a -> Sem r a+runContUnsafe = runContWithCUnsafe pure+{-# INLINE runContUnsafe #-}
+ src/Polysemy/Cont/Internal.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.Cont.Internal where++import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Union+import Control.Monad+import Control.Monad.Cont (ContT(..))++-----------------------------------------------------------------------------+-- | An effect for abortive continuations.+--+-- Formulated à la Tom Schrijvers et al.+-- "Monad Transformers and Modular Algebraic Effects: What Binds Them Together"+-- (2016). <http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW699.pdf>+--+-- Activating polysemy-plugin is highly recommended when using this effect+-- in order to avoid ambiguous types.+data Cont ref m a where+ Jump :: ref a -> a -> Cont ref m b+ Subst :: (ref a -> m b) -> (a -> m b) -> Cont ref m b++makeSem ''Cont++-----------------------------------------------------------------------------+-- | Provide an answer to a prompt, jumping to its reified continuation,+-- and aborting the current continuation.+--+-- Using 'jump' will rollback all effectful state back to the point where the+-- prompt was created, unless such state is interpreted in terms of the final+-- monad, /or/ the associated interpreter of the effectful state+-- is run after 'runContUnsafe', which may be done if the effect isn't+-- higher-order.+--+-- Higher-order effects do not interact with the continuation in any meaningful+-- way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does not affect+-- it, and 'Polysemy.Error.catch' will fail to catch any of its exceptions.+-- The only exception to this is if you interpret such effects /and/ 'Cont'+-- in terms of the final monad, and the final monad can perform such interactions+-- in a meaningful manner.+-- jump :: forall ref x a r.+-- Member (Cont ref) r+-- => ref x+-- -> x+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Reifies the current continuation in the form of a prompt, and passes it to+-- the first argument. If the prompt becomes invoked via 'jump', then the+-- second argument will be run before the reified continuation, and otherwise+-- will not be called at all.+-- subst :: forall ref x a r.+-- Member (Cont ref) r+-- => (ref x -> Sem r a)+-- -> (x -> Sem r a)+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Runs a 'Cont' effect by providing a final continuation.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runContUnsafeWithC' /after/ running all interpreters+-- for your higher-order effects.__+runContWithCUnsafe :: (a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) ': r) a -> Sem r s+runContWithCUnsafe c (Sem m) = (`runContT` c) $ m $ \u -> case decomp u of+ Right weaving -> runContWeaving runContWithCUnsafe weaving+ Left g -> ContT $ \c' -> embedSem g >>= runContWithCUnsafe c'+{-# INLINE runContWithCUnsafe #-}++runContWeaving :: Monad m+ => (forall x. (x -> m s) -> Sem r x -> m s)+ -> Weaving (Cont (Ref m s)) (Sem r) a+ -> ContT s m a+runContWeaving runW (Weaving e s wv ex _) =+ ContT $ \c ->+ case e of+ Jump ref a -> runRef ref a+ Subst main cb ->+ let+ callback a = runW (c . ex) (wv (cb a <$ s))+ in+ runW (c . ex) (wv (main (Ref callback) <$ s))+{-# INLINE runContWeaving #-}++inspectSem :: Sem r a -> Maybe a+inspectSem (Sem m) = m (\_ -> Nothing)+{-# INLINE inspectSem #-}++embedSem :: Union r (Sem r') a -> Sem r (Sem r' a)+embedSem = liftSem . weave (pure ()) (pure . join) inspectSem+{-# INLINE embedSem #-}++newtype Ref m s a = Ref { runRef :: a -> m s }+newtype ExitRef m a = ExitRef { enterExit :: forall b. a -> m b }
src/Polysemy/Final.hs view
@@ -73,8 +73,10 @@ ----------------------------------------------------------------------------- -- | 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,+-- 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,@@ -156,7 +158,7 @@ -- 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 '[]+type WithStrategy m f n = WithTactics (Embed m) f n '[] ------------------------------------------------------------------------------ -- | Get a natural transformation capable of potentially inspecting values@@ -181,7 +183,7 @@ {-# INLINE getInitialStateS #-} --------------------------------------------------------------------------------- | Lift a value into 'Strategic'.+-- | Embed a value into 'Strategic'. pureS :: Applicative m => a -> Strategic m n a pureS = fmap pure . pureT {-# INLINE pureS #-}@@ -211,7 +213,7 @@ {-# INLINE runS #-} --------------------------------------------------------------------------------- | Lift a kleisli action into the stateful environment, in terms of the final+-- | Embed 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@.@@ -230,7 +232,7 @@ 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+ HoistInterpretation na -> embed . wv . fmap na GetInspector -> Inspector ins {-# INLINE runStrategy #-} @@ -239,12 +241,12 @@ -- 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 :: Monad m => Sem '[Final m, Embed 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+ Weaving (Embed m) s _ ex _ -> ex . (<$ s) <$> m {-# INLINE runFinal #-} ------------------------------------------------------------------------------@@ -255,28 +257,28 @@ -- 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/.+-- used, 'runFinalLift' may become /unsafe/. ----- For example, 'runFinalTrans' is unsafe with 'runAsync' if+-- For example, 'runFinalLift' is unsafe with 'Polysemy.Async.asyncToIO' 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+ -> Sem [Final m, Embed m, Embed 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+ Right (Weaving (Embed m) s _ ex _) -> ex . (<$ s) <$> m Left g' -> case extract g' of- Weaving (Lift n) s _ ex _ -> ex . (<$ s) <$> nat n+ Weaving (Embed n) s _ ex _ -> ex . (<$ s) <$> nat n {-# INLINE runFinalLift #-} ------------------------------------------------------------------------------ -- | 'runFinalLift', specialized to transform 'IO' to a 'MonadIO'. runFinalLiftIO :: MonadIO m- => Sem [Final m, Lift m, Lift IO] a+ => Sem [Final m, Embed m, Embed IO] a -> m a runFinalLiftIO = runFinalLift liftIO {-# INLINE runFinalLiftIO #-}
src/Polysemy/Final/Async.hs view
@@ -14,18 +14,18 @@ ------------------------------------------------------------------------------ -- | Run an 'Async' effect through final 'IO' ----- This can be used as an alternative to 'runAsyncInIO'.+-- This can be used as an alternative to 'lowerAsync'. -- -- /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+-- Notably, unlike 'asyncToIO', 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+-- Prefer 'asyncToIO' unless its unsafe or inefficient in the context of your -- application. runAsyncFinal :: Member (Final IO) r => Sem (Async ': r) a
src/Polysemy/Final/MTL.hs view
@@ -64,12 +64,12 @@ -- /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)+runStateFinal :: (Member (Embed m) r, MonadState s m) => Sem (State s ': r) a -> Sem r a runStateFinal = interpret $ \case- Get -> sendM get- Put s -> sendM (put s)+ Get -> embed get+ Put s -> embed (put s) {-# INLINE runStateFinal #-} -----------------------------------------------------------------------------
src/Polysemy/Final/Resource.hs view
@@ -25,7 +25,7 @@ -- 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+-- Prefer 'runResourceBase' unless it's unsafe or inefficient in the context of -- your application. runResourceFinal :: Member (Final IO) r => Sem (Resource ': r) a
src/Polysemy/IdempotentLowering.hs view
@@ -96,7 +96,7 @@ ------------------------------------------------------------------------------ -- | Like '.@!', but for interpreters which change the resulting type --- eg.--- 'Polysemy.Error.runErrorInIO'.+-- 'Polysemy.Error.lowerError. -- -- @since 0.1.1.0 (.@@!)
src/Polysemy/KVStore.hs view
@@ -107,7 +107,7 @@ runKVStoreInRedis- :: ( Member (Lift R.Redis) r+ :: ( Member (Embed R.Redis) r , Member (Error R.Reply) r , Binary k , Binary v
src/Polysemy/Operators.hs view
@@ -3,7 +3,7 @@ -- interpreters in more concise way, without mentioning unnecessary details: -- -- @--- foo :: 'Member' ('Lift' 'IO') r => 'String' -> 'Int' -> 'Sem' r ()+-- foo :: 'Member' ('Embed' 'IO') r => 'String' -> 'Int' -> 'Sem' r () -- @ -- -- can be written simply as:@@ -27,7 +27,7 @@ -- -- 'makeSem' ''ConsoleIO ----- -- runConsoleIO :: Member (Lift IO) r => Sem (ConsoleIO : r) a -> Sem r a+-- -- runConsoleIO :: Member (Embed IO) r => Sem (ConsoleIO : r) a -> Sem r a -- runConsoleIO :: ConsoleIO : r '@>' a -> 'IO' '~@' r '@>' a -- runConsoleIO = 'interpret' \\case -- WriteStrLn s -> 'sendM' '$' 'putStrLn' s@@ -64,7 +64,7 @@ -- constraint instead: -- -- @--- foo :: 'Member' ('Lift' 'IO') r+-- foo :: 'Member' ('Embed' 'IO') r -- => (forall x. r '@>' x -> 'IO' x) -- -> 'IO' (forall a. Foo : r '@>' a -> r '@>' a) -- @@@ -143,7 +143,7 @@ -- 'Sem' with __exactly__ one, lifted monad: -- -- @--- foo :: 'Sem' \'['Lift' 'IO'] ()+-- foo :: 'Sem' \'['Embed' 'IO'] () -- @ -- -- can be written simply as:@@ -157,7 +157,7 @@ type (@>) = Sem type (@-) e = Sem '[e]-type (@~) m = Sem '[Lift m]+type (@~) m = Sem '[Embed m] -- $MemberOperators -- Infix equivalents of 'Member'(s) constraint used directly in /return/ type,@@ -201,7 +201,7 @@ -- __Exactly__ one, lifted monad as a member: -- -- @--- foo :: 'Member' ('Lift' 'IO') r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r ()+-- foo :: 'Member' ('Embed' 'IO') r => 'Sem' ('Polysemy.Output.Output' ['String'] : r) () -> 'Sem' r () -- @ -- -- can be written simply as:@@ -213,7 +213,7 @@ type (>@) es s = Members es (SemList s) => s type (-@) e s = Member e (SemList s) => s-type (~@) m s = Member (Lift m) (SemList s) => s+type (~@) m s = Member (Embed m) (SemList s) => s -- $CombinedOperators -- Joined versions of one of ('>@'), ('-@'), ('~@') and ('@>') with implicit,@@ -255,7 +255,7 @@ -- __Exactly__ one, lifted monad as a member: -- -- @--- foo :: 'Member' ('Lift' 'IO') r => 'Sem' r ()+-- foo :: 'Member' ('Embed' 'IO') r => 'Sem' r () -- @ -- -- can be written simply as:@@ -267,4 +267,4 @@ type (>@>) es a = forall r. Members es r => Sem r a type (-@>) e a = forall r. Member e r => Sem r a-type (~@>) m a = forall r. Member (Lift m) r => Sem r a+type (~@>) m a = forall r. Member (Embed m) r => Sem r a
src/Polysemy/Random.hs view
@@ -49,9 +49,9 @@ ------------------------------------------------------------------------------ -- | Run a 'Random' effect by using the 'IO' random generator.-runRandomIO :: Member (Lift IO) r => Sem (Random ': r) a -> Sem r a+runRandomIO :: Member (Embed IO) r => Sem (Random ': r) a -> Sem r a runRandomIO m = do- q <- sendM R.newStdGen+ q <- embed R.newStdGen snd <$> runRandom q m {-# INLINE runRandomIO #-}
src/Polysemy/SetStore.hs view
@@ -42,7 +42,7 @@ runSetStoreInRedis- :: ( Member (Lift R.Redis) r+ :: ( Member (Embed R.Redis) r , Member (Error R.Reply) r , Binary k , Binary v
+ src/Polysemy/Shift.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.Shift+ (+ module Polysemy.Cont+ -- * Effect+ , Shift(..)++ -- * Actions+ , trap+ , invoke+ , abort+ , reset+ , reset'+ , shift++ -- * Interpretations+ , runShiftPure+ , runShiftM+ , runShiftFinal+ , runShiftWithCPure+ , runShiftWithCM++ , runContShiftPure+ , runContShiftM+ , runContShiftWithCPure+ , runContShiftWithCM++ -- * Unsafe Interpretations+ , runShiftUnsafe+ , runShiftWithCUnsafe+ , runContShiftUnsafe+ , runContShiftWithCUnsafe+ ) where+++import Polysemy+import Polysemy.Cont+import Polysemy.Cont.Internal+import Polysemy.Shift.Internal+import Polysemy.Final+import Control.Monad.Cont (ContT(..))++import Polysemy.Internal+import Polysemy.Internal.Union+++-----------------------------------------------------------------------------+-- | A variant of 'callCC'.+-- Executing the provided continuation will not abort execution.+--+-- Any effectful state of effects which have been run before the interpreter for+-- 'Shift' will be embedded in the return value of the continuation,+-- and therefore the continuation won't have any apparent effects unless these+-- effects are interpreted in the final monad.+--+-- Any higher-order actions will also not interact with the continuation in any+-- meaningful way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does+-- not affect it, 'Polysemy.Error.catch' will fail to catch any of its exceptions,+-- and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases, in+-- which case such failure may be detected by using 'reset\'' together+-- with the provided continuation.+shift :: Member (Shift ref s) r+ => ((a -> Sem r s) -> Sem r s)+ -> Sem r a+shift cc = trap $ \ref -> cc (invoke ref)+{-# INLINE shift #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by providing @'pure' '.' 'Just'@ as the final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runShiftPure :: Sem '[Shift (Ref (Sem '[]) (Maybe a)) a] a+ -> Sem '[] (Maybe a)+runShiftPure = runShiftUnsafe+{-# INLINE runShiftPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by providing @'pure' '.' 'Just'@ as the final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runShiftM :: Sem '[Shift (Ref (Sem '[Embed m]) (Maybe a)) a, Embed m] a+ -> Sem '[Embed m] (Maybe a)+runShiftM = runShiftUnsafe+{-# INLINE runShiftM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect in terms of a final 'ContT'+--+-- /Beware/: Effects that aren't interpreted in terms of the final monad+-- will have local state semantics in regards to 'Shift' effects+-- interpreted this way. See 'interpretFinal'.+runShiftFinal :: forall s m a r+ . (Member (Final (ContT (Maybe s) m)) r, Monad m)+ => Sem (Shift (Ref m (Maybe s)) s ': r) a+ -> Sem r a+runShiftFinal = interpretFinal $ \case+ Trap main -> do+ main' <- bindS main+ s <- getInitialStateS+ Inspector ins <- getInspectorS+ pure $ ContT $ \c ->+ runContT (main' (Ref (c . (<$ s)) <$ s)) (pure . ins)+ Invoke ref a -> liftS $ ContT $ \c -> runRef ref a >>= maybe (pure Nothing) c+ Abort s -> pure $ ContT $ \_ -> pure (Just s)+ Reset main -> do+ main' <- runS main+ Inspector ins <- getInspectorS+ liftS $ ContT $ \c ->+ runContT main' (pure . ins) >>= maybe (pure Nothing) c+ Reset' main -> do+ main' <- runS main+ Inspector ins <- getInspectorS+ liftS $ ContT $ \c ->+ runContT main' (pure . ins) >>= c+{-# INLINE runShiftFinal #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by explicitly providing a final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runShiftWithCUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runShiftWithCPure :: (a -> Sem '[] (Maybe b))+ -> Sem '[Shift (Ref (Sem '[]) (Maybe b)) b] a+ -> Sem '[] (Maybe b)+runShiftWithCPure = runShiftWithCUnsafe+{-# INLINE runShiftWithCPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by explicitly providing a final+-- continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runShiftWithCUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runShiftWithCM :: (a -> Sem '[Embed m] (Maybe b))+ -> Sem '[Shift (Ref (Sem '[Embed m]) (Maybe b)) b, Embed m] a+ -> Sem '[Embed m] (Maybe b)+runShiftWithCM = runShiftWithCUnsafe+{-# INLINE runShiftWithCM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by providing+-- @'pure' '.' 'Just'@ as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftUnsafe', as this may only be used+-- as the final interpreter before 'run'.+runContShiftPure :: Sem [ Cont (Ref (Sem '[]) (Maybe a))+ , Shift (Ref (Sem '[]) (Maybe a)) a+ ] a+ -> Sem '[] (Maybe a)+runContShiftPure = runContShiftUnsafe+{-# INLINE runContShiftPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by providing+-- @'pure' '.' 'Just'@ as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runContShiftM :: Sem [ Cont (Ref (Sem '[Embed m]) (Maybe a))+ , Shift (Ref (Sem '[Embed m]) (Maybe a)) a+ , Embed m+ ] a+ -> Sem '[Embed m] (Maybe a)+runContShiftM = runContShiftUnsafe+{-# INLINE runContShiftM #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by explicitly providing+-- a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftWithCUnsafe', as this may only be+-- used as the final interpreter before 'run'.+runContShiftWithCPure :: (a -> Sem '[] (Maybe s))+ -> Sem [ Cont (Ref (Sem '[]) (Maybe s))+ , Shift (Ref (Sem '[]) (Maybe s)) s+ ] a+ -> Sem '[] (Maybe s)+runContShiftWithCPure = runContShiftWithCUnsafe+{-# INLINE runContShiftWithCPure #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by explicitly providing+-- a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- This is a safe variant of 'runContShiftWithCUnsafe', as this may only be used+-- as the final interpreter before 'runM'.+runContShiftWithCM :: (a -> Sem '[Embed m] (Maybe s))+ -> Sem [ Cont (Ref (Sem '[Embed m]) (Maybe s))+ , Shift (Ref (Sem '[Embed m]) (Maybe s)) s+ , Embed m+ ] a+ -> Sem '[Embed m] (Maybe s)+runContShiftWithCM = runContShiftWithCUnsafe+{-# INLINE runContShiftWithCM #-}+++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by providing @'pure' '.' 'Just'@+-- as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runShift' /after/ running all interpreters for+-- your higher-order effects.__+runShiftUnsafe :: Sem (Shift (Ref (Sem r) (Maybe a)) a ': r) a -> Sem r (Maybe a)+runShiftUnsafe = runShiftWithCUnsafe (pure . Just)+{-# INLINE runShiftUnsafe #-}++-----------------------------------------------------------------------------+-- | Runs a 'Shift' effect by explicitly providing a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that any+-- continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runShiftWithC' /after/ running all interpreters for+-- your higher-order effects.__+runShiftWithCUnsafe :: forall s a r.+ (a -> Sem r (Maybe s))+ -> Sem (Shift (Ref (Sem r) (Maybe s)) s ': r) a+ -> Sem r (Maybe s)+runShiftWithCUnsafe c (Sem sem) = (`runContT` c) $ sem $ \u -> case decomp u of+ Right weaving -> runShiftWeaving runShiftWithCUnsafe weaving+ Left g -> ContT $ \c' -> embedSem g >>= runShiftWithCUnsafe c'+{-# INLINE runShiftWithCUnsafe #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by providing+-- @'pure' '.' 'Just'@ as the final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runShift' /after/ running all interpreters for+-- your higher-order effects.__+runContShiftUnsafe :: Sem ( Cont (Ref (Sem r) (Maybe a))+ ': Shift (Ref (Sem r) (Maybe a)) a+ ': r) a+ -> Sem r (Maybe a)+runContShiftUnsafe = runContShiftWithCUnsafe (pure . Just)+{-# INLINE runContShiftUnsafe #-}++-----------------------------------------------------------------------------+-- | Runs a 'Cont' and a 'Shift' effect simultaneously by explicitly providing+-- a final continuation.+--+-- The final return type is wrapped in a 'Maybe' due to the fact that+-- any continuation may fail locally.+--+-- __Beware__: This interpreter will invalidate all higher-order effects of any+-- interpreter run after it; i.e. 'Polysemy.Reader.local' and+-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail+-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- __You should therefore use 'runShift' /after/ running all interpreters for+-- your higher-order effects.__+runContShiftWithCUnsafe :: forall s a r.+ (a -> Sem r (Maybe s))+ -> Sem ( Cont (Ref (Sem r) (Maybe s))+ ': Shift (Ref (Sem r) (Maybe s)) s+ ': r) a+ -> Sem r (Maybe s)+runContShiftWithCUnsafe c (Sem m) = (`runContT` c) $ m $ \u -> case decomp u of+ Right weaving -> runContWeaving runContShiftWithCUnsafe weaving+ Left g -> case decomp g of+ Right weaving -> runShiftWeaving runContShiftWithCUnsafe weaving+ Left g' -> ContT $ \c' -> embedSem g' >>= runContShiftWithCUnsafe c'+{-# INLINE runContShiftWithCUnsafe #-}
+ src/Polysemy/Shift/Internal.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.Shift.Internal where++import Polysemy+import Polysemy.Internal.Union+import Polysemy.Cont.Internal (Ref(..))+import Control.Monad.Cont (ContT(..))++-----------------------------------------------------------------------------+-- | An effect for delimited continuations, formulated algebraically+-- through a variant of the 'Polysemy.Cont.Jump/'Polysemy.Cont.Subst'+-- formulation of abortive continuations.+--+-- Activating polysemy-plugin is highly recommended when using this effect+-- in order to avoid ambiguous types.+data Shift ref s m a where+ Trap :: (ref a -> m s) -> Shift ref s m a+ Invoke :: ref a -> a -> Shift ref s m s+ Abort :: s -> Shift ref s m a+ Reset :: m s -> Shift ref s m s+ Reset' :: m s -> Shift ref s m (Maybe s)++makeSem ''Shift++-----------------------------------------------------------------------------+-- | Reifies the current continuation in the form of a prompt, and passes it to+-- the first argument. Unlike 'subst', control will never return to the current+-- continuation unless the prompt is invoked via 'release'.+-- trap :: forall ref s a r+-- . Member (Shift ref s) r+-- => (ref a -> Sem r s)+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Provide an answer to a prompt, jumping to its reified continuation.+-- Unlike 'jump', this will not abort the current continuation, and the+-- reified computation will instead return its final result when finished.+--+-- Any effectful state of effects which have been run before the interpreter for+-- 'Shift' will be embedded in the return value, and therefore the invocation+-- won't have any apparent effects unless these are interpreted in the final+-- monad.+--+-- Any higher-order actions will also not interact with the continuation in any+-- meaningful way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does+-- not affect it, 'Polysemy.Error.catch' will fail to catch any of its exceptions,+-- and 'Polysemy.Writer.listen' will always return 'mempty'.+--+-- The provided continuation may fail locally in its subcontinuations.+-- It may sometimes become necessary to handle such cases. To do so,+-- use 'reset\'' together with 'release'.+-- invoke :: forall ref a x r+-- . Member (Shift ref a) r+-- => ref x+-- -> x+-- -> Sem r a+++-----------------------------------------------------------------------------+-- | Aborts the current continuation with a result.+-- abort :: forall ref s a r+-- . Member (Shift ref s) r+-- => s+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Delimits any continuations and calls to 'abort'.+-- reset :: forall ref a r+-- . Member (Shift ref a) r+-- => Sem r a+-- -> Sem r a++-----------------------------------------------------------------------------+-- | Delimits any continuations and calls to 'abort', and detects if+-- any subcontinuation has failed locally.+-- reset' :: forall ref s r+-- . Member (Shift ref s) r+-- => Sem r s+-- -> Sem r (Maybe s)++runShiftWeaving :: Monad m+ => (forall x. (x -> m (Maybe s)) -> Sem r x -> m (Maybe s))+ -> Weaving (Shift (Ref m (Maybe s)) s) (Sem r) a+ -> ContT (Maybe s) m a+runShiftWeaving runW (Weaving e s wv ex ins) =+ fmap (ex . (<$ s)) $ ContT $ \c ->+ case e of+ Trap main ->+ runW (pure . ins) $ wv (main (Ref c) <$ s)+ Invoke ref a ->+ runRef ref a >>= maybe (pure Nothing) c+ Abort t -> pure (Just t)+ Reset main ->+ runW (pure . ins) (wv (main <$ s)) >>= maybe (pure Nothing) c+ Reset' main ->+ runW (pure . ins) (wv (main <$ s)) >>= c+{-# INLINE runShiftWeaving #-}
+ test/CaptureSpec.hs view
@@ -0,0 +1,115 @@+module CaptureSpec where++import Test.Hspec++import Polysemy+import Polysemy.Capture+import Polysemy.Writer+import Polysemy.Reader+import Polysemy.Error++test1 :: (String, Maybe ())+test1 =+ run+ . runReader (1 :: Int)+ . runWriter+ . runCapture+ $ do+ capture $ \c -> do+ _ <- local (+1) (c ())+ _ <- censor (show . (+2) . (read :: String -> Int)) (c ())+ tell "important"+ local (+3) (c ())+ j <- ask+ tell (show j)++test2 :: (String, Maybe ())+test2 =+ run+ . runReader (1 :: Int)+ . runWriter+ . runCapture+ $ do+ delimit $ capture $ \c -> do+ _ <- local (+1) (c ())+ _ <- local (+2) (c ())+ tell "important"+ local (+3) (c ())+ j <- ask+ tell (show j)++test3 :: (String, Maybe ())+test3 =+ run+ . runReader (1 :: Int)+ . runWriter+ . runCapture+ $ do+ censor (++"!") $ capture $ \c -> do+ _ <- local (+1) (c ())+ _ <- local (+2) (c ())+ tell "important"+ local (+3) (c ())+ j <- ask+ tell (show j)++test4 :: Maybe (String, ())+test4 =+ run+ . runReader (1 :: Int)+ . runCapture+ . runWriter+ $ do+ capture $ \c -> do+ _ <- local (+1) (c ())+ _ <- local (+2) (c ())+ tell "important"+ local (+3) (c ())+ j <- ask+ tell (show j)++test5 :: Maybe (Either () ())+test5 =+ run+ . runCapture+ . runError+ $ do+ capture $ \_ -> do+ throw ()++test6 :: Maybe (Either () ())+test6 =+ run+ . runCapture+ . runError+ $ do+ r <- delimit' $ capture $ \_ -> do+ throw ()+ case r of+ Just g -> return g+ _ -> return ()++spec :: Spec+spec = do+ describe "runCapture" $ do+ it "should have global state semantics, and\+ \ have higher-order effects affect continuations" $+ test1 `shouldBe` ("23important4", Just ())++ it "should have global state semantics, but\+ \ 'delimit' should delimit the continuation." $+ test2 `shouldBe` ("important1", Just ())++ it "should have global state semantics, and\+ \ 'censor' should delimit the continuation" $+ test3 `shouldBe` ("important!1", Just ())++ it "should treat writer with local state semantics, but\+ \ reader with global state semantics." $+ test4 `shouldBe` Just ("4", ())++ it "should fail from failing locally" $+ test5 `shouldBe` Nothing++ it "should recover from failing locally" $+ test6 `shouldBe` Just (Right ())
+ test/ContSpec.hs view
@@ -0,0 +1,154 @@+module ContSpec where++import Test.Hspec++import Data.IORef++import Polysemy+import Polysemy.Cont+import Polysemy.Error+import Polysemy.Reader+import Polysemy.Writer+import Polysemy.State+import Polysemy.Trace+import Polysemy.Final.MTL++import qualified Control.Monad.State as S+import qualified Control.Monad.Cont as C++test1 :: (String, Int)+test1 =+ run+ . runContPure+ . runReader 1+ . runWriter+ $ do+ i <- censor (++"!") $ local (+1) $ callCC $ \c -> do+ i <- local (+1) ask+ tell "unimportant"+ local (+1) (c i)+ tell (show i)+ j <- ask+ return j++test2 :: (String, ())+test2 =+ run+ . runContPure+ . runReader (1 :: Int)+ . runWriter+ $ do+ i <- censor (++"!") $ local (+1) $ callCC $ \_ -> do+ i <- local (+1) ask+ tell "important"+ return i+ tell (show i)+ return ()++test3 :: Either () ()+test3 =+ run+ . runContPure+ . runError+ $ catch (callCC $ \_ -> throw ()) (\_ -> pure ())++stateTest :: (Member (State Int) r, Member (Cont ref) r)+ => Sem r Int+stateTest = do+ i <- get+ put (i + 1)+ callCC $ \c -> do+ j <- get+ put (j + 1)+ c ()+ get++test4 :: (Int, Int)+test4 =+ (`S.runState` 1)+ . runM+ . runContM+ . runStateFinal+ $ stateTest++test5 :: IO (Int, Int)+test5 = do+ ref <- newIORef 1++ r <- runM+ . runContM+ . runStateIORef ref+ $ stateTest+ s' <- readIORef ref+ return (r, s')++test6 :: (Int, Int)+test6 =+ run+ . runState 1+ . runContUnsafe+ $ stateTest++test7 :: ([String], String)+test7 =+ (`C.runCont` id)+ . runFinal+ . runTraceList+ . runReader ""+ . runContFinal+ $ do+ j <- local (++".") $ callCC $ \c -> do+ j <- ask+ trace "Global state semantics?"+ local (\_ -> "What's that?") (c j)+ i <- local (++"Nothing") ask+ trace $ i+ callCC $ \_ ->+ trace "at"+ trace "all."+ return j++test8 :: Int+test8 =+ ($ 1)+ . (`C.runContT` pure)+ . runFinal+ . runReaderFinal+ . runContFinal+ $ do+ callCC $ \c ->+ local (+1) (c ())+ ask++spec :: Spec+spec = do+ describe "runContPure" $ do+ it "should work with higher-order effects if not applied on continuations\+ \ and discard local state" $+ test1 `shouldBe` ("!3", 1)++ it "should not discard local state if continuation is never invoked" $+ test2 `shouldBe` ("important!3", ())++ it "should catch exception within callCC" $+ test3 `shouldBe` Right ()++ describe "runContM" $ do+ it "should have global state semantics with runStateFinal" $+ test4 `shouldBe` (3, 3)++ it "should have global state semantics with runStateInIORef" $ do+ r <- test5+ r `shouldBe` (3, 3)++ describe "runContFinal" $ do+ it "should work just like runContPure/M." $+ test7 `shouldBe` (["Nothing", "at", "all."], ".")++ it "should be able to apply local to continuation" $+ test8 `shouldBe` 2++ describe "runContUnsafe" $ do+ it "should work with and have global state semantics with runState\+ \ run after it" $+ test6 `shouldBe` (3, 3)
test/FinalSpec.hs view
@@ -25,34 +25,34 @@ data Node a = Node a (IORef (Node a)) -mkNode :: (Member (Lift IO) r, Member Fixpoint r)+mkNode :: (Member (Embed IO) r, Member Fixpoint r) => a -> Sem r (Node a) mkNode a = mdo let nd = Node a p- p <- sendM $ newIORef nd+ p <- embed $ newIORef nd return nd -linkNode :: Member (Lift IO) r+linkNode :: Member (Embed IO) r => Node a -> Node a -> Sem r () linkNode (Node _ r) b =- sendM $ writeIORef r b+ embed $ writeIORef r b readNode :: Node a -> a readNode (Node a _) = a -follow :: Member (Lift IO) r+follow :: Member (Embed IO) r => Node a -> Sem r (Node a)-follow (Node _ ref) = sendM $ readIORef ref+follow (Node _ ref) = embed $ 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+ . runStateIORef ref -- Order of these interpreters don't matter . runErrorInIOFinal . runFixpointFinal . runAsyncFinal@@ -73,7 +73,7 @@ test2 :: IO ([String], Either () ()) test2 = runFinal- . runTraceAsList+ . runTraceList . runErrorInIOFinal . runAsyncFinal $ do@@ -101,7 +101,7 @@ . runExceptT . (`runStateT` 0) . runFinal- . runTraceAsList -- Order of these interpreters don't matter+ . runTraceList -- Order of these interpreters don't matter . runWriterFinal . runStateFinal . runErrorFinal
test/FloodgateSpec.hs view
@@ -8,7 +8,7 @@ spec :: Spec spec = describe "Floodgate" $ do it "should delay held traces until release" $ do- let (ts, n) = run . runTraceAsList . runFloodgate $ do+ let (ts, n) = run . runTraceList . runFloodgate $ do hold $ trace "first1" hold $ trace "first2" trace "not held"
test/IdempotentLoweringSpec.hs view
@@ -10,10 +10,10 @@ import Test.Hspec -runStateInIO :: Member (Lift IO) r => s -> IO (∀ x. Sem (State s ': r) x -> Sem r x)+runStateInIO :: Member (Embed IO) r => s -> IO (∀ x. Sem (State s ': r) x -> Sem r x) runStateInIO s = do ref <- newIORef s- nat $ runStateInIORef ref+ nat $ runStateIORef ref test@@ -32,7 +32,7 @@ spec :: Spec spec = describe "Idempotent Lowering" $ do it "should persist an IORef through a bracket" $ do- runIt <- nat runM .@! const (runStateInIO 0) .@! liftNat runResourceInIO+ runIt <- nat runM .@! const (runStateInIO 0) .@! liftNat lowerResource result <- runIt test result `shouldBe` (3 :: Int)
test/SeveralSpec.hs view
@@ -54,7 +54,7 @@ runStates = runSeveral (fmap (fmap snd) . runState) runConstInputs :: HList t -> Sem (TypeConcat (TypeMap Input t) r) a -> Sem r a-runConstInputs = runSeveral runConstInput+runConstInputs = runSeveral runInputConst spec :: Spec spec = do@@ -73,11 +73,11 @@ it "should be equivalent to composed runState" $ do run original `shouldBe` run new - describe "runConstInput" $ do- let original = runConstInput 5 . runConstInput "test"- . runConstInput True $ inputProgram+ describe "runInputConst" $ do+ let original = runInputConst 5 . runInputConst "test"+ . runInputConst True $ inputProgram new = runConstInputs (True ::: "test" ::: 5 ::: HNil) inputProgram - it "should be equivalent to composed runConstInput" $ do+ it "should be equivalent to composed runInputConst" $ do run original `shouldBe` run new
+ test/ShiftSpec.hs view
@@ -0,0 +1,126 @@+module ShiftSpec where++import Test.Hspec++import Data.IORef++import Polysemy+import Polysemy.Shift+import Polysemy.Error+import Polysemy.Reader+import Polysemy.Writer+import Polysemy.State+import Polysemy.Final.MTL++import Control.Monad.Cont(ContT(..))+import Control.Monad.State(StateT(..))+++test1 :: Maybe (String, ())+test1 =+ run+ . runShiftPure+ . runReader (1 :: Int)+ . runWriter+ $ do+ censor (++"!") $ shift $ \c -> do+ _ <- local (+1) (c ())+ _ <- local (+1) (c ())+ tell "unimportant"+ local (+1) (c ())+ j <- ask+ tell (show j)++test2 :: Maybe (Either () ())+test2 =+ run+ . runShiftPure+ . runError+ $ do+ shift $ \_ -> do+ throw ()++test3 :: Maybe (Either () ())+test3 =+ run+ . runShiftPure+ . runError+ $ do+ r <- reset' $ shift $ \_ -> do+ throw ()+ case r of+ Just r' -> abort r'+ _ -> pure ()++test4 :: IO (Maybe Int)+test4 = do+ ref <- newIORef 1+ runM+ . runShiftM+ . runStateIORef ref+ $ do+ shift $ \c -> do+ _ <- c ()+ _ <- c ()+ c ()+ modify (+1)+ get++test5 :: (Maybe Int, Int)+test5 =+ ($ 1)+ . (`runStateT` 1)+ . (`runContT` (pure . Just))+ . runFinal+ . runStateFinal+ . runShiftFinal+ . runReaderFinal+ $ do+ shift $ \c -> do+ _ <- local (+1) (c ())+ _ <- local (+2) (c ())+ local (+3) (c ())+ i <- ask+ modify (+i)+ get++test6 :: (Int, Maybe Int)+test6 =+ run+ . runState 1+ . runShiftUnsafe+ $ do+ shift $ \c -> do+ _ <- c ()+ _ <- c ()+ c ()+ modify (+1)+ get++spec :: Spec+spec = do+ describe "runShiftPure" $ do+ it "should only tell once, censor once, and\+ \ local should have no effect on the continuation." $+ test1 `shouldBe` Just ("!1", ())++ it "should fail from failing locally" $ do+ test2 `shouldBe` Nothing++ it "should recover from failing locally" $ do+ test3 `shouldBe` Just (Right ())++ describe "runShiftM" $ do+ it "should modify multiple times with runStateInIORef" $ do+ res <- test4+ res `shouldBe` Just 4++ describe "runShiftFinal" $ do+ it "should modify multiple times with runStateFinal\+ \ and should be able to apply local to continuation" $+ test5 `shouldBe` (Just 10, 10)++ describe "runShiftUnsafe" $ do+ it "should modify multiple times with runState\+ \ run after it" $+ test6 `shouldBe` (4, Just 4)