diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@

-Polysemy +Polysemy

 

@@ -11,84 +11,75 @@ [![Hackage](https://img.shields.io/hackage/v/polysemy-plugin.svg?logo=haskell&label=polysemy-plugin)](https://hackage.haskell.org/package/polysemy-plugin) [![Zulip chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](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[1](#fn1) can optimize - away the entire abstraction at compile time. - -1: 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 diff --git a/bench/Poly.hs b/bench/Poly.hs deleted file mode 100644 --- a/bench/Poly.hs +++ /dev/null @@ -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 - ) - diff --git a/bench/countDown.hs b/bench/countDown.hs deleted file mode 100644 --- a/bench/countDown.hs +++ /dev/null @@ -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 - ] - ] diff --git a/polysemy.cabal b/polysemy.cabal --- a/polysemy.cabal +++ b/polysemy.cabal @@ -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 +version: 1.9.2.0 +synopsis: Higher-order, low-boilerplate free monads. +description: Please see the README on GitHub at 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 diff --git a/src/Polysemy.hs b/src/Polysemy.hs --- a/src/Polysemy.hs +++ b/src/Polysemy.hs @@ -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 - diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs --- a/src/Polysemy/Async.hs +++ b/src/Polysemy/Async.hs @@ -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 . --- --- 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" #-} diff --git a/src/Polysemy/AtomicState.hs b/src/Polysemy/AtomicState.hs --- a/src/Polysemy/AtomicState.hs +++ b/src/Polysemy/AtomicState.hs @@ -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 #-} diff --git a/src/Polysemy/Bundle.hs b/src/Polysemy/Bundle.hs --- a/src/Polysemy/Bundle.hs +++ b/src/Polysemy/Bundle.hs @@ -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 #-} ------------------------------------------------------------------------------ diff --git a/src/Polysemy/Embed.hs b/src/Polysemy/Embed.hs --- a/src/Polysemy/Embed.hs +++ b/src/Polysemy/Embed.hs @@ -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@ diff --git a/src/Polysemy/Embed/Type.hs b/src/Polysemy/Embed/Type.hs --- a/src/Polysemy/Embed/Type.hs +++ b/src/Polysemy/Embed/Type.hs @@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Embed' effect module Polysemy.Embed.Type ( -- * Effect Embed (..) diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs --- a/src/Polysemy/Error.hs +++ b/src/Polysemy/Error.hs @@ -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 #-} diff --git a/src/Polysemy/Fail.hs b/src/Polysemy/Fail.hs --- a/src/Polysemy/Fail.hs +++ b/src/Polysemy/Fail.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: 'Fail' interpreters module Polysemy.Fail ( -- * Effect Fail(..) diff --git a/src/Polysemy/Fail/Type.hs b/src/Polysemy/Fail/Type.hs --- a/src/Polysemy/Fail/Type.hs +++ b/src/Polysemy/Fail/Type.hs @@ -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 diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs --- a/src/Polysemy/Final.hs +++ b/src/Polysemy/Final.hs @@ -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 diff --git a/src/Polysemy/Fixpoint.hs b/src/Polysemy/Fixpoint.hs --- a/src/Polysemy/Fixpoint.hs +++ b/src/Polysemy/Fixpoint.hs @@ -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" #-} diff --git a/src/Polysemy/IO.hs b/src/Polysemy/IO.hs --- a/src/Polysemy/IO.hs +++ b/src/Polysemy/IO.hs @@ -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 diff --git a/src/Polysemy/Input.hs b/src/Polysemy/Input.hs --- a/src/Polysemy/Input.hs +++ b/src/Polysemy/Input.hs @@ -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 #-} - diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs --- a/src/Polysemy/Internal.hs +++ b/src/Polysemy/Internal.hs @@ -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 --- . --- --- 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 diff --git a/src/Polysemy/Internal.hs-boot b/src/Polysemy/Internal.hs-boot new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal.hs-boot @@ -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) diff --git a/src/Polysemy/Internal/Bundle.hs b/src/Polysemy/Internal/Bundle.hs --- a/src/Polysemy/Internal/Bundle.hs +++ b/src/Polysemy/Internal/Bundle.hs @@ -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 #-} - diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs --- a/src/Polysemy/Internal/Combinators.hs +++ b/src/Polysemy/Internal/Combinators.hs @@ -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) diff --git a/src/Polysemy/Internal/CustomErrors.hs b/src/Polysemy/Internal/CustomErrors.hs --- a/src/Polysemy/Internal/CustomErrors.hs +++ b/src/Polysemy/Internal/CustomErrors.hs @@ -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 diff --git a/src/Polysemy/Internal/CustomErrors/Redefined.hs b/src/Polysemy/Internal/CustomErrors/Redefined.hs --- a/src/Polysemy/Internal/CustomErrors/Redefined.hs +++ b/src/Polysemy/Internal/CustomErrors/Redefined.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_HADDOCK prune #-} ------------------------------------------------------------------------------ -- | This code is copied verbatim from 'Type.Errors' due to limitations in the diff --git a/src/Polysemy/Internal/Fixpoint.hs b/src/Polysemy/Internal/Fixpoint.hs --- a/src/Polysemy/Internal/Fixpoint.hs +++ b/src/Polysemy/Internal/Fixpoint.hs @@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Fixpoint' effect module Polysemy.Internal.Fixpoint where ------------------------------------------------------------------------------ diff --git a/src/Polysemy/Internal/Forklift.hs b/src/Polysemy/Internal/Forklift.hs deleted file mode 100644 --- a/src/Polysemy/Internal/Forklift.hs +++ /dev/null @@ -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 - diff --git a/src/Polysemy/Internal/Index.hs b/src/Polysemy/Internal/Index.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Index.hs @@ -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." diff --git a/src/Polysemy/Internal/Kind.hs b/src/Polysemy/Internal/Kind.hs --- a/src/Polysemy/Internal/Kind.hs +++ b/src/Polysemy/Internal/Kind.hs @@ -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 diff --git a/src/Polysemy/Internal/NonDet.hs b/src/Polysemy/Internal/NonDet.hs --- a/src/Polysemy/Internal/NonDet.hs +++ b/src/Polysemy/Internal/NonDet.hs @@ -4,6 +4,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The 'NonDet' effect module Polysemy.Internal.NonDet where diff --git a/src/Polysemy/Internal/Scoped.hs b/src/Polysemy/Internal/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Scoped.hs @@ -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 +-- , 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 . +-- 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 #-} + diff --git a/src/Polysemy/Internal/Sing.hs b/src/Polysemy/Internal/Sing.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Sing.hs @@ -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 #-} diff --git a/src/Polysemy/Internal/Strategy.hs b/src/Polysemy/Internal/Strategy.hs --- a/src/Polysemy/Internal/Strategy.hs +++ b/src/Polysemy/Internal/Strategy.hs @@ -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 #-} - diff --git a/src/Polysemy/Internal/TH/Common.hs b/src/Polysemy/Internal/TH/Common.hs --- a/src/Polysemy/Internal/TH/Common.hs +++ b/src/Polysemy/Internal/TH/Common.hs @@ -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 diff --git a/src/Polysemy/Internal/TH/Effect.hs b/src/Polysemy/Internal/TH/Effect.hs --- a/src/Polysemy/Internal/TH/Effect.hs +++ b/src/Polysemy/Internal/TH/Effect.hs @@ -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) diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs --- a/src/Polysemy/Internal/Tactics.hs +++ b/src/Polysemy/Internal/Tactics.hs @@ -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 #-} diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs --- a/src/Polysemy/Internal/Union.hs +++ b/src/Polysemy/Internal/Union.hs @@ -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 --- . --- --- @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 #-} diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs --- a/src/Polysemy/Internal/Writer.hs +++ b/src/Polysemy/Internal/Writer.hs @@ -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 #-} diff --git a/src/Polysemy/Law.hs b/src/Polysemy/Law.hs deleted file mode 100644 --- a/src/Polysemy/Law.hs +++ /dev/null @@ -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 - diff --git a/src/Polysemy/Membership.hs b/src/Polysemy/Membership.hs --- a/src/Polysemy/Membership.hs +++ b/src/Polysemy/Membership.hs @@ -1,3 +1,4 @@ +-- | Description: Reexports of membership related functionality module Polysemy.Membership ( -- * Witnesses ElemOf (..) diff --git a/src/Polysemy/NonDet.hs b/src/Polysemy/NonDet.hs --- a/src/Polysemy/NonDet.hs +++ b/src/Polysemy/NonDet.hs @@ -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 $ diff --git a/src/Polysemy/Opaque.hs b/src/Polysemy/Opaque.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Opaque.hs @@ -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 #-} diff --git a/src/Polysemy/Output.hs b/src/Polysemy/Output.hs --- a/src/Polysemy/Output.hs +++ b/src/Polysemy/Output.hs @@ -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 diff --git a/src/Polysemy/Reader.hs b/src/Polysemy/Reader.hs --- a/src/Polysemy/Reader.hs +++ b/src/Polysemy/Reader.hs @@ -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 #-} diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs --- a/src/Polysemy/Resource.hs +++ b/src/Polysemy/Resource.hs @@ -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 #-} diff --git a/src/Polysemy/Scoped.hs b/src/Polysemy/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Scoped.hs @@ -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 #-} diff --git a/src/Polysemy/State.hs b/src/Polysemy/State.hs --- a/src/Polysemy/State.hs +++ b/src/Polysemy/State.hs @@ -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 #-} - diff --git a/src/Polysemy/State/Law.hs b/src/Polysemy/State/Law.hs deleted file mode 100644 --- a/src/Polysemy/State/Law.hs +++ /dev/null @@ -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) - diff --git a/src/Polysemy/Tagged.hs b/src/Polysemy/Tagged.hs --- a/src/Polysemy/Tagged.hs +++ b/src/Polysemy/Tagged.hs @@ -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 diff --git a/src/Polysemy/Trace.hs b/src/Polysemy/Trace.hs --- a/src/Polysemy/Trace.hs +++ b/src/Polysemy/Trace.hs @@ -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" #-} ------------------------------------------------------------------------------ diff --git a/src/Polysemy/View.hs b/src/Polysemy/View.hs deleted file mode 100644 --- a/src/Polysemy/View.hs +++ /dev/null @@ -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) - diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs --- a/src/Polysemy/Writer.hs +++ b/src/Polysemy/Writer.hs @@ -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 #-} ----------------------------------------------------------------------------- diff --git a/test/AsyncSpec.hs b/test/AsyncSpec.hs deleted file mode 100644 --- a/test/AsyncSpec.hs +++ /dev/null @@ -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" diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs --- a/test/BracketSpec.hs +++ b/test/BracketSpec.hs @@ -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 diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -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 ()) diff --git a/test/FixpointSpec.hs b/test/FixpointSpec.hs --- a/test/FixpointSpec.hs +++ b/test/FixpointSpec.hs @@ -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 () diff --git a/test/FusionSpec.hs b/test/FusionSpec.hs --- a/test/FusionSpec.hs +++ b/test/FusionSpec.hs @@ -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 diff --git a/test/InspectorSpec.hs b/test/InspectorSpec.hs deleted file mode 100644 --- a/test/InspectorSpec.hs +++ /dev/null @@ -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 - diff --git a/test/LawsSpec.hs b/test/LawsSpec.hs deleted file mode 100644 --- a/test/LawsSpec.hs +++ /dev/null @@ -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 - diff --git a/test/ScopedSpec.hs b/test/ScopedSpec.hs new file mode 100644 --- /dev/null +++ b/test/ScopedSpec.hs @@ -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 diff --git a/test/TacticsSpec.hs b/test/TacticsSpec.hs new file mode 100644 --- /dev/null +++ b/test/TacticsSpec.hs @@ -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 diff --git a/test/TypeErrors.hs b/test/TypeErrors.hs --- a/test/TypeErrors.hs +++ b/test/TypeErrors.hs @@ -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 = () diff --git a/test/ViewSpec.hs b/test/ViewSpec.hs deleted file mode 100644 --- a/test/ViewSpec.hs +++ /dev/null @@ -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)) -