mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
Add Final Effect (#217)
* Add Final Effect * Changes per review, Final at top-level, doc changes * Update Changelog * Final touches to Final * Revert change to stack.yaml
This commit is contained in:
parent
baa83700c3
commit
4a5f2ce92a
29
ChangeLog.md
29
ChangeLog.md
@ -1,5 +1,34 @@
|
||||
# Changelog for polysemy
|
||||
|
||||
|
||||
## 1.2.0.0 (TODO)
|
||||
|
||||
### Breaking Changes
|
||||
|
||||
- All `lower-` interpreters have been deprecated, in favor of corresponding
|
||||
`-Final` interpreters.
|
||||
- `runFixpoint` and `runFixpointM` have been deprecated in favor of `fixpointToFinal`.
|
||||
- The semantics for `runNonDet` when `<|>` is used inside a higher-order action of
|
||||
another effect has been changed.
|
||||
- Type variables for certain internal functions and `failToEmbed` have been rearranged.
|
||||
|
||||
## Other changes
|
||||
|
||||
- Added `Final` effect, an effect for embedding higher-order actions in the
|
||||
final monad of the effect stack. Any interpreter should use this instead of
|
||||
requiring to be provided an explicit lowering function to the final monad.
|
||||
- Added `Strategy` environment for use together with `Final`
|
||||
- Added `asyncToIOFinal`, a better alternative of `lowerAsync`
|
||||
- Added `errorToIOFinal`, a better alternative of `lowerError`
|
||||
- Added `fixpointToFinal`, a better alternative of `runFixpoint` and `runFixpointM`
|
||||
- Added `resourceToIOFinal`, a better alternative of `lowerResource`
|
||||
- Added `outputToIOMonoid` and `outputToIOMonoidAssocR`
|
||||
- Added `runWriterTVar`, `writerToIOFinal`, and `writerToIOAssocRFinal`
|
||||
- Added `writerToEndoWriter`
|
||||
- Added `subsume` operation
|
||||
- Exposed `raiseUnder`/`2`/`3` in `Polysemy`
|
||||
|
||||
|
||||
## 1.1.0.0 (2019-08-15)
|
||||
|
||||
### Breaking Changes
|
||||
|
@ -153,7 +153,13 @@ program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)
|
||||
_ -> writeTTY input >> writeTTY "no exceptions"
|
||||
|
||||
main :: IO (Either CustomException ())
|
||||
main = (runM .@ lowerResource .@@ lowerError @CustomException) . teletypeToIO $ program
|
||||
main =
|
||||
runFinal
|
||||
. embedToFinal @IO
|
||||
. resourceToIOFinal
|
||||
. errorToIOFinal @CustomException
|
||||
. teletypeToIO
|
||||
$ program
|
||||
```
|
||||
|
||||
Easy.
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: polysemy
|
||||
version: 1.1.0.0
|
||||
version: 1.2.0.0
|
||||
github: "isovector/polysemy"
|
||||
license: BSD3
|
||||
author: "Sandy Maguire"
|
||||
|
@ -39,7 +39,7 @@ tests:
|
||||
build-tools:
|
||||
- hspec-discover
|
||||
dependencies:
|
||||
- polysemy >= 0.6.0.0
|
||||
- polysemy >= 1.2.0.0
|
||||
- polysemy-plugin
|
||||
- hspec >= 2.6.0 && < 3
|
||||
- should-not-typecheck >= 2.1.0 && < 3
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: b8d6dd19e90295689617adfecbd3bb83127b112840f4f304d956a4d5b33bf821
|
||||
-- hash: a3e70728f8ab4d2e3e7b2727e004b88a497852dd2b44df914418e070f5171e92
|
||||
|
||||
name: polysemy-plugin
|
||||
version: 0.2.2.0
|
||||
@ -76,7 +76,7 @@ test-suite polysemy-plugin-test
|
||||
, ghc-tcplugins-extra >=0.3 && <0.4
|
||||
, hspec >=2.6.0 && <3
|
||||
, inspection-testing >=0.4.2 && <0.5
|
||||
, polysemy >=0.6.0.0
|
||||
, polysemy >=1.2.0.0
|
||||
, polysemy-plugin
|
||||
, should-not-typecheck >=2.1.0 && <3
|
||||
, syb >=0.7 && <0.8
|
||||
|
@ -33,7 +33,13 @@ program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)
|
||||
_ -> writeTTY i >> writeTTY "no exceptions"
|
||||
|
||||
foo :: IO (Either CustomException ())
|
||||
foo = (runM .@ lowerResource .@@ lowerError @CustomException) $ teletypeToIO program
|
||||
foo =
|
||||
runFinal
|
||||
. embedToFinal @IO
|
||||
. resourceToIOFinal
|
||||
. errorToIOFinal @CustomException
|
||||
. teletypeToIO
|
||||
$ program
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "example" $ do
|
||||
|
@ -4,10 +4,10 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: ed739126c69520676b38ca047f46cbddc31813120ceb38b36fe7ac3c0012a606
|
||||
-- hash: a8b3a81d8983405247d7e8cb0010669caf9e8f62f85762990fadbeccdafc6094
|
||||
|
||||
name: polysemy
|
||||
version: 1.1.0.0
|
||||
version: 1.2.0.0
|
||||
synopsis: Higher-order, low-boilerplate, zero-cost free monads.
|
||||
description: Please see the README on GitHub at <https://github.com/isovector/polysemy#readme>
|
||||
category: Language
|
||||
@ -47,6 +47,7 @@ library
|
||||
Polysemy.Error
|
||||
Polysemy.Fail
|
||||
Polysemy.Fail.Type
|
||||
Polysemy.Final
|
||||
Polysemy.Fixpoint
|
||||
Polysemy.Input
|
||||
Polysemy.Internal
|
||||
@ -57,10 +58,12 @@ library
|
||||
Polysemy.Internal.Forklift
|
||||
Polysemy.Internal.Kind
|
||||
Polysemy.Internal.NonDet
|
||||
Polysemy.Internal.Strategy
|
||||
Polysemy.Internal.Tactics
|
||||
Polysemy.Internal.TH.Common
|
||||
Polysemy.Internal.TH.Effect
|
||||
Polysemy.Internal.Union
|
||||
Polysemy.Internal.Writer
|
||||
Polysemy.IO
|
||||
Polysemy.NonDet
|
||||
Polysemy.Output
|
||||
@ -118,6 +121,7 @@ test-suite polysemy-test
|
||||
BracketSpec
|
||||
DoctestSpec
|
||||
FailSpec
|
||||
FinalSpec
|
||||
FixpointSpec
|
||||
FusionSpec
|
||||
HigherOrderSpec
|
||||
|
@ -7,10 +7,18 @@ module Polysemy
|
||||
-- * Running Sem
|
||||
, run
|
||||
, runM
|
||||
, runFinal
|
||||
|
||||
-- * Interoperating With Other Monads
|
||||
-- ** Embed
|
||||
, Embed (..)
|
||||
, embed
|
||||
, embedToFinal
|
||||
-- ** Final
|
||||
-- | For advanced uses of 'Final', including creating your own interpreters
|
||||
-- that make use of it, see "Polysemy.Final"
|
||||
, Final
|
||||
, embedFinal
|
||||
|
||||
-- * Lifting
|
||||
, raise
|
||||
@ -130,4 +138,5 @@ import Polysemy.Internal.Forklift
|
||||
import Polysemy.Internal.Kind
|
||||
import Polysemy.Internal.TH.Effect
|
||||
import Polysemy.Internal.Tactics
|
||||
import Polysemy.Final
|
||||
|
||||
|
@ -10,11 +10,13 @@ module Polysemy.Async
|
||||
|
||||
-- * Interpretations
|
||||
, asyncToIO
|
||||
, asyncToIOFinal
|
||||
, lowerAsync
|
||||
) where
|
||||
|
||||
import qualified Control.Concurrent.Async as A
|
||||
import Polysemy
|
||||
import Polysemy.Final
|
||||
|
||||
|
||||
|
||||
@ -32,13 +34,23 @@ data Async m a where
|
||||
makeSem ''Async
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A more flexible --- though less performant --- version of 'lowerAsync'.
|
||||
-- | A more flexible --- though less performant ---
|
||||
-- version of 'asyncToIOFinal'.
|
||||
--
|
||||
-- This function is capable of running 'Async' effects anywhere within an
|
||||
-- effect stack, without relying on an explicit function to lower it into 'IO'.
|
||||
-- effect stack, without relying on 'Final' to lower it into 'IO'.
|
||||
-- Notably, this means that 'Polysemy.State.State' effects will be consistent
|
||||
-- in the presence of 'Async'.
|
||||
--
|
||||
-- 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions
|
||||
-- of other effects interpreted after 'Async'.
|
||||
-- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.
|
||||
--
|
||||
-- Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters
|
||||
-- after the interpreter for 'Async'.
|
||||
-- (Pure interpreters are interpreters that aren't expressed in terms of
|
||||
-- another effect or monad; for example, 'Polysemy.State.runState'.)
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
asyncToIO
|
||||
:: Member (Embed IO) r
|
||||
@ -57,9 +69,37 @@ asyncToIO m = withLowerToIO $ \lower _ -> lower $
|
||||
) m
|
||||
{-# INLINE asyncToIO #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Async' effect in terms of 'A.async' through final 'IO'.
|
||||
--
|
||||
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
|
||||
-- will have local state semantics in regards to 'Async' effects
|
||||
-- interpreted this way. See 'Final'.
|
||||
--
|
||||
-- Notably, unlike 'asyncToIO', this is not consistent with
|
||||
-- 'Polysemy.State.State' unless 'Polysemy.State.runStateIORef' is used.
|
||||
-- State that seems like it should be threaded globally throughout 'Async'
|
||||
-- /will not be./
|
||||
--
|
||||
-- Use 'asyncToIO' instead if you need to run
|
||||
-- pure, stateful interpreters after the interpreter for 'Async'.
|
||||
-- (Pure interpreters are interpreters that aren't expressed in terms of
|
||||
-- another effect or monad; for example, 'Polysemy.State.runState'.)
|
||||
--
|
||||
-- @since 1.2.0.0
|
||||
asyncToIOFinal :: Member (Final IO) r
|
||||
=> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
asyncToIOFinal = interpretFinal $ \case
|
||||
Async m -> do
|
||||
ins <- getInspectorS
|
||||
m' <- runS m
|
||||
liftS $ A.async (inspect ins <$> m')
|
||||
Await a -> liftS (A.wait a)
|
||||
{-# INLINE asyncToIOFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Async' effect via in terms of 'A.async'.
|
||||
-- | Run an 'Async' effect in terms of 'A.async'.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
lowerAsync
|
||||
@ -80,4 +120,4 @@ lowerAsync lower m = interpretH
|
||||
Await a -> pureT =<< embed (A.wait a)
|
||||
) m
|
||||
{-# INLINE lowerAsync #-}
|
||||
|
||||
{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}
|
||||
|
@ -13,6 +13,7 @@ module Polysemy.Error
|
||||
-- * Interpretations
|
||||
, runError
|
||||
, mapError
|
||||
, errorToIOFinal
|
||||
, lowerError
|
||||
) where
|
||||
|
||||
@ -22,6 +23,7 @@ import qualified Control.Monad.Trans.Except as E
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Typeable
|
||||
import Polysemy
|
||||
import Polysemy.Final
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Union
|
||||
|
||||
@ -130,6 +132,48 @@ instance Typeable e => Show (WrappedExc e) where
|
||||
instance (Typeable e) => X.Exception (WrappedExc e)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Error' effect as an 'IO' 'X.Exception' through final 'IO'. This
|
||||
-- interpretation is significantly faster than 'runError'.
|
||||
--
|
||||
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
|
||||
-- will have local state semantics in regards to 'Error' effects
|
||||
-- interpreted this way. See 'Final'.
|
||||
--
|
||||
-- @since 1.2.0.0
|
||||
errorToIOFinal
|
||||
:: ( Typeable e
|
||||
, Member (Final IO) r
|
||||
)
|
||||
=> Sem (Error e ': r) a
|
||||
-> Sem r (Either e a)
|
||||
errorToIOFinal sem = withStrategicToFinal @IO $ do
|
||||
m' <- runS (runErrorAsExcFinal sem)
|
||||
s <- getInitialStateS
|
||||
pure $
|
||||
either
|
||||
((<$ s) . Left . unwrapExc)
|
||||
(fmap Right)
|
||||
<$> X.try m'
|
||||
{-# INLINE errorToIOFinal #-}
|
||||
|
||||
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 $ X.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)
|
||||
{-# INLINE runErrorAsExcFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is
|
||||
-- significantly faster than 'runError', at the cost of being less flexible.
|
||||
@ -151,6 +195,7 @@ lowerError lower
|
||||
. X.try
|
||||
. (lower .@ runErrorAsExc)
|
||||
{-# INLINE lowerError #-}
|
||||
{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-}
|
||||
|
||||
|
||||
-- TODO(sandy): Can we use the new withLowerToIO machinery for this?
|
||||
@ -171,4 +216,3 @@ runErrorAsExc lower = interpretH $ \case
|
||||
embed $ X.catch (runIt t) $ \(se :: WrappedExc e) ->
|
||||
runIt $ h $ unwrapExc se <$ is
|
||||
{-# INLINE runErrorAsExc #-}
|
||||
|
||||
|
@ -47,7 +47,7 @@ failToNonDet = interpret $ \(Fail _) -> empty
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Fail' effect in terms of an underlying 'MonadFail' instance.
|
||||
failToEmbed :: forall m a r
|
||||
failToEmbed :: forall m r a
|
||||
. (Member (Embed m) r, MonadFail m)
|
||||
=> Sem (Fail ': r) a
|
||||
-> Sem r a
|
||||
|
242
src/Polysemy/Final.hs
Normal file
242
src/Polysemy/Final.hs
Normal file
@ -0,0 +1,242 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Polysemy.Final
|
||||
(
|
||||
-- * Effect
|
||||
Final(..)
|
||||
, ThroughWeavingToFinal
|
||||
|
||||
-- * Actions
|
||||
, withWeavingToFinal
|
||||
, withStrategicToFinal
|
||||
, embedFinal
|
||||
|
||||
-- * Combinators for Interpreting to the Final Monad
|
||||
, interpretFinal
|
||||
|
||||
-- * Strategy
|
||||
-- | Strategy is a domain-specific language very similar to @Tactics@
|
||||
-- (see 'Polysemy.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
|
||||
, finalToFinal
|
||||
|
||||
-- * Interpretations for Other Effects
|
||||
, embedToFinal
|
||||
) where
|
||||
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Combinators
|
||||
import Polysemy.Internal.Union
|
||||
import Polysemy.Internal.Strategy
|
||||
import Polysemy.Internal.TH.Effect
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- | This represents a function which produces
|
||||
-- an action of the final monad @m@ given:
|
||||
--
|
||||
-- * The initial effectful state at the moment the action
|
||||
-- is to be executed.
|
||||
--
|
||||
-- * A way to convert @z@ (which is typically @'Sem' r@) to @m@ by
|
||||
-- threading the effectful state through.
|
||||
--
|
||||
-- * An inspector that is able to view some value within the
|
||||
-- effectful state if the effectful state contains any values.
|
||||
--
|
||||
-- A @'Polysemy.Internal.Union.Weaving'@ provides these components,
|
||||
-- hence the name 'ThroughWeavingToFinal'.
|
||||
type ThroughWeavingToFinal m z a =
|
||||
forall f
|
||||
. Functor f
|
||||
=> f ()
|
||||
-> (forall x. f (z x) -> m (f x))
|
||||
-> (forall x. f x -> Maybe x)
|
||||
-> m (f a)
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- | An effect for embedding higher-order actions 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.
|
||||
--
|
||||
-- 'Final' is more powerful than 'Embed', but is also less flexible
|
||||
-- to interpret (compare 'Polysemy.Embed.runEmbedded' with 'finalToFinal').
|
||||
-- If you only need the power of 'embed', then you should use 'Embed' instead.
|
||||
--
|
||||
-- /Beware/: 'Final' actions are interpreted as actions of the final monad,
|
||||
-- and the effectful state visible to
|
||||
-- 'withWeavingToFinal' \/ 'withStrategicToFinal'
|
||||
-- \/ 'interpretFinal'
|
||||
-- is that of /all interpreters run in order to produce the final monad/.
|
||||
--
|
||||
-- This means that any interpreter built using 'Final' 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. For example, if the final monad is a monad transformer
|
||||
-- stack, then state semantics will depend on the order monad transformers are stacked.
|
||||
newtype Final m z a where
|
||||
WithWeavingToFinal
|
||||
:: ThroughWeavingToFinal m z 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 'withStrategicToFinal' instead,
|
||||
-- which provides a more user-friendly interface, but is also slightly weaker.
|
||||
--
|
||||
-- You are discouraged from using 'withWeavingToFinal' directly
|
||||
-- in application code, as it ties your application code directly to
|
||||
-- the final monad.
|
||||
withWeavingToFinal
|
||||
:: forall m a r
|
||||
. Member (Final m) r
|
||||
=> ThroughWeavingToFinal m (Sem r) a
|
||||
-> Sem r a
|
||||
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- | 'withWeavingToFinal' admits an implementation of 'embed'.
|
||||
--
|
||||
-- Just like 'embed', you are discouraged from using this in application code.
|
||||
embedFinal :: (Member (Final m) r, Functor m) => m a -> Sem r a
|
||||
embedFinal m = withWeavingToFinal $ \s _ _ -> (<$ s) <$> m
|
||||
{-# INLINE embedFinal #-}
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- | 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, which provides 'runS' and 'bindS'.
|
||||
--
|
||||
-- You are discouraged from using 'withStrategicToFinal' in application code,
|
||||
-- as it ties your application code directly to the final monad.
|
||||
withStrategicToFinal :: Member (Final m) r
|
||||
=> Strategic m (Sem r) a
|
||||
-> Sem r a
|
||||
withStrategicToFinal strat = withWeavingToFinal (runStrategy strat)
|
||||
{-# INLINE withStrategicToFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'interpretH', but may be used to
|
||||
-- interpret higher-order effects in terms of the final monad.
|
||||
--
|
||||
-- 'interpretFinal' requires less boilerplate than using 'interpretH'
|
||||
-- together with 'withStrategicToFinal' \/ 'withWeavingToFinal',
|
||||
-- but is also less powerful.
|
||||
-- 'interpretFinal' does not provide any means of executing actions
|
||||
-- of @'Sem' r@ as you interpret each action, and the provided interpreter
|
||||
-- is automatically recursively used to process higher-order occurences of
|
||||
-- @'Sem' (e ': r)@ to @'Sem' r@.
|
||||
--
|
||||
-- If you need greater control of how the effect is interpreted,
|
||||
-- use 'interpretH' together with 'withStrategicToFinal' \/
|
||||
-- 'withWeavingToFinal' instead.
|
||||
--
|
||||
-- /Beware/: Effects that aren't interpreted in terms of the final
|
||||
-- monad will have local state semantics in regards to effects
|
||||
-- interpreted using 'interpretFinal'. See 'Final'.
|
||||
interpretFinal
|
||||
:: forall m e r a
|
||||
. Member (Final m) r
|
||||
=> (forall x n. e n x -> Strategic m n x)
|
||||
-- ^ A natural transformation from the handled effect to the final monad.
|
||||
-> Sem (e ': r) a
|
||||
-> Sem r a
|
||||
interpretFinal n =
|
||||
let
|
||||
go :: Sem (e ': r) x -> Sem r x
|
||||
go = hoistSem $ \u -> case decomp u of
|
||||
Right (Weaving e s wv ex ins) ->
|
||||
injWeaving $
|
||||
Weaving
|
||||
(WithWeavingToFinal (runStrategy (n e)))
|
||||
s
|
||||
(go . wv)
|
||||
ex
|
||||
ins
|
||||
Left g -> hoist go g
|
||||
{-# INLINE go #-}
|
||||
in
|
||||
go
|
||||
{-# INLINE interpretFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lower a 'Sem' containing only a single lifted, final 'Monad' into that
|
||||
-- monad.
|
||||
--
|
||||
-- If you also need to process an @'Embed' m@ effect, use this together with
|
||||
-- 'embedToFinal'.
|
||||
runFinal :: Monad m => Sem '[Final m] a -> m a
|
||||
runFinal = usingSem $ \u -> case extract u of
|
||||
Weaving (WithWeavingToFinal wav) s wv ex ins ->
|
||||
ex <$> wav s (runFinal . wv) ins
|
||||
{-# INLINE runFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given natural transformations between @m1@ and @m2@, run a @'Final' m1@
|
||||
-- effect by transforming it into a @'Final' m2@ effect.
|
||||
finalToFinal :: forall m1 m2 a r
|
||||
. (Member (Final m2) r, Functor m2)
|
||||
=> (forall x. m1 x -> m2 x)
|
||||
-> (forall x. m2 x -> m1 x)
|
||||
-> Sem (Final m1 ': r) a
|
||||
-> Sem r a
|
||||
finalToFinal to from =
|
||||
let
|
||||
go :: Sem (Final m1 ': r) x -> Sem r x
|
||||
go = hoistSem $ \u -> case decomp u of
|
||||
Right (Weaving (WithWeavingToFinal wav) s wv ex ins) ->
|
||||
injWeaving $
|
||||
Weaving
|
||||
(WithWeavingToFinal $ \s' wv' ins' ->
|
||||
to $ wav s' (from . wv') ins'
|
||||
)
|
||||
s
|
||||
(go . wv)
|
||||
ex
|
||||
ins
|
||||
Left g -> hoist go g
|
||||
{-# INLINE go #-}
|
||||
in
|
||||
go
|
||||
{-# INLINE finalToFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Transform an @'Embed' m@ effect into a @'Final' m@ effect
|
||||
embedToFinal :: (Member (Final m) r, Functor m)
|
||||
=> Sem (Embed m ': r) a
|
||||
-> Sem r a
|
||||
embedToFinal = interpret $ \(Embed m) -> embedFinal m
|
||||
{-# INLINE embedToFinal #-}
|
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}
|
||||
|
||||
module Polysemy.Fixpoint
|
||||
( -- * Effect
|
||||
@ -12,10 +12,14 @@ import Control.Monad.Fix
|
||||
import Data.Maybe
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Final
|
||||
import Polysemy.Internal.Fixpoint
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Fixpoint' effect purely.
|
||||
-----------------------------------------------------------------------------
|
||||
-- | Run a 'Fixpoint' effect in terms of a final 'MonadFix' instance.
|
||||
--
|
||||
-- If you need to run a 'Fixpoint' effect purely, use this together with
|
||||
-- @'Final' 'Data.Functor.Identity.Identity'@.
|
||||
--
|
||||
-- __Note__: This is subject to the same traps as 'MonadFix' instances for
|
||||
-- monads with failure: this will throw an exception if you try to recursively use
|
||||
@ -28,9 +32,10 @@ import Polysemy.Internal.Fixpoint
|
||||
-- @
|
||||
-- bad :: (Int, Either () Int)
|
||||
-- bad =
|
||||
-- 'run'
|
||||
-- . 'runFixpoint' 'run'
|
||||
-- . 'Polysemy.State.runLazyState' @Int 1
|
||||
-- 'Data.Functor.Identity.runIdentity'
|
||||
-- . 'runFinal'
|
||||
-- . 'fixpointToFinal' \@'Data.Functor.Identity.Identity'
|
||||
-- . 'Polysemy.State.runLazyState' \@Int 1
|
||||
-- . 'Polysemy.Error.runError'
|
||||
-- $ mdo
|
||||
-- 'Polysemy.State.put' a
|
||||
@ -38,16 +43,38 @@ import Polysemy.Internal.Fixpoint
|
||||
-- return a
|
||||
-- @
|
||||
--
|
||||
-- 'runFixpoint' also operates under the assumption that any effectful
|
||||
-- 'fixpointToFinal' also operates under the assumption that any effectful
|
||||
-- state which can't be inspected using 'Polysemy.Inspector' can't contain any
|
||||
-- values. This is true for all interpreters featured in this package,
|
||||
-- values. For example, the effectful state for 'Polysemy.Error.runError' is
|
||||
-- @'Either' e a@. The inspector for this effectful state only fails if the
|
||||
-- effectful state is a @'Left'@ value, which therefore doesn't contain any
|
||||
-- values of @a@.
|
||||
--
|
||||
-- This assumption holds true for all interpreters featured in this package,
|
||||
-- and is presumably always true for any properly implemented interpreter.
|
||||
-- 'runFixpoint' may throw an exception if it is used together with an
|
||||
-- 'fixpointToFinal' may throw an exception if it is used together with an
|
||||
-- interpreter that uses 'Polysemy.Internal.Union.weave' improperly.
|
||||
--
|
||||
-- If 'runFixpoint' throws an exception for you, and it can't
|
||||
-- If 'fixpointToFinal' throws an exception for you, and it can't
|
||||
-- be due to any of the above, then open an issue over at the
|
||||
-- GitHub repository for polysemy.
|
||||
fixpointToFinal :: forall m r a
|
||||
. (Member (Final m) r, MonadFix m)
|
||||
=> Sem (Fixpoint ': r) a
|
||||
-> Sem r a
|
||||
fixpointToFinal = interpretFinal @m $
|
||||
\(Fixpoint f) -> do
|
||||
f' <- bindS f
|
||||
s <- getInitialStateS
|
||||
ins <- getInspectorS
|
||||
pure $ mfix $ \fa -> f' $
|
||||
fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s
|
||||
{-# INLINE fixpointToFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Fixpoint' effect purely.
|
||||
--
|
||||
-- __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'.
|
||||
runFixpoint
|
||||
:: (∀ x. Sem r x -> x)
|
||||
-> Sem (Fixpoint ': r) a
|
||||
@ -61,11 +88,14 @@ runFixpoint lower = interpretH $ \case
|
||||
lower . runFixpoint lower . c $
|
||||
fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s
|
||||
{-# INLINE runFixpoint #-}
|
||||
{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \
|
||||
\'Data.Functor.Identity.Identity' instead" #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.
|
||||
--
|
||||
-- __Note__: 'runFixpointM' is subject to the same caveats as 'runFixpoint'.
|
||||
-- __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'.
|
||||
runFixpointM
|
||||
:: ( MonadFix m
|
||||
, Member (Embed m) r
|
||||
@ -82,3 +112,4 @@ runFixpointM lower = interpretH $ \case
|
||||
lower . runFixpointM lower . c $
|
||||
fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s
|
||||
{-# INLINE runFixpointM #-}
|
||||
{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}
|
||||
|
@ -61,15 +61,19 @@ import Polysemy.Internal.Union
|
||||
-- interpretations (and others that you might add) may be used interchangably
|
||||
-- without needing to write any newtypes or 'Monad' instances. The only
|
||||
-- change needed to swap interpretations is to change a call from
|
||||
-- 'Polysemy.Error.runError' to 'Polysemy.Error.lowerError'.
|
||||
-- 'Polysemy.Error.runError' to 'Polysemy.Error.errorToIOFinal'.
|
||||
--
|
||||
-- The effect stack @r@ can contain arbitrary other monads inside of it. These
|
||||
-- monads are lifted into effects via the 'Embed' effect. Monadic values can be
|
||||
-- lifted into a 'Sem' via 'embed'.
|
||||
--
|
||||
-- Higher-order actions of another monad can be lifted into higher-order actions
|
||||
-- of 'Sem' via the 'Polysemy.Final' effect, which is more powerful
|
||||
-- than 'Embed', but also less flexible to interpret.
|
||||
--
|
||||
-- A 'Sem' can be interpreted as a pure value (via 'run') or as any
|
||||
-- traditional 'Monad' (via 'runM'). Each effect @E@ comes equipped with some
|
||||
-- interpreters of the form:
|
||||
-- traditional 'Monad' (via 'runM' or 'Polysemy.runFinal').
|
||||
-- Each effect @E@ comes equipped with some interpreters of the form:
|
||||
--
|
||||
-- @
|
||||
-- runE :: 'Sem' (E ': r) a -> 'Sem' r a
|
||||
@ -127,8 +131,9 @@ import Polysemy.Internal.Union
|
||||
-- behaviour over other effects later in the chain.
|
||||
--
|
||||
-- After all of your effects are handled, you'll be left with either
|
||||
-- a @'Sem' '[] a@ or a @'Sem' '[ 'Embed' m ] a@ value, which can be
|
||||
-- consumed respectively by 'run' and 'runM'.
|
||||
-- a @'Sem' '[] a@, a @'Sem' '[ 'Embed' m ] a@, or a @'Sem' '[ 'Polysemy.Final' m ] a@
|
||||
-- value, which can be consumed respectively by 'run', 'runM', and
|
||||
-- 'Polysemy.runFinal'.
|
||||
--
|
||||
-- ==== Examples
|
||||
--
|
||||
@ -452,6 +457,11 @@ runM (Sem m) = m $ \z ->
|
||||
-- just for initialization. This can result in rather surprising behavior. For
|
||||
-- a version of '.@' that won't duplicate work, see the @.\@!@ operator in
|
||||
-- <http://hackage.haskell.org/package/polysemy-zoo/docs/Polysemy-IdempotentLowering.html polysemy-zoo>.
|
||||
--
|
||||
-- Interpreters using 'Polysemy.Final' may be composed normally, and
|
||||
-- avoid the work duplication issue. For that reason, you're encouraged to use
|
||||
-- @-'Polysemy.Final'@ interpreters instead of @lower-@ interpreters whenever
|
||||
-- possible.
|
||||
(.@)
|
||||
:: Monad m
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
|
@ -4,13 +4,14 @@ module Polysemy.Internal.Fixpoint where
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | An effect for providing 'Control.Monad.Fix.mfix'.
|
||||
data Fixpoint m a where
|
||||
newtype Fixpoint m a where
|
||||
Fixpoint :: (a -> m a) -> Fixpoint m a
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The error used in 'Polysemy.Fixpoint.runFixpoint' and
|
||||
-- 'Polysemy.Fixpoint.runFixpointM' when the result of a failed computation
|
||||
-- | The error used in 'Polysemy.Fixpoint.fixpointToFinal',
|
||||
-- 'Polysemy.Fixpoint.runFixpoint' and 'Polysemy.Fixpoint.runFixpointM'
|
||||
-- when the result of a failed computation
|
||||
-- is recursively used and somehow visible. You may use this for your own
|
||||
-- 'Fixpoint' interpreters. The argument should be the name of the interpreter.
|
||||
bomb :: String -> a
|
||||
|
@ -9,6 +9,7 @@ module Polysemy.Internal.Forklift where
|
||||
import qualified Control.Concurrent.Async as A
|
||||
import Control.Concurrent.Chan.Unagi
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Union
|
||||
|
||||
@ -66,7 +67,7 @@ withLowerToIO action = do
|
||||
res <- embed $ A.async $ do
|
||||
a <- action (runViaForklift inchan)
|
||||
(putMVar signal ())
|
||||
putMVar signal ()
|
||||
`finally` (putMVar signal ())
|
||||
pure a
|
||||
|
||||
let me = do
|
||||
|
101
src/Polysemy/Internal/Strategy.hs
Normal file
101
src/Polysemy/Internal/Strategy.hs
Normal file
@ -0,0 +1,101 @@
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
module Polysemy.Internal.Strategy where
|
||||
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Combinators
|
||||
import Polysemy.Internal.Tactics (Inspector(..))
|
||||
|
||||
|
||||
data Strategy m f n z a where
|
||||
GetInitialState :: Strategy m f n z (f ())
|
||||
HoistInterpretation :: (a -> n b) -> Strategy m f n z (f a -> m (f b))
|
||||
GetInspector :: Strategy m f n z (Inspector f)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 'Strategic' is an environment in which you're capable of explicitly
|
||||
-- threading higher-order effect states to the final monad.
|
||||
-- This is a variant of @Tactics@ (see 'Polysemy.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 = '[Strategy m f n]
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Internal function to process Strategies in terms of
|
||||
-- 'Polysemy.Final.withWeavingToFinal'.
|
||||
runStrategy :: Functor f
|
||||
=> Sem '[Strategy m f n] a
|
||||
-> f ()
|
||||
-> (forall x. f (n x) -> m (f x))
|
||||
-> (forall x. f x -> Maybe x)
|
||||
-> a
|
||||
runStrategy sem = \s wv ins -> run $ interpret
|
||||
(\case
|
||||
GetInitialState -> pure s
|
||||
HoistInterpretation f -> pure $ \fa -> wv (f <$> fa)
|
||||
GetInspector -> pure (Inspector ins)
|
||||
) sem
|
||||
{-# INLINE runStrategy #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 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 'Polysemy.getInspectorT'
|
||||
getInspectorS :: forall m f n. Sem (WithStrategy m f n) (Inspector f)
|
||||
getInspectorS = send (GetInspector @m @f @n)
|
||||
{-# INLINE getInspectorS #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Get the stateful environment of the world at the moment the
|
||||
-- @Strategy@ is to be run.
|
||||
--
|
||||
-- Prefer 'pureS', 'liftS', 'runS', or 'bindS' instead of using this function
|
||||
-- directly.
|
||||
getInitialStateS :: forall m f n. Sem (WithStrategy m f n) (f ())
|
||||
getInitialStateS = send (GetInitialState @m @f @n)
|
||||
{-# INLINE getInitialStateS #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Embed a value into 'Strategic'.
|
||||
pureS :: Applicative m => a -> Strategic m n a
|
||||
pureS a = pure . (a <$) <$> getInitialStateS
|
||||
{-# 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 threaded 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 @Strategy@
|
||||
-- is initially run in.
|
||||
--
|
||||
-- Use 'bindS' if you'd prefer to explicitly manage your stateful environment.
|
||||
runS :: n a -> Sem (WithStrategy m f n) (m (f a))
|
||||
runS na = bindS (const na) <*> getInitialStateS
|
||||
{-# INLINE runS #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 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@.
|
||||
bindS :: (a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
|
||||
bindS = send . HoistInterpretation
|
||||
{-# INLINE bindS #-}
|
@ -237,7 +237,7 @@ inj e = injWeaving $
|
||||
{-# INLINE inj #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lift a @Weaving e@ into a 'Union' capable of holding it.
|
||||
-- | Lift a @'Weaving' e@ into a 'Union' capable of holding it.
|
||||
injWeaving :: forall e r m a. Member e r => Weaving e m a -> Union r m a
|
||||
injWeaving = Union (finder @_ @r @e)
|
||||
{-# INLINE injWeaving #-}
|
||||
|
156
src/Polysemy/Internal/Writer.hs
Normal file
156
src/Polysemy/Internal/Writer.hs
Normal file
@ -0,0 +1,156 @@
|
||||
{-# LANGUAGE BangPatterns, TemplateHaskell, TupleSections #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
module Polysemy.Internal.Writer where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
|
||||
import Data.Semigroup
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Final
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | An effect capable of emitting and intercepting messages.
|
||||
data Writer o m a where
|
||||
Tell :: o -> Writer o m ()
|
||||
Listen :: ∀ o m a. m a -> Writer o m (o, a)
|
||||
Pass :: m (o -> o, a) -> Writer o m a
|
||||
|
||||
makeSem ''Writer
|
||||
|
||||
-- TODO(KingoftheHomeless): Research if this is more or less efficient than
|
||||
-- using 'reinterpretH' + 'subsume'
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- | Transform a @'Writer' o@ effect into a @'Writer' ('Endo' o)@ effect,
|
||||
-- right-associating all uses of '<>' for @o@.
|
||||
--
|
||||
-- This can be used together with 'raiseUnder' in order to create
|
||||
-- @-AssocR@ variants out of regular 'Writer' interpreters.
|
||||
writerToEndoWriter
|
||||
:: (Monoid o, Member (Writer (Endo o)) r)
|
||||
=> Sem (Writer o ': r) a
|
||||
-> Sem r a
|
||||
writerToEndoWriter = interpretH $ \case
|
||||
Tell o -> tell (Endo (o <>)) >>= pureT
|
||||
Listen m -> do
|
||||
m' <- writerToEndoWriter <$> runT m
|
||||
raise $ do
|
||||
(o, fa) <- listen m'
|
||||
return $ (,) (appEndo o mempty) <$> fa
|
||||
Pass m -> do
|
||||
ins <- getInspectorT
|
||||
m' <- writerToEndoWriter <$> runT m
|
||||
raise $ pass $ do
|
||||
t <- m'
|
||||
let
|
||||
f' =
|
||||
maybe
|
||||
id
|
||||
(\(f, _) (Endo oo) -> let !o' = f (oo mempty) in Endo (o' <>))
|
||||
(inspect ins t)
|
||||
return (f', fmap snd t)
|
||||
{-# INLINE writerToEndoWriter #-}
|
||||
|
||||
|
||||
-- TODO(KingoftheHomeless): Make this mess more palatable
|
||||
--
|
||||
-- 'interpretFinal' is too weak for our purposes, so we
|
||||
-- use 'interpretH' + 'withWeavingToFinal'.
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A variant of 'Polysemy.Writer.runWriterTVar' where an 'STM' action is
|
||||
-- used instead of a 'TVar' to commit 'tell's.
|
||||
runWriterSTMAction :: forall o r a
|
||||
. (Member (Final IO) r, Monoid o)
|
||||
=> (o -> STM ())
|
||||
-> Sem (Writer o ': r) a
|
||||
-> Sem r a
|
||||
runWriterSTMAction write = interpretH $ \case
|
||||
Tell o -> do
|
||||
t <- embedFinal $ atomically (write o)
|
||||
pureT t
|
||||
Listen m -> do
|
||||
m' <- runT m
|
||||
-- Using 'withWeavingToFinal' instead of 'withStrategicToFinal'
|
||||
-- here allows us to avoid using two additional 'embedFinal's in
|
||||
-- order to create the TVars.
|
||||
raise $ withWeavingToFinal $ \s wv _ -> mask $ \restore -> do
|
||||
-- See below to understand how this works
|
||||
tvar <- newTVarIO mempty
|
||||
switch <- newTVarIO False
|
||||
fa <-
|
||||
restore (wv (runWriterSTMAction (write' tvar switch) m' <$ s))
|
||||
`onException` commit tvar switch id
|
||||
o <- commit tvar switch id
|
||||
return $ (fmap . fmap) (o, ) fa
|
||||
Pass m -> do
|
||||
m' <- runT m
|
||||
ins <- getInspectorT
|
||||
raise $ withWeavingToFinal $ \s wv ins' -> mask $ \restore -> do
|
||||
tvar <- newTVarIO mempty
|
||||
switch <- newTVarIO False
|
||||
t <-
|
||||
restore (wv (runWriterSTMAction (write' tvar switch) m' <$ s))
|
||||
`onException` commit tvar switch id
|
||||
_ <- commit tvar switch
|
||||
(maybe id fst $ ins' t >>= inspect ins)
|
||||
return $ (fmap . fmap) snd t
|
||||
|
||||
where
|
||||
{- KingoftheHomeless:
|
||||
'write'' is used by the argument computation to a 'listen' or 'pass'
|
||||
in order to 'tell', rather than directly using the 'write'.
|
||||
This is because we need to temporarily store its
|
||||
'tell's seperately in order for the 'listen'/'pass' to work
|
||||
properly. Once the 'listen'/'pass' completes, we 'commit' the
|
||||
changes done to the local tvar globally through 'write'.
|
||||
|
||||
'commit' is protected by 'mask'+'onException'. Combine this
|
||||
with the fact that the 'withWeavingToFinal' can't be interrupted
|
||||
by pure errors emitted by effects (since these will be
|
||||
represented as part of the functorial state), and we
|
||||
guarantee that no writes will be lost if the argument computation
|
||||
fails for whatever reason.
|
||||
|
||||
The argument computation to a 'listen'/'pass' may also spawn
|
||||
asynchronous computations which do 'tell's of their own.
|
||||
In order to make sure these 'tell's won't be lost once a
|
||||
'listen'/'pass' completes, a switch is used to
|
||||
control which tvar 'write'' writes to. The switch is flipped
|
||||
atomically together with commiting the writes of the local tvar
|
||||
as part of 'commit'. Once the switch is flipped,
|
||||
any asynchrounous computations spawned by the argument
|
||||
computation will write to the global tvar instead of the local
|
||||
tvar (which is no longer relevant), and thus no writes will be
|
||||
lost.
|
||||
-}
|
||||
write' :: TVar o
|
||||
-> TVar Bool
|
||||
-> o
|
||||
-> STM ()
|
||||
write' tvar switch = \o -> do
|
||||
useGlobal <- readTVar switch
|
||||
if useGlobal then
|
||||
write o
|
||||
else do
|
||||
s <- readTVar tvar
|
||||
writeTVar tvar $! s <> o
|
||||
|
||||
commit :: TVar o
|
||||
-> TVar Bool
|
||||
-> (o -> o)
|
||||
-> IO o
|
||||
commit tvar switch f = atomically $ do
|
||||
o <- readTVar tvar
|
||||
let !o' = f o
|
||||
-- Likely redundant, but doesn't hurt.
|
||||
alreadyCommited <- readTVar switch
|
||||
unless alreadyCommited $
|
||||
write o'
|
||||
writeTVar switch True
|
||||
return o'
|
||||
{-# INLINE runWriterSTMAction #-}
|
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE BangPatterns, TemplateHaskell #-}
|
||||
|
||||
module Polysemy.Output
|
||||
( -- * Effect
|
||||
@ -13,6 +13,8 @@ module Polysemy.Output
|
||||
, runOutputMonoidAssocR
|
||||
, runOutputMonoidIORef
|
||||
, runOutputMonoidTVar
|
||||
, outputToIOMonoid
|
||||
, outputToIOMonoidAssocR
|
||||
, ignoreOutput
|
||||
, runOutputBatched
|
||||
, runOutputSem
|
||||
@ -83,7 +85,7 @@ runOutputMonoidAssocR
|
||||
-> Sem r (m, a)
|
||||
runOutputMonoidAssocR f =
|
||||
fmap (first (`appEndo` mempty))
|
||||
. runOutputMonoid (\a -> Endo (f a <>))
|
||||
. runOutputMonoid (\o -> let !o' = f o in Endo (o' <>))
|
||||
{-# INLINE runOutputMonoidAssocR #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -97,7 +99,7 @@ runOutputMonoidIORef
|
||||
-> Sem (Output o ': r) a
|
||||
-> Sem r a
|
||||
runOutputMonoidIORef ref f = interpret $ \case
|
||||
Output o -> embed $ atomicModifyIORef' ref (\s -> (s <> f o, ()))
|
||||
Output o -> embed $ atomicModifyIORef' ref (\s -> let !o' = f o in (s <> o', ()))
|
||||
{-# INLINE runOutputMonoidIORef #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -116,6 +118,60 @@ runOutputMonoidTVar tvar f = interpret $ \case
|
||||
writeTVar tvar $! s <> f o
|
||||
{-# INLINE runOutputMonoidTVar #-}
|
||||
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- | Run an 'Output' effect in terms of atomic operations
|
||||
-- in 'IO'.
|
||||
--
|
||||
-- Internally, this simply creates a new 'IORef', passes it to
|
||||
-- 'runOutputMonoidIORef', and then returns the result and the final value
|
||||
-- of the 'IORef'.
|
||||
--
|
||||
-- /Beware/: As this uses an 'IORef' internally,
|
||||
-- all other effects will have local
|
||||
-- state semantics in regards to 'Output' effects
|
||||
-- interpreted this way.
|
||||
-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will
|
||||
-- never revert 'output's, even if 'Polysemy.Error.runError' is used
|
||||
-- after 'outputToIOMonoid'.
|
||||
outputToIOMonoid
|
||||
:: forall o m r a
|
||||
. (Monoid m, Member (Embed IO) r)
|
||||
=> (o -> m)
|
||||
-> Sem (Output o ': r) a
|
||||
-> Sem r (m, a)
|
||||
outputToIOMonoid f sem = do
|
||||
ref <- embed $ newIORef mempty
|
||||
res <- runOutputMonoidIORef ref f sem
|
||||
end <- embed $ readIORef ref
|
||||
return (end, res)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'outputToIOMonoid', but right-associates uses of '<>'.
|
||||
--
|
||||
-- This asymptotically improves performance if the time complexity of '<>' for
|
||||
-- the 'Monoid' depends only on the size of the first argument.
|
||||
--
|
||||
-- You should always use this instead of 'outputToIOMonoid' if the monoid
|
||||
-- is a list, such as 'String'.
|
||||
--
|
||||
-- /Beware/: As this uses an 'IORef' internally,
|
||||
-- all other effects will have local
|
||||
-- state semantics in regards to 'Output' effects
|
||||
-- interpreted this way.
|
||||
-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will
|
||||
-- never revert 'output's, even if 'Polysemy.Error.runError' is used
|
||||
-- after 'outputToIOMonoidAssocR'.
|
||||
outputToIOMonoidAssocR
|
||||
:: forall o m r a
|
||||
. (Monoid m, Member (Embed IO) r)
|
||||
=> (o -> m)
|
||||
-> Sem (Output o ': r) a
|
||||
-> Sem r (m, a)
|
||||
outputToIOMonoidAssocR f =
|
||||
(fmap . first) (`appEndo` mempty)
|
||||
. outputToIOMonoid (\o -> let !o' = f o in Endo (o' <>))
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Output' effect by ignoring it.
|
||||
--
|
||||
|
@ -12,12 +12,14 @@ module Polysemy.Resource
|
||||
|
||||
-- * Interpretations
|
||||
, runResource
|
||||
, lowerResource
|
||||
, resourceToIOFinal
|
||||
, resourceToIO
|
||||
, lowerResource
|
||||
) where
|
||||
|
||||
import qualified Control.Exception as X
|
||||
import Polysemy
|
||||
import Polysemy.Final
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -72,9 +74,44 @@ onException
|
||||
-> Sem r a
|
||||
onException act end = bracketOnError (pure ()) (const end) (const act)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Resource' effect in terms of 'X.bracket' through final 'IO'
|
||||
--
|
||||
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
|
||||
-- will have local state semantics in regards to 'Resource' effects
|
||||
-- interpreted this way. See 'Final'.
|
||||
--
|
||||
-- Notably, unlike 'resourceToIO', 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./
|
||||
--
|
||||
-- Use 'resourceToIO' instead if you need to run
|
||||
-- pure, stateful interpreters after the interpreter for 'Resource'.
|
||||
-- (Pure interpreters are interpreters that aren't expressed in terms of
|
||||
-- another effect or monad; for example, 'Polysemy.State.runState'.)
|
||||
--
|
||||
-- @since 1.2.0.0
|
||||
resourceToIOFinal :: Member (Final IO) r
|
||||
=> Sem (Resource ': r) a
|
||||
-> Sem r a
|
||||
resourceToIOFinal = 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 resourceToIOFinal #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Resource' effect via in terms of 'X.bracket'.
|
||||
-- | Run a 'Resource' effect in terms of 'X.bracket'.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
lowerResource
|
||||
@ -106,6 +143,7 @@ lowerResource finish = interpretH $ \case
|
||||
|
||||
embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
|
||||
{-# INLINE lowerResource #-}
|
||||
{-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -148,7 +186,7 @@ runResource = interpretH $ \case
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A more flexible --- though less safe --- version of 'lowerResource'.
|
||||
-- | A more flexible --- though less safe --- version of 'resourceToIOFinal'
|
||||
--
|
||||
-- This function is capable of running 'Resource' effects anywhere within an
|
||||
-- effect stack, without relying on an explicit function to lower it into 'IO'.
|
||||
@ -159,7 +197,7 @@ runResource = interpretH $ \case
|
||||
-- by effects _already handled_ in your effect stack, or in 'IO' code run
|
||||
-- directly inside of 'bracket'. It is not safe against exceptions thrown
|
||||
-- explicitly at the main thread. If this is not safe enough for your use-case,
|
||||
-- use 'lowerResource' instead.
|
||||
-- use 'resourceToIOFinal' instead.
|
||||
--
|
||||
-- This function creates a thread, and so should be compiled with @-threaded@.
|
||||
--
|
||||
|
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Polysemy.Writer
|
||||
( -- * Effect
|
||||
@ -14,26 +13,27 @@ module Polysemy.Writer
|
||||
-- * Interpretations
|
||||
, runWriter
|
||||
, runWriterAssocR
|
||||
, runWriterTVar
|
||||
, writerToIOFinal
|
||||
, writerToIOAssocRFinal
|
||||
, writerToEndoWriter
|
||||
|
||||
-- * Interpretations for Other Effects
|
||||
, outputToWriter
|
||||
) where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Semigroup
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Output
|
||||
import Polysemy.State
|
||||
|
||||
import Polysemy.Internal.Writer
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | An effect capable of emitting and intercepting messages.
|
||||
data Writer o m a where
|
||||
Tell :: o -> Writer o m ()
|
||||
Listen :: ∀ o m a. m a -> Writer o m (o, a)
|
||||
Pass :: m (o -> o, a) -> Writer o m a
|
||||
|
||||
makeSem ''Writer
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | @since 0.7.0.0
|
||||
@ -94,31 +94,64 @@ runWriterAssocR
|
||||
=> Sem (Writer o ': r) a
|
||||
-> Sem r (o, a)
|
||||
runWriterAssocR =
|
||||
let
|
||||
go :: forall o r a
|
||||
. Monoid o
|
||||
=> Sem (Writer o ': r) a
|
||||
-> Sem r (o -> o, a)
|
||||
go =
|
||||
runState id
|
||||
. reinterpretH
|
||||
(\case
|
||||
Tell o -> do
|
||||
modify' @(o -> o) (. (o <>)) >>= pureT
|
||||
Listen m -> do
|
||||
mm <- runT m
|
||||
-- TODO(sandy): this is stupid
|
||||
(oo, fa) <- raise $ go mm
|
||||
modify' @(o -> o) (. oo)
|
||||
pure $ fmap (oo mempty, ) fa
|
||||
Pass m -> do
|
||||
mm <- runT m
|
||||
(o, t) <- raise $ runWriterAssocR mm
|
||||
ins <- getInspectorT
|
||||
let f = maybe id fst (inspect ins t)
|
||||
modify' @(o -> o) (. (f o <>))
|
||||
pure (fmap snd t)
|
||||
)
|
||||
{-# INLINE go #-}
|
||||
in fmap (first ($ mempty)) . go
|
||||
(fmap . first) (`appEndo` mempty)
|
||||
. runWriter
|
||||
. writerToEndoWriter
|
||||
. raiseUnder
|
||||
{-# INLINE runWriterAssocR #-}
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- | Transform a 'Writer' effect into atomic operations
|
||||
-- over a 'TVar' through final 'IO'.
|
||||
runWriterTVar :: (Monoid o, Member (Final IO) r)
|
||||
=> TVar o
|
||||
-> Sem (Writer o ': r) a
|
||||
-> Sem r a
|
||||
runWriterTVar tvar = runWriterSTMAction $ \o -> do
|
||||
s <- readTVar tvar
|
||||
writeTVar tvar $! s <> o
|
||||
{-# INLINE runWriterTVar #-}
|
||||
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- | Run a 'Writer' effect by transforming it into atomic operations
|
||||
-- through final 'IO'.
|
||||
--
|
||||
-- Internally, this simply creates a new 'TVar', passes it to
|
||||
-- 'runWriterTVar', and then returns the result and the final value
|
||||
-- of the 'TVar'.
|
||||
--
|
||||
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
|
||||
-- will have local state semantics in regards to 'Writer' effects
|
||||
-- interpreted this way. See 'Final'.
|
||||
writerToIOFinal :: (Monoid o, Member (Final IO) r)
|
||||
=> Sem (Writer o ': r) a
|
||||
-> Sem r (o, a)
|
||||
writerToIOFinal sem = do
|
||||
tvar <- embedFinal $ newTVarIO mempty
|
||||
res <- runWriterTVar tvar sem
|
||||
end <- embedFinal $ readTVarIO tvar
|
||||
return (end, res)
|
||||
{-# INLINE writerToIOFinal #-}
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- | Like 'writerToIOFinal'. but right-associates uses of '<>'.
|
||||
--
|
||||
-- This asymptotically improves performance if the time complexity of '<>'
|
||||
-- for the 'Monoid' depends only on the size of the first argument.
|
||||
--
|
||||
-- You should always use this instead of 'writerToIOFinal' if the monoid
|
||||
-- is a list, such as 'String'.
|
||||
--
|
||||
-- /Beware/: Effects that aren't interpreted in terms of 'IO'
|
||||
-- will have local state semantics in regards to 'Writer' effects
|
||||
-- interpreted this way. See 'Final'.
|
||||
writerToIOAssocRFinal :: (Monoid o, Member (Final IO) r)
|
||||
=> Sem (Writer o ': r) a
|
||||
-> Sem r (o, a)
|
||||
writerToIOAssocRFinal =
|
||||
(fmap . first) (`appEndo` mempty)
|
||||
. writerToIOFinal
|
||||
. writerToEndoWriter
|
||||
. raiseUnder
|
||||
{-# INLINE writerToIOAssocRFinal #-}
|
||||
|
@ -16,4 +16,4 @@ extra-deps:
|
||||
- th-abstraction-0.3.1.0
|
||||
- unagi-chan-0.4.1.0
|
||||
- type-errors-0.2.0.0
|
||||
- type-errors-pretty-0.0.0.0
|
||||
- type-errors-pretty-0.0.0.0
|
@ -2,7 +2,6 @@
|
||||
|
||||
module AsyncSpec where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import Polysemy
|
||||
|
96
test/FinalSpec.hs
Normal file
96
test/FinalSpec.hs
Normal file
@ -0,0 +1,96 @@
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
module FinalSpec where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
import Data.Either
|
||||
import Data.IORef
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Async
|
||||
import Polysemy.Error
|
||||
import Polysemy.Fixpoint
|
||||
import Polysemy.Trace
|
||||
import Polysemy.State
|
||||
|
||||
|
||||
data Node a = Node a (IORef (Node a))
|
||||
|
||||
mkNode :: (Member (Embed IO) r, Member Fixpoint r)
|
||||
=> a
|
||||
-> Sem r (Node a)
|
||||
mkNode a = mdo
|
||||
let nd = Node a p
|
||||
p <- embed $ newIORef nd
|
||||
return nd
|
||||
|
||||
linkNode :: Member (Embed IO) r
|
||||
=> Node a
|
||||
-> Node a
|
||||
-> Sem r ()
|
||||
linkNode (Node _ r) b =
|
||||
embed $ writeIORef r b
|
||||
|
||||
readNode :: Node a -> a
|
||||
readNode (Node a _) = a
|
||||
|
||||
follow :: Member (Embed IO) r
|
||||
=> Node a
|
||||
-> Sem r (Node a)
|
||||
follow (Node _ ref) = embed $ readIORef ref
|
||||
|
||||
test1 :: IO (Either Int (String, Int, Maybe Int))
|
||||
test1 = do
|
||||
ref <- newIORef "abra"
|
||||
runFinal
|
||||
. embedToFinal @IO
|
||||
. runStateIORef ref -- Order of these interpreters don't matter
|
||||
. errorToIOFinal
|
||||
. fixpointToFinal @IO
|
||||
. asyncToIOFinal
|
||||
$ 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
|
||||
. runTraceList
|
||||
. errorToIOFinal
|
||||
. asyncToIOFinal
|
||||
$ do
|
||||
fut <- async $ do
|
||||
trace "Global state semantics?"
|
||||
catch @() (trace "What's that?" *> throw ()) (\_ -> return ())
|
||||
_ <- await fut
|
||||
trace "Nothing at all."
|
||||
|
||||
|
||||
|
||||
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 ())
|
@ -2,7 +2,8 @@
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
module FixpointSpec where
|
||||
|
||||
import Control.Exception (try, evaluate)
|
||||
import Data.Functor.Identity
|
||||
import Control.Exception (evaluate)
|
||||
import Control.Monad.Fix
|
||||
|
||||
import Polysemy
|
||||
@ -29,8 +30,9 @@ runFinalState s sm = mfix $ \ ~(s', _) ->
|
||||
|
||||
test1 :: (String, (Int, ()))
|
||||
test1 =
|
||||
run
|
||||
. runFixpoint run
|
||||
runIdentity
|
||||
. runFinal
|
||||
. fixpointToFinal @Identity
|
||||
. runOutputMonoid (show @Int)
|
||||
. runFinalState 1
|
||||
$ do
|
||||
@ -42,8 +44,9 @@ test1 =
|
||||
|
||||
test2 :: Either [Int] [Int]
|
||||
test2 =
|
||||
run
|
||||
. runFixpoint run
|
||||
runIdentity
|
||||
. runFinal
|
||||
. fixpointToFinal @Identity
|
||||
. runError
|
||||
$ mdo
|
||||
a <- throw (2 : a) `catch` (\e -> return (1 : e))
|
||||
@ -51,8 +54,9 @@ test2 =
|
||||
|
||||
test3 :: Either () (Int, Int)
|
||||
test3 =
|
||||
run
|
||||
. runFixpoint run
|
||||
runIdentity
|
||||
. runFinal
|
||||
. fixpointToFinal @Identity
|
||||
. runError
|
||||
. runLazyState @Int 1
|
||||
$ mdo
|
||||
@ -62,8 +66,9 @@ test3 =
|
||||
|
||||
test4 :: (Int, Either () Int)
|
||||
test4 =
|
||||
run
|
||||
. runFixpoint run
|
||||
runIdentity
|
||||
. runFinal
|
||||
. fixpointToFinal @Identity
|
||||
. runLazyState @Int 1
|
||||
. runError
|
||||
$ mdo
|
||||
@ -73,7 +78,7 @@ test4 =
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ describe "runFixpoint" $ do
|
||||
spec = parallel $ describe "fixpointToFinal on Identity" $ do
|
||||
it "should work with runState" $ do
|
||||
test1 `shouldBe` ("12", (2, ()))
|
||||
it "should work with runError" $ do
|
||||
@ -88,10 +93,10 @@ spec = parallel $ describe "runFixpoint" $ do
|
||||
|
||||
bombMessage :: String
|
||||
bombMessage =
|
||||
"runFixpoint: Internal computation failed.\
|
||||
\ This is likely because you have tried to recursively use\
|
||||
\ the result of a failed computation in an action\
|
||||
\ whose effect may be observed even though the computation failed.\
|
||||
\ It's also possible that you're using an interpreter\
|
||||
\ that uses 'weave' improperly.\
|
||||
\ See documentation for more information."
|
||||
"fixpointToFinal: Internal computation failed.\
|
||||
\ This is likely because you have tried to recursively use\
|
||||
\ the result of a failed computation in an action\
|
||||
\ whose effect may be observed even though the computation failed.\
|
||||
\ It's also possible that you're using an interpreter\
|
||||
\ that uses 'weave' improperly.\
|
||||
\ See documentation for more information."
|
||||
|
@ -9,6 +9,7 @@ import Data.Foldable
|
||||
import Polysemy
|
||||
import Polysemy.Async
|
||||
import Polysemy.Output
|
||||
import Polysemy.Final
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
@ -47,8 +48,11 @@ spec = parallel $ do
|
||||
it "should commit writes of asynced computations" $
|
||||
let io = do
|
||||
ref <- newIORef ""
|
||||
(runM .@ lowerAsync) . runOutputMonoidIORef ref (show @Int) $
|
||||
test1
|
||||
runFinal
|
||||
. embedToFinal @IO
|
||||
. asyncToIOFinal
|
||||
. runOutputMonoidIORef ref (show @Int)
|
||||
$ test1
|
||||
readIORef ref
|
||||
in do
|
||||
res <- io
|
||||
@ -58,8 +62,11 @@ spec = parallel $ do
|
||||
it "should commit writes of asynced computations" $
|
||||
let io = do
|
||||
ref <- newTVarIO ""
|
||||
(runM .@ lowerAsync) . runOutputMonoidTVar ref (show @Int) $
|
||||
test1
|
||||
runFinal
|
||||
. embedToFinal @IO
|
||||
. asyncToIOFinal
|
||||
. runOutputMonoidTVar ref (show @Int)
|
||||
$ test1
|
||||
readTVarIO ref
|
||||
in do
|
||||
res <- io
|
||||
|
@ -8,8 +8,6 @@ import Control.Concurrent.MVar
|
||||
import Control.Concurrent.STM
|
||||
import Control.Exception (evaluate)
|
||||
|
||||
import Data.IORef
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Async
|
||||
import Polysemy.Error
|
||||
@ -55,6 +53,56 @@ test2 =
|
||||
test3 :: (String, (String, ()))
|
||||
test3 = run . runWriter $ listen (tell "and hear")
|
||||
|
||||
test4 :: IO (String, String)
|
||||
test4 = do
|
||||
tvar <- newTVarIO ""
|
||||
(listened, _) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do
|
||||
tell "message "
|
||||
listen $ do
|
||||
tell "has been"
|
||||
a <- async $ tell " received"
|
||||
await a
|
||||
end <- readTVarIO tvar
|
||||
return (end, listened)
|
||||
|
||||
test5 :: IO (String, String)
|
||||
test5 = do
|
||||
tvar <- newTVarIO ""
|
||||
lock <- newEmptyMVar
|
||||
(listened, a) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do
|
||||
tell "message "
|
||||
listen $ do
|
||||
tell "has been"
|
||||
a <- async $ do
|
||||
embedFinal $ takeMVar lock
|
||||
tell " received"
|
||||
return a
|
||||
putMVar lock ()
|
||||
_ <- A.wait a
|
||||
end <- readTVarIO tvar
|
||||
return (end, listened)
|
||||
|
||||
test6 :: Sem '[Error (A.Async (Maybe ())), Final IO] String
|
||||
test6 = do
|
||||
tvar <- embedFinal $ newTVarIO ""
|
||||
lock <- embedFinal $ newEmptyMVar
|
||||
let
|
||||
inner = do
|
||||
tell "message "
|
||||
fmap snd $ listen @String $ do
|
||||
tell "has been"
|
||||
a <- async $ do
|
||||
embedFinal $ takeMVar lock
|
||||
tell " received"
|
||||
throw a
|
||||
asyncToIOFinal (runWriterTVar tvar inner) `catch` \a ->
|
||||
embedFinal $ do
|
||||
putMVar lock ()
|
||||
(_ :: Maybe ()) <- A.wait a
|
||||
readTVarIO tvar
|
||||
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "writer" $ do
|
||||
@ -87,3 +135,24 @@ spec = do
|
||||
evaluate (run t2) `shouldThrow` errorCall "strict"
|
||||
runM t3 `shouldThrow` errorCall "strict"
|
||||
evaluate (run t3) `shouldThrow` errorCall "strict"
|
||||
|
||||
describe "runWriterTVar" $ do
|
||||
it "should listen and commit asyncs spawned and awaited upon in a listen \
|
||||
\block" $ do
|
||||
(end, listened) <- test4
|
||||
end `shouldBe` "message has been received"
|
||||
listened `shouldBe` "has been received"
|
||||
|
||||
it "should commit writes of asyncs spawned inside a listen block even if \
|
||||
\the block has finished." $ do
|
||||
(end, listened) <- test5
|
||||
end `shouldBe` "message has been received"
|
||||
listened `shouldBe` "has been"
|
||||
|
||||
|
||||
it "should commit writes of asyncs spawned inside a listen block even if \
|
||||
\the block failed for any reason." $ do
|
||||
Right end1 <- runFinal . errorToIOFinal $ test6
|
||||
Right end2 <- runFinal . runError $ test6
|
||||
end1 `shouldBe` "message has been received"
|
||||
end2 `shouldBe` "message has been received"
|
||||
|
Loading…
Reference in New Issue
Block a user