polysemy 1.3.0.0 → 1.4.0.0
raw patch · 22 files changed
+668/−430 lines, 22 filesdep ~criteriondep ~doctestdep ~dump-corenew-uploader
Dependency ranges changed: criterion, doctest, dump-core, free, freer-simple, mtl, th-abstraction, type-errors
Files
- ChangeLog.md +26/−6
- README.md +135/−86
- polysemy.cabal +203/−188
- src/Polysemy.hs +11/−8
- src/Polysemy/Async.hs +7/−3
- src/Polysemy/Embed.hs +0/−1
- src/Polysemy/Final.hs +1/−1
- src/Polysemy/IO.hs +1/−2
- src/Polysemy/Input.hs +6/−2
- src/Polysemy/Internal.hs +144/−39
- src/Polysemy/Internal.hs-boot +12/−0
- src/Polysemy/Internal/Combinators.hs +35/−27
- src/Polysemy/Internal/Strategy.hs +1/−2
- src/Polysemy/Internal/TH/Common.hs +1/−1
- src/Polysemy/Internal/TH/Effect.hs +1/−1
- src/Polysemy/Internal/Union.hs +57/−49
- src/Polysemy/Internal/Writer.hs +1/−1
- src/Polysemy/NonDet.hs +1/−1
- src/Polysemy/Resource.hs +16/−1
- src/Polysemy/State.hs +4/−6
- src/Polysemy/Writer.hs +4/−4
- test/FixpointSpec.hs +1/−1
ChangeLog.md view
@@ -1,6 +1,31 @@ # Changelog for polysemy +## Unreleased changes++## 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 +172,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 +306,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>@@ -19,76 +19,72 @@ > > 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).+- Paweł Szulc gave a [great talk](https://youtu.be/idU7GdlfP9Q?t=1394) on how+ to start thinking about polysemy.+- Sandy Maguire, the author, 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 #-} import Polysemy import Polysemy.Input@@ -101,15 +97,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 +134,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 +152,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 +173,6 @@ Easy. - ## Friendly Error Messages Free monad libraries aren't well known for their ease-of-use. But following in@@ -194,22 +193,21 @@ 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.-+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 @@ -230,36 +228,88 @@ - TypeFamilies ``` -## Stellar Engineering - Aligning the stars to optimize `polysemy` away+## *What about performance?* ([TL;DR](#tldr)) -Several things need to be in place to fully realize our performance goals:+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. -- 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)+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 consider option of+switching to 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 +319,3 @@ [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-
polysemy.cabal view
@@ -1,207 +1,222 @@-cabal-version: 1.24---- This file has been generated from package.yaml by hpack version 0.31.2.------ see: https://github.com/sol/hpack------ hash: 0f1599ec8e1caf24489536a197f2eb261ecdfb3613fdc2f2221186cdb0f31a5e+cabal-version: 2.0+name: polysemy+version: 1.4.0.0+license: BSD3+license-file: LICENSE+copyright: 2019 Sandy Maguire+maintainer: sandy@sandymaguire.me+author: Sandy Maguire+homepage: https://github.com/polysemy-research/polysemy#readme+bug-reports: https://github.com/polysemy-research/polysemy/issues+synopsis: Higher-order, low-boilerplate free monads.+description:+ Please see the README on GitHub at <https://github.com/isovector/polysemy#readme> -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>-category: Language-homepage: https://github.com/isovector/polysemy#readme-bug-reports: https://github.com/isovector/polysemy/issues-author: Sandy Maguire-maintainer: sandy@sandymaguire.me-copyright: 2019 Sandy Maguire-license: BSD3-license-file: LICENSE-build-type: Custom+category: Language+build-type: Custom extra-source-files: README.md ChangeLog.md source-repository head- type: git- location: https://github.com/isovector/polysemy+ type: git+ location: https://github.com/polysemy-research/polysemy custom-setup- setup-depends:- Cabal- , base >=4.9 && <5- , cabal-doctest >=1.0.6 && <1.1+ setup-depends:+ Cabal >=3.0.1.0 && <3.1,+ 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+ description: Dump HTML for the core generated by GHC during compilation+ default: False+ manual: True flag error-messages- description: Provide custom error messages- manual: True- default: True+ description: Provide custom error messages+ manual: True library- exposed-modules:- Polysemy- Polysemy.Async- Polysemy.AtomicState- Polysemy.Bundle- Polysemy.Embed- Polysemy.Embed.Type- Polysemy.Error- Polysemy.Fail- Polysemy.Fail.Type- Polysemy.Final- Polysemy.Fixpoint- Polysemy.Input- Polysemy.Internal- Polysemy.Internal.Bundle- Polysemy.Internal.Combinators- Polysemy.Internal.CustomErrors- Polysemy.Internal.CustomErrors.Redefined- Polysemy.Internal.Fixpoint- Polysemy.Internal.Forklift- Polysemy.Internal.Kind- Polysemy.Internal.NonDet- Polysemy.Internal.Strategy- Polysemy.Internal.Tactics- Polysemy.Internal.TH.Common- Polysemy.Internal.TH.Effect- Polysemy.Internal.Union- Polysemy.Internal.Writer- Polysemy.IO- Polysemy.Law- Polysemy.Membership- Polysemy.NonDet- Polysemy.Output- Polysemy.Reader- Polysemy.Resource- Polysemy.State- Polysemy.State.Law- Polysemy.Tagged- Polysemy.Trace- Polysemy.View- Polysemy.Writer- other-modules:- Polysemy.Internal.PluginLookup- hs-source-dirs:- src- default-extensions: 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- , base >=4.9 && <5- , containers >=0.5 && <0.7- , first-class-families >=0.5.0.0 && <0.8- , mtl >=2.2.2 && <3- , 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- if flag(dump-core)- ghc-options: -fplugin=DumpCore -fplugin-opt=DumpCore:core-html- build-depends:- dump-core- if impl(ghc < 8.2.2)+ exposed-modules:+ Polysemy+ Polysemy.Async+ Polysemy.AtomicState+ Polysemy.Bundle+ Polysemy.Embed+ Polysemy.Embed.Type+ Polysemy.Error+ Polysemy.Fail+ Polysemy.Fail.Type+ Polysemy.Final+ Polysemy.Fixpoint+ Polysemy.Input+ Polysemy.Internal+ Polysemy.Internal.Bundle+ Polysemy.Internal.Combinators+ Polysemy.Internal.CustomErrors+ Polysemy.Internal.CustomErrors.Redefined+ Polysemy.Internal.Fixpoint+ Polysemy.Internal.Forklift+ Polysemy.Internal.Kind+ Polysemy.Internal.NonDet+ Polysemy.Internal.Strategy+ Polysemy.Internal.Tactics+ Polysemy.Internal.TH.Common+ Polysemy.Internal.TH.Effect+ Polysemy.Internal.Union+ Polysemy.Internal.Writer+ Polysemy.IO+ Polysemy.Law+ Polysemy.Membership+ Polysemy.NonDet+ Polysemy.Output+ Polysemy.Reader+ Polysemy.Resource+ Polysemy.State+ Polysemy.State.Law+ Polysemy.Tagged+ Polysemy.Trace+ Polysemy.View+ Polysemy.Writer++ hs-source-dirs: src+ other-modules:+ Polysemy.Internal.PluginLookup+ Paths_polysemy++ autogen-modules: Paths_polysemy+ default-language: Haskell2010+ default-extensions:+ DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds+ RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications+ TypeOperators TypeFamilies UnicodeSyntax++ ghc-options: -Wall 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+ QuickCheck >=2.11.3 && <3,+ async >=2.2 && <3,+ base >=4.9 && <5,+ containers >=0.5 && <0.7,+ first-class-families >=0.5.0.0 && <0.9,+ mtl >=2.2.2 && <3,+ stm ==2.*,+ syb ==0.7.*,+ template-haskell >=2.12.0.0 && <3,+ th-abstraction >=0.3.1.0 && <0.5,+ transformers >=0.5.2.0 && <0.6,+ type-errors >=0.2.0.0 && <0.3,+ 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++ if flag(dump-core)+ ghc-options: -fplugin=DumpCore -fplugin-opt=DumpCore:core-html+ build-depends: dump-core >=0.1.3.2 && <0.2++ 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+ test-suite polysemy-test- type: exitcode-stdio-1.0- main-is: Main.hs- other-modules:- AlternativeSpec- AsyncSpec- BracketSpec- DoctestSpec- ErrorSpec- FailSpec- FinalSpec- FixpointSpec- FusionSpec- HigherOrderSpec- InspectorSpec- InterceptSpec- KnownRowSpec- LawsSpec- OutputSpec- ThEffectSpec- TypeErrors- ViewSpec- WriterSpec- Paths_polysemy- hs-source-dirs:- test- default-extensions: 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- , 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- , hspec >=2.6.0 && <3- , inspection-testing >=0.4.2 && <0.5- , mtl >=2.2.2 && <3- , 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+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-tool-depends: hspec-discover:hspec-discover >=2.0+ hs-source-dirs: test+ other-modules:+ AlternativeSpec+ AsyncSpec+ BracketSpec+ DoctestSpec+ ErrorSpec+ FailSpec+ FinalSpec+ FixpointSpec+ FusionSpec+ HigherOrderSpec+ InspectorSpec+ InterceptSpec+ KnownRowSpec+ LawsSpec+ OutputSpec+ ThEffectSpec+ TypeErrors+ ViewSpec+ WriterSpec+ Paths_polysemy+ Build_doctests + autogen-modules: Build_doctests+ default-language: Haskell2010+ default-extensions:+ DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds+ RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications+ TypeOperators TypeFamilies UnicodeSyntax++ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck >=2.11.3 && <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.9,+ hspec >=2.6.0 && <3,+ inspection-testing >=0.4.2 && <0.5,+ mtl >=2.2.2 && <3,+ polysemy -any,+ stm ==2.*,+ syb ==0.7.*,+ template-haskell >=2.12.0.0 && <3,+ th-abstraction >=0.3.1.0 && <0.5,+ transformers >=0.5.2.0 && <0.6,+ type-errors >=0.2.0.0 && <0.3,+ 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+ 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+ type: exitcode-stdio-1.0+ main-is: countDown.hs+ hs-source-dirs: bench+ other-modules:+ Poly+ Paths_polysemy++ default-language: Haskell2010+ 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 >=1.5.6.2 && <1.6,+ first-class-families >=0.5.0.0 && <0.9,+ free >=5.1.3 && <5.2,+ freer-simple >=1.2.1.1 && <1.3,+ mtl >=2.2.2 && <2.3,+ polysemy -any,+ stm ==2.*,+ syb ==0.7.*,+ template-haskell >=2.12.0.0 && <3,+ th-abstraction >=0.3.1.0 && <0.5,+ transformers >=0.5.2.0 && <0.6,+ type-errors >=0.2.0.0 && <0.3,+ 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
src/Polysemy.hs view
@@ -5,23 +5,23 @@ , MemberWithError , Members - -- * Running Sem+ -- * Running Sem , run , runM , runFinal - -- * Type synonyms for user convenience+ -- * Type synonyms for user convenience , InterpreterFor - -- * 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 +30,10 @@ , raiseUnder , raiseUnder2 , raiseUnder3+ , raise2Under+ , raise3Under+ , raise_+ , subsume_ -- * Trivial Interpretation , subsume@@ -146,4 +150,3 @@ import Polysemy.Internal.Kind import Polysemy.Internal.Tactics import Polysemy.Internal.TH.Effect-
src/Polysemy/Async.hs view
@@ -7,6 +7,7 @@ -- * Actions , async , await+ , cancel -- * Helpers , sequenceConcurrently@@ -33,6 +34,7 @@ data Async m a where Async :: m a -> Async m (A.Async (Maybe a)) Await :: A.Async a -> Async m a+ Cancel :: A.Async a -> Async m () makeSem ''Async @@ -46,7 +48,6 @@ sequenceConcurrently t = traverse async t >>= traverse await {-# INLINABLE sequenceConcurrently #-} - ------------------------------------------------------------------------------ -- | A more flexible --- though less performant --- -- version of 'asyncToIOFinal'.@@ -77,9 +78,10 @@ ma <- runT a ins <- getInspectorT fa <- embed $ A.async $ lower $ asyncToIO ma- pureT $ fmap (inspect ins) fa+ pureT $ inspect ins <$> fa Await a -> pureT =<< embed (A.wait a)+ Cancel a -> pureT =<< embed (A.cancel a) ) m {-# INLINE asyncToIO #-} @@ -110,6 +112,7 @@ m' <- runS m liftS $ A.async (inspect ins <$> m') Await a -> liftS (A.wait a)+ Cancel a -> liftS (A.cancel a) {-# INLINE asyncToIOFinal #-} ------------------------------------------------------------------------------@@ -129,9 +132,10 @@ ma <- runT a ins <- getInspectorT fa <- embed $ A.async $ lower $ lowerAsync lower ma- pureT $ fmap (inspect ins) fa+ pureT $ inspect ins <$> fa Await a -> pureT =<< embed (A.wait a)+ Cancel a -> pureT =<< embed (A.cancel a) ) m {-# INLINE lowerAsync #-} {-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}
src/Polysemy/Embed.hs view
@@ -12,7 +12,6 @@ ) where import Polysemy-import Polysemy.Embed.Type (Embed (..)) ------------------------------------------------------------------------------ -- | Given a natural transform from @m1@ to @m2@
src/Polysemy/Final.hs view
@@ -182,7 +182,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/IO.hs view
@@ -69,5 +69,4 @@ $ hoist (lowerEmbedded run_m) x Right (Weaving (Embed wd) s _ y _) ->- fmap y $ fmap (<$ s) wd-+ y <$> ((<$ s) <$> wd)
src/Polysemy/Input.hs view
@@ -6,6 +6,7 @@ -- * Actions , input+ , inputs -- * Interpretations , runInputConst@@ -26,6 +27,10 @@ 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 +52,7 @@ Input -> do s <- gets uncons for_ s $ put . snd- pure $ fmap fst s+ pure $ fst <$> s ) {-# INLINE runInputList #-} @@ -58,4 +63,3 @@ runInputSem m = interpret $ \case Input -> m {-# INLINE runInputSem #-}-
src/Polysemy/Internal.hs view
@@ -1,7 +1,9 @@-{-# 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 #-}@@ -16,10 +18,16 @@ , embed , run , runM+ , raise_+ , Raise (..) , raise , raiseUnder , raiseUnder2 , raiseUnder3+ , raise2Under+ , raise3Under+ , subsume_+ , Subsume (..) , subsume , subsumeUsing , Embed (..)@@ -33,7 +41,9 @@ 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,6 +51,7 @@ import Polysemy.Embed.Type import Polysemy.Fail.Type import Polysemy.Internal.Fixpoint+import Polysemy.Internal.Kind import Polysemy.Internal.NonDet import Polysemy.Internal.PluginLookup import Polysemy.Internal.Union@@ -249,7 +260,7 @@ 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 #-} @@ -260,11 +271,18 @@ 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@@ -292,7 +310,7 @@ -- | 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 #-} @@ -315,21 +333,50 @@ ------------------------------------------------------------------------------+-- | 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 +397,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 +407,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 +417,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 +495,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 +519,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@@ -436,6 +539,7 @@ send = liftSem . inj {-# INLINE[3] send #-} + ------------------------------------------------------------------------------ -- | Embed an effect into a 'Sem', given an explicit proof -- that the effect exists in @r@.@@ -474,6 +578,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,8 +589,9 @@ -- teletypeToIO :: 'Member' (Embed IO) r -- => 'InterpreterFor' Teletype r -- @-type InterpreterFor e r = forall a. Sem (e ': r) a -> Sem r a+type InterpreterFor e r = ∀ 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@@ -547,4 +653,3 @@ -> m (f z) f .@@ g = f . g f infixl 8 .@@-
+ 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/Combinators.hs view
@@ -45,10 +45,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 +59,7 @@ -- transforming it into other effects inside of @r@. interpret :: FirstOrder e "interpret"- => (∀ 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 (e ': r) a@@ -73,7 +75,7 @@ -- -- See the notes on 'Tactical' for how to use this function. interpretH- :: (∀ 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 (e ': r) a@@ -86,7 +88,6 @@ pure $ y a {-# INLINE interpretH #-} - ------------------------------------------------------------------------------ -- | A highly-performant combinator for interpreting an effect statefully. See -- 'stateful' for a more user-friendly variety of this function.@@ -106,7 +107,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 +129,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,7 +161,8 @@ -- 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@@ -182,7 +184,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 +199,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@@ -215,7 +218,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,7 +233,8 @@ -- 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@@ -247,7 +252,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 +268,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 +308,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 +333,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 +342,7 @@ 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+ usingSem k $ y <$> runTactics s (raise . d) v (f e) Nothing -> k $ hoist (interceptUsingH pr f) u {-# INLINE interceptUsingH #-} @@ -346,13 +353,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 +371,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/Strategy.hs view
@@ -100,7 +100,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 +128,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
@@ -172,7 +172,7 @@ -- 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
src/Polysemy/Internal/TH/Effect.hs view
@@ -161,7 +161,7 @@ -- @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 pure [ PragmaD $ InlineP (cliFunName cli) Inlinable ConLike AllPhases
src/Polysemy/Internal/Union.hs view
@@ -47,6 +47,7 @@ import Data.Kind import Data.Typeable import Polysemy.Internal.Kind+import {-# SOURCE #-} Polysemy.Internal #ifndef NO_ERROR_MESSAGES import Polysemy.Internal.CustomErrors@@ -56,7 +57,7 @@ ------------------------------------------------------------------------------ -- | 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,38 +66,37 @@ -> Weaving e m a -> Union r m a -instance Functor (Union r m) where- fmap f (Union w t) = Union w $ fmap f t+instance Functor (Union r mWoven) where+ fmap f (Union w t) = Union w $ f <$> t {-# INLINE fmap #-} -data Weaving e m a where+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@@ -105,14 +105,15 @@ 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)@@ -120,13 +121,11 @@ 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+hoist f' (Union w (Weaving e s nt f v)) =+ Union w $ Weaving e s (f' . nt) f v {-# INLINE hoist #-} @@ -266,14 +265,20 @@ -- | Retrieve the last effect in a 'Union'. extract :: Union '[e] m a -> Weaving e m a extract (Union Here a) = a+#if __GLASGOW_HASKELL__ < 808 extract (Union (There g) _) = case g of {}+#endif {-# INLINE extract #-} ------------------------------------------------------------------------------ -- | An empty union contains nothing, so this function is uncallable. absurdU :: Union '[] m a -> b+#if __GLASGOW_HASKELL__ < 808 absurdU (Union pr _) = case pr of {}+#else+absurdU = \case {}+#endif ------------------------------------------------------------------------------@@ -286,24 +291,27 @@ ------------------------------------------------------------------------------ -- | 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)+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) {-# INLINE 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)+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) {-# INLINE injUsing #-} ------------------------------------------------------------------------------
src/Polysemy/Internal/Writer.hs view
@@ -59,7 +59,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 #-}
src/Polysemy/NonDet.hs view
@@ -41,7 +41,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/Resource.hs view
@@ -6,6 +6,7 @@ -- * Actions , bracket+ , bracket_ , bracketOnError , finally , onException@@ -48,6 +49,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 TODO+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 +74,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) ------------------------------------------------------------------------------
src/Polysemy/State.hs view
@@ -55,7 +55,7 @@ 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 #-} @@ -251,12 +251,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 +268,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/Writer.hs view
@@ -45,7 +45,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 +75,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 +112,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/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 ()