polysemy 1.3.0.0 → 1.9.2.0
raw patch · 62 files changed
Files
- ChangeLog.md +131/−6
- README.md +181/−98
- bench/Poly.hs +0/−64
- bench/countDown.hs +0/−133
- polysemy.cabal +77/−96
- src/Polysemy.hs +22/−17
- src/Polysemy/Async.hs +7/−72
- src/Polysemy/AtomicState.hs +51/−0
- src/Polysemy/Bundle.hs +6/−4
- src/Polysemy/Embed.hs +1/−1
- src/Polysemy/Embed/Type.hs +1/−0
- src/Polysemy/Error.hs +54/−80
- src/Polysemy/Fail.hs +1/−0
- src/Polysemy/Fail/Type.hs +8/−0
- src/Polysemy/Final.hs +4/−1
- src/Polysemy/Fixpoint.hs +1/−42
- src/Polysemy/IO.hs +2/−31
- src/Polysemy/Input.hs +8/−2
- src/Polysemy/Internal.hs +221/−103
- src/Polysemy/Internal.hs-boot +12/−0
- src/Polysemy/Internal/Bundle.hs +9/−39
- src/Polysemy/Internal/Combinators.hs +65/−38
- src/Polysemy/Internal/CustomErrors.hs +20/−107
- src/Polysemy/Internal/CustomErrors/Redefined.hs +1/−0
- src/Polysemy/Internal/Fixpoint.hs +1/−0
- src/Polysemy/Internal/Forklift.hs +0/−87
- src/Polysemy/Internal/Index.hs +64/−0
- src/Polysemy/Internal/Kind.hs +10/−1
- src/Polysemy/Internal/NonDet.hs +1/−0
- src/Polysemy/Internal/Scoped.hs +159/−0
- src/Polysemy/Internal/Sing.hs +45/−0
- src/Polysemy/Internal/Strategy.hs +5/−3
- src/Polysemy/Internal/TH/Common.hs +35/−10
- src/Polysemy/Internal/TH/Effect.hs +29/−26
- src/Polysemy/Internal/Tactics.hs +61/−6
- src/Polysemy/Internal/Union.hs +183/−134
- src/Polysemy/Internal/Writer.hs +11/−6
- src/Polysemy/Law.hs +0/−197
- src/Polysemy/Membership.hs +1/−0
- src/Polysemy/NonDet.hs +2/−1
- src/Polysemy/Opaque.hs +54/−0
- src/Polysemy/Output.hs +2/−0
- src/Polysemy/Reader.hs +5/−0
- src/Polysemy/Resource.hs +19/−108
- src/Polysemy/Scoped.hs +329/−0
- src/Polysemy/State.hs +19/−14
- src/Polysemy/State/Law.hs +0/−59
- src/Polysemy/Tagged.hs +3/−1
- src/Polysemy/Trace.hs +36/−2
- src/Polysemy/View.hs +0/−76
- src/Polysemy/Writer.hs +5/−4
- test/AsyncSpec.hs +0/−47
- test/BracketSpec.hs +0/−16
- test/ErrorSpec.hs +19/−1
- test/FixpointSpec.hs +1/−1
- test/FusionSpec.hs +0/−1
- test/InspectorSpec.hs +0/−77
- test/LawsSpec.hs +0/−20
- test/ScopedSpec.hs +117/−0
- test/TacticsSpec.hs +22/−0
- test/TypeErrors.hs +0/−107
- test/ViewSpec.hs +0/−40
ChangeLog.md view
@@ -1,6 +1,136 @@ # Changelog for polysemy +## Unreleased +## 1.9.1.0 (2023-04-09)++### Other Changes++* Support GHC 9.6++### Breaking Changes++### Other Changes++## 1.9.0.0 (2022-12-28)++### Breaking Changes+- Slightly modified the signatures of the various `Scoped` interpreters.++### Other Changes+- Added `runScopedNew`, a simple but powerful `Scoped` interpreter.+ `runScopedNew` can be considered a sneak-peek of the future of `Scoped`,+ which will eventually receive a major API rework to make it both simpler and+ more expressive.+- Fixed a bug in various `Scoped` interpreters where a `scoped` usage of an+ effect always relied on the nearest enclosing use of `scoped` from the same+ `Scoped` effect, rather than the `scoped` which handles the effect.+- Added `Polysemy.Opaque`, a module for the `Opaque` effect newtype, meant as+ a tool to wrap polymorphic effect variables so they don't jam up resolution of+ `Member` constraints.+- Expose the type alias `Scoped_` for a scoped effect without callsite parameters.++## 1.8.0.0 (2022-12-22)++### Breaking Changes++- Removed `Polysemy.View`+- Removed `Polysemy.Law`+- Removed `(@)` and `(@@)` from `Polysemy`+- Removed `withLowerToIO` from `Polysemy`. Use `withWeavingToFinal` instead.+- Removed `asyncToIO` and `lowerAsync` from `Polysemy.Async`. Use+ `asyncToIOFinal` instead.+- Removed `lowerEmbedded` from `Polysemy.IO`. Use `embedToMonadIO` instead.+- Removed `lowerError` from `Polysemy.Error`. Use `errorToIOFinal` instead.+- Removed `resourceToIO` and `lowerResource` from `Polysemy.Resource`. Use+ `resourceToIOFinal` instead.+- Removed `runFixpoint` and `runFixpointM` from `Polysemy.Fixpoint`. Use+ `fixpointToFinal` instead.+- Changed semantics of `errorToIOFinal` so that it no longer catches errors+ from other handlers of the same type.+- The semantics of `runScoped` has been changed so that the provided interpreter+ is now used only once per use of `scoped`, instead of each individual action.++### Other Changes++- Exposed `send` from `Polysemy`.+- Dramatically improved build performance of projects when compiling with `-O2`.+- Removed the debug `dump-core` flag.+- Introduced the new meta-effect `Scoped`, which allows running an interpreter locally whose implementation is deferred+ to a later stage.+- Fixed a bug in various `Scoped` interpreters where any explicit recursive+ interpretation of higher-order computations that the handler may perform are+ ignored by the interpreter, and the original handler was reused instead.++## 1.7.1.0 (2021-11-23)++### Other Changes++* Support GHC 9.2.1++## 1.7.0.0 (2021-11-16)++### Breaking Changes++* Added interpreters for `AtomicState` that run in terms of `State`.+* Removed `MemberWithError`+* Removed `DefiningModule`++### Other Changes++* The internal `ElemOf` proof is now implemented as an unsafe integer,+ significantly cutting down on generated core.+* Polysemy no longer emits custom type errors for ambiguous effect actions.+ These have long been rendered moot by `polysemy-plugin`, and the cases that+ they still exist are usually overeager (and wrong.)+* As a result, the core produced by `polysemy` is significantly smaller.+ Programs should see a reduction of ~20% in terms and types, and ~60% in+ coercions.++## 1.6.0.0 (2021-07-12)++### Breaking Changes++* Deprecate `traceToIO` and replace it with `traceToStdout` and `traceToStderr`+* Support GHC 9.0.1++### Other Changes++* Added the combinator `insertAt`, which allows adding effects at a specified index into the effect stack+* Added `Semigroup` and `Monoid` for `Sem`++## 1.5.0.0 (2021-03-30)++### Breaking Changes+* Dropped support for GHC 8.4++### Other Changes+- Added `InterpretersFor` as a shorthand for interpreters consuming multiple effects+- Added `runTSimple` and `bindTSimple`, which are simplified variants of `runT` and `bindT`++## 1.4.0.0 (2020-10-31)++### Breaking Changes+- Added `Polysemy.Async.cancel` to allow cancelling `Async` action (possible name collision)+ ([#321](https://github.com/polysemy-research/polysemy/pull/321), thanks to @aidangilmore)++### Other Changes+- Added `Polysemy.Input.inputs` to mirror `Polysemy.Reader.asks`+ ([#327](https://github.com/polysemy-research/polysemy/issues/327), thanks to @expipiplus1)+- Added `Polysemy.Resource.bracket_`+ ([#335](https://github.com/polysemy-research/polysemy/pull/335), thanks to @expipiplus1)+- Support GHC 8.10.x+ ([#337](https://github.com/polysemy-research/polysemy/pull/337), [#382](https://github.com/polysemy-research/polysemy/pull/382))+- Restrict the existentially quantified monad in a `Weaving` to `Sem r`+ ([#333](https://github.com/polysemy-research/polysemy/pull/333), thanks to @A1kmm)+- Added `raise2Under` and `raise3Under`+ ([#369](https://github.com/polysemy-research/polysemy/pull/369))+- Added `Raise` and `Subsume`+ ([#370](https://github.com/polysemy-research/polysemy/pull/370))+- Fixed memory leaks in `Applicative (Sem r)` methods+ ([#372](https://github.com/polysemy-research/polysemy/pull/372), thanks to @goertzenator)+- Smaller suggestions and fixes (thanks to @jeremyschlatter, @galagora and @felixonmars)+ ## 1.3.0.0 (2020-02-14) ### Breaking Changes@@ -147,7 +277,7 @@ - Fixed a bug in `runWriter` where the MTL semantics wouldn't be respected (thanks to @KingoftheHomeless) - Removed the `Censor` constructor of `Writer` (thanks to @KingoftheHomeless) - Renamed `Yo` to `Weaving`-- Changed the visible type applications for `asks`, `gets`, and `runErrorAsAnother`+- Changed the visible type applications for `asks`, `gets`, `runEmbedded`, `fromEitherM` and `runErrorAsAnother` ### Other Changes @@ -281,8 +411,3 @@ ## 0.1.0.0 (2019-04-11) - Initial release--## Unreleased changes--- Changed the tyvars of `fromEitherM`, `runErrorAsAnother`, `runEmbedded`,- `asks` and `gets`
README.md view
@@ -1,5 +1,5 @@ <p align="center">-<img src="https://raw.githubusercontent.com/isovector/polysemy/master/polysemy.png" alt="Polysemy" title="Polysemy">+<img src="https://raw.githubusercontent.com/polysemy-research/polysemy/master/polysemy.png" alt="Polysemy" title="Polysemy"> </p> <p> </p>@@ -11,84 +11,75 @@ [](https://hackage.haskell.org/package/polysemy-plugin) [](https://funprog.zulipchat.com/#narrow/stream/216942-Polysemy) -## Dedication--> The word 'good' has many meanings. For example, if a man were to shoot his-> grandmother at a range of five hundred yards, I should call him a good shot,-> but not necessarily a good man.->-> Gilbert K. Chesterton-- ## Overview -`polysemy` is a library for writing high-power, low-boilerplate, zero-cost,-domain specific languages. It allows you to separate your business logic from-your implementation details. And in doing so, `polysemy` lets you turn your+`polysemy` is a library for writing high-power, low-boilerplate domain specific+languages. It allows you to separate your business logic from your+implementation details. And in doing so, `polysemy` lets you turn your implementation code into reusable library code. It's like `mtl` but composes better, requires less boilerplate, and avoids the O(n^2) instances problem. -It's like `freer-simple` but more powerful and 35x faster.+It's like `freer-simple` but more powerful. It's like `fused-effects` but with an order of magnitude less boilerplate. Additionally, unlike `mtl`, `polysemy` has no functional dependencies, so you can use multiple copies of the same effect. This alleviates the need for ~~ugly-hacks~~ band-aids like [classy-lenses](http://hackage.haskell.org/package/lens-4.17.1/docs/Control-Lens-TH.html#v:makeClassy),-the [`ReaderT`-pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern) and-nicely solves the [trouble with typed-errors](https://www.parsonsmatt.org/2018/11/03/trouble_with_typed_errors.html).+hacks~~ band-aids like+[classy lenses](http://hackage.haskell.org/package/lens-4.17.1/docs/Control-Lens-TH.html#v:makeClassy),+the+[`ReaderT` pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern)+and nicely solves the+[trouble with typed errors](https://www.parsonsmatt.org/2018/11/03/trouble_with_typed_errors.html). -Concerned about type inference? Check out-[polysemy-plugin](https://github.com/isovector/polysemy/tree/master/polysemy-plugin),-which should perform just as well as `mtl`'s! Add `polysemy-plugin` to your package.yaml-or .cabal file's dependencies section to use. Then turn it on with a pragma in your source-files:+Concerned about type inference? `polysemy` comes with its companion+[`polysemy-plugin`](https://github.com/isovector/polysemy/tree/master/polysemy-plugin),+which helps it perform just as well as `mtl`'s! Add `polysemy-plugin` to your+`package.yaml` or `.cabal` file's `dependencies` section to use. Then turn it on with a pragma in your source files: ```haskell {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} ```-Or by adding `-fplugin=Polysemy.Plugin` to your package.yaml/.cabal file `ghc-options` section. +Or by adding `-fplugin=Polysemy.Plugin` to your `package.yaml`/`.cabal` file `ghc-options` section. ## Features -* *Effects are higher-order,* meaning it's trivial to write `bracket` and `local`+- *Effects are higher-order,* meaning it's trivial to write `bracket` and `local` as first-class effects.-* *Effects are low-boilerplate,* meaning you can create new effects in a+- *Effects are low-boilerplate,* meaning you can create new effects in a single-digit number of lines. New interpreters are nothing but functions and pattern matching.-* *Effects are zero-cost,* meaning that GHC<sup>[1](#fn1)</sup> can optimize- away the entire abstraction at compile time. --<sup><a name="fn1">1</a></sup>: Unfortunately this is not true in GHC 8.6.3, but-will be true in GHC 8.10.1.-- ## Tutorials and Resources -- Raghu Kaippully wrote a beginner friendly [tutorial](https://haskell-explained.gitlab.io/blog/posts/2019/07/28/polysemy-is-cool-part-1/index.html).-- Paweł Szulc gave a [great talk](https://youtu.be/idU7GdlfP9Q?t=1394) on how to start thinking about polysemy.-- I've given a talk on some of the [performance implementation](https://www.youtube.com/watch?v=-dHFOjcK6pA)-- I've also written [some](http://reasonablypolymorphic.com/blog/freer-higher-order-effects/) [blog posts](http://reasonablypolymorphic.com/blog/tactics/) on other implementation details.-+- Raghu Kaippully wrote a beginner friendly+ [tutorial](https://haskell-explained.gitlab.io/blog/posts/2019/07/28/polysemy-is-cool-part-1/index.html).+- Sandy Maguire, the author, wrote a post about+ [Porting to Polysemy](https://reasonablypolymorphic.com/blog/porting-to-polysemy/)+ from transformers/MTL-style monads.+- Paweł Szulc gave a [great talk](https://youtu.be/idU7GdlfP9Q?t=1394) on how+ to start thinking about polysemy.+- Sandy Maguire gave a talk on some of the+ [performance implementation](https://www.youtube.com/watch?v=-dHFOjcK6pA)+- He has also written+ [some](http://reasonablypolymorphic.com/blog/freer-higher-order-effects/)+ [blog posts](http://reasonablypolymorphic.com/blog/tactics/) on other+ implementation details. ## Examples -Make sure you read the [Necessary Language-Extensions](https://github.com/isovector/polysemy#necessary-language-extensions)+Make sure you read the+[Necessary Language Extensions](https://github.com/polysemy-research/polysemy#necessary-language-extensions) before trying these yourself! Teletype effect: ```haskell-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE LambdaCase, BlockArguments #-}-{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds #-}+{-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments, GADTs+ , FlexibleContexts, TypeOperators, DataKinds, PolyKinds, ScopedTypeVariables #-} import Polysemy import Polysemy.Input@@ -101,15 +92,19 @@ makeSem ''Teletype teletypeToIO :: Member (Embed IO) r => Sem (Teletype ': r) a -> Sem r a-teletypeToIO = interpret $ \case+teletypeToIO = interpret \case ReadTTY -> embed getLine WriteTTY msg -> embed $ putStrLn msg runTeletypePure :: [String] -> Sem (Teletype ': r) a -> Sem r ([String], a) runTeletypePure i- = runOutputMonoid pure -- For each WriteTTY in our program, consume an output by appending it to the list in a ([String], a)- . runInputList i -- Treat each element of our list of strings as a line of input- . reinterpret2 \case -- Reinterpret our effect in terms of Input and Output+ -- For each WriteTTY in our program, consume an output by appending it to the+ -- list in a ([String], a)+ = runOutputMonoid pure+ -- Treat each element of our list of strings as a line of input+ . runInputList i+ -- Reinterpret our effect in terms of Input and Output+ . reinterpret2 \case ReadTTY -> maybe "" id <$> input WriteTTY msg -> output msg @@ -134,13 +129,12 @@ main = runM . teletypeToIO $ echo ``` - Resource effect: ```haskell-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE LambdaCase, BlockArguments #-}-{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds, TypeApplications #-}+{-# LANGUAGE TemplateHaskell, LambdaCase, BlockArguments, GADTs+ , FlexibleContexts, TypeOperators, DataKinds, PolyKinds+ , TypeApplications #-} import Polysemy import Polysemy.Input@@ -153,17 +147,18 @@ data CustomException = ThisException | ThatException deriving Show program :: Members '[Resource, Teletype, Error CustomException] r => Sem r ()-program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e)- where work = bracket (readTTY) (const $ writeTTY "exiting bracket") $ \input -> do- writeTTY "entering bracket"- case input of- "explode" -> throw ThisException- "weird stuff" -> writeTTY input >> throw ThatException- _ -> writeTTY input >> writeTTY "no exceptions"+program = catch @CustomException work \e -> writeTTY $ "Caught " ++ show e+ where+ work = bracket (readTTY) (const $ writeTTY "exiting bracket") \input -> do+ writeTTY "entering bracket"+ case input of+ "explode" -> throw ThisException+ "weird stuff" -> writeTTY input *> throw ThatException+ _ -> writeTTY input *> writeTTY "no exceptions" main :: IO (Either CustomException ())-main =- runFinal+main+ = runFinal . embedToFinal @IO . resourceToIOFinal . errorToIOFinal @CustomException@@ -173,7 +168,6 @@ Easy. - ## Friendly Error Messages Free monad libraries aren't well known for their ease-of-use. But following in@@ -194,23 +188,16 @@ makes the helpful suggestion: -```- • 'Resource' is higher-order, but 'interpret' can help only- with first-order effects.- Fix:- use 'interpretH' instead.- • In the expression:- interpret- $ \case+```txt+• 'Resource' is higher-order, but 'interpret' can help only+ with first-order effects.+ Fix:+ use 'interpretH' instead.+• In the expression:+ interpret+ $ \case ``` -Likewise it will give you tips on what to do if you forget a `TypeApplication`-or forget to handle an effect.--Don't like helpful errors? That's OK too --- just flip the `error-messages` flag-and enjoy the raw, unadulterated fury of the typesystem.-- ## Necessary Language Extensions You're going to want to stick all of this into your `package.yaml` file.@@ -230,36 +217,132 @@ - TypeFamilies ``` -## Stellar Engineering - Aligning the stars to optimize `polysemy` away+## Building with Nix -Several things need to be in place to fully realize our performance goals:+The project provides a basic nix config for building in development.+It is defined as a [flake] with backwards compatibility stubs in `default.nix` and `shell.nix`. -- GHC Version- - GHC 8.9+-- Your code- - The module you want to be optimized needs to import `Polysemy.Internal` somewhere in its dependency tree (sufficient to `import Polysemy`)-- GHC Flags- - `-O` or `-O2`- - `-flate-specialise` (this should be automatically turned on by the plugin, but it's worth mentioning)-- Plugin- - `-fplugin=Polysemy.Plugin`-- Additional concerns:- - additional core passes (turned on by the plugin)+To build the main library or plugin: +```bash+nix-build -A polysemy+nix-build -A polysemy-plugin+``` +Flake version:++```bash+nix build+nix build '.#polysemy-plugin'+```++To inspect a dependency:++```bash+nix repl++> p = import ./.+> p.unagi-chan+```++To run a shell command with all dependencies in the environment:++```bash+nix-shell --pure+nix-shell --pure --run 'cabal v2-haddock polysemy'+nix-shell --pure --run ghcid+```++Flake version:++```bash+nix develop -i # just enter a shell+nix develop -i -c cabal v2-haddock polysemy+nix develop -i -c haskell-language-server-wrapper # start HLS for your IDE+```++## *What about performance?* ([TL;DR](#tldr))++Previous versions of this `README` mentioned **the library being**+***zero-cost***, as in having no visible effect on performance. While this was+the original motivation and main factor in implementation of this library, it+turned out that+[**optimizations** we depend on](https://reasonablypolymorphic.com/blog/specialization/),+while showing amazing results in small benchmarks, **don't work in+[bigger, multi-module programs](https://github.com/ghc-proposals/ghc-proposals/pull/313#issuecomment-590143835)**,+what greatly limits their usefulness.++What's more interesting though is that+this **isn't a `polysemy`-specific** problem - basically **all popular effects+libraries** ended up being bitten by variation of this problem in one way or+another, resulting in+[visible drop in performance](https://github.com/lexi-lambda/ghc-proposals/blob/delimited-continuation-primops/proposals/0000-delimited-continuation-primops.md#putting-numbers-to-the-cost)+compared to equivalent code without use of effect systems.++*Why did nobody notice this?*++One factor may be that while GHC's optimizer is+very, very good in general in optimizing all sorts of abstraction, it's+relatively complex and hard to predict - authors of libraries may have not+deemed location of code relevant, even though it had big effect at the end.+The other is that maybe **it doesn't matter as much** as we like to tell+ourselves. Many of these effects+libraries are used in production and they're doing just fine, because maximum+performance usually matters in small, controlled areas of code, that often+don't use features of effect systems at all.++*What can we do about this?*++Luckily, the same person that uncovered this problems proposed a+[solution](https://github.com/lexi-lambda/ghc-proposals/blob/delimited-continuation-primops/proposals/0000-delimited-continuation-primops.md) -+set of primops that will allow interpretation of effects at runtime, with+minimal overhead. It's not *zero-cost* as we hoped for with `polysemy` at+first, but it should have negligible effect on performance in real life and+compared to current solutions, it should be much more predictable and even+resolve some problems with behaviour of+[specific effects](https://github.com/polysemy-research/polysemy/issues/246).+You can try out experimental library that uses proposed features+[here](https://github.com/hasura/eff).++When it comes to `polysemy`, once GHC proposal lands, we will consider the option of+switching to an implementation based on it. This will probably require some+breaking changes, but should resolve performance issues and maybe even make+implementation of higher-order effects easier.++If you're interested in more details, see+Alexis King's+[talk about the problem](https://www.youtube.com/watch?v=0jI-AlWEwYI),+Sandy Maguire's+[followup about how it relates to `polysemy`](https://reasonablypolymorphic.com/blog/mea-culpa/) and+[GHC proposal](https://github.com/ghc-proposals/ghc-proposals/pull/313) that+adds features needed for new type of implementation.++### TL;DR++Basically all current effects libraries (including `polysemy` and+even `mtl`) got performance wrong - **but**, there's ongoing work on extending+GHC with features that will allow for creation of effects implementation with+stable and strong performance. It's what `polysemy` may choose at some point,+but it will probably require few breaking changes.+ ## Acknowledgements, citations, and related work The following is a non-exhaustive list of people and works that have had a significant impact, directly or indirectly, on `polysemy`’s design and implementation: - - Oleg Kiselyov, Amr Sabry, and Cameron Swords — [Extensible Effects: An alternative to monad transfomers][oleg:exteff]- - Oleg Kiselyov and Hiromi Ishii — [Freer Monads, More Extensible Effects][oleg:more]- - Nicolas Wu, Tom Schrijvers, and Ralf Hinze — [Effect Handlers in Scope][wu:scope]- - Nicolas Wu and Tom Schrijvers — [Fusion for Free: Efficient Algebraic Effect Handlers][schrijvers:fusion]- - Andy Gill and other contributors — [`mtl`][hackage:mtl]- - Rob Rix, Patrick Thomson, and other contributors — [`fused-effects`][gh:fused-effects]- - Alexis King and other contributors — [`freer-simple`][gh:freer-simple]+- Oleg Kiselyov, Amr Sabry, and Cameron Swords —+ [Extensible Effects: An alternative to monad transfomers][oleg:exteff]+- Oleg Kiselyov and Hiromi Ishii —+ [Freer Monads, More Extensible Effects][oleg:more]+- Nicolas Wu, Tom Schrijvers, and Ralf Hinze —+ [Effect Handlers in Scope][wu:scope]+- Nicolas Wu and Tom Schrijvers —+ [Fusion for Free: Efficient Algebraic Effect Handlers][schrijvers:fusion]+- Andy Gill and other contributors — [`mtl`][hackage:mtl]+- Rob Rix, Patrick Thomson, and other contributors —+ [`fused-effects`][gh:fused-effects]+- Alexis King and other contributors — [`freer-simple`][gh:freer-simple] [docs]: https://hasura.github.io/eff/Control-Effect.html [gh:fused-effects]: https://github.com/fused-effects/fused-effects@@ -269,4 +352,4 @@ [oleg:more]: http://okmij.org/ftp/Haskell/extensible/more.pdf [schrijvers:fusion]: https://people.cs.kuleuven.be/~tom.schrijvers/Research/papers/mpc2015.pdf [wu:scope]: https://www.cs.ox.ac.uk/people/nicolas.wu/papers/Scope.pdf-+[flake]: https://wiki.nixos.org/wiki/Flakes
− bench/Poly.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}--{-# OPTIONS_GHC -fwarn-all-missed-specializations #-}--module Poly where--import Polysemy-import Polysemy.Error-import Polysemy.Resource-import Polysemy.State-import Polysemy.Input-import Polysemy.Output---slowBeforeSpecialization :: Member (State Int) r => Sem r Int-slowBeforeSpecialization = do- n <- get- if n <= 0- then pure n- else do- put $ n - 1- slowBeforeSpecialization--{-# SPECIALIZE slowBeforeSpecialization :: Sem '[State Int] Int #-}---countDown :: Int -> Int-countDown s =- fst . run . runState s $ slowBeforeSpecialization--prog- :: Sem '[ State Bool- , Error Bool- , Resource- , Embed IO- ] Bool-prog = catch @Bool (throw True) (pure . not)--zoinks :: IO (Either Bool Bool)-zoinks = fmap (fmap snd)- . (runM .@ lowerResource .@@ lowerError)- . runState False- $ prog--data Console m a where- ReadLine :: Console m String- WriteLine :: String -> Console m ()--makeSem ''Console--runConsoleBoring :: [String] -> Sem (Console ': r) a -> Sem r ([String], a)-runConsoleBoring inputs- = runOutputMonoid (:[])- . runInputList inputs- . reinterpret2- (\case- ReadLine -> maybe "" id <$> input- WriteLine msg -> output msg- )-
− bench/countDown.hs
@@ -1,133 +0,0 @@-{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-}-module Main (main) where--import Control.Monad (replicateM_)--import qualified Control.Monad.Except as MTL-import qualified Control.Monad.State as MTL-import qualified Control.Monad.Free as Free--import Criterion (bench, bgroup, whnf)-import Criterion.Main (defaultMain)--import Control.Monad.Freer (Member, Eff, run, send)-import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton)-import Control.Monad.Freer.Error (runError, throwError)-import Control.Monad.Freer.State (get, put, runState)--import qualified Poly as P----------------------------------------------------------------------------------- -- State Benchmarks -------------------------------------------------------------------------------------oneGet :: Int -> (Int, Int)-oneGet n = run (runState n get)--oneGetMTL :: Int -> (Int, Int)-oneGetMTL = MTL.runState MTL.get--countDown :: Int -> (Int, Int)-countDown start = run (runState start go)- where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)--countDownMTL :: Int -> (Int, Int)-countDownMTL = MTL.runState go- where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)----------------------------------------------------------------------------------- -- Exception + State ------------------------------------------------------------------------------------countDownExc :: Int -> Either String (Int,Int)-countDownExc start = run $ runError (runState start go)- where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)--countDownExcMTL :: Int -> Either String (Int,Int)-countDownExcMTL = MTL.runStateT go- where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)----------------------------------------------------------------------------------- -- Freer: Interpreter ------------------------------------------------------------------------------------data Http out where- Open :: String -> Http ()- Close :: Http ()- Post :: String -> Http String- Get :: Http String--open' :: Member Http r => String -> Eff r ()-open' = send . Open--close' :: Member Http r => Eff r ()-close' = send Close--post' :: Member Http r => String -> Eff r String-post' = send . Post--get' :: Member Http r => Eff r String-get' = send Get--runHttp :: Eff (Http ': r) w -> Eff r w-runHttp (Val x) = pure x-runHttp (E u q) = case decomp u of- Right (Open _) -> runHttp (qApp q ())- Right Close -> runHttp (qApp q ())- Right (Post d) -> runHttp (qApp q d)- Right Get -> runHttp (qApp q "")- Left u' -> E u' (tsingleton (runHttp . qApp q ))----------------------------------------------------------------------------------- -- Free: Interpreter ------------------------------------------------------------------------------------data FHttpT x- = FOpen String x- | FClose x- | FPost String (String -> x)- | FGet (String -> x)- deriving Functor--type FHttp = Free.Free FHttpT--fopen' :: String -> FHttp ()-fopen' s = Free.liftF $ FOpen s ()--fclose' :: FHttp ()-fclose' = Free.liftF $ FClose ()--fpost' :: String -> FHttp String-fpost' s = Free.liftF $ FPost s id--fget' :: FHttp String-fget' = Free.liftF $ FGet id--runFHttp :: FHttp a -> Maybe a-runFHttp (Free.Pure x) = pure x-runFHttp (Free.Free (FOpen _ n)) = runFHttp n-runFHttp (Free.Free (FClose n)) = runFHttp n-runFHttp (Free.Free (FPost s n)) = pure s >>= runFHttp . n-runFHttp (Free.Free (FGet n)) = pure "" >>= runFHttp . n----------------------------------------------------------------------------------- -- Benchmark Suite ------------------------------------------------------------------------------------prog :: Member Http r => Eff r ()-prog = open' "cats" >> get' >> post' "cats" >> close'--prog' :: FHttp ()-prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose'--p :: Member Http r => Int -> Eff r ()-p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'--p' :: Int -> FHttp ()-p' count = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose'--main :: IO ()-main =- defaultMain [- bgroup "Countdown Bench" [- bench "discount" $ whnf P.countDown 10000- , bench "freer-simple" $ whnf countDown 10000- , bench "mtl" $ whnf countDownMTL 10000- ]- ]
polysemy.cabal view
@@ -1,21 +1,19 @@-cabal-version: 1.24+cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack------ hash: 0f1599ec8e1caf24489536a197f2eb261ecdfb3613fdc2f2221186cdb0f31a5e name: polysemy-version: 1.3.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>+version: 1.9.2.0+synopsis: Higher-order, low-boilerplate free monads.+description: Please see the README on GitHub at <https://github.com/polysemy-research/polysemy#readme> category: Language-homepage: https://github.com/isovector/polysemy#readme-bug-reports: https://github.com/isovector/polysemy/issues+homepage: https://github.com/polysemy-research/polysemy#readme+bug-reports: https://github.com/polysemy-research/polysemy/issues author: Sandy Maguire-maintainer: sandy@sandymaguire.me-copyright: 2019 Sandy Maguire+maintainer: https://funprog.zulipchat.com/#narrow/stream/216942-Polysemy+copyright: 2019-2023 The Polysemy Lounge license: BSD3 license-file: LICENSE build-type: Custom@@ -25,24 +23,14 @@ source-repository head type: git- location: https://github.com/isovector/polysemy+ location: https://github.com/polysemy-research/polysemy custom-setup setup-depends:- Cabal+ Cabal <3.11 , base >=4.9 && <5 , cabal-doctest >=1.0.6 && <1.1 -flag dump-core- description: Dump HTML for the core generated by GHC during compilation- manual: True- default: False--flag error-messages- description: Provide custom error messages- manual: True- default: True- library exposed-modules: Polysemy@@ -63,9 +51,11 @@ Polysemy.Internal.CustomErrors Polysemy.Internal.CustomErrors.Redefined Polysemy.Internal.Fixpoint- Polysemy.Internal.Forklift+ Polysemy.Internal.Index Polysemy.Internal.Kind Polysemy.Internal.NonDet+ Polysemy.Internal.Scoped+ Polysemy.Internal.Sing Polysemy.Internal.Strategy Polysemy.Internal.Tactics Polysemy.Internal.TH.Common@@ -73,60 +63,67 @@ Polysemy.Internal.Union Polysemy.Internal.Writer Polysemy.IO- Polysemy.Law Polysemy.Membership Polysemy.NonDet+ Polysemy.Opaque Polysemy.Output Polysemy.Reader Polysemy.Resource+ Polysemy.Scoped Polysemy.State- Polysemy.State.Law Polysemy.Tagged Polysemy.Trace- Polysemy.View Polysemy.Writer other-modules: Polysemy.Internal.PluginLookup+ Paths_polysemy+ autogen-modules:+ Paths_polysemy hs-source-dirs: src- default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+ default-extensions:+ BlockArguments+ DataKinds+ DeriveFunctor+ FlexibleContexts+ GADTs+ LambdaCase+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TypeApplications+ TypeOperators+ TypeFamilies+ UnicodeSyntax ghc-options: -Wall build-depends:- QuickCheck >=2.11.3 && <3- , async >=2.2 && <3+ async >=2.2 && <3 , base >=4.9 && <5 , containers >=0.5 && <0.7- , first-class-families >=0.5.0.0 && <0.8+ , first-class-families >=0.5.0.0 && <0.9 , mtl >=2.2.2 && <3- , stm >=2 && <3- , syb >=0.7 && <0.8+ , stm ==2.*+ , syb ==0.7.* , template-haskell >=2.12.0.0 && <3- , th-abstraction >=0.3.1.0 && <0.4- , transformers >=0.5.2.0 && <0.6+ , th-abstraction >=0.3.1.0 && <0.8+ , transformers >=0.5.2.0 && <0.7 , type-errors >=0.2.0.0- , type-errors-pretty >=0.0.0.0 && <0.1 , unagi-chan >=0.4.0.0 && <0.5+ default-language: Haskell2010 if impl(ghc < 8.6)- default-extensions: MonadFailDesugaring TypeInType- if flag(dump-core)- ghc-options: -fplugin=DumpCore -fplugin-opt=DumpCore:core-html- build-depends:- dump-core+ default-extensions:+ MonadFailDesugaring+ TypeInType if impl(ghc < 8.2.2) build-depends: unsupported-ghc-version >1 && <1- if flag(error-messages)- cpp-options: -DCABAL_SERIOUSLY_CMON_MATE- else- cpp-options: -DNO_ERROR_MESSAGES- default-language: Haskell2010 test-suite polysemy-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: AlternativeSpec- AsyncSpec BracketSpec DoctestSpec ErrorSpec@@ -135,73 +132,57 @@ FixpointSpec FusionSpec HigherOrderSpec- InspectorSpec InterceptSpec KnownRowSpec- LawsSpec OutputSpec+ ScopedSpec+ TacticsSpec ThEffectSpec TypeErrors- ViewSpec WriterSpec Paths_polysemy+ Build_doctests+ autogen-modules:+ Paths_polysemy+ Build_doctests hs-source-dirs: test- default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+ default-extensions:+ BlockArguments+ DataKinds+ DeriveFunctor+ FlexibleContexts+ GADTs+ LambdaCase+ PolyKinds+ RankNTypes+ ScopedTypeVariables+ StandaloneDeriving+ TypeApplications+ TypeOperators+ TypeFamilies+ UnicodeSyntax ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-tool-depends:- hspec-discover:hspec-discover >=2.0 build-depends:- QuickCheck >=2.11.3 && <3- , async >=2.2 && <3+ async >=2.2 && <3 , base >=4.9 && <5 , containers >=0.5 && <0.7- , doctest >=0.16.0.1 && <0.17- , first-class-families >=0.5.0.0 && <0.8+ , doctest >=0.16.0.1 && <0.23+ , first-class-families >=0.5.0.0 && <0.9 , hspec >=2.6.0 && <3- , inspection-testing >=0.4.2 && <0.5+ , hspec-discover >=2.0+ , inspection-testing >=0.4.2 && <0.6 , mtl >=2.2.2 && <3 , polysemy- , stm >=2 && <3- , syb >=0.7 && <0.8+ , stm ==2.*+ , syb ==0.7.* , template-haskell >=2.12.0.0 && <3- , th-abstraction >=0.3.1.0 && <0.4- , transformers >=0.5.2.0 && <0.6+ , th-abstraction >=0.3.1.0 && <0.8+ , transformers >=0.5.2.0 && <0.7 , type-errors >=0.2.0.0- , type-errors-pretty >=0.0.0.0 && <0.1 , unagi-chan >=0.4.0.0 && <0.5- if impl(ghc < 8.6)- default-extensions: MonadFailDesugaring TypeInType default-language: Haskell2010--benchmark polysemy-bench- type: exitcode-stdio-1.0- main-is: countDown.hs- other-modules:- Poly- Paths_polysemy- hs-source-dirs:- bench- default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax- build-depends:- QuickCheck >=2.11.3 && <3- , async >=2.2 && <3- , base >=4.9 && <5- , containers >=0.5 && <0.7- , criterion- , first-class-families >=0.5.0.0 && <0.8- , free- , freer-simple- , mtl- , polysemy- , stm >=2 && <3- , syb >=0.7 && <0.8- , template-haskell >=2.12.0.0 && <3- , th-abstraction >=0.3.1.0 && <0.4- , transformers >=0.5.2.0 && <0.6- , type-errors >=0.2.0.0- , type-errors-pretty >=0.0.0.0 && <0.1- , unagi-chan >=0.4.0.0 && <0.5 if impl(ghc < 8.6)- default-extensions: MonadFailDesugaring TypeInType- default-language: Haskell2010+ default-extensions:+ MonadFailDesugaring+ TypeInType
src/Polysemy.hs view
@@ -1,27 +1,28 @@+-- | Description: Polysemy is a library for writing high-power, low-boilerplate domain specific languages module Polysemy ( -- * Core Types Sem () , Member- , MemberWithError , Members - -- * Running Sem+ -- * Running Sem , run , runM , runFinal - -- * Type synonyms for user convenience+ -- * Type synonyms for user convenience , InterpreterFor+ , InterpretersFor - -- * Interoperating With Other Monads- -- ** Embed+ -- * 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+ -- | For advanced uses of 'Final', including creating your own interpreters+ -- that make use of it, see "Polysemy.Final" , Final , embedFinal @@ -30,6 +31,11 @@ , raiseUnder , raiseUnder2 , raiseUnder3+ , raise2Under+ , raise3Under+ , raise_+ , subsume_+ , insertAt -- * Trivial Interpretation , subsume@@ -63,6 +69,11 @@ -- readLine :: 'Member' Console r => 'Sem' r String -- @ --+ -- Each of these generated definitions make use of 'send' in order to perform+ -- the corresponding action of the effect. If you don't want to use+ -- Template Haskell, you can write the necessary boilerplate yourself by+ -- using 'send' directly.+ -- -- Effects which don't make use of the @m@ parameter are known as -- "first-order effects." @@ -90,6 +101,7 @@ -- @ -- -- As you see, in the smart constructors, the @m@ parameter has become @'Sem' r@.+ , send , makeSem , makeSem_ @@ -109,17 +121,10 @@ , reinterpret2H , reinterpret3H - -- * Combinators for Interpreting Directly to IO- , withLowerToIO- -- * Kind Synonyms , Effect , EffectRow - -- * Composing IO-based Interpreters- , (.@)- , (.@@)- -- * Tactics -- | Higher-order effects need to explicitly thread /other effects'/ state -- through themselves. Tactics are a domain-specific language for describing@@ -133,6 +138,8 @@ , WithTactics , getInitialStateT , pureT+ , runTSimple+ , bindTSimple , runT , bindT , getInspectorT@@ -142,8 +149,6 @@ import Polysemy.Final import Polysemy.Internal import Polysemy.Internal.Combinators-import Polysemy.Internal.Forklift import Polysemy.Internal.Kind import Polysemy.Internal.Tactics import Polysemy.Internal.TH.Effect-
src/Polysemy/Async.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The effect 'Async', providing an interface to "Control.Concurrent.Async" module Polysemy.Async ( -- * Effect Async (..)@@ -7,14 +8,13 @@ -- * Actions , async , await+ , cancel -- * Helpers , sequenceConcurrently -- * Interpretations- , asyncToIO , asyncToIOFinal- , lowerAsync ) where import qualified Control.Concurrent.Async as A@@ -31,8 +31,12 @@ -- -- @since 0.5.0.0 data Async m a where+ -- | Run the given action asynchronously and return a thread handle. Async :: m a -> Async m (A.Async (Maybe a))+ -- | Wait for the thread referenced by the given handle to terminate. Await :: A.Async a -> Async m a+ -- | Cancel the thread referenced by the given handle.+ Cancel :: A.Async a -> Async m () makeSem ''Async @@ -46,60 +50,13 @@ sequenceConcurrently t = traverse async t >>= traverse await {-# INLINABLE sequenceConcurrently #-} - --------------------------------------------------------------------------------- | 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 '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- => Sem (Async ': r) a- -> Sem r a-asyncToIO m = withLowerToIO $ \lower _ -> lower $- interpretH- ( \case- Async a -> do- ma <- runT a- ins <- getInspectorT- fa <- embed $ A.async $ lower $ asyncToIO ma- pureT $ fmap (inspect ins) fa-- Await a -> pureT =<< embed (A.wait a)- ) 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@@ -110,28 +67,6 @@ m' <- runS m liftS $ A.async (inspect ins <$> m') Await a -> liftS (A.wait a)+ Cancel a -> liftS (A.cancel a) {-# INLINE asyncToIOFinal #-} ---------------------------------------------------------------------------------- | Run an 'Async' effect in terms of 'A.async'.------ @since 1.0.0.0-lowerAsync- :: Member (Embed IO) r- => (forall x. Sem r x -> IO x)- -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely- -- some combination of 'runM' and other interpreters composed via '.@'.- -> Sem (Async ': r) a- -> Sem r a-lowerAsync lower m = interpretH- ( \case- Async a -> do- ma <- runT a- ins <- getInspectorT- fa <- embed $ A.async $ lower $ lowerAsync lower ma- pureT $ fmap (inspect ins) fa-- Await a -> pureT =<< embed (A.wait a)- ) m-{-# INLINE lowerAsync #-}-{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}
src/Polysemy/AtomicState.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-}++-- | Description: The 'AtomicState' effect module Polysemy.AtomicState ( -- * Effect AtomicState (..)@@ -18,6 +20,9 @@ , runAtomicStateTVar , atomicStateToIO , atomicStateToState+ , runAtomicStateViaState+ , evalAtomicStateViaState+ , execAtomicStateViaState ) where @@ -33,7 +38,9 @@ -- -- @since 1.1.0.0 data AtomicState s m a where+ -- | Run a state action. AtomicState :: (s -> (s, a)) -> AtomicState s m a+ -- | Get the state. AtomicGet :: AtomicState s m s makeSem_ ''AtomicState@@ -75,6 +82,8 @@ return a {-# INLINE atomicState' #-} +-----------------------------------------------------------------------------+-- | Replace the state with the given value. atomicPut :: Member (AtomicState s) r => s -> Sem r ()@@ -83,6 +92,8 @@ return () {-# INLINE atomicPut #-} +-----------------------------------------------------------------------------+-- | Modify the state lazily. atomicModify :: Member (AtomicState s) r => (s -> s) -> Sem r ()@@ -170,3 +181,43 @@ return a AtomicGet -> get {-# INLINE atomicStateToState #-}++------------------------------------------------------------------------------+-- | Run an 'AtomicState' with local state semantics, discarding+-- the notion of atomicity, by transforming it into 'State' and running it+-- with the provided initial state.+--+--+-- @since v1.7.0.0+runAtomicStateViaState :: s+ -> Sem (AtomicState s ': r) a+ -> Sem r (s, a)+runAtomicStateViaState s =+ runState s . atomicStateToState . raiseUnder+{-# INLINE runAtomicStateViaState #-}++------------------------------------------------------------------------------+-- | Evaluate an 'AtomicState' with local state semantics, discarding+-- the notion of atomicity, by transforming it into 'State' and running it+-- with the provided initial state.+--+-- @since v1.7.0.0+evalAtomicStateViaState :: s+ -> Sem (AtomicState s ': r) a+ -> Sem r a+evalAtomicStateViaState s =+ evalState s . atomicStateToState . raiseUnder+{-# INLINE evalAtomicStateViaState #-}++------------------------------------------------------------------------------+-- | Execute an 'AtomicState' with local state semantics, discarding+-- the notion of atomicity, by transforming it into 'State' and running it+-- with the provided initial state.+--+-- @since v1.7.0.0+execAtomicStateViaState :: s+ -> Sem (AtomicState s ': r) a+ -> Sem r s+execAtomicStateViaState s =+ execState s . atomicStateToState . raiseUnder+{-# INLINE execAtomicStateViaState #-}
src/Polysemy/Bundle.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}++-- | Description: The 'Bundle' effect for bundling effects module Polysemy.Bundle ( -- * Effect Bundle (..)@@ -9,13 +11,13 @@ , runBundle , subsumeBundle -- * Miscellaneous- , KnownList ) where import Polysemy import Polysemy.Internal-import Polysemy.Internal.Bundle import Polysemy.Internal.Union+import Polysemy.Internal.Bundle (subsumeMembership)+import Polysemy.Internal.Sing (KnownList (singList)) ------------------------------------------------------------------------------ -- | An effect for collecting multiple effects into one effect.@@ -58,8 +60,8 @@ -> Sem (Append r' r) a runBundle = hoistSem $ \u -> hoist runBundle $ case decomp u of Right (Weaving (Bundle pr e) s wv ex ins) ->- Union (extendMembership @_ @r pr) $ Weaving e s wv ex ins- Left g -> weakenList @r' @r g+ Union (extendMembershipRight @r' @r pr) $ Weaving e s wv ex ins+ Left g -> weakenList @r' @r (singList @r') g {-# INLINE runBundle #-} ------------------------------------------------------------------------------
src/Polysemy/Embed.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for the effect 'Embed' module Polysemy.Embed ( -- * Effect Embed (..)@@ -12,7 +13,6 @@ ) where import Polysemy-import Polysemy.Embed.Type (Embed (..)) ------------------------------------------------------------------------------ -- | Given a natural transform from @m1@ to @m2@
src/Polysemy/Embed/Type.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Embed' effect module Polysemy.Embed.Type ( -- * Effect Embed (..)
src/Polysemy/Error.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK prune #-} +-- | Description: The effect 'Error' and its interpreters module Polysemy.Error ( -- * Effect Error (..)@@ -23,22 +25,30 @@ , runError , mapError , errorToIOFinal- , lowerError ) where -import qualified Control.Exception as X+import qualified Control.Exception as X import Control.Monad import qualified Control.Monad.Trans.Except as E-import Data.Bifunctor (first)-import Data.Typeable+import Data.Unique (Unique, hashUnique, newUnique)+import GHC.Exts (Any) import Polysemy import Polysemy.Final import Polysemy.Internal import Polysemy.Internal.Union+import Unsafe.Coerce (unsafeCoerce) +------------------------------------------------------------------------------+-- | This effect abstracts the throwing and catching of errors, leaving+-- it up to the interpreter whether to use exceptions or monad transformers+-- like 'E.ExceptT' to perform the short-circuiting mechanism. data Error e m a where+ -- | Short-circuit the current program using the given error value. Throw :: e -> Error e m a+ -- | Recover from an error that might have been thrown in the higher-order+ -- action given by the first argument by passing the error to the handler+ -- given by the second argument. Catch :: ∀ e m a. m a -> (e -> m a) -> Error e m a makeSem ''Error@@ -46,7 +56,7 @@ hush :: Either e a -> Maybe a hush (Right a) = Just a-hush (Left _) = Nothing+hush (Left _) = Nothing ------------------------------------------------------------------------------@@ -57,7 +67,7 @@ :: Member (Error e) r => Either e a -> Sem r a-fromEither (Left e) = throw e+fromEither (Left e) = throw e fromEither (Right a) = pure a {-# INLINABLE fromEither #-} @@ -105,7 +115,7 @@ fromExceptionVia f m = do r <- embed $ X.try m case r of- Left e -> throw $ f e+ Left e -> throw $ f e Right a -> pure a {-# INLINABLE fromExceptionVia #-} @@ -139,7 +149,7 @@ s <- getInitialStateS pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s)) case r of- Left e -> throw $ f e+ Left e -> throw $ f e Right a -> pure a {-# INLINABLE fromExceptionSemVia #-} @@ -152,16 +162,16 @@ {-# INLINABLE note #-} --------------------------------------------------------------------------------- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@) --- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type --- @e@ was @'throw'@n and its value is @ex@. +-- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@)+-- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type+-- @e@ was @'throw'@n and its value is @ex@. try :: Member (Error e) r => Sem r a -> Sem r (Either e a) try m = catch (Right <$> m) (return . Left) {-# INLINABLE try #-} ------------------------------------------------------------------------------ -- | A variant of @'try'@ that takes an exception predicate to select which exceptions--- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, +-- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, -- it is re-@'throw'@n. tryJust :: Member (Error e) r => (e -> Maybe b) -> Sem r a -> Sem r (Either b a) tryJust f m = do@@ -170,14 +180,14 @@ Right v -> return (Right v) Left e -> case f e of Nothing -> throw e- Just b -> return $ Left b+ Just b -> return $ Left b {-# INLINABLE tryJust #-} --------------------------------------------------------------------------------- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument --- which is an exception predicate, a function which selects which type of exceptions +-- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument+-- which is an exception predicate, a function which selects which type of exceptions -- we're interested in.-catchJust :: Member (Error e) r +catchJust :: Member (Error e) r => (e -> Maybe b) -- ^ Predicate to select exceptions -> Sem r a -- ^ Computation to run -> (b -> Sem r a) -- ^ Handler@@ -186,7 +196,7 @@ where handler e = case ef e of Nothing -> throw e- Just b -> bf b+ Just b -> bf b {-# INLINABLE catchJust #-} ------------------------------------------------------------------------------@@ -244,14 +254,24 @@ {-# INLINE mapError #-} -newtype WrappedExc e = WrappedExc { unwrapExc :: e }- deriving (Typeable)+data WrappedExc = WrappedExc !Unique Any -instance Typeable e => Show (WrappedExc e) where- show = mappend "WrappedExc: " . show . typeRep+instance Show WrappedExc where+ show (WrappedExc uid _) =+ "errorToIOFinal: Escaped opaque exception. Unique hash is: " <>+ show (hashUnique uid) <> "This should only happen if the computation that " <>+ "threw the exception was somehow invoked outside of the argument of 'errorToIOFinal'; " <>+ "for example, if you 'async' an exceptional computation inside of the argument " <>+ "provided to 'errorToIOFinal', and then 'await' on it *outside* of the argument " <>+ "provided to 'errorToIOFinal'. If that or any similar shenanigans seems unlikely, " <>+ "please open an issue on the GitHub repository." -instance (Typeable e) => X.Exception (WrappedExc e)+instance X.Exception WrappedExc +catchWithUid :: forall e a. Unique -> IO a -> (e -> IO a) -> IO a+catchWithUid uid m h = X.catch m $ \exc@(WrappedExc uid' e) ->+ if uid == uid' then h (unsafeCoerce e) else X.throwIO exc+{-# INLINE catchWithUid #-} ------------------------------------------------------------------------------ -- | Run an 'Error' effect as an 'IO' 'X.Exception' through final 'IO'. This@@ -263,77 +283,31 @@ -- -- @since 1.2.0.0 errorToIOFinal- :: ( Typeable e- , Member (Final IO) r+ :: forall e r a+ . ( Member (Final IO) r ) => Sem (Error e ': r) a -> Sem r (Either e a) errorToIOFinal sem = withStrategicToFinal @IO $ do- m' <- runS (runErrorAsExcFinal sem)+ m' <- bindS (`runErrorAsExcFinal` sem) s <- getInitialStateS- pure $- either- ((<$ s) . Left . unwrapExc)- (fmap Right)- <$> X.try m'+ pure $ do+ uid <- newUnique+ catchWithUid @e uid (fmap Right <$> m' (uid <$ s)) (pure . (<$ s) . Left) {-# INLINE errorToIOFinal #-} runErrorAsExcFinal :: forall e r a- . ( Typeable e- , Member (Final IO) r+ . ( Member (Final IO) r )- => Sem (Error e ': r) a+ => Unique+ -> Sem (Error e ': r) a -> Sem r a-runErrorAsExcFinal = interpretFinal $ \case- Throw e -> pure $ X.throwIO $ WrappedExc e+runErrorAsExcFinal uid = interpretFinal $ \case+ Throw e -> pure $ X.throwIO $ WrappedExc uid (unsafeCoerce e) Catch m h -> do m' <- runS m h' <- bindS h s <- getInitialStateS- pure $ X.catch m' $ \(se :: WrappedExc e) ->- h' (unwrapExc se <$ s)+ pure $ catchWithUid uid m' $ \e -> h' (e <$ 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.------ @since 1.0.0.0-lowerError- :: ( Typeable e- , Member (Embed IO) r- )- => (∀ x. Sem r x -> IO x)- -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is- -- likely some combination of 'runM' and other interpreters composed via- -- '.@'.- -> Sem (Error e ': r) a- -> Sem r (Either e a)-lowerError lower- = embed- . fmap (first unwrapExc)- . X.try- . (lower .@ runErrorAsExc)-{-# INLINE lowerError #-}-{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-}----- TODO(sandy): Can we use the new withLowerToIO machinery for this?-runErrorAsExc- :: forall e r a. ( Typeable e- , Member (Embed IO) r- )- => (∀ x. Sem r x -> IO x)- -> Sem (Error e ': r) a- -> Sem r a-runErrorAsExc lower = interpretH $ \case- Throw e -> embed $ X.throwIO $ WrappedExc e- Catch main handle -> do- is <- getInitialStateT- m <- runT main- h <- bindT handle- let runIt = lower . runErrorAsExc lower- embed $ X.catch (runIt m) $ \(se :: WrappedExc e) ->- runIt $ h $ unwrapExc se <$ is-{-# INLINE runErrorAsExc #-}
src/Polysemy/Fail.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: 'Fail' interpreters module Polysemy.Fail ( -- * Effect Fail(..)
src/Polysemy/Fail/Type.hs view
@@ -1,3 +1,11 @@+-- | Description: 'Fail' effect module Polysemy.Fail.Type where +------------------------------------------------------------------------------+-- | This effect abstracts the concept of 'Control.Monad.Fail.MonadFail',+-- which is a built-in mechanism that converts pattern matching errors to+-- calls to the current monad's instance of that class.+--+-- The instance defined in "Polysemy.Internal" uses this effect to catch+-- those errors. newtype Fail m a = Fail String
src/Polysemy/Final.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-}++-- | Description: The effect 'Final' that allows embedding higher-order actions in+-- the final target monad of the effect stack module Polysemy.Final ( -- * Effect@@ -182,7 +185,7 @@ interpretFinal :: forall m e r a . Member (Final m) r- => (forall x n. e n x -> Strategic m n x)+ => (forall x rInitial. e (Sem rInitial) x -> Strategic m (Sem rInitial) x) -- ^ A natural transformation from the handled effect to the final monad. -> Sem (e ': r) a -> Sem r a
src/Polysemy/Fixpoint.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-} +-- | Description: Interpreters for 'Fixpoint' module Polysemy.Fixpoint ( -- * Effect Fixpoint (..)@@ -73,45 +74,3 @@ 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- -> Sem r a-runFixpoint lower = interpretH $ \case- Fixpoint mf -> do- c <- bindT mf- s <- getInitialStateT- ins <- getInspectorT- pure $ fix $ \fa ->- 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 'fixpointToFinal'.-runFixpointM- :: ( MonadFix m- , Member (Embed m) r- )- => (∀ x. Sem r x -> m x)- -> Sem (Fixpoint ': r) a- -> Sem r a-runFixpointM lower = interpretH $ \case- Fixpoint mf -> do- c <- bindT mf- s <- getInitialStateT- ins <- getInspectorT- embed $ mfix $ \fa ->- lower . runFixpointM lower . c $- fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s-{-# INLINE runFixpointM #-}-{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}
src/Polysemy/IO.hs view
@@ -1,20 +1,18 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: Compatibility with 'MonadIO' module Polysemy.IO ( -- * Interpretations embedToMonadIO- , lowerEmbedded ) where import Control.Monad.IO.Class import Polysemy import Polysemy.Embed-import Polysemy.Internal-import Polysemy.Internal.Union --------------------------------------------------------------------------------- The 'MonadIO' class is conceptually an interpretation of 'IO' to some+-- | The 'MonadIO' class is conceptually an interpretation of 'IO' to some -- other monad. This function reifies that intuition, by transforming an 'IO' -- effect into some other 'MonadIO'. --@@ -43,31 +41,4 @@ -> Sem r a embedToMonadIO = runEmbedded $ liftIO @m {-# INLINE embedToMonadIO #-}------------------------------------------------------------------------------------ | Given some @'MonadIO' m@, interpret all @'Embed' m@ actions in that monad--- at once. This is useful for interpreting effects like databases, which use--- their own monad for describing actions.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 1.0.0.0-lowerEmbedded- :: ( MonadIO m- , Member (Embed IO) r- )- => (forall x. m x -> IO x) -- ^ The means of running this monad.- -> Sem (Embed m ': r) a- -> Sem r a-lowerEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->- run_m $ m $ \u ->- case decomp u of- Left x -> liftIO- . lower- . liftSem- $ hoist (lowerEmbedded run_m) x-- Right (Weaving (Embed wd) s _ y _) ->- fmap y $ fmap (<$ s) wd
src/Polysemy/Input.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Input' effect module Polysemy.Input ( -- * Effect Input (..) -- * Actions , input+ , inputs -- * Interpretations , runInputConst@@ -22,10 +24,15 @@ -- | An effect which can provide input to an application. Useful for dealing -- with streaming input. data Input i m a where+ -- | Get the next available message. Input :: Input i m i makeSem ''Input +-- | Apply a function to an input, cf. 'Polysemy.Reader.asks'+inputs :: forall i j r. Member (Input i) r => (i -> j) -> Sem r j+inputs f = f <$> input+{-# INLINABLE inputs #-} ------------------------------------------------------------------------------ -- | Run an 'Input' effect by always giving back the same value.@@ -47,7 +54,7 @@ Input -> do s <- gets uncons for_ s $ put . snd- pure $ fmap fst s+ pure $ fst <$> s ) {-# INLINE runInputList #-} @@ -58,4 +65,3 @@ runInputSem m = interpret $ \case Input -> m {-# INLINE runInputSem #-}-
src/Polysemy/Internal.hs view
@@ -1,39 +1,53 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The 'Sem' type and the most basic stack manipulation utilities module Polysemy.Internal ( Sem (..) , Member- , MemberWithError , Members , send , sendUsing , embed , run , runM+ , raise_+ , Raise (..) , raise , raiseUnder , raiseUnder2 , raiseUnder3+ , raise2Under+ , raise3Under+ , subsume_+ , Subsume (..) , subsume , subsumeUsing+ , insertAt , Embed (..) , usingSem , liftSem , hoistSem+ , restack+ , Append , InterpreterFor- , (.@)- , (.@@)+ , InterpretersFor ) where import Control.Applicative import Control.Monad+#if __GLASGOW_HASKELL__ < 808++ import Control.Monad.Fail+#endif import Control.Monad.Fix import Control.Monad.IO.Class import Data.Functor.Identity@@ -41,9 +55,13 @@ import Polysemy.Embed.Type import Polysemy.Fail.Type import Polysemy.Internal.Fixpoint+import Polysemy.Internal.Index (InsertAtUnprovidedIndex, InsertAtIndex(insertAtIndex))+import Polysemy.Internal.Kind import Polysemy.Internal.NonDet import Polysemy.Internal.PluginLookup import Polysemy.Internal.Union+import Type.Errors (WhenStuck)+import Polysemy.Internal.Sing (ListOfLength (listOfLength)) -- $setup@@ -249,22 +267,29 @@ instance Functor (Sem f) where- fmap f (Sem m) = Sem $ \k -> fmap f $ m k+ fmap f (Sem m) = Sem $ \k -> f <$> m k {-# INLINE fmap #-} instance Applicative (Sem f) where- pure a = Sem $ const $ pure a+ pure a = Sem $ \_ -> pure a {-# INLINE pure #-} Sem f <*> Sem a = Sem $ \k -> f k <*> a k {-# INLINE (<*>) #-} + liftA2 f ma mb = Sem $ \k -> liftA2 f (runSem ma k) (runSem mb k)+ {-# INLINE liftA2 #-} -instance Monad (Sem f) where- return = pure- {-# INLINE return #-}+ ma <* mb = Sem $ \k -> runSem ma k <* runSem mb k+ {-# INLINE (<*) #-} + -- Use (>>=) because many monads are bad at optimizing (*>).+ -- Ref https://github.com/polysemy-research/polysemy/issues/368+ ma *> mb = Sem $ \k -> runSem ma k >>= \_ -> runSem mb k+ {-# INLINE (*>) #-}++instance Monad (Sem f) where Sem ma >>= f = Sem $ \k -> do z <- ma k runSem (f z) k@@ -287,12 +312,19 @@ fail = send . Fail {-# INLINE fail #-} +-- | @since 1.6.0.0+instance Semigroup a => Semigroup (Sem f a) where+ (<>) = liftA2 (<>) +-- | @since 1.6.0.0+instance Monoid a => Monoid (Sem f a) where+ mempty = pure mempty+ ------------------------------------------------------------------------------ -- | This instance will only lift 'IO' actions. If you want to lift into some -- other 'MonadIO' type, use this instance, and handle it via the -- 'Polysemy.IO.embedToMonadIO' interpretation.-instance (Member (Embed IO) r) => MonadIO (Sem r) where+instance Member (Embed IO) r => MonadIO (Sem r) where liftIO = embed {-# INLINE liftIO #-} @@ -301,11 +333,15 @@ {-# INLINE mfix #-} +------------------------------------------------------------------------------+-- | Create a 'Sem' from a 'Union' with matching stacks. liftSem :: Union r (Sem r) a -> Sem r a liftSem u = Sem $ \k -> k u {-# INLINE liftSem #-} +------------------------------------------------------------------------------+-- | Extend the stack of a 'Sem' with an explicit 'Union' transformation. hoistSem :: (∀ x. Union r (Sem r) x -> Union r' (Sem r') x) -> Sem r a@@ -313,23 +349,60 @@ hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u {-# INLINE hoistSem #-} +------------------------------------------------------------------------------+-- | Extend the stack of a 'Sem' with an explicit membership proof+-- transformation.+restack :: (forall e. ElemOf e r -> ElemOf e r')+ -> Sem r a+ -> Sem r' a+restack n = hoistSem $ \(Union pr wav) -> hoist (restack n) $ Union (n pr) wav+{-# INLINE restack #-} ------------------------------------------------------------------------------+-- | Introduce an arbitrary number of effects on top of the effect stack. This+-- function is highly polymorphic, so it may be good idea to use its more+-- concrete versions (like 'raise') or type annotations to avoid vague errors+-- in ambiguous contexts.+--+-- @since 1.4.0.0+raise_ :: ∀ r r' a. Raise r r' => Sem r a -> Sem r' a+raise_ = hoistSem $ hoist raise_ . raiseUnion+{-# INLINE raise_ #-}+++-- | See 'raise'.+--+-- @since 1.4.0.0+class Raise (r :: EffectRow) (r' :: EffectRow) where+ raiseUnion :: Union r m a -> Union r' m a++instance {-# overlapping #-} Raise r r where+ raiseUnion = id+ {-# INLINE raiseUnion #-}++instance (r' ~ (_0 ': r''), Raise r r'') => Raise r r' where+ raiseUnion = (\(Union n w) -> Union (There n) w) . raiseUnion+ {-# INLINE raiseUnion #-}+++------------------------------------------------------------------------------ -- | Introduce an effect into 'Sem'. Analogous to--- 'Control.Monad.Class.Trans.lift' in the mtl ecosystem+-- 'Control.Monad.Class.Trans.lift' in the mtl ecosystem. For a variant that+-- can introduce an arbitrary number of effects, see 'raise_'. raise :: ∀ e r a. Sem r a -> Sem (e ': r) a-raise = hoistSem $ hoist raise . weaken+raise = raise_ {-# INLINE raise #-} ------------------------------------------------------------------------------ -- | Like 'raise', but introduces a new effect underneath the head of the--- list.+-- list. See 'raiseUnder2' or 'raiseUnder3' for introducing more effects. If+-- you need to introduce even more of them, check out 'subsume_'. -- -- 'raiseUnder' can be used in order to turn transformative interpreters--- into reinterpreters. This is especially useful if you're writing an interpreter--- which introduces an intermediary effect, and then want to use an existing--- interpreter on that effect.+-- into reinterpreters. This is especially useful if you're writing an+-- interpreter which introduces an intermediary effect, and then want to use+-- an existing interpreter on that effect. -- -- For example, given: --@@ -350,12 +423,7 @@ -- -- @since 1.2.0.0 raiseUnder :: ∀ e2 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': r) a-raiseUnder = hoistSem $ hoist raiseUnder . weakenUnder- where- weakenUnder :: ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': r) m x- weakenUnder (Union Here a) = Union Here a- weakenUnder (Union (There n) a) = Union (There (There n)) a- {-# INLINE weakenUnder #-}+raiseUnder = subsume_ {-# INLINE raiseUnder #-} @@ -365,12 +433,7 @@ -- -- @since 1.2.0.0 raiseUnder2 :: ∀ e2 e3 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': r) a-raiseUnder2 = hoistSem $ hoist raiseUnder2 . weakenUnder2- where- weakenUnder2 :: ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': e3 ': r) m x- weakenUnder2 (Union Here a) = Union Here a- weakenUnder2 (Union (There n) a) = Union (There (There (There n))) a- {-# INLINE weakenUnder2 #-}+raiseUnder2 = subsume_ {-# INLINE raiseUnder2 #-} @@ -380,15 +443,77 @@ -- -- @since 1.2.0.0 raiseUnder3 :: ∀ e2 e3 e4 e1 r a. Sem (e1 ': r) a -> Sem (e1 ': e2 ': e3 ': e4 ': r) a-raiseUnder3 = hoistSem $ hoist raiseUnder3 . weakenUnder3- where- weakenUnder3 :: ∀ m x. Union (e1 ': r) m x -> Union (e1 ': e2 ': e3 ': e4 ': r) m x- weakenUnder3 (Union Here a) = Union Here a- weakenUnder3 (Union (There n) a) = Union (There (There (There (There n)))) a- {-# INLINE weakenUnder3 #-}+raiseUnder3 = subsume_ {-# INLINE raiseUnder3 #-} + ------------------------------------------------------------------------------+-- | Like 'raise', but introduces an effect two levels underneath the head of+-- the list.+--+-- @since 1.4.0.0+raise2Under :: ∀ e3 e1 e2 r a. Sem (e1 : e2 : r) a -> Sem (e1 : e2 : e3 : r) a+raise2Under = hoistSem $ hoist raise2Under . weaken2Under+ where+ weaken2Under :: ∀ m x. Union (e1 : e2 : r) m x -> Union (e1 : e2 : e3 : r) m x+ weaken2Under (Union Here a) = Union Here a+ weaken2Under (Union (There Here) a) = Union (There Here) a+ weaken2Under (Union (There (There n)) a) = Union (There (There (There n))) a+ {-# INLINE weaken2Under #-}+{-# INLINE raise2Under #-}+++------------------------------------------------------------------------------+-- | Like 'raise', but introduces an effect three levels underneath the head+-- of the list.+--+-- @since 1.4.0.0+raise3Under :: ∀ e4 e1 e2 e3 r a. Sem (e1 : e2 : e3 : r) a -> Sem (e1 : e2 : e3 : e4 : r) a+raise3Under = hoistSem $ hoist raise3Under . weaken3Under+ where+ weaken3Under :: ∀ m x. Union (e1 : e2 : e3 : r) m x -> Union (e1 : e2 : e3 : e4 : r) m x+ weaken3Under (Union Here a) = Union Here a+ weaken3Under (Union (There Here) a) = Union (There Here) a+ weaken3Under (Union (There (There Here)) a) = Union (There (There Here)) a+ weaken3Under (Union (There (There (There n))) a) = Union (There (There (There (There n)))) a+ {-# INLINE weaken3Under #-}+{-# INLINE raise3Under #-}+++------------------------------------------------------------------------------+-- | Allows reordering and adding known effects on top of the effect stack, as+-- long as the polymorphic "tail" of new stack is a 'raise'-d version of the+-- original one. This function is highly polymorphic, so it may be a good idea+-- to use its more concrete version ('subsume'), fitting functions from the+-- 'raise' family or type annotations to avoid vague errors in ambiguous+-- contexts.+--+-- @since 1.4.0.0+subsume_ :: ∀ r r' a. Subsume r r' => Sem r a -> Sem r' a+subsume_ = hoistSem $ hoist subsume_ . subsumeUnion+{-# INLINE subsume_ #-}+++-- | See 'subsume_'.+--+-- @since 1.4.0.0+class Subsume (r :: EffectRow) (r' :: EffectRow) where+ subsumeUnion :: Union r m a -> Union r' m a++instance {-# incoherent #-} Raise r r' => Subsume r r' where+ subsumeUnion = raiseUnion+ {-# INLINE subsumeUnion #-}++instance (Member e r', Subsume r r') => Subsume (e ': r) r' where+ subsumeUnion = either subsumeUnion injWeaving . decomp+ {-# INLINE subsumeUnion #-}++instance Subsume '[] r where+ subsumeUnion = absurdU+ {-# INLINE subsumeUnion #-}+++------------------------------------------------------------------------------ -- | Interprets an effect in terms of another identical effect. -- -- This is useful for defining interpreters that use 'Polysemy.reinterpretH'@@ -396,11 +521,15 @@ -- Using such an interpreter recursively may result in duplicate effects, -- which may then be eliminated using 'subsume'. --+-- For a version that can introduce an arbitrary number of new effects and+-- reorder existing ones, see 'subsume_'.+-- -- @since 1.2.0.0-subsume :: Member e r => Sem (e ': r) a -> Sem r a-subsume = subsumeUsing membership+subsume :: ∀ e r a. Member e r => Sem (e ': r) a -> Sem r a+subsume = subsume_ {-# INLINE subsume #-} + ------------------------------------------------------------------------------ -- | Interprets an effect in terms of another identical effect, given an -- explicit proof that the effect exists in @r@.@@ -416,10 +545,10 @@ -- @ -- -- @since 1.3.0.0-subsumeUsing :: forall e r a. ElemOf e r -> Sem (e ': r) a -> Sem r a+subsumeUsing :: ∀ e r a. ElemOf e r -> Sem (e ': r) a -> Sem r a subsumeUsing pr = let- go :: forall x. Sem (e ': r) x -> Sem r x+ go :: ∀ x. Sem (e ': r) x -> Sem r x go = hoistSem $ \u -> hoist go $ case decomp u of Right w -> Union pr w Left g -> g@@ -428,14 +557,58 @@ go {-# INLINE subsumeUsing #-} +------------------------------------------------------------------------------+-- | Introduce a set of effects into 'Sem' at the index @i@, before the effect+-- that previously occupied that position. This is intended to be used with a+-- type application:+--+-- @+-- let+-- sem1 :: Sem [e1, e2, e3, e4, e5] a+-- sem1 = insertAt @2 (sem0 :: Sem [e1, e2, e5] a)+-- @+--+-- @since 1.6.0.0+insertAt+ :: forall index inserted head oldTail tail old full a+ . ( ListOfLength index head+ , WhenStuck index InsertAtUnprovidedIndex+ , old ~ Append head oldTail+ , tail ~ Append inserted oldTail+ , full ~ Append head tail+ , InsertAtIndex index head tail oldTail full inserted)+ => Sem old a+ -> Sem full a+insertAt = hoistSem $ \u -> hoist (insertAt @index @inserted @head @oldTail) $+ weakenMid @oldTail (listOfLength @index @head) (insertAtIndex @Effect @index @head @tail @oldTail @full @inserted) u+{-# INLINE insertAt #-} + --------------------------------------------------------------------------------- | Embed an effect into a 'Sem'. This is used primarily via--- 'Polysemy.makeSem' to implement smart constructors.+-- | Execute an action of an effect.+--+-- This is primarily used to create methods for actions of effects:+--+-- @+-- data FooBar m a where+-- Foo :: String -> m a -> FooBar m a+-- Bar :: FooBar m Int+--+-- foo :: Member FooBar r => String -> Sem r a -> Sem r a+-- foo s m = send (Foo s m)+--+-- bar :: Member FooBar r => Sem r Int+-- bar = send Bar+-- @+--+-- 'Polysemy.makeSem' allows you to eliminate this boilerplate.+--+-- @since TODO send :: Member e r => e (Sem r) a -> Sem r a send = liftSem . inj {-# INLINE[3] send #-} + ------------------------------------------------------------------------------ -- | Embed an effect into a 'Sem', given an explicit proof -- that the effect exists in @r@.@@ -474,6 +647,7 @@ pure $ f $ a <$ s {-# INLINE runM #-} + ------------------------------------------------------------------------------ -- | Type synonym for interpreters that consume an effect without changing the -- return value. Offered for user convenience.@@ -484,67 +658,11 @@ -- teletypeToIO :: 'Member' (Embed IO) r -- => 'InterpreterFor' Teletype r -- @-type InterpreterFor e r = forall a. Sem (e ': r) a -> Sem r a----------------------------------------------------------------------------------- | Some interpreters need to be able to lower down to the base monad (often--- 'IO') in order to function properly --- some good examples of this are--- 'Polysemy.Error.lowerError' and 'Polysemy.Resource.lowerResource'.------ However, these interpreters don't compose particularly nicely; for example,--- to run 'Polysemy.Resource.lowerResource', you must write:------ @--- runM . lowerError runM--- @------ Notice that 'runM' is duplicated in two places here. The situation gets--- exponentially worse the more intepreters you have that need to run in this--- pattern.------ Instead, '.@' performs the composition we'd like. The above can be written as------ @--- (runM .@ lowerError)--- @------ The parentheses here are important; without them you'll run into operator--- precedence errors.------ __Warning:__ This combinator will __duplicate work__ that is intended to be--- 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)- -- ^ The lowering function, likely 'runM'.- -> (∀ y. (∀ x. Sem r x -> m x)- -> Sem (e ': r) y- -> Sem r y)- -> Sem (e ': r) z- -> m z-f .@ g = f . g f-infixl 8 .@+type InterpreterFor e r = ∀ a. Sem (e ': r) a -> Sem r a --------------------------------------------------------------------------------- | Like '.@', but for interpreters which change the resulting type --- eg.--- 'Polysemy.Error.lowerError'.-(.@@)- :: Monad m- => (∀ x. Sem r x -> m x)- -- ^ The lowering function, likely 'runM'.- -> (∀ y. (∀ x. Sem r x -> m x)- -> Sem (e ': r) y- -> Sem r (f y))- -> Sem (e ': r) z- -> m (f z)-f .@@ g = f . g f-infixl 8 .@@+-- | Variant of 'InterpreterFor' that takes a list of effects.+-- @since 1.5.0.0+type InterpretersFor es r = ∀ a. Sem (Append es r) a -> Sem r a
+ src/Polysemy/Internal.hs-boot view
@@ -0,0 +1,12 @@+{-# LANGUAGE RoleAnnotations #-}+module Polysemy.Internal where++import Polysemy.Internal.Kind+import Data.Kind (Type)++type role Sem nominal nominal+data Sem (r :: EffectRow) (a :: Type)++instance Functor (Sem r)+instance Applicative (Sem r)+instance Monad (Sem r)
src/Polysemy/Internal/Bundle.hs view
@@ -2,54 +2,24 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: Stack manipulation handlers for the 'Polysemy.Bundle.Bundle' effect module Polysemy.Internal.Bundle where -import Data.Proxy-import Polysemy-import Polysemy.Internal.Union--type family Append l r where- Append (a ': l) r = a ': (Append l r)- Append '[] r = r+import Polysemy (Members)+import Polysemy.Internal.Union (ElemOf(..), membership)+import Polysemy.Internal.Kind (Append) +------------------------------------------------------------------------------+-- | Extend a membership proof's stack by arbitrary effects. extendMembership :: forall r r' e. ElemOf e r -> ElemOf e (Append r r') extendMembership Here = Here extendMembership (There e) = There (extendMembership @_ @r' e) {-# INLINE extendMembership #-} +------------------------------------------------------------------------------+-- | Transform a membership proof's stack by arbitrary effects using evidence+-- from the context. subsumeMembership :: forall r r' e. Members r r' => ElemOf e r -> ElemOf e r' subsumeMembership Here = membership @e @r' subsumeMembership (There (pr :: ElemOf e r'')) = subsumeMembership @r'' @r' pr {-# INLINE subsumeMembership #-}--weakenList :: forall r' r m a- . KnownList r'- => Union r m a- -> Union (Append r' r) m a-weakenList u = unconsKnownList @_ @r' u (\_ (_ :: Proxy r'') -> weaken (weakenList @r'' u))-{-# INLINE weakenList #-}------------------------------------------------------------------------------------ | A class for type-level lists with a known spine.------ This constraint is eventually satisfied as @r@ is instantied to a--- concrete list.-class KnownList (l :: [k]) where- unconsKnownList :: (l ~ '[] => a)- -> ( forall x r- . (l ~ (x ': r), KnownList r)- => Proxy x- -> Proxy r- -> a- )- -> a--instance KnownList '[] where- unconsKnownList b _ = b- {-# INLINE unconsKnownList #-}--instance KnownList r => KnownList (x ': r) where- unconsKnownList _ b = b Proxy Proxy- {-# INLINE unconsKnownList #-}-
src/Polysemy/Internal/Combinators.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The basic interpreter-building combinators module Polysemy.Internal.Combinators ( -- * First order interpret@@ -18,6 +19,7 @@ , reinterpretH , reinterpret2H , reinterpret3H+ , interpretWeaving -- * Conditional , interceptUsing@@ -28,6 +30,7 @@ , lazilyStateful ) where +import Control.Arrow ((>>>)) import Control.Monad import qualified Control.Monad.Trans.State.Lazy as LS import qualified Control.Monad.Trans.State.Strict as S@@ -45,10 +48,12 @@ firstOrder- :: ((forall m x. e m x -> Tactical e m r x) -> t)- -> (forall m x. e m x -> Sem r x)+ :: ((forall rInitial x. e (Sem rInitial) x ->+ Tactical e (Sem rInitial) r x) -> t)+ -> (forall rInitial x. e (Sem rInitial) x -> Sem r x) -> t-firstOrder higher f = higher $ \(e :: e m x) -> liftT @m $ f e+firstOrder higher f = higher $ \(e :: e (Sem rInitial) x) ->+ liftT $ f e {-# INLINE firstOrder #-} @@ -57,7 +62,7 @@ -- transforming it into other effects inside of @r@. interpret :: FirstOrder e "interpret"- => (∀ x m. e m x -> Sem r x)+ => (∀ rInitial x. e (Sem rInitial) x -> Sem r x) -- ^ A natural transformation from the handled effect to other effects -- already in 'Sem'. -> Sem (e ': r) a@@ -73,19 +78,29 @@ -- -- See the notes on 'Tactical' for how to use this function. interpretH- :: (∀ x m . e m x -> Tactical e m r x)+ :: (∀ rInitial x . e (Sem rInitial) x -> Tactical e (Sem rInitial) r x) -- ^ A natural transformation from the handled effect to other effects -- already in 'Sem'. -> Sem (e ': r) a -> Sem r a-interpretH f (Sem m) = m $ \u ->+interpretH f (Sem m) = Sem $ \k -> m $ \u -> case decomp u of- Left x -> liftSem $ hoist (interpretH f) x+ Left x -> k $ hoist (interpretH f) x Right (Weaving e s d y v) -> do- a <- runTactics s d v $ f e- pure $ y a+ fmap y $ usingSem k $ runTactics s d v (interpretH f . d) $ f e {-# INLINE interpretH #-} +-- | Interpret an effect @e@ through a natural transformation from @Weaving e@+-- to @Sem r@+interpretWeaving ::+ ∀ e r .+ (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) ->+ InterpreterFor e r+interpretWeaving h (Sem m) =+ Sem \ k -> m $ decomp >>> \case+ Right wav -> runSem (h wav) k+ Left g -> k $ hoist (interpretWeaving h) g+{-# inline interpretWeaving #-} ------------------------------------------------------------------------------ -- | A highly-performant combinator for interpreting an effect statefully. See@@ -106,7 +121,7 @@ (Just . snd) $ x Right (Weaving e z _ y _) ->- fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e+ y . (<$ z) <$> S.mapStateT (usingSem k) (f e) {-# INLINE interpretInStateT #-} @@ -128,7 +143,7 @@ (Just . snd) $ x Right (Weaving e z _ y _) ->- fmap (y . (<$ z)) $ LS.mapStateT (usingSem k) $ f e+ y . (<$ z) <$> LS.mapStateT (usingSem k) (f e) {-# INLINE interpretInLazyStateT #-} @@ -160,16 +175,18 @@ -- See the notes on 'Tactical' for how to use this function. reinterpretH :: forall e1 e2 r a- . (∀ m x. e1 m x -> Tactical e1 m (e2 ': r) x)+ . (∀ rInitial x. e1 (Sem rInitial) x ->+ Tactical e1 (Sem rInitial) (e2 ': r) x) -- ^ A natural transformation from the handled effect to the new effect. -> Sem (e1 ': r) a -> Sem (e2 ': r) a-reinterpretH f (Sem m) = Sem $ \k -> m $ \u ->+reinterpretH f sem = Sem $ \k -> runSem sem $ \u -> case decompCoerce u of Left x -> k $ hoist (reinterpretH f) $ x Right (Weaving e s d y v) -> do- a <- usingSem k $ runTactics s (raiseUnder . d) v $ f e- pure $ y a+ fmap y $ usingSem k+ $ runTactics s (raiseUnder . d) v (reinterpretH f . d)+ $ f e {-# INLINE[3] reinterpretH #-} -- TODO(sandy): Make this fuse in with 'stateful' directly. @@ -182,7 +199,7 @@ reinterpret :: forall e1 e2 r a . FirstOrder e1 "reinterpret"- => (∀ m x. e1 m x -> Sem (e2 ': r) x)+ => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': r) x) -- ^ A natural transformation from the handled effect to the new effect. -> Sem (e1 ': r) a -> Sem (e2 ': r) a@@ -197,7 +214,8 @@ -- See the notes on 'Tactical' for how to use this function. reinterpret2H :: forall e1 e2 e3 r a- . (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': r) x)+ . (∀ rInitial x. e1 (Sem rInitial) x ->+ Tactical e1 (Sem rInitial) (e2 ': e3 ': r) x) -- ^ A natural transformation from the handled effect to the new effects. -> Sem (e1 ': r) a -> Sem (e2 ': e3 ': r) a@@ -205,8 +223,9 @@ case decompCoerce u of Left x -> k $ weaken $ hoist (reinterpret2H f) $ x Right (Weaving e s d y v) -> do- a <- usingSem k $ runTactics s (raiseUnder2 . d) v $ f e- pure $ y a+ fmap y $ usingSem k+ $ runTactics s (raiseUnder2 . d) v (reinterpret2H f . d)+ $ f e {-# INLINE[3] reinterpret2H #-} @@ -215,7 +234,8 @@ reinterpret2 :: forall e1 e2 e3 r a . FirstOrder e1 "reinterpret2"- => (∀ m x. e1 m x -> Sem (e2 ': e3 ': r) x)+ => (∀ rInitial x. e1 (Sem rInitial) x ->+ Sem (e2 ': e3 ': r) x) -- ^ A natural transformation from the handled effect to the new effects. -> Sem (e1 ': r) a -> Sem (e2 ': e3 ': r) a@@ -229,16 +249,18 @@ -- See the notes on 'Tactical' for how to use this function. reinterpret3H :: forall e1 e2 e3 e4 r a- . (∀ m x. e1 m x -> Tactical e1 m (e2 ': e3 ': e4 ': r) x)+ . (∀ rInitial x. e1 (Sem rInitial) x ->+ Tactical e1 (Sem rInitial) (e2 ': e3 ': e4 ': r) x) -- ^ A natural transformation from the handled effect to the new effects. -> Sem (e1 ': r) a -> Sem (e2 ': e3 ': e4 ': r) a reinterpret3H f (Sem m) = Sem $ \k -> m $ \u -> case decompCoerce u of Left x -> k . weaken . weaken . hoist (reinterpret3H f) $ x- Right (Weaving e s d y v) -> do- a <- usingSem k $ runTactics s (raiseUnder3 . d) v $ f e- pure $ y a+ Right (Weaving e s d y v) ->+ fmap y $ usingSem k+ $ runTactics s (raiseUnder3 . d) v (reinterpret3H f . d)+ $ f e {-# INLINE[3] reinterpret3H #-} @@ -247,7 +269,7 @@ reinterpret3 :: forall e1 e2 e3 e4 r a . FirstOrder e1 "reinterpret3"- => (∀ m x. e1 m x -> Sem (e2 ': e3 ': e4 ': r) x)+ => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': e3 ': e4 ': r) x) -- ^ A natural transformation from the handled effect to the new effects. -> Sem (e1 ': r) a -> Sem (e2 ': e3 ': e4 ': r) a@@ -263,23 +285,24 @@ :: ( Member e r , FirstOrder e "intercept" )- => (∀ x m. e m x -> Sem r x)+ => (∀ x rInitial. e (Sem rInitial) x -> Sem r x) -- ^ A natural transformation from the handled effect to other effects -- already in 'Sem'. -> Sem r a -- ^ Unlike 'interpret', 'intercept' does not consume any effects. -> Sem r a-intercept f = interceptH $ \(e :: e m x) -> liftT @m $ f e+intercept f = interceptH $ \(e :: e (Sem rInitial) x) ->+ liftT @(Sem rInitial) $ f e {-# INLINE intercept #-} --------------------------------------------------------------------------------- | Like 'interceptH', but for higher-order effects.+-- | Like 'intercept', but for higher-order effects. -- -- See the notes on 'Tactical' for how to use this function. interceptH :: Member e r- => (∀ x m. e m x -> Tactical e m r x)+ => (∀ x rInitial. e (Sem rInitial) x -> Tactical e (Sem rInitial) r x) -- ^ A natural transformation from the handled effect to other effects -- already in 'Sem'. -> Sem r a@@ -302,13 +325,14 @@ -- ^ A proof that the handled effect exists in @r@. -- This can be retrieved through 'Polysemy.Membership.membership' or -- 'Polysemy.Membership.tryMembership'.- -> (∀ x m. e m x -> Sem r x)+ -> (∀ x rInitial. e (Sem rInitial) x -> Sem r x) -- ^ A natural transformation from the handled effect to other effects -- already in 'Sem'. -> Sem r a -- ^ Unlike 'interpret', 'intercept' does not consume any effects. -> Sem r a-interceptUsing pr f = interceptUsingH pr $ \(e :: e m x) -> liftT @m $ f e+interceptUsing pr f = interceptUsingH pr $ \(e :: e (Sem rInitial) x) ->+ liftT @(Sem rInitial) $ f e {-# INLINE interceptUsing #-} ------------------------------------------------------------------------------@@ -326,7 +350,7 @@ -- ^ A proof that the handled effect exists in @r@. -- This can be retrieved through 'Polysemy.Membership.membership' or -- 'Polysemy.Membership.tryMembership'.- -> (∀ x m. e m x -> Tactical e m r x)+ -> (∀ x rInitial. e (Sem rInitial) x -> Tactical e (Sem rInitial) r x) -- ^ A natural transformation from the handled effect to other effects -- already in 'Sem'. -> Sem r a@@ -335,7 +359,9 @@ interceptUsingH pr f (Sem m) = Sem $ \k -> m $ \u -> case prjUsing pr u of Just (Weaving e s d y v) ->- usingSem k $ fmap y $ runTactics s (raise . d) v $ f e+ fmap y $ usingSem k+ $ runTactics s (raise . d) v (interceptUsingH pr f . d)+ $ f e Nothing -> k $ hoist (interceptUsingH pr f) u {-# INLINE interceptUsingH #-} @@ -346,13 +372,14 @@ -- @since 1.2.3.0 rewrite :: forall e1 e2 r a- . (forall m x. e1 m x -> e2 m x)+ . (forall rInitial x. e1 (Sem rInitial) x -> e2 (Sem rInitial) x) -> Sem (e1 ': r) a -> Sem (e2 ': r) a rewrite f (Sem m) = Sem $ \k -> m $ \u -> k $ hoist (rewrite f) $ case decompCoerce u of Left x -> x- Right (Weaving e s d n y) -> Union Here $ Weaving (f e) s d n y+ Right (Weaving e s d n y) ->+ Union Here $ Weaving (f e) s d n y ------------------------------------------------------------------------------@@ -363,11 +390,11 @@ transform :: forall e1 e2 r a . Member e2 r- => (forall m x. e1 m x -> e2 m x)+ => (forall rInitial x. e1 (Sem rInitial) x -> e2 (Sem rInitial) x) -> Sem (e1 ': r) a -> Sem r a transform f (Sem m) = Sem $ \k -> m $ \u -> k $ hoist (transform f) $ case decomp u of Left g -> g- Right (Weaving e s wv ex ins) -> injWeaving (Weaving (f e) s wv ex ins)-+ Right (Weaving e s wv ex ins) ->+ injWeaving (Weaving (f e) s wv ex ins)
src/Polysemy/Internal/CustomErrors.hs view
@@ -4,108 +4,39 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: type-errors-pretty redefinitions module Polysemy.Internal.CustomErrors- ( AmbiguousSend- , WhenStuck+ ( WhenStuck , FirstOrder- , UnhandledEffect- , DefiningModule- , DefiningModuleForEffect+ , type (<>)+ , type (%) ) where import Data.Kind import Fcf import GHC.TypeLits (Symbol)-import Polysemy.Internal.Kind-import Polysemy.Internal.CustomErrors.Redefined-import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)-import Type.Errors.Pretty (type (<>), type (%))------------------------------------------------------------------------------------ | The module this effect was originally defined in. This type family is used--- only for providing better error messages.------ Calls to 'Polysemy.Internal.TH.Effect.makeSem' will automatically give--- instances of 'DefiningModule'.-type family DefiningModule (t :: k) :: Symbol--type family DefiningModuleForEffect (e :: k) :: Symbol where- DefiningModuleForEffect (e a) = DefiningModuleForEffect e- DefiningModuleForEffect e = DefiningModule e----- TODO(sandy): Put in type-errors-type ShowTypeBracketed t = "(" <> t <> ")"------------------------------------------------------------------------------------ | The constructor of the effect row --- it's either completely polymorphic,--- a nil, or a cons.-data EffectRowCtor = TyVarR | NilR | ConsR------------------------------------------------------------------------------------ | Given that @r@ isn't stuck, determine which constructor it has.-type family UnstuckRState (r :: EffectRow) :: EffectRowCtor where- UnstuckRState '[] = 'NilR- UnstuckRState (_ ': _) = 'ConsR------------------------------------------------------------------------------------ | Put brackets around @r@ if it's a cons.-type family ShowRQuoted (rstate :: EffectRowCtor) (r :: EffectRow) :: ErrorMessage where- ShowRQuoted 'TyVarR r = 'ShowType r- ShowRQuoted 'NilR r = 'ShowType r- ShowRQuoted 'ConsR r = ShowTypeBracketed r---type AmbigousEffectMessage (rstate :: EffectRowCtor)- (r :: EffectRow)- (e :: k)- (t :: Effect)- (vs :: [Type])- = "Ambiguous use of effect '" <> e <> "'"- % "Possible fix:"- % " add (Member (" <> t <> ") " <> ShowRQuoted rstate r <> ") to the context of "- % " the type signature"- % "If you already have the constraint you want, instead"- % " add a type application to specify"- % " " <> PrettyPrintList vs <> " directly, or activate polysemy-plugin which"- % " can usually infer the type correctly."+import Type.Errors hiding (IfStuck, UnlessStuck, WhenStuck) -type AmbiguousSend e r =- (IfStuck r- (AmbiguousSendError 'TyVarR r e)- (Pure (AmbiguousSendError (UnstuckRState r) r e)))+import Polysemy.Internal.CustomErrors.Redefined+import Polysemy.Internal.Kind -type family AmbiguousSendError rstate r e where- AmbiguousSendError rstate r (e a b c d f) =- TypeError (AmbigousEffectMessage rstate r e (e a b c d f) '[a, b c d f])-- AmbiguousSendError rstate r (e a b c d) =- TypeError (AmbigousEffectMessage rstate r e (e a b c d) '[a, b c d])-- AmbiguousSendError rstate r (e a b c) =- TypeError (AmbigousEffectMessage rstate r e (e a b c) '[a, b c])-- AmbiguousSendError rstate r (e a b) =- TypeError (AmbigousEffectMessage rstate r e (e a b) '[a, b])-- AmbiguousSendError rstate r (e a) =- TypeError (AmbigousEffectMessage rstate r e (e a) '[a])+-- These are taken from type-errors-pretty because it's not in stackage for 9.0.1+-- See https://github.com/polysemy-research/polysemy/issues/401+type family ToErrorMessage (t :: k) :: ErrorMessage where+ ToErrorMessage (t :: Symbol) = 'Text t+ ToErrorMessage (t :: ErrorMessage) = t+ ToErrorMessage t = 'ShowType t - AmbiguousSendError rstate r e =- TypeError- ( "Could not deduce: (Member " <> e <> " " <> ShowRQuoted rstate r <> ") "- % "Fix:"- % " add (Member " <> e <> " " <> r <> ") to the context of"- % " the type signature"- )+infixl 5 <>+type family (<>) (l :: k1) (r :: k2) :: ErrorMessage where+ l <> r = ToErrorMessage l ':<>: ToErrorMessage r +infixr 4 %+type family (%) (t :: k1) (b :: k2) :: ErrorMessage where+ t % b = ToErrorMessage t ':$$: ToErrorMessage b data FirstOrderErrorFcf :: k -> Symbol -> Exp Constraint type instance Eval (FirstOrderErrorFcf e fn) = $(te[t|@@ -121,24 +52,6 @@ -- | This constraint gives helpful error messages if you attempt to use a -- first-order combinator with a higher-order type. type FirstOrder (e :: Effect) fn = UnlessStuck e (FirstOrderErrorFcf e fn)------------------------------------------------------------------------------------ | Unhandled effects-type UnhandledEffectMsg e- = "Unhandled effect '" <> e <> "'"- % "Probable fix:"- % " add an interpretation for '" <> e <> "'"--type CheckDocumentation e- = " If you are looking for inspiration, try consulting"- % " the documentation for module '" <> DefiningModuleForEffect e <> "'"--type family UnhandledEffect e where- UnhandledEffect e =- IfStuck (DefiningModule e)- (TypeError (UnhandledEffectMsg e))- (DoError (UnhandledEffectMsg e ':$$: CheckDocumentation e)) data DoError :: ErrorMessage -> Exp k
src/Polysemy/Internal/CustomErrors/Redefined.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_HADDOCK prune #-} ------------------------------------------------------------------------------ -- | This code is copied verbatim from 'Type.Errors' due to limitations in the
src/Polysemy/Internal/Fixpoint.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Fixpoint' effect module Polysemy.Internal.Fixpoint where ------------------------------------------------------------------------------
− src/Polysemy/Internal/Forklift.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE NumDecimals #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_HADDOCK not-home #-}--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------------------------------------------------------------------------------------ | A promise for interpreting an effect of the union @r@ in another thread.------ @since 0.5.0.0-data Forklift r = forall a. Forklift- { responseMVar :: MVar a- , request :: Union r (Sem r) a- }------------------------------------------------------------------------------------ | A strategy for automatically interpreting an entire stack of effects by--- just shipping them off to some other interpretation context.------ @since 0.5.0.0-runViaForklift- :: Member (Embed IO) r- => InChan (Forklift r)- -> Sem r a- -> IO a-runViaForklift chan = usingSem $ \u -> do- case prj u of- Just (Weaving (Embed m) s _ ex _) ->- ex . (<$ s) <$> m- _ -> do- mvar <- newEmptyMVar- writeChan chan $ Forklift mvar u- takeMVar mvar-{-# INLINE runViaForklift #-}------------------------------------------------------------------------------------- | Run an effect stack all the way down to 'IO' by running it in a new--- thread, and temporarily turning the current thread into an event poll.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 0.5.0.0-withLowerToIO- :: Member (Embed IO) r- => ((forall x. Sem r x -> IO x) -> IO () -> IO a)- -- ^ A lambda that takes the lowering function, and a finalizing 'IO'- -- action to mark a the forked thread as being complete. The finalizing- -- action need not be called.- -> Sem r a-withLowerToIO action = do- (inchan, outchan) <- embed newChan- signal <- embed newEmptyMVar-- res <- embed $ A.async $ do- a <- action (runViaForklift inchan)- (putMVar signal ())- `finally` (putMVar signal ())- pure a-- let me = do- raced <- embed $ A.race (takeMVar signal) $ readChan outchan- case raced of- Left () -> embed $ A.wait res- Right (Forklift mvar req) -> do- resp <- liftSem req- embed $ putMVar mvar $ resp- me_b- {-# INLINE me #-}-- me_b = me- {-# NOINLINE me_b #-}-- me-
+ src/Polysemy/Internal/Index.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}++{-# OPTIONS_HADDOCK not-home, prune #-}++-- | Description: Class 'InsertAtIndex' that allows stack extension at a numeric index+module Polysemy.Internal.Index where++import GHC.TypeLits (Nat)+import Type.Errors (ErrorMessage (ShowType), TypeError)++import Polysemy.Internal.CustomErrors (type (%), type (<>))+import Polysemy.Internal.Sing (SList (SCons, SEnd))++------------------------------------------------------------------------------+-- | Infer a partition of the result type @full@ so that for the fixed segments+-- @head@ and @tail@, the new segment @inserted@ contains the missing effects+-- between them.+class InsertAtIndex (index :: Nat) (head :: [k]) (tail :: [k]) (oldTail :: [k]) (full :: [k]) (inserted :: [k]) where+ insertAtIndex :: SList inserted++instance inserted ~ '[] => InsertAtIndex index head oldTail oldTail full inserted where+ insertAtIndex = SEnd+ {-# INLINE insertAtIndex #-}++instance {-# INCOHERENT #-} (+ InsertAtIndex index head tail oldTail full insertedTail,+ inserted ~ (e ': insertedTail)+ ) => InsertAtIndex index head (e ': tail) oldTail full inserted where+ insertAtIndex = SCons (insertAtIndex @_ @index @head @tail @oldTail @full)+ {-# INLINE insertAtIndex #-}++-- Broken on 9.2.+-- It appears that instance matching is done with an abstract value for @oldTail@, thus not matching the correct+-- instance and finding only this one, causing a false positive for the @TypeError@.+#if __GLASGOW_HASKELL__ < 902++instance {-# INCOHERENT #-} TypeError (InsertAtFailure index oldTail head full)+ => InsertAtIndex index head tail oldTail full inserted where+ insertAtIndex = error "unreachable"++#endif++type family InsertAtUnprovidedIndex where+ InsertAtUnprovidedIndex = TypeError (+ "insertAt: You must provide the index at which the effects should be inserted as a type application."+ % "Example: insertAt @5"+ )++type InsertAtFailure index soughtTail head full =+ "insertAt: Failed to insert effects at index " <> 'ShowType index+ % "There is a mismatch between what's been determined as the head and tail between the newly inserted effects,"+ <> " and the actual desired return type."+ % "Determined head before inserted effects:"+ % "\t" <> 'ShowType head+ % "Determined tail after the inserted effects:"+ % "\t" <> 'ShowType soughtTail+ % "Actual desired return type:"+ % "\t" <> 'ShowType full+ % "Make sure that the index provided to insertAt is correct, and that the desired return type simply requires"+ <> " inserting effects."
src/Polysemy/Internal/Kind.hs view
@@ -1,6 +1,9 @@+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Kind aliases 'Effect' and 'EffectRow' module Polysemy.Internal.Kind where -import Data.Kind+import Data.Kind (Type) ------------------------------------------------------------------------------ -- | The kind of effects.@@ -14,3 +17,9 @@ -- @since 0.5.0.0 type EffectRow = [Effect] ++------------------------------------------------------------------------------+-- | Append two type-level lists.+type family Append l r where+ Append (a ': l) r = a ': (Append l r)+ Append '[] r = r
src/Polysemy/Internal/NonDet.hs view
@@ -4,6 +4,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The 'NonDet' effect module Polysemy.Internal.NonDet where
+ src/Polysemy/Internal/Scoped.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: The meta-effect 'Scoped'+module Polysemy.Internal.Scoped where++import Data.Kind (Type)++import Polysemy++-- | @Scoped@ transforms a program so that an interpreter for @effect@ may+-- perform arbitrary actions, like resource management, before and after the+-- computation wrapped by a call to 'scoped' is executed.+--+-- An application for this is @Polysemy.Conc.Events@ from+-- <https://hackage.haskell.org/package/polysemy-conc>, in which each program+-- using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of+-- the event channel; or a database transaction, in which a transaction handle+-- is created for the wrapped program and passed to the interpreter for the+-- database effect.+--+-- For a longer exposition, see <https://www.tweag.io/blog/2022-01-05-polysemy-scoped/>.+-- Note that the interface has changed since the blog post was published: The+-- @resource@ parameter no longer exists.+--+-- Resource allocation is performed by a function passed to+-- 'Polysemy.Scoped.interpretScoped'.+--+-- The constructors are not intended to be used directly; the smart constructor+-- 'scoped' is used like a local interpreter for @effect@. 'scoped' takes an+-- argument of type @param@, which will be passed through to the interpreter, to+-- be used by the resource allocation function.+--+-- As an example, imagine an effect for writing lines to a file:+--+-- > data Write :: Effect where+-- > Write :: Text -> Write m ()+-- > makeSem ''Write+--+-- If we now have the following requirements:+--+-- 1. The file should be opened and closed right before and after the part of+-- the program in which we write lines+-- 2. The file name should be specifiable at the point in the program where+-- writing begins+-- 3. We don't want to commit to IO, lines should be stored in memory when+-- running tests+--+-- Then we can take advantage of 'Scoped' to write this program:+--+-- > prog :: Member (Scoped FilePath Write) r => Sem r ()+-- > prog = do+-- > scoped "file1.txt" do+-- > write "line 1"+-- > write "line 2"+-- > scoped "file2.txt" do+-- > write "line 1"+-- > write "line 2"+--+-- Here 'scoped' creates a prompt for an interpreter to start allocating a+-- resource for @"file1.txt"@ and handling @Write@ actions using that resource.+-- When the 'scoped' block ends, the resource should be freed.+--+-- The interpreter may look like this:+--+-- > interpretWriteFile :: Members '[Resource, Embed IO] => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteFile =+-- > interpretScoped allocator handler+-- > where+-- > allocator name use = bracket (openFile name WriteMode) hClose use+-- > handler fileHandle (Write line) = embed (Text.hPutStrLn fileHandle line)+--+-- Essentially, the @bracket@ is executed at the point where @scoped@ was+-- called, wrapping the following block. When the second @scoped@ is executed,+-- another call to @bracket@ is performed.+--+-- The effect of this is that the operation that uses @Embed IO@ was moved from+-- the call site to the interpreter, while the interpreter may be executed at+-- the outermost layer of the app.+--+-- This makes it possible to use a pure interpreter for testing:+--+-- > interpretWriteOutput :: Member (Output (FilePath, Text)) r => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteOutput =+-- > interpretScoped (\ name use -> use name) \ name -> \case+-- > Write line -> output (name, line)+--+-- Here we simply pass the name to the interpreter in the resource allocation+-- function.+--+-- Now imagine that we drop requirement 2 from the initial list – we still want+-- the file to be opened and closed as late/early as possible, but the file name+-- is globally fixed. For this case, the @param@ type is unused, and the API+-- provides some convenience aliases to make your code more concise:+--+-- > prog :: Member (Scoped_ Write) r => Sem r ()+-- > prog = do+-- > scoped_ do+-- > write "line 1"+-- > write "line 2"+-- > scoped_ do+-- > write "line 1"+-- > write "line 2"+--+-- The type 'Scoped_' and the constructor 'scoped_' simply fix @param@ to @()@.+data Scoped (param :: Type) (effect :: Effect) :: Effect where+ Run :: ∀ param effect m a . Word -> effect m a -> Scoped param effect m a+ InScope :: ∀ param effect m a . param -> (Word -> m a) -> Scoped param effect m a++-- | An auxiliary effect for 'Scoped'.+data OuterRun (effect :: Effect) :: Effect where+ OuterRun :: ∀ effect m a . Word -> effect m a -> OuterRun effect m a++-- |A convenience alias for a scope without parameters.+type Scoped_ effect =+ Scoped () effect++-- | Constructor for 'Scoped', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped' param effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples.+scoped ::+ ∀ param effect r .+ Member (Scoped param effect) r =>+ param ->+ InterpreterFor effect r+scoped param main =+ send $ InScope @param @effect param $ \w ->+ transform @effect (Run @param w) main+{-# inline scoped #-}++-- | Constructor for 'Scoped_', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped_' effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples.+scoped_ ::+ ∀ effect r .+ Member (Scoped_ effect) r =>+ InterpreterFor effect r+scoped_ = scoped ()+{-# inline scoped_ #-}++-- | Transform the parameters of a 'Scoped' program.+--+-- This allows incremental additions to the data passed to the interpreter, for+-- example to create an API that permits different ways of running an effect+-- with some fundamental parameters being supplied at scope creation and some+-- optional or specific parameters being selected by the user downstream.+rescope ::+ ∀ param0 param1 effect r .+ Member (Scoped param1 effect) r =>+ (param0 -> param1) ->+ InterpreterFor (Scoped param0 effect) r+rescope fp =+ transform \case+ Run w e -> Run @param1 w e+ InScope p main -> InScope (fp p) main+{-# inline rescope #-}+
+ src/Polysemy/Internal/Sing.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++{-# OPTIONS_HADDOCK not-home #-}++-- | Description: Singleton list+module Polysemy.Internal.Sing where++import GHC.TypeLits (Nat, type (-))++import Polysemy.Internal.Kind (Effect)++------------------------------------------------------------------------------+-- | A singleton type used as a witness for type-level lists.+data SList l where+ SEnd :: SList '[]+ SCons :: SList xs -> SList (x ': xs)++------------------------------------------------------------------------------+-- | A singleton list constructor class.+class KnownList l where+ singList :: SList l++instance KnownList '[] where+ singList = SEnd+ {-# INLINE singList #-}++instance KnownList xs => KnownList (x ': xs) where+ singList = SCons singList+ {-# INLINE singList #-}++------------------------------------------------------------------------------+-- | A utility class for constructing a type-level list of a given length.+class ListOfLength (n :: Nat) (l :: [Effect]) where+ listOfLength :: SList l++instance {-# OVERLAPPING #-} (l ~ '[]) => ListOfLength 0 l where+ listOfLength = SEnd+ {-# INLINE listOfLength #-}++instance (ListOfLength (n - 1) xs, l ~ (x ': xs)) => ListOfLength n l where+ listOfLength = SCons (listOfLength @(n - 1))+ {-# INLINE listOfLength #-}
src/Polysemy/Internal/Strategy.hs view
@@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The auxiliary effect 'Strategy' used for building interpreters+-- that embed 'Sem's in 'IO' callbacks module Polysemy.Internal.Strategy where import Polysemy.Internal@@ -7,7 +9,8 @@ import Polysemy.Internal.Tactics (Inspector(..)) -+------------------------------------------------------------------------------+-- | See 'Strategic'. 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))@@ -100,7 +103,7 @@ liftS :: Functor m => m a -> Strategic m n a liftS m = do s <- getInitialStateS- pure $ fmap (<$ s) m+ pure $ (<$ s) <$> m {-# INLINE liftS #-} @@ -128,4 +131,3 @@ bindS :: (a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b)) bindS = send . HoistInterpretation {-# INLINE bindS #-}-
src/Polysemy/Internal/TH/Common.hs view
@@ -4,8 +4,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: TH utilities for generating effect constructors module Polysemy.Internal.TH.Common ( ConLiftInfo (..) , getEffectMetadata@@ -33,7 +34,7 @@ import Language.Haskell.TH.Datatype import Language.Haskell.TH.PprLib import Polysemy.Internal (Sem, send)-import Polysemy.Internal.Union (MemberWithError)+import Polysemy.Internal.Union (Member) #if __GLASGOW_HASKELL__ >= 804 import Prelude hiding ((<>))@@ -71,11 +72,11 @@ ------------------------------------------------------------------------------ -- | Given an name of datatype or some of it's constructors/fields, return -- datatype's name together with info about it's constructors.-getEffectMetadata :: Name -> Q (Name, [ConLiftInfo])+getEffectMetadata :: Name -> Q [ConLiftInfo] getEffectMetadata type_name = do dt_info <- reifyDatatype type_name cl_infos <- traverse makeCLInfo $ constructorName <$> datatypeCons dt_info- pure (datatypeName dt_info, cl_infos)+ pure cl_infos ------------------------------------------------------------------------------@@ -157,7 +158,7 @@ -- | @'makeMemberConstraint'' r type@ will produce a @Member type r@ -- constraint. makeMemberConstraint' :: Name -> Type -> Pred-makeMemberConstraint' r eff = classPred ''MemberWithError [eff, VarT r]+makeMemberConstraint' r eff = classPred ''Member [eff, VarT r] ------------------------------------------------------------------------------@@ -168,11 +169,11 @@ ------------------------------------------------------------------------------ -- | Given a 'ConLiftInfo', this will produce an action for it. It's arguments--- will come from any variables in scope that correspond to the 'cliArgs' of--- the 'ConLiftInfo'.+-- will come from any variables in scope that correspond to the 'cliEffArgs'+-- of the 'ConLiftInfo'. makeUnambiguousSend :: Bool -> ConLiftInfo -> Exp makeUnambiguousSend should_make_sigs cli =- let fun_args_names = fmap fst $ cliFunArgs cli+ let fun_args_names = fst <$> cliFunArgs cli action = foldl1' AppE $ ConE (cliConName cli) : (VarE <$> fun_args_names) eff = foldl' AppT (ConT $ cliEffName cli) $ args@@ -215,7 +216,13 @@ ) where base = capturableBase name+#if MIN_VERSION_template_haskell(2,21,0)+ args = flip PlainTV BndrInvis . mkName <$> ["m", "a"]+#elif MIN_VERSION_template_haskell(2,17,0)+ args = flip PlainTV () . mkName <$> ["m", "a"]+#else args = PlainTV . mkName <$> ["m", "a"]+#endif notDataCon :: Name -> Q a notDataCon name = fail $ show@@ -226,12 +233,20 @@ -- TH utilities -------------------------------------------------------------- ------------------------------------------------------------------------------ +arrows :: Type -> Bool+arrows = \case+ ArrowT -> True+#if MIN_VERSION_template_haskell(2,17,0)+ AppT MulArrowT _ -> True+#endif+ _ -> False+ ------------------------------------------------------------------------------ -- | Pattern constructing function type and matching on one that may contain -- type annotations on arrow itself. infixr 1 :-> pattern (:->) :: Type -> Type -> Type-pattern a :-> b <- (removeTyAnns -> ArrowT) `AppT` a `AppT` b where+pattern a :-> b <- (arrows . removeTyAnns -> True) `AppT` a `AppT` b where a :-> b = ArrowT `AppT` a `AppT` b @@ -249,8 +264,13 @@ VarT n -> VarT $ capturableBase n ForallT bs cs t -> ForallT (goBndr <$> bs) (capturableTVars <$> cs) t where+#if MIN_VERSION_template_haskell(2,17,0)+ goBndr (PlainTV n flag) = PlainTV (capturableBase n) flag+ goBndr (KindedTV n flag k) = KindedTV (capturableBase n) flag $ capturableTVars k+#else goBndr (PlainTV n ) = PlainTV $ capturableBase n goBndr (KindedTV n k) = KindedTV (capturableBase n) $ capturableTVars k+#endif t -> t @@ -274,8 +294,13 @@ SigT t VarT{} -> t ForallT bs cs t -> ForallT (goBndr <$> bs) (simplifyKinds <$> cs) t where- goBndr (KindedTV n StarT ) = PlainTV n+#if MIN_VERSION_template_haskell(2,17,0)+ goBndr (KindedTV n flag StarT) = PlainTV n flag+ goBndr (KindedTV n flag VarT{}) = PlainTV n flag+#else+ goBndr (KindedTV n StarT) = PlainTV n goBndr (KindedTV n VarT{}) = PlainTV n+#endif goBndr b = b t -> t
src/Polysemy/Internal/TH/Effect.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_HADDOCK not-home #-} -- | This module provides Template Haskell functions for automatically generating--- effect operation functions (that is, functions that use 'send') from a given+-- effect operation functions (that is, functions that use 'Polysemy.send') from a given -- effect algebra. For example, using the @FileSystem@ effect from the example in -- the module documentation for "Polysemy", we can write the following: --@@ -18,11 +18,11 @@ -- This will automatically generate (approximately) the following functions: -- -- @--- readFile :: 'Member' FileSystem r => 'FilePath' -> 'Sem' r 'String'--- readFile a = 'send' (ReadFile a)+-- readFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'Polysemy.Sem' r 'String'+-- readFile a = 'Polysemy.send' (ReadFile a) ----- writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Sem' r ()--- writeFile a b = 'send' (WriteFile a b)+-- writeFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'String' -> 'Polysemy.Sem' r ()+-- writeFile a b = 'Polysemy.send' (WriteFile a b) -- @ module Polysemy.Internal.TH.Effect ( makeSem@@ -31,8 +31,10 @@ import Control.Monad import Language.Haskell.TH+#if __GLASGOW_HASKELL__ >= 902+import Language.Haskell.TH.Syntax (addModFinalizer)+#endif import Language.Haskell.TH.Datatype-import Polysemy.Internal.CustomErrors (DefiningModule) import Polysemy.Internal.TH.Common @@ -74,8 +76,8 @@ -- rules to work properly: -- -- * 'makeSem_' must be used /before/ the explicit type signatures--- * signatures have to specify argument of 'Sem' representing union of--- effects as @r@ (e.g. @'Sem' r ()@)+-- * signatures have to specify argument of 'Polysemy.Sem' representing union of+-- effects as @r@ (e.g. @'Polysemy.Sem' r ()@) -- * all arguments in effect's type constructor have to follow naming scheme -- from data constructor's declaration: --@@ -108,7 +110,7 @@ makeSem_ = genFreer False -- NOTE(makeSem_): -- This function uses an ugly hack to work --- it changes names in data--- constructor's type to capturable ones. This allows user to provide them to+-- constructor's type to capturable ones. This allows users to provide them to -- us from their signature through 'forall' with 'ScopedTypeVariables' -- enabled, so that we can compile liftings of constructors with ambiguous -- type arguments (see issue #48).@@ -119,32 +121,23 @@ ------------------------------------------------------------------------------ -- | Generates declarations and possibly signatures for functions to lift GADT--- constructors into 'Sem' actions.+-- constructors into 'Polysemy.Sem' actions. genFreer :: Bool -> Name -> Q [Dec] genFreer should_mk_sigs type_name = do checkExtensions [ScopedTypeVariables, FlexibleContexts, DataKinds]- (dt_name, cl_infos) <- getEffectMetadata type_name- tyfams_on <- isExtEnabled TypeFamilies- def_mod_fi <- sequence [ tySynInstDCompat- ''DefiningModule- Nothing- [pure $ ConT dt_name]- (LitT . StrTyLit . loc_module <$> location)- | tyfams_on- ]+ cl_infos <- getEffectMetadata type_name decs <- traverse (genDec should_mk_sigs) cl_infos let sigs = if should_mk_sigs then genSig <$> cl_infos else []-- pure $ join $ def_mod_fi : sigs ++ decs+ pure $ join $ sigs ++ decs ------------------------------------------------------------------------------ -- | Generates signature for lifting function and type arguments to apply in -- its body on effect's data constructor. genSig :: ConLiftInfo -> [Dec]-genSig cli- = maybe [] (pure . flip InfixD (cliFunName cli)) (cliFunFixity cli)+genSig cli =+ infixDecl ++ [ SigD (cliFunName cli) $ quantifyType $ ForallT [] (member_cxt : cliFunCxt cli) $ foldArrowTs sem@@ -152,6 +145,13 @@ $ cliFunArgs cli ] where+ infixDecl = case cliFunFixity cli of+#if __GLASGOW_HASKELL__ >= 910+ Just fixity -> [InfixD fixity NoNamespaceSpecifier (cliFunName cli)]+#else+ Just fixity -> [InfixD fixity (cliFunName cli)]+#endif+ Nothing -> [] member_cxt = makeMemberConstraint (cliUnionName cli) cli sem = makeSemType (cliUnionName cli) (cliEffRes cli) @@ -161,8 +161,11 @@ -- @x a b c = send (X a b c :: E m a)@. genDec :: Bool -> ConLiftInfo -> Q [Dec] genDec should_mk_sigs cli = do- let fun_args_names = fmap fst $ cliFunArgs cli-+ let fun_args_names = fst <$> cliFunArgs cli+#if __GLASGOW_HASKELL__ >= 902+ doc <- getDoc $ DeclDoc $ cliConName cli+ maybe (pure ()) (addModFinalizer . putDoc (DeclDoc $ cliFunName cli)) doc+#endif pure [ PragmaD $ InlineP (cliFunName cli) Inlinable ConLike AllPhases , FunD (cliFunName cli)
src/Polysemy/Internal/Tactics.hs view
@@ -2,13 +2,16 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The auxiliary higher-order interpreter effect 'Tactics' module Polysemy.Internal.Tactics ( Tactics (..) , getInitialStateT , getInspectorT , Inspector (..) , runT+ , runTSimple , bindT+ , bindTSimple , pureT , liftT , runTactics@@ -74,12 +77,17 @@ type Tactical e m r x = ∀ f. Functor f => Sem (WithTactics e f m r) (f x) +------------------------------------------------------------------------------+-- | Convenience type alias, see 'Tactical'. type WithTactics e f m r = Tactics f m (e ': r) ': r +------------------------------------------------------------------------------+-- | See 'Tactical'. data Tactics f n r m a where- GetInitialState :: Tactics f n r m (f ())- HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))- GetInspector :: Tactics f n r m (Inspector f)+ GetInitialState :: Tactics f n r m (f ())+ HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))+ HoistInterpretationH :: (a -> n b) -> f a -> Tactics f n r m (f b)+ GetInspector :: Tactics f n r m (Inspector f) ------------------------------------------------------------------------------@@ -124,7 +132,7 @@ ------------------------------------------------------------------------------ -- | Lift a value into 'Tactical'.-pureT :: a -> Tactical e m r a+pureT :: Functor f => a -> Sem (WithTactics e f m r) (f a) pureT a = do istate <- getInitialStateT pure $ a <$ istate@@ -146,7 +154,27 @@ pure $ na' istate {-# INLINE runT #-} +------------------------------------------------------------------------------+-- | Run a monadic action in a 'Tactical' environment. The stateful environment+-- used will be the same one that the effect is initally run in.+-- Use 'bindTSimple' if you'd prefer to explicitly manage your stateful+-- environment.+--+-- This is a less flexible but significantly simpler variant of 'runT'.+-- Instead of returning a 'Sem' action corresponding to the provided action,+-- 'runTSimple' runs the action immediately.+--+-- @since 1.5.0.0+runTSimple :: m a+ -- ^ The monadic action to lift. This is usually a parameter in your+ -- effect.+ -> Tactical e m r a+runTSimple na = do+ istate <- getInitialStateT+ bindTSimple (const na) istate+{-# INLINE runTSimple #-} + ------------------------------------------------------------------------------ -- | Lift a kleisli action into the stateful environment. You can use -- 'bindT' to get an effect parameter of the form @a -> m b@ into something@@ -163,7 +191,31 @@ bindT f = send $ HoistInterpretation f {-# INLINE bindT #-} +------------------------------------------------------------------------------+-- | Lift a kleisli action into the stateful environment.+-- You can use 'bindTSimple' to execute an effect parameter of the form+-- @a -> m b@ by providing the result of a `runTSimple` or another+-- `bindTSimple`.+--+-- This is a less flexible but significantly simpler variant of 'bindT'.+-- Instead of returning a 'Sem' kleisli action corresponding to the+-- provided kleisli action, 'bindTSimple' runs the kleisli action immediately.+--+-- @since 1.5.0.0+bindTSimple+ :: forall m f r e a b+ . (a -> m b)+ -- ^ The monadic continuation to lift. This is usually a parameter in+ -- your effect.+ --+ -- Continuations executed via 'bindTSimple' will run in the same+ -- environment which produced the @a@.+ -> f a+ -> Sem (WithTactics e f m r) (f b)+bindTSimple f s = send @(Tactics _ _ (e ': r)) $ HoistInterpretationH f s+{-# INLINE bindTSimple #-} + ------------------------------------------------------------------------------ -- | Internal function to create first-order interpreter combinators out of -- higher-order ones.@@ -185,15 +237,18 @@ => f () -> (∀ x. f (m x) -> Sem r2 (f x)) -> (∀ x. f x -> Maybe x)+ -> (∀ x. f (m x) -> Sem r (f x)) -> Sem (Tactics f m r2 ': r) a -> Sem r a-runTactics s d v (Sem m) = m $ \u ->+runTactics s d v d' (Sem m) = Sem $ \k -> m $ \u -> case decomp u of- Left x -> liftSem $ hoist (runTactics s d v) x+ Left x -> k $ hoist (runTactics s d v d') x Right (Weaving GetInitialState s' _ y _) -> pure $ y $ s <$ s' Right (Weaving (HoistInterpretation na) s' _ y _) -> do pure $ y $ (d . fmap na) <$ s'+ Right (Weaving (HoistInterpretationH na fa) s' _ y _) -> do+ (y . (<$ s')) <$> runSem (d' (fmap na fa)) k Right (Weaving GetInspector s' _ y _) -> do pure $ y $ Inspector v <$ s' {-# INLINE runTactics #-}
src/Polysemy/Internal/Union.hs view
@@ -6,18 +6,21 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: 'Union', 'Weaving' and 'ElemOf', Polysemy's core types module Polysemy.Internal.Union ( Union (..) , Weaving (..) , Member- , MemberWithError , weave , hoist -- * Building Unions@@ -33,13 +36,17 @@ , absurdU , decompCoerce -- * Witnesses- , ElemOf (..)+ , ElemOf (Here, There) , membership , sameMember -- * Checking membership , KnownRow , tryMembership- ) where+ , extendMembershipLeft+ , extendMembershipRight+ , injectMembership+ , weakenList+ , weakenMid) where import Control.Monad import Data.Functor.Compose@@ -47,16 +54,15 @@ import Data.Kind import Data.Typeable import Polysemy.Internal.Kind--#ifndef NO_ERROR_MESSAGES-import Polysemy.Internal.CustomErrors-#endif+import {-# SOURCE #-} Polysemy.Internal+import Polysemy.Internal.Sing (SList (SEnd, SCons))+import Unsafe.Coerce (unsafeCoerce) ------------------------------------------------------------------------------ -- | An extensible, type-safe union. The @r@ type parameter is a type-level -- list of effects, any one of which may be held within the 'Union'.-data Union (r :: EffectRow) (m :: Type -> Type) a where+data Union (r :: EffectRow) (mWoven :: Type -> Type) a where Union :: -- A proof that the effect is actually in @r@. ElemOf e r@@ -65,105 +71,70 @@ -> Weaving e m a -> Union r m a -instance Functor (Union r m) where- fmap f (Union w t) = Union w $ fmap f t- {-# INLINE fmap #-}+instance Functor (Union r mWoven) where+ fmap f (Union w t) = Union w $ f <$> t+ {-# INLINABLE fmap #-} -data Weaving e m a where+------------------------------------------------------------------------------+-- | Polysemy's core type that stores effect values together with information+-- about the higher-order interpretation state of its construction site.+data Weaving e mAfter resultType where Weaving- :: Functor f- => { weaveEffect :: e m a- -- ^ The original effect GADT originally lifted via- -- 'Polysemy.Internal.send'. There is an invariant that @m ~ Sem r0@,- -- where @r0@ is the effect row that was in scope when this 'Weaving'- -- was originally created.- , weaveState :: f ()- -- ^ A piece of state that other effects' interpreters have already- -- woven through this 'Weaving'. @f@ is a 'Functor', so you can always- -- 'fmap' into this thing.- , weaveDistrib :: forall x. f (m x) -> n (f x)- -- ^ Distribute @f@ by transforming @m@ into @n@. We have invariants- -- on @m@ and @n@, which means in actuality this function looks like- -- @f ('Polysemy.Sem' (Some ': Effects ': r) x) -> 'Polysemy.Sem' r (f- -- x)@.- , weaveResult :: f a -> b- -- ^ Even though @f a@ is the moral resulting type of 'Weaving', we- -- can't expose that fact; such a thing would prevent 'Polysemy.Sem'- -- from being a 'Monad'.- , weaveInspect :: forall x. f x -> Maybe x- -- ^ A function for attempting to see inside an @f@. This is no- -- guarantees that such a thing will succeed (for example,- -- 'Polysemy.Error.Error' might have 'Polysemy.Error.throw'n.)- }- -> Weaving e n b+ :: forall f e rInitial a resultType mAfter. (Functor f)+ => {+ weaveEffect :: e (Sem rInitial) a+ -- ^ The original effect GADT originally lifted via+ -- 'Polysemy.Internal.send'.+ -- ^ @rInitial@ is the effect row that was in scope when this 'Weaving'+ -- was originally created.+ , weaveState :: f ()+ -- ^ A piece of state that other effects' interpreters have already+ -- woven through this 'Weaving'. @f@ is a 'Functor', so you can always+ -- 'fmap' into this thing.+ , weaveDistrib :: forall x. f (Sem rInitial x) -> mAfter (f x)+ -- ^ Distribute @f@ by transforming @Sem rInitial@ into @mAfter@. This is+ -- usually of the form @f ('Polysemy.Sem' (Some ': Effects ': r) x) ->+ -- Sem r (f x)@+ , weaveResult :: f a -> resultType+ -- ^ Even though @f a@ is the moral resulting type of 'Weaving', we+ -- can't expose that fact; such a thing would prevent 'Polysemy.Sem'+ -- from being a 'Monad'.+ , weaveInspect :: forall x. f x -> Maybe x+ -- ^ A function for attempting to see inside an @f@. This is no+ -- guarantees that such a thing will succeed (for example,+ -- 'Polysemy.Error.Error' might have 'Polysemy.Error.throw'n.)+ } -> Weaving e mAfter resultType instance Functor (Weaving e m) where fmap f (Weaving e s d f' v) = Weaving e s d (f . f') v- {-# INLINE fmap #-}+ {-# INLINABLE fmap #-} weave- :: (Functor s, Functor m, Functor n)+ :: (Functor s, Functor n) => s () -> (∀ x. s (m x) -> n (s x)) -> (∀ x. s x -> Maybe x) -> Union r m a -> Union r n (s a)-weave s' d v' (Union w (Weaving e s nt f v)) = Union w $- Weaving e (Compose $ s <$ s')+weave s' d v' (Union w (Weaving e s nt f v)) =+ Union w $ Weaving+ e (Compose $ s <$ s') (fmap Compose . d . fmap nt . getCompose) (fmap f . getCompose) (v <=< v' . getCompose)-{-# INLINE weave #-}+{-# INLINABLE weave #-} hoist- :: ( Functor m- , Functor n- )- => (∀ x. m x -> n x)+ :: (∀ x. m x -> n x) -> Union r m a -> Union r n a-hoist f' (Union w (Weaving e s nt f v)) = Union w $ Weaving e s (f' . nt) f v-{-# INLINE hoist #-}------------------------------------------------------------------------------------ | A proof that the effect @e@ is available somewhere inside of the effect--- stack @r@.-type Member e r = MemberNoError e r----------------------------------------------------------------------------------- | Like 'Member', but will produce an error message if the types are--- ambiguous. This is the constraint used for actions generated by--- 'Polysemy.makeSem'.------ /Be careful with this./ Due to quirks of 'GHC.TypeLits.TypeError',--- the custom error messages emitted by this can potentially override other,--- more helpful error messages.--- See the discussion in--- <https://github.com/polysemy-research/polysemy/issues/227 Issue #227>.------ @since 1.2.3.0-type MemberWithError e r =- ( MemberNoError e r-#ifndef NO_ERROR_MESSAGES- -- NOTE: The plugin explicitly pattern matches on- -- `WhenStuck (LocateEffect _ r) _`, so if you change this, make sure to change- -- the corresponding implementation in- -- Polysemy.Plugin.Fundep.solveBogusError- , WhenStuck (LocateEffect e r) (AmbiguousSend e r)-#endif- )--type MemberNoError e r =- ( Find e r-#ifndef NO_ERROR_MESSAGES- , LocateEffect e r ~ '()-#endif- )+hoist f' (Union w (Weaving e s nt f v)) =+ Union w $ Weaving e s (f' . nt) f v+{-# INLINABLE hoist #-} ------------------------------------------------------------------------------ -- | A proof that @e@ is an element of @r@.@@ -173,12 +144,37 @@ -- into @r@ by using 'Polysemy.Internal.subsumeUsing'. -- -- @since 1.3.0.0-data ElemOf e r where- -- | @e@ is located at the head of the list.- Here :: ElemOf e (e ': r)- -- | @e@ is located somewhere in the tail of the list.- There :: ElemOf e r -> ElemOf e (e' ': r)+type role ElemOf nominal nominal+newtype ElemOf (e :: k) (r :: [k]) = UnsafeMkElemOf Int +data MatchHere e r where+ MHYes :: MatchHere e (e ': r)+ MHNo :: MatchHere e r++data MatchThere e r where+ MTYes :: ElemOf e r -> MatchThere e (e' ': r)+ MTNo :: MatchThere e r++matchHere :: forall e r. ElemOf e r -> MatchHere e r+matchHere (UnsafeMkElemOf 0) = unsafeCoerce $ MHYes+matchHere _ = MHNo++matchThere :: forall e r. ElemOf e r -> MatchThere e r+matchThere (UnsafeMkElemOf 0) = MTNo+matchThere (UnsafeMkElemOf e) = unsafeCoerce $ MTYes $ UnsafeMkElemOf $ e - 1++pattern Here :: () => (r ~ (e ': r')) => ElemOf e r+pattern Here <- (matchHere -> MHYes)+ where+ Here = UnsafeMkElemOf 0++pattern There :: () => (r' ~ (e' ': r)) => ElemOf e r -> ElemOf e r'+pattern There e <- (matchThere -> MTYes e)+ where+ There (UnsafeMkElemOf e) = UnsafeMkElemOf $ e + 1++{-# COMPLETE Here, There #-}+ ------------------------------------------------------------------------------ -- | Checks if two membership proofs are equal. If they are, then that means -- that the effects for which membership is proven must also be equal.@@ -197,26 +193,17 @@ --------------------------------------------------------------------------------- | Used to detect ambiguous uses of effects. If @r@ isn't concrete,--- and we haven't been given @'LocateEffect' e r ~ '()@ from a--- @'Member' e r@ constraint, then @'LocateEffect' e r@ will get stuck.-type family LocateEffect (t :: k) (ts :: [k]) :: () where-#ifndef NO_ERROR_MESSAGES- LocateEffect t '[] = UnhandledEffect t-#endif- LocateEffect t (t ': ts) = '()- LocateEffect t (u ': ts) = LocateEffect t ts--class Find (t :: k) (r :: [k]) where+-- | This class indicates that an effect must be present in the caller's stack.+-- It is the main mechanism by which a program defines its effect dependencies.+class Member (t :: Effect) (r :: EffectRow) where+ -- | Create a proof that the effect @t@ is present in the effect stack @r@. membership' :: ElemOf t r -instance {-# OVERLAPPING #-} Find t (t ': z) where+instance {-# OVERLAPPING #-} Member t (t ': z) where membership' = Here- {-# INLINE membership' #-} -instance Find t z => Find t (_1 ': z) where- membership' = There $ membership' @_ @t @z- {-# INLINE membership' #-}+instance Member t z => Member t (_1 ': z) where+ membership' = There $ membership' @t @z ------------------------------------------------------------------------------ -- | A class for effect rows whose elements are inspectable.@@ -230,29 +217,64 @@ instance KnownRow '[] where tryMembership' = Nothing- {-# INLINE tryMembership' #-}+ {-# INLINABLE tryMembership' #-} instance (Typeable e, KnownRow r) => KnownRow (e ': r) where tryMembership' :: forall e'. Typeable e' => Maybe (ElemOf e' (e ': r)) tryMembership' = case eqT @e @e' of Just Refl -> Just Here _ -> There <$> tryMembership' @r @e'- {-# INLINE tryMembership' #-}+ {-# INLINABLE tryMembership' #-} ------------------------------------------------------------------------------ -- | Given @'Member' e r@, extract a proof that @e@ is an element of @r@. membership :: Member e r => ElemOf e r membership = membership'-{-# INLINE membership #-}+{-# INLINABLE membership #-} ------------------------------------------------------------------------------ -- | Extracts a proof that @e@ is an element of @r@ if that -- is indeed the case; otherwise returns @Nothing@. tryMembership :: forall e r. (Typeable e, KnownRow r) => Maybe (ElemOf e r) tryMembership = tryMembership' @r @e-{-# INLINE tryMembership #-}+{-# INLINABLE tryMembership #-} + ------------------------------------------------------------------------------+-- | Extends a proof that @e@ is an element of @r@ to a proof that @e@ is an+-- element of the concatenation of the lists @l@ and @r@.+-- @l@ must be specified as a singleton list proof.+extendMembershipLeft :: forall l r e. SList l -> ElemOf e r -> ElemOf e (Append l r)+extendMembershipLeft SEnd pr = pr+extendMembershipLeft (SCons l) pr = There (extendMembershipLeft l pr)+{-# INLINABLE extendMembershipLeft #-}+++------------------------------------------------------------------------------+-- | Extends a proof that @e@ is an element of @l@ to a proof that @e@ is an+-- element of the concatenation of the lists @l@ and @r@.+extendMembershipRight :: forall l r e. ElemOf e l -> ElemOf e (Append l r)+extendMembershipRight Here = Here+extendMembershipRight (There e) = There (extendMembershipRight @_ @r e)+{-# INLINABLE extendMembershipRight #-}+++------------------------------------------------------------------------------+-- | Extends a proof that @e@ is an element of @left <> right@ to a proof that+-- @e@ is an element of @left <> mid <> right@.+-- Both @left@ and @right@ must be specified as singleton list proofs.+injectMembership :: forall right e left mid+ . SList left+ -> SList mid+ -> ElemOf e (Append left right)+ -> ElemOf e (Append left (Append mid right))+injectMembership SEnd sm pr = extendMembershipLeft sm pr+injectMembership (SCons _) _ Here = Here+injectMembership (SCons sl) sm (There pr) = There (injectMembership @right sl sm pr)+{-# INLINABLE injectMembership #-}+++------------------------------------------------------------------------------ -- | Decompose a 'Union'. Either this union contains an effect @e@---the head -- of the @r@ list---or it doesn't. decomp :: Union (e ': r) m a -> Either (Union r m a) (Weaving e m a)@@ -260,57 +282,84 @@ case p of Here -> Right a There pr -> Left $ Union pr a-{-# INLINE decomp #-}+{-# INLINABLE decomp #-} ------------------------------------------------------------------------------ -- | Retrieve the last effect in a 'Union'. extract :: Union '[e] m a -> Weaving e m a extract (Union Here a) = a-extract (Union (There g) _) = case g of {}-{-# INLINE extract #-}+extract (Union (There _) _) = error "Unsafe use of UnsafeMkElemOf"+{-# INLINABLE extract #-} ------------------------------------------------------------------------------ -- | An empty union contains nothing, so this function is uncallable. absurdU :: Union '[] m a -> b-absurdU (Union pr _) = case pr of {}+#if __GLASGOW_HASKELL__ >= 902+absurdU = \case+#else+absurdU _ = error "Unsafe use of UnsafeMkElemOf"+#endif --------------------------------------------------------------------------------- | Weaken a 'Union' so it is capable of storing a new sort of effect.+-- | Weaken a 'Union' so it is capable of storing a new sort of effect at the+-- head. weaken :: forall e r m a. Union r m a -> Union (e ': r) m a weaken (Union pr a) = Union (There pr) a-{-# INLINE weaken #-}+{-# INLINABLE weaken #-} +------------------------------------------------------------------------------+-- | Weaken a 'Union' so it is capable of storing a number of new effects at+-- the head, specified as a singleton list proof.+weakenList :: SList l -> Union r m a -> Union (Append l r) m a+weakenList sl (Union pr e) = Union (extendMembershipLeft sl pr) e+{-# INLINABLE weakenList #-} + ------------------------------------------------------------------------------+-- | Weaken a 'Union' so it is capable of storing a number of new effects+-- somewhere within the previous effect list.+-- Both the prefix and the new effects are specified as singleton list proofs.+weakenMid :: forall right m a left mid+ . SList left -> SList mid+ -> Union (Append left right) m a+ -> Union (Append left (Append mid right)) m a+weakenMid sl sm (Union pr e) = Union (injectMembership @right sl sm pr) e+{-# INLINABLE weakenMid #-}+++------------------------------------------------------------------------------ -- | Lift an effect @e@ into a 'Union' capable of holding it.-inj :: forall e r m a. (Functor m , Member e r) => e m a -> Union r m a-inj e = injWeaving $- Weaving e (Identity ())- (fmap Identity . runIdentity)- runIdentity- (Just . runIdentity)-{-# INLINE inj #-}+inj :: forall e r rInitial a. (Member e r) => e (Sem rInitial) a -> Union r (Sem rInitial) a+inj e = injWeaving $ Weaving+ e+ (Identity ())+ (fmap Identity . runIdentity)+ runIdentity+ (Just . runIdentity)+{-# INLINABLE inj #-} ------------------------------------------------------------------------------ -- | Lift an effect @e@ into a 'Union' capable of holding it, -- given an explicit proof that the effect exists in @r@-injUsing :: forall e r m a. Functor m => ElemOf e r -> e m a -> Union r m a-injUsing pr e = Union pr $- Weaving e (Identity ())- (fmap Identity . runIdentity)- runIdentity- (Just . runIdentity)-{-# INLINE injUsing #-}+injUsing :: forall e r rInitial a.+ ElemOf e r -> e (Sem rInitial) a -> Union r (Sem rInitial) a+injUsing pr e = Union pr $ Weaving+ e+ (Identity ())+ (fmap Identity . runIdentity)+ runIdentity+ (Just . runIdentity)+{-# INLINABLE injUsing #-} ------------------------------------------------------------------------------ -- | 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 membership-{-# INLINE injWeaving #-}+{-# INLINABLE injWeaving #-} ------------------------------------------------------------------------------ -- | Attempt to take an @e@ effect out of a 'Union'.@@ -320,7 +369,7 @@ => Union r m a -> Maybe (Weaving e m a) prj = prjUsing membership-{-# INLINE prj #-}+{-# INLINABLE prj #-} ------------------------------------------------------------------------------ -- | Attempt to take an @e@ effect out of a 'Union', given an explicit@@ -331,7 +380,7 @@ -> Union r m a -> Maybe (Weaving e m a) prjUsing pr (Union sn a) = (\Refl -> a) <$> sameMember pr sn-{-# INLINE prjUsing #-}+{-# INLINABLE prjUsing #-} ------------------------------------------------------------------------------ -- | Like 'decomp', but allows for a more efficient@@ -343,4 +392,4 @@ case p of Here -> Right a There pr -> Left (Union (There pr) a)-{-# INLINE decompCoerce #-}+{-# INLINABLE decompCoerce #-}
src/Polysemy/Internal/Writer.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, TemplateHaskell, TupleSections #-}-{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-}++-- | Description: The 'Writer' effect module Polysemy.Internal.Writer where import Control.Concurrent.STM@@ -20,8 +22,11 @@ ------------------------------------------------------------------------------ -- | An effect capable of emitting and intercepting messages. data Writer o m a where+ -- | Write a message to the log. Tell :: o -> Writer o m ()+ -- | Return the log produced by the higher-order action. Listen :: ∀ o m a. m a -> Writer o m (o, a)+ -- | Run the given action and apply the function it returns to the log. Pass :: m (o -> o, a) -> Writer o m a makeSem ''Writer@@ -59,7 +64,7 @@ id (\(f, _) (Endo oo) -> let !o' = f (oo mempty) in Endo (o' <>)) (inspect ins t)- return (f', fmap snd t)+ return (f', snd <$> t) {-# INLINE writerToEndoWriter #-} @@ -148,8 +153,8 @@ -> o -> STM () writeListen tvar switch = \o -> do- alreadyCommited <- readTVar switch- unless alreadyCommited $ do+ alreadyCommitted <- readTVar switch+ unless alreadyCommitted $ do s <- readTVar tvar writeTVar tvar $! s <> o write o@@ -184,8 +189,8 @@ o <- readTVar tvar let !o' = f o -- Likely redundant, but doesn't hurt.- alreadyCommited <- readTVar switch- unless alreadyCommited $+ alreadyCommitted <- readTVar switch+ unless alreadyCommitted $ write o' writeTVar switch True {-# INLINE commitPass #-}
− src/Polysemy/Law.hs
@@ -1,197 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--#if __GLASGOW_HASKELL__ < 806--- There is a bug in older versions of Haddock that don't allow documentation--- on GADT arguments.-#define HADDOCK ---#else-#define HADDOCK -- ^-#endif--module Polysemy.Law- ( Law (..)- , runLaw- , MakeLaw (..)- , Citizen (..)- , printf- , module Test.QuickCheck- ) where--import Control.Arrow (first)-import Data.Char-import Polysemy-import Test.QuickCheck------------------------------------------------------------------------------------ | Associates the name @r@ with the eventual type @a@. For example,--- @'Citizen' (String -> Bool) Bool@ can produce arbitrary @Bool@s by calling--- the given function with arbitrary @String@s.-class Citizen r a | r -> a where- -- | Generate two @a@s via two @r@s. Additionally, produce a list of strings- -- corresponding to any arbitrary arguments we needed to build.- getCitizen :: r -> r -> Gen ([String], (a, a))--instance {-# OVERLAPPING #-} Citizen (Sem r a -> b) (Sem r a -> b) where- getCitizen r1 r2 = pure ([], (r1, r2))--instance Citizen (Sem r a) (Sem r a) where- getCitizen r1 r2 = pure ([], (r1, r2))--instance (Arbitrary a, Show a, Citizen b r) => Citizen (a -> b) r where- getCitizen f1 f2 = do- a <- arbitrary- first (show a :) <$> getCitizen (f1 a) (f2 a)------------------------------------------------------------------------------------ | A law that effect @e@ must satisfy whenever it is in environment @r@. You--- can use 'runLaw' to transform these 'Law's into QuickCheck-able 'Property's.-data Law e r where- -- | A pure 'Law', that doesn't require any access to 'IO'.- Law- :: ( Eq a- , Show a- , Citizen i12n (Sem r x -> a)- , Citizen res (Sem (e ': r) x)- )- => i12n- HADDOCK An interpretation from @'Sem' r x@ down to a pure value. This is- -- likely 'run'.- -> String- HADDOCK A string representation of the left-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the right-handed side was called with.- -> String- HADDOCK A string representation of the right-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the left-handed side was called with.- -> Law e r- -- | Like 'Law', but for 'IO'-accessing effects.- LawIO- :: ( Eq a- , Show a- , Citizen i12n (Sem r x -> IO a)- , Citizen res (Sem (e ': r) x)- )- => i12n- HADDOCK An interpretation from @'Sem' r x@ down to an 'IO' value. This is- -- likely 'runM'.- -> String- HADDOCK A string representation of the left-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the right-handed side was called with.- -> String- HADDOCK A string representation of the right-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the left-handed side was called with.- -> Law e r------------------------------------------------------------------------------------ | A typeclass that provides the smart constructor 'mkLaw'.-class MakeLaw e r where- -- | A smart constructor for building 'Law's.- mkLaw- :: (Eq a, Show a, Citizen res (Sem (e ': r) a))- => String- -> res- -> String- -> res- -> Law e r--instance MakeLaw e '[] where- mkLaw = Law run--instance MakeLaw e '[Embed IO] where- mkLaw = LawIO runM------------------------------------------------------------------------------------ | Produces a QuickCheck-able 'Property' corresponding to whether the given--- interpreter satisfies the 'Law'.-runLaw :: InterpreterFor e r -> Law e r -> Property-runLaw i12n (Law finish str1 a str2 b) = property $ do- (_, (lower, _)) <- getCitizen finish finish- (args, (ma, mb)) <- getCitizen a b- let run_it = lower . i12n- a' = run_it ma- b' = run_it mb- pure $- counterexample- (mkCounterexampleString str1 a' str2 b' args)- (a' == b')-runLaw i12n (LawIO finish str1 a str2 b) = property $ do- (_, (lower, _)) <- getCitizen finish finish- (args, (ma, mb)) <- getCitizen a b- let run_it = lower . i12n- pure $ ioProperty $ do- a' <- run_it ma- b' <- run_it mb- pure $- counterexample- (mkCounterexampleString str1 a' str2 b' args)- (a' == b')------------------------------------------------------------------------------------ | Make a string representation for a failing 'runLaw' property.-mkCounterexampleString- :: Show a- => String- -> a- -> String- -> a- -> [String]- -> String-mkCounterexampleString str1 a str2 b args =- mconcat- [ printf str1 args , " (result: " , show a , ")\n /= \n"- , printf str2 args , " (result: " , show b , ")"- ]------------------------------------------------------------------------------------ | A bare-boned implementation of printf. This function will replace tokens--- of the form @"%n"@ in the first string with @args !! n@.------ This will only work for indexes up to 9.------ For example:------ >>> printf "hello %1 %2% %3 %1" ["world", "50"]--- "hello world 50% %3 world"-printf :: String -> [String] -> String-printf str args = splitArgs str- where- splitArgs :: String -> String- splitArgs s =- case break (== '%') s of- (as, "") -> as- (as, _ : b : bs)- | isDigit b- , let d = read [b] - 1- , d < length args- -> as ++ (args !! d) ++ splitArgs bs- (as, _ : bs) -> as ++ "%" ++ splitArgs bs-
src/Polysemy/Membership.hs view
@@ -1,3 +1,4 @@+-- | Description: Reexports of membership related functionality module Polysemy.Membership ( -- * Witnesses ElemOf (..)
src/Polysemy/NonDet.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for 'NonDet' module Polysemy.NonDet ( -- * Effect NonDet (..)@@ -41,7 +42,7 @@ case e of Empty -> empty Choose left right ->- MaybeT $ usingSem k $ runMaybeT $ fmap ex $ do+ MaybeT $ usingSem k $ runMaybeT $ fmap ex $ MaybeT (runNonDetMaybe (wv (left <$ s))) <|> MaybeT (runNonDetMaybe (wv (right <$ s))) Left x -> MaybeT $
+ src/Polysemy/Opaque.hs view
@@ -0,0 +1,54 @@+-- | The auxiliary effect 'Opaque' used by interpreters of 'Polysemy.Scoped.Scoped'+module Polysemy.Opaque (+ -- * Effect+ Opaque(..),++ -- * Interpreters+ toOpaque,+ fromOpaque,+ ) where++import Polysemy++-- | An effect newtype meant to be used to wrap polymorphic effect variables to+-- prevent them from jamming up resolution of 'Polysemy.Member'.+-- For example, consider:+--+-- @+-- badPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) ()+-- badPut = 'Polysemy.State.put' () -- error+-- @+--+-- This fails to compile. This is because @e@ /could/ be+-- @'Polysemy.State.State' ()@' -- in which case the 'Polysemy.State.put'+-- should target it instead of the concretely provided+-- @'Polysemy.State.State' ()@; as the compiler can't know for sure which effect+-- should be targeted, the program is rejected.+-- There are various ways to resolve this, including using 'raise' or+-- 'Polysemy.Membership.subsumeUsing'. 'Opaque' provides another way:+--+-- @+-- okPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) ()+-- okPut = 'fromOpaque' ('Polysemy.State.put' ()) -- OK+-- @+--+-- 'Opaque' is most useful as a tool for library writers, in the case where some+-- function of the library requires the user to work with an effect stack+-- containing some polymorphic effect variables. By wrapping the polymorphic+-- effect variables using 'Opaque', users of the function can use effects as+-- normal, without having to use 'raise' or 'Polysemy.Membership.subsumeUsing'+-- in order to have 'Polysemy.Member' resolve. The various interpreters of+-- 'Polysemy.Scoped.Scoped' are examples of such usage of 'Opaque'.+--+-- @since 1.9.0.0+newtype Opaque (e :: Effect) m a = Opaque (e m a)++-- | Wrap 'Opaque' around the top effect of the effect stack+toOpaque :: Sem (e ': r) a -> Sem (Opaque e ': r) a+toOpaque = rewrite Opaque+{-# INLINE toOpaque #-}++-- | Unwrap 'Opaque' around the top effect of the effect stack+fromOpaque :: Sem (Opaque e ': r) a -> Sem (e ': r) a+fromOpaque = rewrite (\(Opaque e) -> e)+{-# INLINE fromOpaque #-}
src/Polysemy/Output.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, TemplateHaskell #-} +-- | Description: The 'Output' effect for sending side-effecting messages module Polysemy.Output ( -- * Effect Output (..)@@ -41,6 +42,7 @@ -- | An effect capable of sending messages. Useful for streaming output and for -- logging. data Output o m a where+ -- | Output a message. Output :: o -> Output o m () makeSem ''Output
src/Polysemy/Reader.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Reader' effect and its interpreters module Polysemy.Reader ( -- * Effect Reader (..)@@ -23,12 +24,16 @@ ------------------------------------------------------------------------------ -- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'. data Reader i m a where+ -- | Get the environment. Ask :: Reader i m i+ -- | Transform the environment. Local :: (i -> i) -> m a -> Reader i m a makeSem ''Reader +------------------------------------------------------------------------------+-- | Apply a function to the environment and return the result. asks :: forall i j r. Member (Reader i) r => (i -> j) -> Sem r j asks f = f <$> ask {-# INLINABLE asks #-}
src/Polysemy/Resource.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Resource' effect, providing bracketing functionality module Polysemy.Resource ( -- * Effect Resource (..) -- * Actions , bracket+ , bracket_ , bracketOnError , finally , onException@@ -13,8 +15,6 @@ -- * Interpretations , runResource , resourceToIOFinal- , resourceToIO- , lowerResource ) where import qualified Control.Exception as X@@ -27,6 +27,7 @@ -- will successfully run the deallocation action even in the presence of other -- short-circuiting effects. data Resource m a where+ -- | Allocate a resource, use it, and clean it up afterwards. Bracket :: m a -- Action to allocate a resource.@@ -36,6 +37,7 @@ -> (a -> m b) -- Action which uses the resource. -> Resource m b+ -- | Allocate a resource, use it, and clean it up afterwards if an error occurred. BracketOnError :: m a -- Action to allocate a resource.@@ -48,6 +50,20 @@ makeSem ''Resource +------------------------------------------------------------------------------+-- | A variant of 'bracket' where the return value from the first computation+-- is not required.+--+-- cf. 'Control.Exception.bracket' and 'Control.Exception.bracket_'+--+-- @since 1.5.0.0+bracket_+ :: Member Resource r+ => Sem r a -- ^ computation to run first+ -> Sem r b -- ^ computation to run last (even if an exception was raised)+ -> Sem r c -- ^ computation to run in-between+ -> Sem r c+bracket_ begin end act = bracket begin (const end) (const act) ------------------------------------------------------------------------------ -- | Like 'bracket', but for the simple case of one computation to run@@ -59,7 +75,7 @@ => Sem r a -- ^ computation to run first -> Sem r b -- ^ computation to run afterward (even if an exception was raised) -> Sem r a-finally act end = bracket (pure ()) (pure end) (const act)+finally act end = bracket (pure ()) (const end) (const act) ------------------------------------------------------------------------------@@ -81,16 +97,6 @@ -- 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@@ -124,42 +130,6 @@ --------------------------------------------------------------------------------- | Run a 'Resource' effect in terms of 'X.bracket'.------ @since 1.0.0.0-lowerResource- :: ∀ r a- . Member (Embed IO) r- => (∀ x. Sem r x -> IO x)- -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely- -- some combination of 'runM' and other interpreters composed via '.@'.- -> Sem (Resource ': r) a- -> Sem r a-lowerResource finish = interpretH $ \case- Bracket alloc dealloc use -> do- a <- runT alloc- d <- bindT dealloc- u <- bindT use-- let run_it :: Sem (Resource ': r) x -> IO x- run_it = finish .@ lowerResource-- embed $ X.bracket (run_it a) (run_it . d) (run_it . u)-- BracketOnError alloc dealloc use -> do- a <- runT alloc- d <- bindT dealloc- u <- bindT use-- let run_it :: Sem (Resource ': r) x -> IO x- run_it = finish .@ lowerResource-- embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)-{-# INLINE lowerResource #-}-{-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}--------------------------------------------------------------------------------- -- | Run a 'Resource' effect purely. -- -- @since 1.0.0.0@@ -196,63 +166,4 @@ _ <- run_it $ d resource pure result {-# INLINE runResource #-}------------------------------------------------------------------------------------ | 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'.--- Notably, this means that 'Polysemy.State.State' effects will be consistent--- in the presence of 'Resource'.------ ResourceToIO' is safe whenever you're concerned about exceptions thrown--- 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 'resourceToIOFinal' instead.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 1.0.0.0-resourceToIO- :: forall r a- . Member (Embed IO) r- => Sem (Resource ': r) a- -> Sem r a-resourceToIO = interpretH $ \case- Bracket a b c -> do- ma <- runT a- mb <- bindT b- mc <- bindT c-- withLowerToIO $ \lower finish -> do- let done :: Sem (Resource ': r) x -> IO x- done = lower . raise . resourceToIO- X.bracket- (done ma)- (\x -> done (mb x) >> finish)- (done . mc)-- BracketOnError a b c -> do- ins <- getInspectorT- ma <- runT a- mb <- bindT b- mc <- bindT c-- withLowerToIO $ \lower finish -> do- let done :: Sem (Resource ': r) x -> IO x- done = lower . raise . resourceToIO- X.bracketOnError- (done ma)- (\x -> done (mb x) >> finish)- (\x -> do- result <- done $ mc x- case inspect ins result of- Just _ -> pure result- Nothing -> do- _ <- done $ mb x- pure result- )-{-# INLINE resourceToIO #-}
+ src/Polysemy/Scoped.hs view
@@ -0,0 +1,329 @@+{-# language AllowAmbiguousTypes, BangPatterns #-}++-- | Description: Interpreters for 'Scoped'+module Polysemy.Scoped (+ -- * Effect+ Scoped,+ Scoped_,++ -- * Constructors+ scoped,+ scoped_,+ rescope,++ -- * Interpreters+ runScopedNew,+ interpretScopedH,+ interpretScopedH',+ interpretScoped,+ interpretScopedAs,+ interpretScopedWithH,+ interpretScopedWith,+ interpretScopedWith_,+ runScoped,+ runScopedAs,+) where++import Data.Function ((&))+import Data.Sequence (Seq(..))+import qualified Data.Sequence as S++import Polysemy.Opaque+import Polysemy.Internal+import Polysemy.Internal.Sing+import Polysemy.Internal.Union+import Polysemy.Internal.Combinators+import Polysemy.Internal.Scoped+import Polysemy.Internal.Tactics++-- | Construct an interpreter for a higher-order effect wrapped in a 'Scoped',+-- given a resource allocation function and a parameterized handler for the+-- plain effect.+--+-- This combinator is analogous to 'interpretH' in that it allows the handler to+-- use the 'Tactical' environment and transforms the effect into other effects+-- on the stack.+interpretScopedH ::+ ∀ resource param effect r .+ -- | A callback function that allows the user to acquire a resource for each+ -- computation wrapped by 'scoped' using other effects, with an additional+ -- argument that contains the call site parameter passed to 'scoped'.+ (∀ q x . param ->+ (resource -> Sem (Opaque q ': r) x) ->+ Sem (Opaque q ': r) x) ->+ -- | A handler like the one expected by 'interpretH' with an additional+ -- parameter that contains the @resource@ allocated by the first argument.+ (∀ q r0 x . resource ->+ effect (Sem r0) x ->+ Tactical effect (Sem r0) (Opaque q ': r) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedH withResource scopedHandler = runScopedNew \param sem ->+ withResource param \r -> interpretH (scopedHandler r) sem+{-# inline interpretScopedH #-}++-- | Variant of 'interpretScopedH' that allows the resource acquisition function+-- to use 'Tactical'.+interpretScopedH' ::+ ∀ resource param effect r .+ (∀ e r0 x . param -> (resource -> Tactical e (Sem r0) r x) ->+ Tactical e (Sem r0) r x) ->+ (∀ r0 x .+ resource -> effect (Sem r0) x ->+ Tactical (Scoped param effect) (Sem r0) r x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedH' withResource scopedHandler =+ go 0 Empty+ where+ go :: Word -> Seq resource -> InterpreterFor (Scoped param effect) r+ go depth resources =+ interpretH \case+ Run w act ->+ scopedHandler (S.index resources (fromIntegral w)) act+ InScope param main | !depth' <- depth + 1 ->+ withResource param \ resource ->+ raise . go depth' (resources :|> resource) =<< runT (main depth)+{-# inline interpretScopedH' #-}++-- | First-order variant of 'interpretScopedH'.+interpretScoped ::+ ∀ resource param effect r .+ (∀ q x . param ->+ (resource -> Sem (Opaque q ': r) x) ->+ Sem (Opaque q ': r) x) ->+ (∀ m x . resource -> effect m x -> Sem r x) ->+ InterpreterFor (Scoped param effect) r+interpretScoped withResource scopedHandler =+ interpretScopedH withResource \ r e -> liftT (raise (scopedHandler r e))+{-# inline interpretScoped #-}++-- | Variant of 'interpretScoped' in which the resource allocator is a plain+-- action.+interpretScopedAs ::+ ∀ resource param effect r .+ (param -> Sem r resource) ->+ (∀ m x . resource -> effect m x -> Sem r x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedAs resource =+ interpretScoped \ p use -> use =<< raise (resource p)+{-# inline interpretScopedAs #-}++-- | Higher-order interpreter for 'Scoped' that allows the handler to use+-- additional effects that are interpreted by the resource allocator.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@.+--+-- As an example for a higher order effect, consider a mutexed concurrent state+-- effect, where an effectful function may lock write access to the state while+-- making it still possible to read it:+--+-- > data MState s :: Effect where+-- > MState :: (s -> m (s, a)) -> MState s m a+-- > MRead :: MState s m s+-- >+-- > makeSem ''MState+--+-- We can now use an 'Polysemy.AtomicState.AtomicState' to store the current+-- value and lock write access with an @MVar@. Since the state callback is+-- effectful, we need a higher order interpreter:+--+-- > withResource ::+-- > Member (Embed IO) r =>+-- > s ->+-- > (MVar () -> Sem (AtomicState s : r) a) ->+-- > Sem r a+-- > withResource initial use = do+-- > tv <- embed (newTVarIO initial)+-- > lock <- embed (newMVar ())+-- > runAtomicStateTVar tv $ use lock+-- >+-- > interpretMState ::+-- > ∀ s r .+-- > Members [Resource, Embed IO] r =>+-- > InterpreterFor (Scoped s (MState s)) r+-- > interpretMState =+-- > interpretScopedWithH @'[AtomicState s] withResource \ lock -> \case+-- > MState f ->+-- > bracket_ (embed (takeMVar lock)) (embed (tryPutMVar lock ())) do+-- > s0 <- atomicGet+-- > res <- runTSimple (f s0)+-- > Inspector ins <- getInspectorT+-- > for_ (ins res) \ (s, _) -> atomicPut s+-- > pure (snd <$> res)+-- > MRead ->+-- > liftT atomicGet+interpretScopedWithH ::+ ∀ extra resource param effect r .+ KnownList extra =>+ (∀ q x .+ param ->+ (resource -> Sem (Append extra (Opaque q ': r)) x) ->+ Sem (Opaque q ': r) x) ->+ (∀ q r0 x .+ resource ->+ effect (Sem r0) x ->+ Tactical effect (Sem r0) (Append extra (Opaque q ': r)) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedWithH withResource scopedHandler = runScopedNew+ \param (sem :: Sem (effect ': Opaque q ': r) x) ->+ withResource param \resource ->+ sem+ & restack+ (injectMembership (singList @'[effect]) (singList @extra))+ & interpretH (scopedHandler @q resource)+{-# inline interpretScopedWithH #-}++-- | First-order variant of 'interpretScopedWithH'.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@:+--+-- > data SomeAction :: Effect where+-- > SomeAction :: SomeAction m ()+-- >+-- > foo :: InterpreterFor (Scoped () SomeAction) r+-- > foo =+-- > interpretScopedWith @[Reader Int, State Bool] localEffects \ () -> \case+-- > SomeAction -> put . (> 0) =<< ask @Int+-- > where+-- > localEffects () use = evalState False (runReader 5 (use ()))+interpretScopedWith ::+ ∀ extra param resource effect r.+ KnownList extra =>+ (∀ q x .+ param ->+ (resource -> Sem (Append extra (Opaque q ': r)) x) ->+ Sem (Opaque q ': r) x) ->+ (∀ m x . resource -> effect m x -> Sem (Append extra r) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedWith withResource scopedHandler = runScopedNew+ \param (sem :: Sem (effect ': Opaque q ': r) x) ->+ withResource param \resource ->+ sem+ & restack+ (injectMembership (singList @'[effect]) (singList @extra))+ & interpretH \e -> liftT $+ restack+ (injectMembership @r (singList @extra) (singList @'[Opaque q]))+ (scopedHandler resource e)+{-# inline interpretScopedWith #-}++-- | Variant of 'interpretScopedWith' in which no resource is used and the+-- resource allocator is a plain interpreter.+-- This is useful for scopes that only need local effects, but no resources in+-- the handler.+--+-- See the /Note/ on 'interpretScopedWithH'.+interpretScopedWith_ ::+ ∀ extra param effect r .+ KnownList extra =>+ (∀ q x .+ param ->+ Sem (Append extra (Opaque q ': r)) x ->+ Sem (Opaque q ': r) x) ->+ (∀ m x . effect m x -> Sem (Append extra r) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedWith_ withResource scopedHandler =+ interpretScopedWith @extra+ (\ p f -> withResource p (f ()))+ (\ () -> scopedHandler)+{-# inline interpretScopedWith_ #-}++-- | Variant of 'interpretScoped' that uses another interpreter instead of a+-- handler.+--+-- This is mostly useful if you want to reuse an interpreter that you cannot+-- easily rewrite (like from another library). If you have full control over the+-- implementation, 'interpretScoped' should be preferred.+--+-- /Note/: In previous versions of Polysemy, the wrapped interpreter was+-- executed fully, including the initializing code surrounding its handler,+-- for each action in the program. However, new and continuing discoveries+-- regarding 'Scoped' has allowed the improvement of having the interpreter be+-- used only once per use of 'scoped', and have it cover the same scope of+-- actions that the resource allocator does.+--+-- This renders the resource allocator practically redundant; for the moment,+-- the API surrounding 'Scoped' remains the same, but work is in progress to+-- revamp the entire API of 'Scoped'.+runScoped ::+ ∀ resource param effect r .+ (∀ q x . param -> (resource -> Sem (Opaque q ': r) x) -> Sem (Opaque q ': r) x) ->+ (∀ q . resource -> InterpreterFor effect (Opaque q ': r)) ->+ InterpreterFor (Scoped param effect) r+runScoped withResource scopedInterpreter = runScopedNew \param sem ->+ withResource param (\r -> scopedInterpreter r sem)+{-# inline runScoped #-}++-- | Variant of 'runScoped' in which the resource allocator returns the resource+-- rather than calling a continuation.+runScopedAs ::+ ∀ resource param effect r .+ (param -> Sem r resource) ->+ (∀ q. resource -> InterpreterFor effect (Opaque q ': r)) ->+ InterpreterFor (Scoped param effect) r+runScopedAs resource = runScoped \ p use -> use =<< raise (resource p)+{-# inline runScopedAs #-}++-- | Run a 'Scoped' effect by specifying the interpreter to be used at every+-- use of 'scoped'.+--+-- This interpretation of 'Scoped' is powerful enough to subsume all other+-- interpretations of 'Scoped' (except 'interpretScopedH'' which works+-- differently from all other interpretations) while also being much simpler.+--+-- Consider this a sneak-peek of the future of 'Scoped'. In the API rework+-- planned for 'Scoped', the effect and its interpreters will be further+-- expanded to make 'Scoped' even more flexible.+--+-- @since 1.9.0.0+runScopedNew ::+ ∀ param effect r .+ (∀ q. param -> InterpreterFor effect (Opaque q ': r)) ->+ InterpreterFor (Scoped param effect) r+runScopedNew h =+ interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of+ Run w _ -> errorWithoutStackTrace $ "top level run with depth " ++ show w+ InScope param main ->+ wv (main 0 <$ s)+ & raiseUnder2+ & go 0+ & h param+ & interpretH (\(Opaque (OuterRun w _)) ->+ errorWithoutStackTrace $ "unhandled OuterRun with depth " ++ show w)+ & fmap ex+ where+ go' :: Word+ -> InterpreterFor+ (Opaque (OuterRun effect))+ (effect ': Opaque (OuterRun effect) ': r)+ go' depth =+ interpretWeaving \ (Weaving sr@(Opaque (OuterRun w act)) s wv ex ins) ->+ if w == depth then+ liftSem $ injWeaving $ Weaving act s (go' depth . wv) ex ins+ else+ liftSem $ injWeaving $ Weaving sr s (go' depth . wv) ex ins++ -- TODO investigate whether loopbreaker optimization is effective here+ go :: Word+ -> InterpreterFor+ (Scoped param effect)+ (effect ': Opaque (OuterRun effect) ': r)+ go depth =+ interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of+ Run w act+ | w == depth -> liftSem $ injWeaving $+ Weaving act s (go depth . wv) ex ins+ | otherwise -> liftSem $ injWeaving $+ Weaving (Opaque (OuterRun w act)) s (go depth . wv) ex ins+ InScope param main -> do+ let !depth' = depth + 1+ wv (main depth' <$ s)+ & go depth'+ & h param+ & raiseUnder2+ & go' depth+ & fmap ex+{-# INLINE runScopedNew #-}
src/Polysemy/State.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'State' effect module Polysemy.State ( -- * Effect State (..)@@ -28,15 +29,15 @@ , hoistStateIntoStateT ) where -import Control.Monad.ST+import Control.Monad.ST import qualified Control.Monad.Trans.State as S-import Data.IORef-import Data.STRef-import Data.Tuple (swap)-import Polysemy-import Polysemy.Internal-import Polysemy.Internal.Combinators-import Polysemy.Internal.Union+import Data.IORef+import Data.STRef+import Data.Tuple (swap)+import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Combinators+import Polysemy.Internal.Union ------------------------------------------------------------------------------@@ -48,17 +49,23 @@ -- Interpreters which require statefulness can 'Polysemy.reinterpret' -- themselves in terms of 'State', and subsequently call 'runState'. data State s m a where+ -- | Get the state. Get :: State s m s+ -- | Update the state. Put :: s -> State s m () makeSem ''State +------------------------------------------------------------------------------+-- | Apply a function to the state and return the result. gets :: forall s a r. Member (State s) r => (s -> a) -> Sem r a-gets f = fmap f get+gets f = f <$> get {-# INLINABLE gets #-} +------------------------------------------------------------------------------+-- | Modify the state. modify :: Member (State s) r => (s -> s) -> Sem r () modify f = do s <- get@@ -251,12 +258,11 @@ Left x -> S.StateT $ \s -> liftSem . fmap swap . weave (s, ())- (\(s', m') -> fmap swap- $ S.runStateT m' s')+ (\(s', m') -> swap <$> S.runStateT m' s') (Just . snd) $ hoist hoistStateIntoStateT x- Right (Weaving Get z _ y _) -> fmap (y . (<$ z)) $ S.get- Right (Weaving (Put s) z _ y _) -> fmap (y . (<$ z)) $ S.put s+ Right (Weaving Get z _ y _) -> y . (<$ z) <$> S.get+ Right (Weaving (Put s) z _ y _) -> y . (<$ z) <$> S.put s {-# INLINE hoistStateIntoStateT #-} @@ -269,4 +275,3 @@ forall s e (f :: forall m x. e m x -> Sem (State s ': r) x). runLazyState s (reinterpret f e) = lazilyStateful (\x s' -> runLazyState s' $ f x) s e #-}-
− src/Polysemy/State/Law.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Polysemy.State.Law where--import Polysemy-import Polysemy.Law-import Polysemy.State-import Control.Applicative-import Control.Arrow------------------------------------------------------------------------------------ | A collection of laws that show a `State` interpreter is correct.-prop_lawfulState- :: forall r s- . (Eq s, Show s, Arbitrary s, MakeLaw (State s) r)- => InterpreterFor (State s) r- -> Property-prop_lawfulState i12n = conjoin- [ runLaw i12n law_putTwice- , runLaw i12n law_getTwice- , runLaw i12n law_getPutGet- ]---law_putTwice- :: forall s r- . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)- => Law (State s) r-law_putTwice =- mkLaw- "put %1 >> put %2 >> get"- (\s s' -> put @s s >> put @s s' >> get @s)- "put %2 >> get"- (\_ s' -> put @s s' >> get @s)--law_getTwice- :: forall s r- . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)- => Law (State s) r-law_getTwice =- mkLaw- "liftA2 (,) get get"- (liftA2 (,) (get @s) (get @s))- "(id &&& id) <$> get"- ((id &&& id) <$> get @s)--law_getPutGet- :: forall s r- . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)- => Law (State s) r-law_getPutGet =- mkLaw- "get >>= put >> get"- (get @s >>= put @s >> get @s)- "get"- (get @s)-
src/Polysemy/Tagged.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}++-- | Description: The 'Tagged' effect and its interpreters module Polysemy.Tagged ( -- * Effect@@ -39,7 +41,7 @@ -- -> 'Sem' r a -- -> 'Sem' r a -- taggedLocal f m =--- 'tag' @k @('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m)+-- 'tag' \@k \@('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m) -- @ -- tag
src/Polysemy/Trace.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Trace' effect and its interpreters module Polysemy.Trace ( -- * Effect Trace (..)@@ -8,6 +9,9 @@ , trace -- * Interpretations+ , traceToHandle+ , traceToStdout+ , traceToStderr , traceToIO , runTraceList , ignoreTrace@@ -19,24 +23,54 @@ import Polysemy import Polysemy.Output+import System.IO (stdout, stderr, hPutStrLn, Handle) ------------------------------------------------------------------------------ -- | An effect for logging strings. data Trace m a where+ -- | Log a message. Trace :: String -> Trace m () makeSem ''Trace ------------------------------------------------------------------------------+-- | Run a 'Trace' effect by printing the messages to the provided 'Handle'.+--+-- @since 1.6.0.0+traceToHandle :: Member (Embed IO) r => Handle -> Sem (Trace ': r) a -> Sem r a+traceToHandle handle = interpret $ \case+ Trace m -> embed $ hPutStrLn handle m+{-# INLINE traceToHandle #-}+++------------------------------------------------------------------------------ -- | Run a 'Trace' effect by printing the messages to stdout. --+-- @since 1.6.0.0+traceToStdout :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a+traceToStdout = traceToHandle stdout+{-# INLINE traceToStdout #-}+++------------------------------------------------------------------------------+-- | Run a 'Trace' effect by printing the messages to stderr.+--+-- @since 1.6.0.0+traceToStderr :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a+traceToStderr = traceToHandle stderr+{-# INLINE traceToStderr #-}+++------------------------------------------------------------------------------+-- | Run a 'Trace' effect by printing the messages to stdout.+-- -- @since 1.0.0.0 traceToIO :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a-traceToIO = interpret $ \case- Trace m -> embed $ putStrLn m+traceToIO = traceToStdout {-# INLINE traceToIO #-}+{-# deprecated traceToIO "Use traceToStdout" #-} ------------------------------------------------------------------------------
− src/Polysemy/View.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Polysemy.View- ( -- * Effect- View (..)-- -- * Actions- , see-- -- * Interpretations- , viewToState- , viewToInput- ) where--import Polysemy-import Polysemy.Input-import Polysemy.State-import Polysemy.Tagged------------------------------------------------------------------------------------ | A 'View' is an expensive computation that should be cached.-data View v m a where- See :: View v m v--makeSem ''View------------------------------------------------------------------------------------ | Transform a 'View' into an 'Input'.-viewToInput- :: forall v i r a- . Member (Input i) r- => (i -> v)- -> Sem (View v ': r) a- -> Sem r a-viewToInput f = interpret $ \case- See -> f <$> input------------------------------------------------------------------------------------ | Get a 'View' as an exensive computation over an underlying 'State' effect.--- This 'View' is only invalidated when the underlying 'State' changes.-viewToState- :: forall v s r a- . Member (State s) r- => (s -> Sem r v)- -> Sem (View v ': r) a- -> Sem r a-viewToState f = do- evalState Dirty- . untag @"view" @(State (Cached v))- . intercept @(State s)- ( \case- Get -> get- Put s -> do- put s- tag @"view" @(State (Cached v)) $ put $ Dirty @v- )- . reinterpret @(View v)- ( \case- See -> do- dirty <- tagged @"view" $ get @(Cached v)- case dirty of- Dirty -> do- s <- get- v' <- raise $ f s- tagged @"view" $ put $ Cached v'- pure v'- Cached v -> pure v- )---data Cached a = Cached a | Dirty- deriving (Eq, Ord, Show, Functor)-
src/Polysemy/Writer.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections #-} +-- | Description: Interpreters for 'Writer' module Polysemy.Writer ( -- * Effect Writer (..)@@ -45,7 +46,7 @@ => (o -> o) -> Sem r a -> Sem r a-censor f m = pass (fmap (f ,) m)+censor f m = pass $ (f ,) <$> m {-# INLINE censor #-} ------------------------------------------------------------------------------@@ -75,14 +76,14 @@ -- TODO(sandy): this is stupid (o, fa) <- raise $ runWriter mm modify' (<> o)- pure $ fmap (o, ) fa+ pure $ (o, ) <$> fa Pass m -> do mm <- runT m (o, t) <- raise $ runWriter mm ins <- getInspectorT let f = maybe id fst (inspect ins t) modify' (<> f o)- pure (fmap snd t)+ pure $ snd <$> t ) {-# INLINE runWriter #-} @@ -112,7 +113,7 @@ Lazy.pass $ do ft <- m' let f = maybe id fst (ins ft)- return (ex (fmap snd ft), f)+ return (ex $ snd <$> ft, f) {-# INLINE runLazyWriter #-} -----------------------------------------------------------------------------
− test/AsyncSpec.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE NumDecimals #-}--module AsyncSpec where--import Control.Concurrent.MVar-import Control.Monad-import Polysemy-import Polysemy.Async-import Polysemy.State-import Polysemy.Trace-import Test.Hspec---spec :: Spec-spec = describe "async" $ do- it "should thread state and not lock" $ do- (ts, (s, r)) <- runM- . runTraceList- . runState "hello"- . asyncToIO $ do- let message :: Member Trace r => Int -> String -> Sem r ()- message n msg = trace $ mconcat- [ show n, "> ", msg ]- ~[lock1, lock2] <- embed $- replicateM 2 newEmptyMVar- a1 <- async $ do- v <- get @String- message 1 v- put $ reverse v-- embed $ putMVar lock1 ()- embed $ takeMVar lock2- get >>= message 1-- get @String-- void $ async $ do- embed $ takeMVar lock1- get >>= message 2- put "pong"- embed $ putMVar lock2 ()-- await a1 <* put "final"-- ts `shouldContain` ["1> hello", "2> olleh", "1> pong"]- s `shouldBe` "final"- r `shouldBe` Just "pong"
test/BracketSpec.hs view
@@ -151,16 +151,6 @@ . runResource . runError @() -runTest2- :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a- -> IO ([String], ([Char], Either () a))-runTest2 = runM- . ignoreOutput- . runTraceList- . runState ""- . resourceToIO- . runError @()- runTest3 :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO, Final IO] a -> IO ([String], ([Char], Either () a))@@ -185,9 +175,6 @@ k z -- NOTE(sandy): These unsafeCoerces are safe, because we're just weakening -- the end of the union- it "via resourceToIO" $ do- z <- runTest2 $ unsafeCoerce m- k z it "via resourceToIOFinal" $ do z <- runTest3 $ unsafeCoerce m k z@@ -200,9 +187,6 @@ -> Spec testTheIOTwo name k m = do describe name $ do- it "via resourceToIO" $ do- z <- runTest2 m- k z -- NOTE(sandy): This unsafeCoerces are safe, because we're just weakening -- the end of the union it "via resourceToIOFinal" $ do
test/ErrorSpec.hs view
@@ -2,6 +2,7 @@ import qualified Control.Exception as X import Polysemy+import Polysemy.Async import Polysemy.Error import Polysemy.Resource import Test.Hspec@@ -28,11 +29,28 @@ it "should happen before Resource" $ do a <-- runM $ resourceToIO $ runError @MyExc $ do+ runFinal $ embedToFinal @IO $ resourceToIOFinal $ runError @MyExc $ do onException (fromException @MyExc $ do _ <- X.throwIO $ MyExc "hello" pure () ) $ pure $ error "this exception shouldn't happen" a `shouldBe` (Left $ MyExc "hello")+ describe "errorToIOFinal" $ do+ it "should catch errors only for the interpreted Error" $ do+ res1 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do+ raise $ throw () `catch` \() -> return ()+ res1 `shouldBe` Right (Right ())+ res2 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do+ raise (throw ()) `catch` \() -> return ()+ res2 `shouldBe` Left () + it "should propagate errors thrown in 'async'" $ do+ res1 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do+ a <- async $ throw ()+ await a+ res1 `shouldBe` (Left () :: Either () (Maybe ()))+ res2 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do+ a <- async $ throw ()+ await a `catch` \() -> return $ Just ()+ res2 `shouldBe` Right (Just ())
test/FixpointSpec.hs view
@@ -82,7 +82,7 @@ it "should work with runState" $ do test1 `shouldBe` ("12", (2, ())) it "should work with runError" $ do- let res = fmap (take 10) test2+ let res = take 10 <$> test2 res `shouldBe` Right (take 10 $ cycle [1,2]) it "should not trigger the bomb" $ do test3 `shouldBe` Left ()
test/FusionSpec.hs view
@@ -36,7 +36,6 @@ spec = parallel $ do describe "fusion" $ do -- #if __GLASGOW_HASKELL__ >= 807--- -- TODO: Investigate why this test fails mysteriously on GHC < 8.6 -- it "Union proofs should simplify" $ do -- shouldSucceed $(inspectTest $ 'countDown `hasNoType` ''SNat) -- #endif
− test/InspectorSpec.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module InspectorSpec where--import Control.Monad-import Data.IORef-import Polysemy-import Polysemy.Error-import Polysemy.State-import Test.Hspec----data Callback m a where- Callback :: m String -> Callback m ()--makeSem ''Callback----spec :: Spec-spec = parallel $ describe "Inspector" $ do- it "should inspect State effects" $ do- withNewTTY $ \ref -> do- void . (runM .@ runCallback ref)- . runState False- $ do- embed $ pretendPrint ref "hello world"- callback $ show <$> get @Bool- modify not- callback $ show <$> get @Bool-- result <- readIORef ref- result `shouldContain` ["hello world"]- result `shouldContain` ["False", "True"]-- it "should not inspect thrown Error effects" $ do- withNewTTY $ \ref -> do- void . (runM .@ runCallback ref)- . runError @()- $ do- callback $ throw ()- callback $ pure "nice"-- result <- readIORef ref- result `shouldContain` [":(", "nice"]---runCallback- :: Member (Embed IO) r- => IORef [String]- -> (forall x. Sem r x -> IO x)- -> Sem (Callback ': r) a- -> Sem r a-runCallback ref lower = interpretH $ \case- Callback cb -> do- cb' <- runT cb- ins <- getInspectorT- embed $ doCB ref $ do- v <- lower .@ runCallback ref $ cb'- pure $ maybe ":(" id $ inspect ins v- getInitialStateT---doCB :: IORef [String] -> IO String -> IO ()-doCB ref m = m >>= pretendPrint ref---pretendPrint :: IORef [String] -> String -> IO ()-pretendPrint ref msg = modifyIORef ref (++ [msg])---withNewTTY :: (IORef [String] -> IO a) -> IO a-withNewTTY f = do- ref <- newIORef []- f ref-
− test/LawsSpec.hs
@@ -1,20 +0,0 @@-module LawsSpec where--import Polysemy-import Polysemy.Law-import Polysemy.State-import Polysemy.State.Law-import Test.Hspec--spec :: Spec-spec = parallel $ do- describe "State effects" $ do- it "runState should pass the laws" $- property $ prop_lawfulState @'[] $ fmap snd . runState @Int 0-- it "runLazyState should pass the laws" $- property $ prop_lawfulState @'[] $ fmap snd . runLazyState @Int 0-- it "stateToIO should pass the laws" $- property $ prop_lawfulState @'[Embed IO] $ fmap snd . stateToIO @Int 0-
+ test/ScopedSpec.hs view
@@ -0,0 +1,117 @@+{-# language TemplateHaskell, DerivingStrategies, GeneralizedNewtypeDeriving #-}++module ScopedSpec where++import Control.Concurrent.STM+import Polysemy+import Polysemy.Internal.Tactics+import Polysemy.Scoped+import Test.Hspec++newtype Par =+ Par { unPar :: Int }+ deriving stock (Eq, Show)+ deriving newtype (Num, Real, Enum, Integral, Ord)++data E :: Effect where+ E1 :: E m Int+ E2 :: E m Int++makeSem ''E++data F :: Effect where+ F :: F m Int++makeSem ''F++handleE ::+ Member (Embed IO) r =>+ TVar Int ->+ E m a ->+ Tactical effect m (F : r) a+handleE tv = \case+ E1 -> do+ i1 <- embed (readTVarIO tv)+ i2 <- f+ pureT (i1 + i2 + 10)+ E2 ->+ pureT (-1)++interpretF ::+ Member (Embed IO) r =>+ TVar Int ->+ InterpreterFor F r+interpretF tv =+ interpret \ F -> do+ embed (atomically (writeTVar tv 7))+ pure 5++scope ::+ Member (Embed IO) r =>+ Par ->+ (TVar Int -> Sem (F : r) a) ->+ Sem r a+scope (Par n) use = do+ tv <- embed (newTVarIO n)+ interpretF tv (use tv)++data HO :: Effect where+ Inc :: m a -> HO m a+ Ret :: HO m Int++makeSem ''HO++scopeHO :: () -> (() -> Sem r a) -> Sem r a+scopeHO () use =+ use ()++handleHO :: Int -> () -> HO m a -> Tactical HO m r a+handleHO n () = \case+ Inc ma -> raise . interpretH (handleHO (n + 1) ()) =<< runT ma+ Ret -> pureT n++data Esc :: Effect where+ Esc :: Esc m Int+makeSem ''Esc++data Indirect :: Effect where+ Indirect :: Indirect m Int+makeSem ''Indirect++interpretIndirect :: Member Esc r => InterpreterFor Indirect r+interpretIndirect = interpret \ Indirect -> esc++handleEsc :: Int -> Esc m a -> Sem r a+handleEsc i = \ Esc -> pure i++test_escape :: Sem (Scoped Int Esc ': r) Int+test_escape =+ scoped @Int @Esc 2+ $ interpretIndirect+ $ scoped @Int @Esc 1 indirect++spec :: Spec+spec = parallel do+ describe "Scoped" do+ it "local effects" do+ (i1, i2) <- runM $ interpretScopedWithH @'[F] @(TVar Int) @Par @E scope handleE do+ scoped @Par @E 20 do+ i1 <- e1+ i2 <- scoped @Par @E 23 e1+ pure (i1, i2)+ i1 `shouldBe` 35+ i2 `shouldBe` 38+ it "switch interpreter" do+ r <- runM $ interpretScopedH scopeHO (handleHO 1) do+ scoped_ @HO do+ inc do+ ret+ r `shouldBe` 2+ it "scoped depth" do+ r <- runM $ interpretScoped (flip ($)) handleEsc $ test_escape+ r `shouldBe` 2+ r' <- runM $ interpretScopedH'+ (\r h -> h r)+ (\i e -> liftT (handleEsc i e))+ $ test_escape+ r' `shouldBe` 2
+ test/TacticsSpec.hs view
@@ -0,0 +1,22 @@+module TacticsSpec where++import Polysemy+import Polysemy.Internal (send)+import Test.Hspec++data TestE :: Effect where+ TestE :: m a -> (a -> m b) -> TestE m b++interpretTestE :: InterpreterFor TestE r+interpretTestE =+ interpretH $ \case+ TestE ma f -> do+ a <- runTSimple ma+ bindTSimple f a++spec :: Spec+spec = parallel $ describe "runTH and bindTH" $ do+ it "should act as expected" $ do+ r <- runM (interpretTestE (send (TestE (pure 5) (pure . (9 +)))))+ print r+ (14 :: Int) `shouldBe` r
test/TypeErrors.hs view
@@ -16,36 +16,6 @@ -------------------------------------------------------------------------------- -- | -- >>> :{--- foo :: Sem r ()--- foo = put ()--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...--- ... (Member (State ()) r) ...--- ...-ambiguousMonoState = ()-------------------------------------------------------------------------------------- |--- >>> :{--- foo :: Sem r ()--- foo = put 5--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...--- ... (Member (State s0) r) ...--- ...--- ... 's0' directly...--- ...-ambiguousPolyState = ()-------------------------------------------------------------------------------------- |--- >>> :{ -- interpret @(Reader Bool) $ \case -- Ask -> undefined -- :}@@ -74,81 +44,4 @@ -- ... Probable cause: ...reinterpret... is applied to too few arguments -- ... tooFewArgumentsReinterpret = ()-------------------------------------------------------------------------------------- |--- >>> :{--- let reinterpretScrub :: Sem (Output Int ': m) a -> Sem (State Bool ': Trace ': m) a--- reinterpretScrub = undefined--- foo :: Sem '[Output Int] ()--- foo = pure ()--- foo' = reinterpretScrub foo--- foo'' = runState True foo'--- foo''' = traceToIO foo''--- in runM foo'''--- :}--- ...--- ... Unhandled effect 'Embed IO'--- ...--- ... Expected type: Sem '[Embed m] (Bool, ())--- ... Actual type: Sem '[] (Bool, ())--- ...-runningTooManyEffects = ()-------------------------------------------------------------------------------------- |--- >>> :{--- foo :: Sem (State Int ': r) ()--- foo = put ()--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...--- ... (Member (State ()) (State Int : r)) ...--- ...-ambiguousSendInConcreteR = ()-------------------------------------------------------------------------------------- |--- >>> :{--- let foo :: Member Resource r => Sem r ()--- foo = undefined--- in runM $ lowerResource foo--- :}--- ...--- ... Couldn't match expected type ...--- ... with actual type ...--- ... Probable cause: ... is applied to too few arguments--- ...-missingArgumentToRunResourceInIO = ()-------------------------------------------------------------------------------------- |--- >>> :{--- existsKV :: Member (State (Maybe Int)) r => Sem r Bool--- existsKV = isJust get--- :}--- ...--- ... Ambiguous use of effect 'State'--- ...------ NOTE: This is fixed by enabling the plugin!-missingFmap'PLUGIN = ()------------------------------------------------------------------------------------- |--- >>> :{--- foo :: Sem '[State Int, Embed IO] ()--- foo = output ()--- :}--- ...--- ... Unhandled effect 'Output ()'--- ...--- ... add an interpretation for 'Output ()'--- ...-missingEffectInStack'WRONG = ()
− test/ViewSpec.hs
@@ -1,40 +0,0 @@-module ViewSpec where--import Polysemy-import Polysemy.State-import Polysemy.Trace-import Polysemy.View-import Test.Hspec---check_see :: Members '[View String, Trace] r => Sem r ()-check_see = trace . ("saw " ++) =<< see--spec :: Spec-spec = parallel $ do- describe "View effect" $ do- it "should cache views" $ do- let a = run- . runTraceList- . runState @Int 0- . viewToState @String @Int (\i -> do- trace $ "caching " ++ show i- pure $ show i ) $ do- check_see- check_see- put @Int 3- trace "it's lazy"- put @Int 5- check_see- check_see- get @Int-- a `shouldBe` ([ "caching 0"- , "saw 0"- , "saw 0"- , "it's lazy"- , "caching 5"- , "saw 5"- , "saw 5"- ], (5, 5))-