polysemy-research/polysemy
1
1
Fork 0
mirror of https://github.com/polysemy-research/polysemy.git synced 2024-09-11 02:25:43 +03:00
Code Issues Projects Releases Wiki Activity

Add Final Effect (#217)

Browse Source 
* 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:
KingoftheHomeless 2019-08-30 22:38:53 +02:00 committed by GitHub
parent baa83700c3
commit 4a5f2ce92a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
28 changed files with 1086 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
ChangeLog.md
View File

@ -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

8
README.md
View File

@ -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.

2
package.yaml
View File

@ -1,5 +1,5 @@
name: polysemy
version: 1.1.0.0
version: 1.2.0.0
github: "isovector/polysemy"
license: BSD3
author: "Sandy Maguire"

2
polysemy-plugin/package.yaml
View File

@ -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
polysemy-plugin/polysemy-plugin.cabal
View File

@ -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

8
polysemy-plugin/test/ExampleSpec.hs
View File

@ -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

8
polysemy.cabal
View File

@ -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

9
src/Polysemy.hs
View File

@ -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

48
src/Polysemy/Async.hs
View File

@ -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" #-}

46
src/Polysemy/Error.hs
View File

@ -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 #-}

2
src/Polysemy/Fail.hs
View File

@ -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
View 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 #-}

53
src/Polysemy/Fixpoint.hs
View File

@ -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" #-}

20
src/Polysemy/Internal.hs
View File

@ -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)

7
src/Polysemy/Internal/Fixpoint.hs
View File

@ -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

3
src/Polysemy/Internal/Forklift.hs
View File

@ -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
View 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 #-}

2
src/Polysemy/Internal/Union.hs
View File

@ -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
View 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 #-}

62
src/Polysemy/Output.hs
View File

@ -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.
--

46
src/Polysemy/Resource.hs
View File

@ -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@.
--

105
src/Polysemy/Writer.hs
View File

@ -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 #-}

2
stack.yaml
View File

@ -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

1
test/AsyncSpec.hs
View File

@ -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
View 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 ())

39
test/FixpointSpec.hs
View File

@ -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."

15
test/OutputSpec.hs
View File

@ -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

73
test/WriterSpec.hs
View File

@ -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"