polysemy 1.7.1.0 → 1.9.2.0
raw patch · 58 files changed
Files
- ChangeLog.md +56/−0
- README.md +5/−2
- bench/Poly.hs +0/−64
- bench/countDown.hs +0/−133
- polysemy.cabal +22/−81
- src/Polysemy.hs +7/−8
- src/Polysemy/Async.hs +4/−73
- src/Polysemy/AtomicState.hs +8/−0
- src/Polysemy/Bundle.hs +2/−0
- src/Polysemy/Embed.hs +1/−0
- src/Polysemy/Embed/Type.hs +1/−0
- src/Polysemy/Error.hs +54/−80
- src/Polysemy/Fail.hs +1/−0
- src/Polysemy/Fail/Type.hs +8/−0
- src/Polysemy/Final.hs +3/−0
- src/Polysemy/Fixpoint.hs +1/−42
- src/Polysemy/IO.hs +2/−30
- src/Polysemy/Input.hs +2/−0
- src/Polysemy/Internal.hs +34/−67
- src/Polysemy/Internal/Bundle.hs +6/−0
- src/Polysemy/Internal/Combinators.hs +15/−0
- src/Polysemy/Internal/CustomErrors.hs +5/−3
- src/Polysemy/Internal/CustomErrors/Redefined.hs +1/−0
- src/Polysemy/Internal/Fixpoint.hs +1/−0
- src/Polysemy/Internal/Forklift.hs +0/−87
- src/Polysemy/Internal/Index.hs +2/−1
- src/Polysemy/Internal/Kind.hs +3/−0
- src/Polysemy/Internal/NonDet.hs +1/−0
- src/Polysemy/Internal/Scoped.hs +159/−0
- src/Polysemy/Internal/Sing.hs +9/−1
- src/Polysemy/Internal/Strategy.hs +4/−1
- src/Polysemy/Internal/TH/Common.hs +7/−4
- src/Polysemy/Internal/TH/Effect.hs +25/−12
- src/Polysemy/Internal/Tactics.hs +5/−0
- src/Polysemy/Internal/Union.hs +36/−26
- src/Polysemy/Internal/Writer.hs +10/−5
- src/Polysemy/Law.hs +0/−197
- src/Polysemy/Membership.hs +1/−0
- src/Polysemy/NonDet.hs +1/−0
- src/Polysemy/Opaque.hs +54/−0
- src/Polysemy/Output.hs +2/−0
- src/Polysemy/Reader.hs +5/−0
- src/Polysemy/Resource.hs +3/−107
- src/Polysemy/Scoped.hs +329/−0
- src/Polysemy/State.hs +15/−8
- src/Polysemy/State/Law.hs +0/−59
- src/Polysemy/Tagged.hs +3/−1
- src/Polysemy/Trace.hs +2/−0
- src/Polysemy/View.hs +0/−76
- src/Polysemy/Writer.hs +1/−0
- test/AsyncSpec.hs +0/−47
- test/BracketSpec.hs +0/−16
- test/ErrorSpec.hs +19/−1
- test/InspectorSpec.hs +0/−77
- test/LawsSpec.hs +0/−20
- test/ScopedSpec.hs +117/−0
- test/TypeErrors.hs +0/−15
- test/ViewSpec.hs +0/−40
ChangeLog.md view
@@ -2,9 +2,65 @@ ## 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)
README.md view
@@ -57,9 +57,12 @@ - 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, the author, gave a talk on some of the+- 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/)@@ -349,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://nixos.wiki/wiki/Flakes+[flake]: https://wiki.nixos.org/wiki/Flakes
− bench/Poly.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}--{-# OPTIONS_GHC -fwarn-all-missed-specializations #-}--module Poly where--import Polysemy-import Polysemy.Error-import Polysemy.Resource-import Polysemy.State-import Polysemy.Input-import Polysemy.Output---slowBeforeSpecialization :: Member (State Int) r => Sem r Int-slowBeforeSpecialization = do- n <- get- if n <= 0- then pure n- else do- put $ n - 1- slowBeforeSpecialization--{-# SPECIALIZE slowBeforeSpecialization :: Sem '[State Int] Int #-}---countDown :: Int -> Int-countDown s =- fst . run . runState s $ slowBeforeSpecialization--prog- :: Sem '[ State Bool- , Error Bool- , Resource- , Embed IO- ] Bool-prog = catch @Bool (throw True) (pure . not)--zoinks :: IO (Either Bool Bool)-zoinks = fmap (fmap snd)- . (runM .@ lowerResource .@@ lowerError)- . runState False- $ prog--data Console m a where- ReadLine :: Console m String- WriteLine :: String -> Console m ()--makeSem ''Console--runConsoleBoring :: [String] -> Sem (Console ': r) a -> Sem r ([String], a)-runConsoleBoring inputs- = runOutputMonoid (:[])- . runInputList inputs- . reinterpret2- (\case- ReadLine -> maybe "" id <$> input- WriteLine msg -> output msg- )-
− bench/countDown.hs
@@ -1,133 +0,0 @@-{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-}-module Main (main) where--import Control.Monad (replicateM_)--import qualified Control.Monad.Except as MTL-import qualified Control.Monad.State as MTL-import qualified Control.Monad.Free as Free--import Criterion (bench, bgroup, whnf)-import Criterion.Main (defaultMain)--import Control.Monad.Freer (Member, Eff, run, send)-import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton)-import Control.Monad.Freer.Error (runError, throwError)-import Control.Monad.Freer.State (get, put, runState)--import qualified Poly as P----------------------------------------------------------------------------------- -- State Benchmarks -------------------------------------------------------------------------------------oneGet :: Int -> (Int, Int)-oneGet n = run (runState n get)--oneGetMTL :: Int -> (Int, Int)-oneGetMTL = MTL.runState MTL.get--countDown :: Int -> (Int, Int)-countDown start = run (runState start go)- where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)--countDownMTL :: Int -> (Int, Int)-countDownMTL = MTL.runState go- where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)----------------------------------------------------------------------------------- -- Exception + State ------------------------------------------------------------------------------------countDownExc :: Int -> Either String (Int,Int)-countDownExc start = run $ runError (runState start go)- where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)--countDownExcMTL :: Int -> Either String (Int,Int)-countDownExcMTL = MTL.runStateT go- where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)----------------------------------------------------------------------------------- -- Freer: Interpreter ------------------------------------------------------------------------------------data Http out where- Open :: String -> Http ()- Close :: Http ()- Post :: String -> Http String- Get :: Http String--open' :: Member Http r => String -> Eff r ()-open' = send . Open--close' :: Member Http r => Eff r ()-close' = send Close--post' :: Member Http r => String -> Eff r String-post' = send . Post--get' :: Member Http r => Eff r String-get' = send Get--runHttp :: Eff (Http ': r) w -> Eff r w-runHttp (Val x) = pure x-runHttp (E u q) = case decomp u of- Right (Open _) -> runHttp (qApp q ())- Right Close -> runHttp (qApp q ())- Right (Post d) -> runHttp (qApp q d)- Right Get -> runHttp (qApp q "")- Left u' -> E u' (tsingleton (runHttp . qApp q ))----------------------------------------------------------------------------------- -- Free: Interpreter ------------------------------------------------------------------------------------data FHttpT x- = FOpen String x- | FClose x- | FPost String (String -> x)- | FGet (String -> x)- deriving Functor--type FHttp = Free.Free FHttpT--fopen' :: String -> FHttp ()-fopen' s = Free.liftF $ FOpen s ()--fclose' :: FHttp ()-fclose' = Free.liftF $ FClose ()--fpost' :: String -> FHttp String-fpost' s = Free.liftF $ FPost s id--fget' :: FHttp String-fget' = Free.liftF $ FGet id--runFHttp :: FHttp a -> Maybe a-runFHttp (Free.Pure x) = pure x-runFHttp (Free.Free (FOpen _ n)) = runFHttp n-runFHttp (Free.Free (FClose n)) = runFHttp n-runFHttp (Free.Free (FPost s n)) = pure s >>= runFHttp . n-runFHttp (Free.Free (FGet n)) = pure "" >>= runFHttp . n----------------------------------------------------------------------------------- -- Benchmark Suite ------------------------------------------------------------------------------------prog :: Member Http r => Eff r ()-prog = open' "cats" >> get' >> post' "cats" >> close'--prog' :: FHttp ()-prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose'--p :: Member Http r => Int -> Eff r ()-p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'--p' :: Int -> FHttp ()-p' count = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose'--main :: IO ()-main =- defaultMain [- bgroup "Countdown Bench" [- bench "discount" $ whnf P.countDown 10000- , bench "freer-simple" $ whnf countDown 10000- , bench "mtl" $ whnf countDownMTL 10000- ]- ]
polysemy.cabal view
@@ -1,19 +1,19 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: polysemy-version: 1.7.1.0+version: 1.9.2.0 synopsis: Higher-order, low-boilerplate free monads. description: Please see the README on GitHub at <https://github.com/polysemy-research/polysemy#readme> category: Language homepage: https://github.com/polysemy-research/polysemy#readme bug-reports: https://github.com/polysemy-research/polysemy/issues author: Sandy Maguire-maintainer: sandy@sandymaguire.me-copyright: 2019-2021 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@@ -27,15 +27,10 @@ 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- library exposed-modules: Polysemy@@ -56,10 +51,10 @@ 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@@ -68,17 +63,16 @@ 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@@ -88,6 +82,7 @@ hs-source-dirs: src default-extensions:+ BlockArguments DataKinds DeriveFunctor FlexibleContexts@@ -103,8 +98,7 @@ 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.9@@ -112,29 +106,24 @@ , stm ==2.* , syb ==0.7.* , template-haskell >=2.12.0.0 && <3- , th-abstraction >=0.3.1.0 && <0.5- , transformers >=0.5.2.0 && <0.6+ , th-abstraction >=0.3.1.0 && <0.8+ , transformers >=0.5.2.0 && <0.7 , type-errors >=0.2.0.0 , 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 if impl(ghc < 8.2.2) build-depends: unsupported-ghc-version >1 && <1- default-language: Haskell2010 test-suite polysemy-test type: exitcode-stdio-1.0 main-is: Main.hs other-modules: AlternativeSpec- AsyncSpec BracketSpec DoctestSpec ErrorSpec@@ -143,23 +132,23 @@ 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:+ BlockArguments DataKinds DeriveFunctor FlexibleContexts@@ -174,74 +163,26 @@ 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.19+ , 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.* , syb ==0.7.* , template-haskell >=2.12.0.0 && <3- , th-abstraction >=0.3.1.0 && <0.5- , transformers >=0.5.2.0 && <0.6+ , th-abstraction >=0.3.1.0 && <0.8+ , transformers >=0.5.2.0 && <0.7 , type-errors >=0.2.0.0 , 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.9- , free- , freer-simple- , mtl- , polysemy- , stm ==2.*- , syb ==0.7.*- , template-haskell >=2.12.0.0 && <3- , th-abstraction >=0.3.1.0 && <0.5- , transformers >=0.5.2.0 && <0.6- , type-errors >=0.2.0.0- , unagi-chan >=0.4.0.0 && <0.5 if impl(ghc < 8.6) default-extensions: MonadFailDesugaring TypeInType- default-language: Haskell2010
src/Polysemy.hs view
@@ -1,3 +1,4 @@+-- | Description: Polysemy is a library for writing high-power, low-boilerplate domain specific languages module Polysemy ( -- * Core Types Sem ()@@ -68,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." @@ -95,6 +101,7 @@ -- @ -- -- As you see, in the smart constructors, the @m@ parameter has become @'Sem' r@.+ , send , makeSem , makeSem_ @@ -114,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@@ -149,7 +149,6 @@ import Polysemy.Final import Polysemy.Internal import Polysemy.Internal.Combinators-import Polysemy.Internal.Forklift import Polysemy.Internal.Kind import Polysemy.Internal.Tactics import Polysemy.Internal.TH.Effect
src/Polysemy/Async.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The effect 'Async', providing an interface to "Control.Concurrent.Async" module Polysemy.Async ( -- * Effect Async (..)@@ -13,9 +14,7 @@ , sequenceConcurrently -- * Interpretations- , asyncToIO , asyncToIOFinal- , lowerAsync ) where import qualified Control.Concurrent.Async as A@@ -32,8 +31,11 @@ -- -- @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@@ -49,59 +51,12 @@ {-# INLINABLE sequenceConcurrently #-} --------------------------------------------------------------------------------- | A more flexible --- though less performant ------ version of 'asyncToIOFinal'.------ This function is capable of running 'Async' effects anywhere within an--- effect stack, without relying on 'Final' to lower it into 'IO'.--- Notably, this means that 'Polysemy.State.State' effects will be consistent--- in the presence of 'Async'.------ 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions--- of other effects interpreted after 'Async'.--- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.------ Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters--- after the interpreter for 'Async'.--- (Pure interpreters are interpreters that aren't expressed in terms of--- another effect or monad; for example, 'Polysemy.State.runState'.)------ @since 1.0.0.0-asyncToIO- :: Member (Embed IO) r- => Sem (Async ': r) a- -> Sem r a-asyncToIO m = withLowerToIO $ \lower _ -> lower $- interpretH- ( \case- Async a -> do- ma <- runT a- ins <- getInspectorT- fa <- embed $ A.async $ lower $ asyncToIO ma- pureT $ inspect ins <$> fa-- Await a -> pureT =<< embed (A.wait a)- Cancel a -> pureT =<< embed (A.cancel 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@@ -115,27 +70,3 @@ 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 $ inspect ins <$> fa-- Await a -> pureT =<< embed (A.wait a)- Cancel a -> pureT =<< embed (A.cancel a)- ) m-{-# INLINE lowerAsync #-}-{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}
src/Polysemy/AtomicState.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-}++-- | Description: The 'AtomicState' effect module Polysemy.AtomicState ( -- * Effect AtomicState (..)@@ -36,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@@ -78,6 +82,8 @@ return a {-# INLINE atomicState' #-} +-----------------------------------------------------------------------------+-- | Replace the state with the given value. atomicPut :: Member (AtomicState s) r => s -> Sem r ()@@ -86,6 +92,8 @@ return () {-# INLINE atomicPut #-} +-----------------------------------------------------------------------------+-- | Modify the state lazily. atomicModify :: Member (AtomicState s) r => (s -> s) -> Sem r ()
src/Polysemy/Bundle.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}++-- | Description: The 'Bundle' effect for bundling effects module Polysemy.Bundle ( -- * Effect Bundle (..)
src/Polysemy/Embed.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for the effect 'Embed' module Polysemy.Embed ( -- * Effect Embed (..)
src/Polysemy/Embed/Type.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Embed' effect module Polysemy.Embed.Type ( -- * Effect Embed (..)
src/Polysemy/Error.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK prune #-} +-- | Description: The effect 'Error' and its interpreters module Polysemy.Error ( -- * Effect Error (..)@@ -23,22 +25,30 @@ , runError , mapError , errorToIOFinal- , lowerError ) where -import qualified Control.Exception as X+import qualified Control.Exception as X import Control.Monad import qualified Control.Monad.Trans.Except as E-import Data.Bifunctor (first)-import Data.Typeable+import Data.Unique (Unique, hashUnique, newUnique)+import GHC.Exts (Any) import Polysemy import Polysemy.Final import Polysemy.Internal import Polysemy.Internal.Union+import Unsafe.Coerce (unsafeCoerce) +------------------------------------------------------------------------------+-- | This effect abstracts the throwing and catching of errors, leaving+-- it up to the interpreter whether to use exceptions or monad transformers+-- like 'E.ExceptT' to perform the short-circuiting mechanism. data Error e m a where+ -- | Short-circuit the current program using the given error value. Throw :: e -> Error e m a+ -- | Recover from an error that might have been thrown in the higher-order+ -- action given by the first argument by passing the error to the handler+ -- given by the second argument. Catch :: ∀ e m a. m a -> (e -> m a) -> Error e m a makeSem ''Error@@ -46,7 +56,7 @@ hush :: Either e a -> Maybe a hush (Right a) = Just a-hush (Left _) = Nothing+hush (Left _) = Nothing ------------------------------------------------------------------------------@@ -57,7 +67,7 @@ :: Member (Error e) r => Either e a -> Sem r a-fromEither (Left e) = throw e+fromEither (Left e) = throw e fromEither (Right a) = pure a {-# INLINABLE fromEither #-} @@ -105,7 +115,7 @@ fromExceptionVia f m = do r <- embed $ X.try m case r of- Left e -> throw $ f e+ Left e -> throw $ f e Right a -> pure a {-# INLINABLE fromExceptionVia #-} @@ -139,7 +149,7 @@ s <- getInitialStateS pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s)) case r of- Left e -> throw $ f e+ Left e -> throw $ f e Right a -> pure a {-# INLINABLE fromExceptionSemVia #-} @@ -152,16 +162,16 @@ {-# INLINABLE note #-} --------------------------------------------------------------------------------- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@) --- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type --- @e@ was @'throw'@n and its value is @ex@. +-- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@)+-- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type+-- @e@ was @'throw'@n and its value is @ex@. try :: Member (Error e) r => Sem r a -> Sem r (Either e a) try m = catch (Right <$> m) (return . Left) {-# INLINABLE try #-} ------------------------------------------------------------------------------ -- | A variant of @'try'@ that takes an exception predicate to select which exceptions--- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, +-- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, -- it is re-@'throw'@n. tryJust :: Member (Error e) r => (e -> Maybe b) -> Sem r a -> Sem r (Either b a) tryJust f m = do@@ -170,14 +180,14 @@ Right v -> return (Right v) Left e -> case f e of Nothing -> throw e- Just b -> return $ Left b+ Just b -> return $ Left b {-# INLINABLE tryJust #-} --------------------------------------------------------------------------------- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument --- which is an exception predicate, a function which selects which type of exceptions +-- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument+-- which is an exception predicate, a function which selects which type of exceptions -- we're interested in.-catchJust :: Member (Error e) r +catchJust :: Member (Error e) r => (e -> Maybe b) -- ^ Predicate to select exceptions -> Sem r a -- ^ Computation to run -> (b -> Sem r a) -- ^ Handler@@ -186,7 +196,7 @@ where handler e = case ef e of Nothing -> throw e- Just b -> bf b+ Just b -> bf b {-# INLINABLE catchJust #-} ------------------------------------------------------------------------------@@ -244,14 +254,24 @@ {-# INLINE mapError #-} -newtype WrappedExc e = WrappedExc { unwrapExc :: e }- deriving (Typeable)+data WrappedExc = WrappedExc !Unique Any -instance Typeable e => Show (WrappedExc e) where- show = mappend "WrappedExc: " . show . typeRep+instance Show WrappedExc where+ show (WrappedExc uid _) =+ "errorToIOFinal: Escaped opaque exception. Unique hash is: " <>+ show (hashUnique uid) <> "This should only happen if the computation that " <>+ "threw the exception was somehow invoked outside of the argument of 'errorToIOFinal'; " <>+ "for example, if you 'async' an exceptional computation inside of the argument " <>+ "provided to 'errorToIOFinal', and then 'await' on it *outside* of the argument " <>+ "provided to 'errorToIOFinal'. If that or any similar shenanigans seems unlikely, " <>+ "please open an issue on the GitHub repository." -instance (Typeable e) => X.Exception (WrappedExc e)+instance X.Exception WrappedExc +catchWithUid :: forall e a. Unique -> IO a -> (e -> IO a) -> IO a+catchWithUid uid m h = X.catch m $ \exc@(WrappedExc uid' e) ->+ if uid == uid' then h (unsafeCoerce e) else X.throwIO exc+{-# INLINE catchWithUid #-} ------------------------------------------------------------------------------ -- | Run an 'Error' effect as an 'IO' 'X.Exception' through final 'IO'. This@@ -263,77 +283,31 @@ -- -- @since 1.2.0.0 errorToIOFinal- :: ( Typeable e- , Member (Final IO) r+ :: forall e r a+ . ( Member (Final IO) r ) => Sem (Error e ': r) a -> Sem r (Either e a) errorToIOFinal sem = withStrategicToFinal @IO $ do- m' <- runS (runErrorAsExcFinal sem)+ m' <- bindS (`runErrorAsExcFinal` sem) s <- getInitialStateS- pure $- either- ((<$ s) . Left . unwrapExc)- (fmap Right)- <$> X.try m'+ pure $ do+ uid <- newUnique+ catchWithUid @e uid (fmap Right <$> m' (uid <$ s)) (pure . (<$ s) . Left) {-# INLINE errorToIOFinal #-} runErrorAsExcFinal :: forall e r a- . ( Typeable e- , Member (Final IO) r+ . ( Member (Final IO) r )- => Sem (Error e ': r) a+ => Unique+ -> Sem (Error e ': r) a -> Sem r a-runErrorAsExcFinal = interpretFinal $ \case- Throw e -> pure $ X.throwIO $ WrappedExc e+runErrorAsExcFinal uid = interpretFinal $ \case+ Throw e -> pure $ X.throwIO $ WrappedExc uid (unsafeCoerce e) Catch m h -> do m' <- runS m h' <- bindS h s <- getInitialStateS- pure $ X.catch m' $ \(se :: WrappedExc e) ->- h' (unwrapExc se <$ s)+ pure $ catchWithUid uid m' $ \e -> h' (e <$ s) {-# INLINE runErrorAsExcFinal #-}----------------------------------------------------------------------------------- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is--- significantly faster than 'runError', at the cost of being less flexible.------ @since 1.0.0.0-lowerError- :: ( Typeable e- , Member (Embed IO) r- )- => (∀ x. Sem r x -> IO x)- -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is- -- likely some combination of 'runM' and other interpreters composed via- -- '.@'.- -> Sem (Error e ': r) a- -> Sem r (Either e a)-lowerError lower- = embed- . fmap (first unwrapExc)- . X.try- . (lower .@ runErrorAsExc)-{-# INLINE lowerError #-}-{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-}----- TODO(sandy): Can we use the new withLowerToIO machinery for this?-runErrorAsExc- :: forall e r a. ( Typeable e- , Member (Embed IO) r- )- => (∀ x. Sem r x -> IO x)- -> Sem (Error e ': r) a- -> Sem r a-runErrorAsExc lower = interpretH $ \case- Throw e -> embed $ X.throwIO $ WrappedExc e- Catch main handle -> do- is <- getInitialStateT- m <- runT main- h <- bindT handle- let runIt = lower . runErrorAsExc lower- embed $ X.catch (runIt m) $ \(se :: WrappedExc e) ->- runIt $ h $ unwrapExc se <$ is-{-# INLINE runErrorAsExc #-}
src/Polysemy/Fail.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: 'Fail' interpreters module Polysemy.Fail ( -- * Effect Fail(..)
src/Polysemy/Fail/Type.hs view
@@ -1,3 +1,11 @@+-- | Description: 'Fail' effect module Polysemy.Fail.Type where +------------------------------------------------------------------------------+-- | This effect abstracts the concept of 'Control.Monad.Fail.MonadFail',+-- which is a built-in mechanism that converts pattern matching errors to+-- calls to the current monad's instance of that class.+--+-- The instance defined in "Polysemy.Internal" uses this effect to catch+-- those errors. newtype Fail m a = Fail String
src/Polysemy/Final.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-}++-- | Description: The effect 'Final' that allows embedding higher-order actions in+-- the final target monad of the effect stack module Polysemy.Final ( -- * Effect
src/Polysemy/Fixpoint.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-} +-- | Description: Interpreters for 'Fixpoint' module Polysemy.Fixpoint ( -- * Effect Fixpoint (..)@@ -73,45 +74,3 @@ fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s {-# INLINE fixpointToFinal #-} ---------------------------------------------------------------------------------- | Run a 'Fixpoint' effect purely.------ __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'.-runFixpoint- :: (∀ x. Sem r x -> x)- -> Sem (Fixpoint ': r) a- -> Sem r a-runFixpoint lower = interpretH $ \case- Fixpoint mf -> do- c <- bindT mf- s <- getInitialStateT- ins <- getInspectorT- pure $ fix $ \fa ->- lower . runFixpoint lower . c $- fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s-{-# INLINE runFixpoint #-}-{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \- \'Data.Functor.Identity.Identity' instead" #-}------------------------------------------------------------------------------------ | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.------ __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'.-runFixpointM- :: ( MonadFix m- , Member (Embed m) r- )- => (∀ x. Sem r x -> m x)- -> Sem (Fixpoint ': r) a- -> Sem r a-runFixpointM lower = interpretH $ \case- Fixpoint mf -> do- c <- bindT mf- s <- getInitialStateT- ins <- getInspectorT- embed $ mfix $ \fa ->- lower . runFixpointM lower . c $- fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s-{-# INLINE runFixpointM #-}-{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}
src/Polysemy/IO.hs view
@@ -1,20 +1,18 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: Compatibility with 'MonadIO' module Polysemy.IO ( -- * Interpretations embedToMonadIO- , lowerEmbedded ) where import Control.Monad.IO.Class import Polysemy import Polysemy.Embed-import Polysemy.Internal-import Polysemy.Internal.Union --------------------------------------------------------------------------------- The 'MonadIO' class is conceptually an interpretation of 'IO' to some+-- | The 'MonadIO' class is conceptually an interpretation of 'IO' to some -- other monad. This function reifies that intuition, by transforming an 'IO' -- effect into some other 'MonadIO'. --@@ -44,29 +42,3 @@ 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 _) ->- y <$> ((<$ s) <$> wd)
src/Polysemy/Input.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Input' effect module Polysemy.Input ( -- * Effect Input (..)@@ -23,6 +24,7 @@ -- | 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
src/Polysemy/Internal.hs view
@@ -8,6 +8,7 @@ {-# 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@@ -34,11 +35,10 @@ , usingSem , liftSem , hoistSem+ , restack , Append , InterpreterFor , InterpretersFor- , (.@)- , (.@@) ) where import Control.Applicative@@ -333,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@@ -345,6 +349,14 @@ 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@@ -358,7 +370,7 @@ {-# INLINE raise_ #-} --- | See 'raise''.+-- | See 'raise'. -- -- @since 1.4.0.0 class Raise (r :: EffectRow) (r' :: EffectRow) where@@ -573,8 +585,25 @@ --------------------------------------------------------------------------------- | 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 #-}@@ -637,65 +666,3 @@ -- @since 1.5.0.0 type InterpretersFor es r = ∀ a. Sem (Append es r) a -> Sem r a ----------------------------------------------------------------------------------- | Some interpreters need to be able to lower down to the base monad (often--- 'IO') in order to function properly --- some good examples of this are--- 'Polysemy.Error.lowerError' and 'Polysemy.Resource.lowerResource'.------ However, these interpreters don't compose particularly nicely; for example,--- to run 'Polysemy.Resource.lowerResource', you must write:------ @--- runM . lowerError runM--- @------ Notice that 'runM' is duplicated in two places here. The situation gets--- exponentially worse the more intepreters you have that need to run in this--- pattern.------ Instead, '.@' performs the composition we'd like. The above can be written as------ @--- (runM .@ lowerError)--- @------ The parentheses here are important; without them you'll run into operator--- precedence errors.------ __Warning:__ This combinator will __duplicate work__ that is intended to be--- just for initialization. This can result in rather surprising behavior. For--- a version of '.@' that won't duplicate work, see the @.\@!@ operator in--- <http://hackage.haskell.org/package/polysemy-zoo/docs/Polysemy-IdempotentLowering.html polysemy-zoo>.------ Interpreters using 'Polysemy.Final' may be composed normally, and--- avoid the work duplication issue. For that reason, you're encouraged to use--- @-'Polysemy.Final'@ interpreters instead of @lower-@ interpreters whenever--- possible.-(.@)- :: Monad m- => (∀ x. Sem r x -> m x)- -- ^ The lowering function, likely 'runM'.- -> (∀ y. (∀ x. Sem r x -> m x)- -> Sem (e ': r) y- -> Sem r y)- -> Sem (e ': r) z- -> m z-f .@ g = f . g f-infixl 8 .@------------------------------------------------------------------------------------ | 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 .@@
src/Polysemy/Internal/Bundle.hs view
@@ -2,17 +2,23 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: Stack manipulation handlers for the 'Polysemy.Bundle.Bundle' effect module Polysemy.Internal.Bundle where 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
src/Polysemy/Internal/Combinators.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The basic interpreter-building combinators module Polysemy.Internal.Combinators ( -- * First order interpret@@ -18,6 +19,7 @@ , reinterpretH , reinterpret2H , reinterpret3H+ , interpretWeaving -- * Conditional , interceptUsing@@ -28,6 +30,7 @@ , lazilyStateful ) where +import Control.Arrow ((>>>)) import Control.Monad import qualified Control.Monad.Trans.State.Lazy as LS import qualified Control.Monad.Trans.State.Strict as S@@ -86,6 +89,18 @@ Right (Weaving e s d y v) -> do 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
src/Polysemy/Internal/CustomErrors.hs view
@@ -4,8 +4,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: type-errors-pretty redefinitions module Polysemy.Internal.CustomErrors ( WhenStuck , FirstOrder@@ -16,9 +17,10 @@ import Data.Kind import Fcf import GHC.TypeLits (Symbol)-import Polysemy.Internal.Kind+import Type.Errors hiding (IfStuck, UnlessStuck, WhenStuck)+ import Polysemy.Internal.CustomErrors.Redefined-import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)+import Polysemy.Internal.Kind -- These are taken from type-errors-pretty because it's not in stackage for 9.0.1
src/Polysemy/Internal/CustomErrors/Redefined.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_HADDOCK prune #-} ------------------------------------------------------------------------------ -- | This code is copied verbatim from 'Type.Errors' due to limitations in the
src/Polysemy/Internal/Fixpoint.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Fixpoint' effect module Polysemy.Internal.Fixpoint where ------------------------------------------------------------------------------
− src/Polysemy/Internal/Forklift.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE NumDecimals #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_HADDOCK not-home #-}--module Polysemy.Internal.Forklift where--import qualified Control.Concurrent.Async as A-import Control.Concurrent.Chan.Unagi-import Control.Concurrent.MVar-import Control.Exception-import Polysemy.Internal-import Polysemy.Internal.Union------------------------------------------------------------------------------------ | A promise for interpreting an effect of the union @r@ in another thread.------ @since 0.5.0.0-data Forklift r = forall a. Forklift- { responseMVar :: MVar a- , request :: Union r (Sem r) a- }------------------------------------------------------------------------------------ | A strategy for automatically interpreting an entire stack of effects by--- just shipping them off to some other interpretation context.------ @since 0.5.0.0-runViaForklift- :: Member (Embed IO) r- => InChan (Forklift r)- -> Sem r a- -> IO a-runViaForklift chan = usingSem $ \u -> do- case prj u of- Just (Weaving (Embed m) s _ ex _) ->- ex . (<$ s) <$> m- _ -> do- mvar <- newEmptyMVar- writeChan chan $ Forklift mvar u- takeMVar mvar-{-# INLINE runViaForklift #-}------------------------------------------------------------------------------------- | Run an effect stack all the way down to 'IO' by running it in a new--- thread, and temporarily turning the current thread into an event poll.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 0.5.0.0-withLowerToIO- :: Member (Embed IO) r- => ((forall x. Sem r x -> IO x) -> IO () -> IO a)- -- ^ A lambda that takes the lowering function, and a finalizing 'IO'- -- action to mark a the forked thread as being complete. The finalizing- -- action need not be called.- -> Sem r a-withLowerToIO action = do- (inchan, outchan) <- embed newChan- signal <- embed newEmptyMVar-- res <- embed $ A.async $ do- a <- action (runViaForklift inchan)- (putMVar signal ())- `finally` (putMVar signal ())- pure a-- let me = do- raced <- embed $ A.race (takeMVar signal) $ readChan outchan- case raced of- Left () -> embed $ A.wait res- Right (Forklift mvar req) -> do- resp <- liftSem req- embed $ putMVar mvar $ resp- me_b- {-# INLINE me #-}-- me_b = me- {-# NOINLINE me_b #-}-- me-
src/Polysemy/Internal/Index.hs view
@@ -4,8 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# 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)
src/Polysemy/Internal/Kind.hs view
@@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: Kind aliases 'Effect' and 'EffectRow' module Polysemy.Internal.Kind where import Data.Kind (Type)@@ -17,6 +18,8 @@ type EffectRow = [Effect] +------------------------------------------------------------------------------+-- | Append two type-level lists. type family Append l r where Append (a ': l) r = a ': (Append l r) Append '[] r = r
src/Polysemy/Internal/NonDet.hs view
@@ -4,6 +4,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The 'NonDet' effect module Polysemy.Internal.NonDet where
+ src/Polysemy/Internal/Scoped.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Description: The meta-effect 'Scoped'+module Polysemy.Internal.Scoped where++import Data.Kind (Type)++import Polysemy++-- | @Scoped@ transforms a program so that an interpreter for @effect@ may+-- perform arbitrary actions, like resource management, before and after the+-- computation wrapped by a call to 'scoped' is executed.+--+-- An application for this is @Polysemy.Conc.Events@ from+-- <https://hackage.haskell.org/package/polysemy-conc>, in which each program+-- using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of+-- the event channel; or a database transaction, in which a transaction handle+-- is created for the wrapped program and passed to the interpreter for the+-- database effect.+--+-- For a longer exposition, see <https://www.tweag.io/blog/2022-01-05-polysemy-scoped/>.+-- Note that the interface has changed since the blog post was published: The+-- @resource@ parameter no longer exists.+--+-- Resource allocation is performed by a function passed to+-- 'Polysemy.Scoped.interpretScoped'.+--+-- The constructors are not intended to be used directly; the smart constructor+-- 'scoped' is used like a local interpreter for @effect@. 'scoped' takes an+-- argument of type @param@, which will be passed through to the interpreter, to+-- be used by the resource allocation function.+--+-- As an example, imagine an effect for writing lines to a file:+--+-- > data Write :: Effect where+-- > Write :: Text -> Write m ()+-- > makeSem ''Write+--+-- If we now have the following requirements:+--+-- 1. The file should be opened and closed right before and after the part of+-- the program in which we write lines+-- 2. The file name should be specifiable at the point in the program where+-- writing begins+-- 3. We don't want to commit to IO, lines should be stored in memory when+-- running tests+--+-- Then we can take advantage of 'Scoped' to write this program:+--+-- > prog :: Member (Scoped FilePath Write) r => Sem r ()+-- > prog = do+-- > scoped "file1.txt" do+-- > write "line 1"+-- > write "line 2"+-- > scoped "file2.txt" do+-- > write "line 1"+-- > write "line 2"+--+-- Here 'scoped' creates a prompt for an interpreter to start allocating a+-- resource for @"file1.txt"@ and handling @Write@ actions using that resource.+-- When the 'scoped' block ends, the resource should be freed.+--+-- The interpreter may look like this:+--+-- > interpretWriteFile :: Members '[Resource, Embed IO] => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteFile =+-- > interpretScoped allocator handler+-- > where+-- > allocator name use = bracket (openFile name WriteMode) hClose use+-- > handler fileHandle (Write line) = embed (Text.hPutStrLn fileHandle line)+--+-- Essentially, the @bracket@ is executed at the point where @scoped@ was+-- called, wrapping the following block. When the second @scoped@ is executed,+-- another call to @bracket@ is performed.+--+-- The effect of this is that the operation that uses @Embed IO@ was moved from+-- the call site to the interpreter, while the interpreter may be executed at+-- the outermost layer of the app.+--+-- This makes it possible to use a pure interpreter for testing:+--+-- > interpretWriteOutput :: Member (Output (FilePath, Text)) r => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteOutput =+-- > interpretScoped (\ name use -> use name) \ name -> \case+-- > Write line -> output (name, line)+--+-- Here we simply pass the name to the interpreter in the resource allocation+-- function.+--+-- Now imagine that we drop requirement 2 from the initial list – we still want+-- the file to be opened and closed as late/early as possible, but the file name+-- is globally fixed. For this case, the @param@ type is unused, and the API+-- provides some convenience aliases to make your code more concise:+--+-- > prog :: Member (Scoped_ Write) r => Sem r ()+-- > prog = do+-- > scoped_ do+-- > write "line 1"+-- > write "line 2"+-- > scoped_ do+-- > write "line 1"+-- > write "line 2"+--+-- The type 'Scoped_' and the constructor 'scoped_' simply fix @param@ to @()@.+data Scoped (param :: Type) (effect :: Effect) :: Effect where+ Run :: ∀ param effect m a . Word -> effect m a -> Scoped param effect m a+ InScope :: ∀ param effect m a . param -> (Word -> m a) -> Scoped param effect m a++-- | An auxiliary effect for 'Scoped'.+data OuterRun (effect :: Effect) :: Effect where+ OuterRun :: ∀ effect m a . Word -> effect m a -> OuterRun effect m a++-- |A convenience alias for a scope without parameters.+type Scoped_ effect =+ Scoped () effect++-- | Constructor for 'Scoped', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped' param effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples.+scoped ::+ ∀ param effect r .+ Member (Scoped param effect) r =>+ param ->+ InterpreterFor effect r+scoped param main =+ send $ InScope @param @effect param $ \w ->+ transform @effect (Run @param w) main+{-# inline scoped #-}++-- | Constructor for 'Scoped_', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped_' effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples.+scoped_ ::+ ∀ effect r .+ Member (Scoped_ effect) r =>+ InterpreterFor effect r+scoped_ = scoped ()+{-# inline scoped_ #-}++-- | Transform the parameters of a 'Scoped' program.+--+-- This allows incremental additions to the data passed to the interpreter, for+-- example to create an API that permits different ways of running an effect+-- with some fundamental parameters being supplied at scope creation and some+-- optional or specific parameters being selected by the user downstream.+rescope ::+ ∀ param0 param1 effect r .+ Member (Scoped param1 effect) r =>+ (param0 -> param1) ->+ InterpreterFor (Scoped param0 effect) r+rescope fp =+ transform \case+ Run w e -> Run @param1 w e+ InScope p main -> InScope (fp p) main+{-# inline rescope #-}+
src/Polysemy/Internal/Sing.hs view
@@ -5,15 +5,21 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: Singleton list module Polysemy.Internal.Sing where -import GHC.TypeLits (type (-), Nat)+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 @@ -25,6 +31,8 @@ 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
src/Polysemy/Internal/Strategy.hs view
@@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The auxiliary effect 'Strategy' used for building interpreters+-- that embed 'Sem's in 'IO' callbacks module Polysemy.Internal.Strategy where import Polysemy.Internal@@ -7,7 +9,8 @@ import Polysemy.Internal.Tactics (Inspector(..)) -+------------------------------------------------------------------------------+-- | See 'Strategic'. data Strategy m f n z a where GetInitialState :: Strategy m f n z (f ()) HoistInterpretation :: (a -> n b) -> Strategy m f n z (f a -> m (f b))
src/Polysemy/Internal/TH/Common.hs view
@@ -4,8 +4,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: TH utilities for generating effect constructors module Polysemy.Internal.TH.Common ( ConLiftInfo (..) , getEffectMetadata@@ -168,8 +169,8 @@ ------------------------------------------------------------------------------ -- | 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 = fst <$> cliFunArgs cli@@ -215,7 +216,9 @@ ) where base = capturableBase name-#if MIN_VERSION_template_haskell(2,17,0)+#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"]
src/Polysemy/Internal/TH/Effect.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_HADDOCK not-home #-} -- | This module provides Template Haskell functions for automatically generating--- effect operation functions (that is, functions that use 'send') from a given+-- effect operation functions (that is, functions that use 'Polysemy.send') from a given -- effect algebra. For example, using the @FileSystem@ effect from the example in -- the module documentation for "Polysemy", we can write the following: --@@ -18,11 +18,11 @@ -- This will automatically generate (approximately) the following functions: -- -- @--- readFile :: 'Member' FileSystem r => 'FilePath' -> 'Sem' r 'String'--- readFile a = 'send' (ReadFile a)+-- readFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'Polysemy.Sem' r 'String'+-- readFile a = 'Polysemy.send' (ReadFile a) ----- writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Sem' r ()--- writeFile a b = 'send' (WriteFile a b)+-- writeFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'String' -> 'Polysemy.Sem' r ()+-- writeFile a b = 'Polysemy.send' (WriteFile a b) -- @ module Polysemy.Internal.TH.Effect ( makeSem@@ -31,6 +31,9 @@ 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.TH.Common @@ -73,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: --@@ -118,7 +121,7 @@ ------------------------------------------------------------------------------ -- | 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]@@ -133,8 +136,8 @@ -- | 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@@ -142,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) @@ -152,7 +162,10 @@ genDec :: Bool -> ConLiftInfo -> Q [Dec] genDec should_mk_sigs cli = do let fun_args_names = fst <$> cliFunArgs cli-+#if __GLASGOW_HASKELL__ >= 902+ doc <- getDoc $ DeclDoc $ cliConName cli+ maybe (pure ()) (addModFinalizer . putDoc (DeclDoc $ cliFunName cli)) doc+#endif pure [ PragmaD $ InlineP (cliFunName cli) Inlinable ConLike AllPhases , FunD (cliFunName cli)
src/Polysemy/Internal/Tactics.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The auxiliary higher-order interpreter effect 'Tactics' module Polysemy.Internal.Tactics ( Tactics (..) , getInitialStateT@@ -76,8 +77,12 @@ 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))
src/Polysemy/Internal/Union.hs view
@@ -14,8 +14,9 @@ {-# 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 (..)@@ -72,9 +73,12 @@ instance Functor (Union r mWoven) where fmap f (Union w t) = Union w $ f <$> t- {-# INLINE fmap #-}+ {-# INLINABLE fmap #-} +------------------------------------------------------------------------------+-- | 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 :: forall f e rInitial a resultType mAfter. (Functor f)@@ -104,7 +108,7 @@ 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 #-} @@ -121,7 +125,7 @@ (fmap Compose . d . fmap nt . getCompose) (fmap f . getCompose) (v <=< v' . getCompose)-{-# INLINE weave #-}+{-# INLINABLE weave #-} hoist@@ -130,7 +134,7 @@ -> 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 #-}+{-# INLINABLE hoist #-} ------------------------------------------------------------------------------ -- | A proof that @e@ is an element of @r@.@@ -188,16 +192,18 @@ Nothing +------------------------------------------------------------------------------+-- | 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 #-} Member t (t ': z) where membership' = Here- {-# INLINE membership' #-} instance Member t z => Member t (_1 ': z) where membership' = There $ membership' @t @z- {-# INLINE membership' #-} ------------------------------------------------------------------------------ -- | A class for effect rows whose elements are inspectable.@@ -211,27 +217,27 @@ 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 #-} ------------------------------------------------------------------------------@@ -241,7 +247,7 @@ 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)-{-# INLINE extendMembershipLeft #-}+{-# INLINABLE extendMembershipLeft #-} ------------------------------------------------------------------------------@@ -250,7 +256,7 @@ extendMembershipRight :: forall l r e. ElemOf e l -> ElemOf e (Append l r) extendMembershipRight Here = Here extendMembershipRight (There e) = There (extendMembershipRight @_ @r e)-{-# INLINE extendMembershipRight #-}+{-# INLINABLE extendMembershipRight #-} ------------------------------------------------------------------------------@@ -265,7 +271,7 @@ injectMembership SEnd sm pr = extendMembershipLeft sm pr injectMembership (SCons _) _ Here = Here injectMembership (SCons sl) sm (There pr) = There (injectMembership @right sl sm pr)-{-# INLINE injectMembership #-}+{-# INLINABLE injectMembership #-} ------------------------------------------------------------------------------@@ -276,20 +282,24 @@ 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 _) _) = error "Unsafe use of UnsafeMkElemOf"-{-# INLINE extract #-}+{-# INLINABLE extract #-} ------------------------------------------------------------------------------ -- | An empty union contains nothing, so this function is uncallable. absurdU :: Union '[] m a -> b-absurdU (Union _ _) = error "Unsafe use of UnsafeMkElemOf"+#if __GLASGOW_HASKELL__ >= 902+absurdU = \case+#else+absurdU _ = error "Unsafe use of UnsafeMkElemOf"+#endif ------------------------------------------------------------------------------@@ -297,7 +307,7 @@ -- 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 #-} ------------------------------------------------------------------------------@@ -305,7 +315,7 @@ -- 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-{-# INLINE weakenList #-}+{-# INLINABLE weakenList #-} ------------------------------------------------------------------------------@@ -317,7 +327,7 @@ -> 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-{-# INLINE weakenMid #-}+{-# INLINABLE weakenMid #-} ------------------------------------------------------------------------------@@ -329,7 +339,7 @@ (fmap Identity . runIdentity) runIdentity (Just . runIdentity)-{-# INLINE inj #-}+{-# INLINABLE inj #-} ------------------------------------------------------------------------------@@ -343,13 +353,13 @@ (fmap Identity . runIdentity) runIdentity (Just . runIdentity)-{-# INLINE injUsing #-}+{-# 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'.@@ -359,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@@ -370,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@@ -382,4 +392,4 @@ case p of Here -> Right a There pr -> Left (Union (There pr) a)-{-# INLINE decompCoerce #-}+{-# INLINABLE decompCoerce #-}
src/Polysemy/Internal/Writer.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, TemplateHaskell, TupleSections #-}-{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-}++-- | Description: The 'Writer' effect module Polysemy.Internal.Writer where import Control.Concurrent.STM@@ -20,8 +22,11 @@ ------------------------------------------------------------------------------ -- | An effect capable of emitting and intercepting messages. data Writer o m a where+ -- | Write a message to the log. Tell :: o -> Writer o m ()+ -- | Return the log produced by the higher-order action. Listen :: ∀ o m a. m a -> Writer o m (o, a)+ -- | Run the given action and apply the function it returns to the log. Pass :: m (o -> o, a) -> Writer o m a makeSem ''Writer@@ -148,8 +153,8 @@ -> o -> STM () writeListen tvar switch = \o -> do- alreadyCommited <- readTVar switch- unless alreadyCommited $ do+ alreadyCommitted <- readTVar switch+ unless alreadyCommitted $ do s <- readTVar tvar writeTVar tvar $! s <> o write o@@ -184,8 +189,8 @@ o <- readTVar tvar let !o' = f o -- Likely redundant, but doesn't hurt.- alreadyCommited <- readTVar switch- unless alreadyCommited $+ alreadyCommitted <- readTVar switch+ unless alreadyCommitted $ write o' writeTVar switch True {-# INLINE commitPass #-}
− src/Polysemy/Law.hs
@@ -1,197 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}--#if __GLASGOW_HASKELL__ < 806--- There is a bug in older versions of Haddock that don't allow documentation--- on GADT arguments.-#define HADDOCK ---#else-#define HADDOCK -- ^-#endif--module Polysemy.Law- ( Law (..)- , runLaw- , MakeLaw (..)- , Citizen (..)- , printf- , module Test.QuickCheck- ) where--import Control.Arrow (first)-import Data.Char-import Polysemy-import Test.QuickCheck------------------------------------------------------------------------------------ | Associates the name @r@ with the eventual type @a@. For example,--- @'Citizen' (String -> Bool) Bool@ can produce arbitrary @Bool@s by calling--- the given function with arbitrary @String@s.-class Citizen r a | r -> a where- -- | Generate two @a@s via two @r@s. Additionally, produce a list of strings- -- corresponding to any arbitrary arguments we needed to build.- getCitizen :: r -> r -> Gen ([String], (a, a))--instance {-# OVERLAPPING #-} Citizen (Sem r a -> b) (Sem r a -> b) where- getCitizen r1 r2 = pure ([], (r1, r2))--instance Citizen (Sem r a) (Sem r a) where- getCitizen r1 r2 = pure ([], (r1, r2))--instance (Arbitrary a, Show a, Citizen b r) => Citizen (a -> b) r where- getCitizen f1 f2 = do- a <- arbitrary- first (show a :) <$> getCitizen (f1 a) (f2 a)------------------------------------------------------------------------------------ | A law that effect @e@ must satisfy whenever it is in environment @r@. You--- can use 'runLaw' to transform these 'Law's into QuickCheck-able 'Property's.-data Law e r where- -- | A pure 'Law', that doesn't require any access to 'IO'.- Law- :: ( Eq a- , Show a- , Citizen i12n (Sem r x -> a)- , Citizen res (Sem (e ': r) x)- )- => i12n- HADDOCK An interpretation from @'Sem' r x@ down to a pure value. This is- -- likely 'run'.- -> String- HADDOCK A string representation of the left-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the right-handed side was called with.- -> String- HADDOCK A string representation of the right-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the left-handed side was called with.- -> Law e r- -- | Like 'Law', but for 'IO'-accessing effects.- LawIO- :: ( Eq a- , Show a- , Citizen i12n (Sem r x -> IO a)- , Citizen res (Sem (e ': r) x)- )- => i12n- HADDOCK An interpretation from @'Sem' r x@ down to an 'IO' value. This is- -- likely 'runM'.- -> String- HADDOCK A string representation of the left-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the right-handed side was called with.- -> String- HADDOCK A string representation of the right-hand of the rule. This is- -- a formatted string, for more details, refer to 'printf'.- -> res- HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,- -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this- -- is a function type, it's guaranteed to be called with the same- -- arguments that the left-handed side was called with.- -> Law e r------------------------------------------------------------------------------------ | A typeclass that provides the smart constructor 'mkLaw'.-class MakeLaw e r where- -- | A smart constructor for building 'Law's.- mkLaw- :: (Eq a, Show a, Citizen res (Sem (e ': r) a))- => String- -> res- -> String- -> res- -> Law e r--instance MakeLaw e '[] where- mkLaw = Law run--instance MakeLaw e '[Embed IO] where- mkLaw = LawIO runM------------------------------------------------------------------------------------ | Produces a QuickCheck-able 'Property' corresponding to whether the given--- interpreter satisfies the 'Law'.-runLaw :: InterpreterFor e r -> Law e r -> Property-runLaw i12n (Law finish str1 a str2 b) = property $ do- (_, (lower, _)) <- getCitizen finish finish- (args, (ma, mb)) <- getCitizen a b- let run_it = lower . i12n- a' = run_it ma- b' = run_it mb- pure $- counterexample- (mkCounterexampleString str1 a' str2 b' args)- (a' == b')-runLaw i12n (LawIO finish str1 a str2 b) = property $ do- (_, (lower, _)) <- getCitizen finish finish- (args, (ma, mb)) <- getCitizen a b- let run_it = lower . i12n- pure $ ioProperty $ do- a' <- run_it ma- b' <- run_it mb- pure $- counterexample- (mkCounterexampleString str1 a' str2 b' args)- (a' == b')------------------------------------------------------------------------------------ | Make a string representation for a failing 'runLaw' property.-mkCounterexampleString- :: Show a- => String- -> a- -> String- -> a- -> [String]- -> String-mkCounterexampleString str1 a str2 b args =- mconcat- [ printf str1 args , " (result: " , show a , ")\n /= \n"- , printf str2 args , " (result: " , show b , ")"- ]------------------------------------------------------------------------------------ | A bare-boned implementation of printf. This function will replace tokens--- of the form @"%n"@ in the first string with @args !! n@.------ This will only work for indexes up to 9.------ For example:------ >>> printf "hello %1 %2% %3 %1" ["world", "50"]--- "hello world 50% %3 world"-printf :: String -> [String] -> String-printf str args = splitArgs str- where- splitArgs :: String -> String- splitArgs s =- case break (== '%') s of- (as, "") -> as- (as, _ : b : bs)- | isDigit b- , let d = read [b] - 1- , d < length args- -> as ++ (args !! d) ++ splitArgs bs- (as, _ : bs) -> as ++ "%" ++ splitArgs bs-
src/Polysemy/Membership.hs view
@@ -1,3 +1,4 @@+-- | Description: Reexports of membership related functionality module Polysemy.Membership ( -- * Witnesses ElemOf (..)
src/Polysemy/NonDet.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for 'NonDet' module Polysemy.NonDet ( -- * Effect NonDet (..)
+ src/Polysemy/Opaque.hs view
@@ -0,0 +1,54 @@+-- | The auxiliary effect 'Opaque' used by interpreters of 'Polysemy.Scoped.Scoped'+module Polysemy.Opaque (+ -- * Effect+ Opaque(..),++ -- * Interpreters+ toOpaque,+ fromOpaque,+ ) where++import Polysemy++-- | An effect newtype meant to be used to wrap polymorphic effect variables to+-- prevent them from jamming up resolution of 'Polysemy.Member'.+-- For example, consider:+--+-- @+-- badPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) ()+-- badPut = 'Polysemy.State.put' () -- error+-- @+--+-- This fails to compile. This is because @e@ /could/ be+-- @'Polysemy.State.State' ()@' -- in which case the 'Polysemy.State.put'+-- should target it instead of the concretely provided+-- @'Polysemy.State.State' ()@; as the compiler can't know for sure which effect+-- should be targeted, the program is rejected.+-- There are various ways to resolve this, including using 'raise' or+-- 'Polysemy.Membership.subsumeUsing'. 'Opaque' provides another way:+--+-- @+-- okPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) ()+-- okPut = 'fromOpaque' ('Polysemy.State.put' ()) -- OK+-- @+--+-- 'Opaque' is most useful as a tool for library writers, in the case where some+-- function of the library requires the user to work with an effect stack+-- containing some polymorphic effect variables. By wrapping the polymorphic+-- effect variables using 'Opaque', users of the function can use effects as+-- normal, without having to use 'raise' or 'Polysemy.Membership.subsumeUsing'+-- in order to have 'Polysemy.Member' resolve. The various interpreters of+-- 'Polysemy.Scoped.Scoped' are examples of such usage of 'Opaque'.+--+-- @since 1.9.0.0+newtype Opaque (e :: Effect) m a = Opaque (e m a)++-- | Wrap 'Opaque' around the top effect of the effect stack+toOpaque :: Sem (e ': r) a -> Sem (Opaque e ': r) a+toOpaque = rewrite Opaque+{-# INLINE toOpaque #-}++-- | Unwrap 'Opaque' around the top effect of the effect stack+fromOpaque :: Sem (Opaque e ': r) a -> Sem (e ': r) a+fromOpaque = rewrite (\(Opaque e) -> e)+{-# INLINE fromOpaque #-}
src/Polysemy/Output.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, TemplateHaskell #-} +-- | Description: The 'Output' effect for sending side-effecting messages module Polysemy.Output ( -- * Effect Output (..)@@ -41,6 +42,7 @@ -- | An effect capable of sending messages. Useful for streaming output and for -- logging. data Output o m a where+ -- | Output a message. Output :: o -> Output o m () makeSem ''Output
src/Polysemy/Reader.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Reader' effect and its interpreters module Polysemy.Reader ( -- * Effect Reader (..)@@ -23,12 +24,16 @@ ------------------------------------------------------------------------------ -- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'. data Reader i m a where+ -- | Get the environment. Ask :: Reader i m i+ -- | Transform the environment. Local :: (i -> i) -> m a -> Reader i m a makeSem ''Reader +------------------------------------------------------------------------------+-- | Apply a function to the environment and return the result. asks :: forall i j r. Member (Reader i) r => (i -> j) -> Sem r j asks f = f <$> ask {-# INLINABLE asks #-}
src/Polysemy/Resource.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Resource' effect, providing bracketing functionality module Polysemy.Resource ( -- * Effect Resource (..)@@ -14,8 +15,6 @@ -- * Interpretations , runResource , resourceToIOFinal- , resourceToIO- , lowerResource ) where import qualified Control.Exception as X@@ -28,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.@@ -37,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.@@ -96,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@@ -139,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@@ -211,63 +166,4 @@ _ <- run_it $ d resource pure result {-# INLINE runResource #-}------------------------------------------------------------------------------------ | A more flexible --- though less safe --- version of 'resourceToIOFinal'------ This function is capable of running 'Resource' effects anywhere within an--- effect stack, without relying on an explicit function to lower it into 'IO'.--- Notably, this means that 'Polysemy.State.State' effects will be consistent--- in the presence of 'Resource'.------ ResourceToIO' is safe whenever you're concerned about exceptions thrown--- by effects _already handled_ in your effect stack, or in 'IO' code run--- directly inside of 'bracket'. It is not safe against exceptions thrown--- explicitly at the main thread. If this is not safe enough for your use-case,--- use 'resourceToIOFinal' instead.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 1.0.0.0-resourceToIO- :: forall r a- . Member (Embed IO) r- => Sem (Resource ': r) a- -> Sem r a-resourceToIO = interpretH $ \case- Bracket a b c -> do- ma <- runT a- mb <- bindT b- mc <- bindT c-- withLowerToIO $ \lower finish -> do- let done :: Sem (Resource ': r) x -> IO x- done = lower . raise . resourceToIO- X.bracket- (done ma)- (\x -> done (mb x) >> finish)- (done . mc)-- BracketOnError a b c -> do- ins <- getInspectorT- ma <- runT a- mb <- bindT b- mc <- bindT c-- withLowerToIO $ \lower finish -> do- let done :: Sem (Resource ': r) x -> IO x- done = lower . raise . resourceToIO- X.bracketOnError- (done ma)- (\x -> done (mb x) >> finish)- (\x -> do- result <- done $ mc x- case inspect ins result of- Just _ -> pure result- Nothing -> do- _ <- done $ mb x- pure result- )-{-# INLINE resourceToIO #-}
+ src/Polysemy/Scoped.hs view
@@ -0,0 +1,329 @@+{-# language AllowAmbiguousTypes, BangPatterns #-}++-- | Description: Interpreters for 'Scoped'+module Polysemy.Scoped (+ -- * Effect+ Scoped,+ Scoped_,++ -- * Constructors+ scoped,+ scoped_,+ rescope,++ -- * Interpreters+ runScopedNew,+ interpretScopedH,+ interpretScopedH',+ interpretScoped,+ interpretScopedAs,+ interpretScopedWithH,+ interpretScopedWith,+ interpretScopedWith_,+ runScoped,+ runScopedAs,+) where++import Data.Function ((&))+import Data.Sequence (Seq(..))+import qualified Data.Sequence as S++import Polysemy.Opaque+import Polysemy.Internal+import Polysemy.Internal.Sing+import Polysemy.Internal.Union+import Polysemy.Internal.Combinators+import Polysemy.Internal.Scoped+import Polysemy.Internal.Tactics++-- | Construct an interpreter for a higher-order effect wrapped in a 'Scoped',+-- given a resource allocation function and a parameterized handler for the+-- plain effect.+--+-- This combinator is analogous to 'interpretH' in that it allows the handler to+-- use the 'Tactical' environment and transforms the effect into other effects+-- on the stack.+interpretScopedH ::+ ∀ resource param effect r .+ -- | A callback function that allows the user to acquire a resource for each+ -- computation wrapped by 'scoped' using other effects, with an additional+ -- argument that contains the call site parameter passed to 'scoped'.+ (∀ q x . param ->+ (resource -> Sem (Opaque q ': r) x) ->+ Sem (Opaque q ': r) x) ->+ -- | A handler like the one expected by 'interpretH' with an additional+ -- parameter that contains the @resource@ allocated by the first argument.+ (∀ q r0 x . resource ->+ effect (Sem r0) x ->+ Tactical effect (Sem r0) (Opaque q ': r) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedH withResource scopedHandler = runScopedNew \param sem ->+ withResource param \r -> interpretH (scopedHandler r) sem+{-# inline interpretScopedH #-}++-- | Variant of 'interpretScopedH' that allows the resource acquisition function+-- to use 'Tactical'.+interpretScopedH' ::+ ∀ resource param effect r .+ (∀ e r0 x . param -> (resource -> Tactical e (Sem r0) r x) ->+ Tactical e (Sem r0) r x) ->+ (∀ r0 x .+ resource -> effect (Sem r0) x ->+ Tactical (Scoped param effect) (Sem r0) r x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedH' withResource scopedHandler =+ go 0 Empty+ where+ go :: Word -> Seq resource -> InterpreterFor (Scoped param effect) r+ go depth resources =+ interpretH \case+ Run w act ->+ scopedHandler (S.index resources (fromIntegral w)) act+ InScope param main | !depth' <- depth + 1 ->+ withResource param \ resource ->+ raise . go depth' (resources :|> resource) =<< runT (main depth)+{-# inline interpretScopedH' #-}++-- | First-order variant of 'interpretScopedH'.+interpretScoped ::+ ∀ resource param effect r .+ (∀ q x . param ->+ (resource -> Sem (Opaque q ': r) x) ->+ Sem (Opaque q ': r) x) ->+ (∀ m x . resource -> effect m x -> Sem r x) ->+ InterpreterFor (Scoped param effect) r+interpretScoped withResource scopedHandler =+ interpretScopedH withResource \ r e -> liftT (raise (scopedHandler r e))+{-# inline interpretScoped #-}++-- | Variant of 'interpretScoped' in which the resource allocator is a plain+-- action.+interpretScopedAs ::+ ∀ resource param effect r .+ (param -> Sem r resource) ->+ (∀ m x . resource -> effect m x -> Sem r x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedAs resource =+ interpretScoped \ p use -> use =<< raise (resource p)+{-# inline interpretScopedAs #-}++-- | Higher-order interpreter for 'Scoped' that allows the handler to use+-- additional effects that are interpreted by the resource allocator.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@.+--+-- As an example for a higher order effect, consider a mutexed concurrent state+-- effect, where an effectful function may lock write access to the state while+-- making it still possible to read it:+--+-- > data MState s :: Effect where+-- > MState :: (s -> m (s, a)) -> MState s m a+-- > MRead :: MState s m s+-- >+-- > makeSem ''MState+--+-- We can now use an 'Polysemy.AtomicState.AtomicState' to store the current+-- value and lock write access with an @MVar@. Since the state callback is+-- effectful, we need a higher order interpreter:+--+-- > withResource ::+-- > Member (Embed IO) r =>+-- > s ->+-- > (MVar () -> Sem (AtomicState s : r) a) ->+-- > Sem r a+-- > withResource initial use = do+-- > tv <- embed (newTVarIO initial)+-- > lock <- embed (newMVar ())+-- > runAtomicStateTVar tv $ use lock+-- >+-- > interpretMState ::+-- > ∀ s r .+-- > Members [Resource, Embed IO] r =>+-- > InterpreterFor (Scoped s (MState s)) r+-- > interpretMState =+-- > interpretScopedWithH @'[AtomicState s] withResource \ lock -> \case+-- > MState f ->+-- > bracket_ (embed (takeMVar lock)) (embed (tryPutMVar lock ())) do+-- > s0 <- atomicGet+-- > res <- runTSimple (f s0)+-- > Inspector ins <- getInspectorT+-- > for_ (ins res) \ (s, _) -> atomicPut s+-- > pure (snd <$> res)+-- > MRead ->+-- > liftT atomicGet+interpretScopedWithH ::+ ∀ extra resource param effect r .+ KnownList extra =>+ (∀ q x .+ param ->+ (resource -> Sem (Append extra (Opaque q ': r)) x) ->+ Sem (Opaque q ': r) x) ->+ (∀ q r0 x .+ resource ->+ effect (Sem r0) x ->+ Tactical effect (Sem r0) (Append extra (Opaque q ': r)) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedWithH withResource scopedHandler = runScopedNew+ \param (sem :: Sem (effect ': Opaque q ': r) x) ->+ withResource param \resource ->+ sem+ & restack+ (injectMembership (singList @'[effect]) (singList @extra))+ & interpretH (scopedHandler @q resource)+{-# inline interpretScopedWithH #-}++-- | First-order variant of 'interpretScopedWithH'.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@:+--+-- > data SomeAction :: Effect where+-- > SomeAction :: SomeAction m ()+-- >+-- > foo :: InterpreterFor (Scoped () SomeAction) r+-- > foo =+-- > interpretScopedWith @[Reader Int, State Bool] localEffects \ () -> \case+-- > SomeAction -> put . (> 0) =<< ask @Int+-- > where+-- > localEffects () use = evalState False (runReader 5 (use ()))+interpretScopedWith ::+ ∀ extra param resource effect r.+ KnownList extra =>+ (∀ q x .+ param ->+ (resource -> Sem (Append extra (Opaque q ': r)) x) ->+ Sem (Opaque q ': r) x) ->+ (∀ m x . resource -> effect m x -> Sem (Append extra r) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedWith withResource scopedHandler = runScopedNew+ \param (sem :: Sem (effect ': Opaque q ': r) x) ->+ withResource param \resource ->+ sem+ & restack+ (injectMembership (singList @'[effect]) (singList @extra))+ & interpretH \e -> liftT $+ restack+ (injectMembership @r (singList @extra) (singList @'[Opaque q]))+ (scopedHandler resource e)+{-# inline interpretScopedWith #-}++-- | Variant of 'interpretScopedWith' in which no resource is used and the+-- resource allocator is a plain interpreter.+-- This is useful for scopes that only need local effects, but no resources in+-- the handler.+--+-- See the /Note/ on 'interpretScopedWithH'.+interpretScopedWith_ ::+ ∀ extra param effect r .+ KnownList extra =>+ (∀ q x .+ param ->+ Sem (Append extra (Opaque q ': r)) x ->+ Sem (Opaque q ': r) x) ->+ (∀ m x . effect m x -> Sem (Append extra r) x) ->+ InterpreterFor (Scoped param effect) r+interpretScopedWith_ withResource scopedHandler =+ interpretScopedWith @extra+ (\ p f -> withResource p (f ()))+ (\ () -> scopedHandler)+{-# inline interpretScopedWith_ #-}++-- | Variant of 'interpretScoped' that uses another interpreter instead of a+-- handler.+--+-- This is mostly useful if you want to reuse an interpreter that you cannot+-- easily rewrite (like from another library). If you have full control over the+-- implementation, 'interpretScoped' should be preferred.+--+-- /Note/: In previous versions of Polysemy, the wrapped interpreter was+-- executed fully, including the initializing code surrounding its handler,+-- for each action in the program. However, new and continuing discoveries+-- regarding 'Scoped' has allowed the improvement of having the interpreter be+-- used only once per use of 'scoped', and have it cover the same scope of+-- actions that the resource allocator does.+--+-- This renders the resource allocator practically redundant; for the moment,+-- the API surrounding 'Scoped' remains the same, but work is in progress to+-- revamp the entire API of 'Scoped'.+runScoped ::+ ∀ resource param effect r .+ (∀ q x . param -> (resource -> Sem (Opaque q ': r) x) -> Sem (Opaque q ': r) x) ->+ (∀ q . resource -> InterpreterFor effect (Opaque q ': r)) ->+ InterpreterFor (Scoped param effect) r+runScoped withResource scopedInterpreter = runScopedNew \param sem ->+ withResource param (\r -> scopedInterpreter r sem)+{-# inline runScoped #-}++-- | Variant of 'runScoped' in which the resource allocator returns the resource+-- rather than calling a continuation.+runScopedAs ::+ ∀ resource param effect r .+ (param -> Sem r resource) ->+ (∀ q. resource -> InterpreterFor effect (Opaque q ': r)) ->+ InterpreterFor (Scoped param effect) r+runScopedAs resource = runScoped \ p use -> use =<< raise (resource p)+{-# inline runScopedAs #-}++-- | Run a 'Scoped' effect by specifying the interpreter to be used at every+-- use of 'scoped'.+--+-- This interpretation of 'Scoped' is powerful enough to subsume all other+-- interpretations of 'Scoped' (except 'interpretScopedH'' which works+-- differently from all other interpretations) while also being much simpler.+--+-- Consider this a sneak-peek of the future of 'Scoped'. In the API rework+-- planned for 'Scoped', the effect and its interpreters will be further+-- expanded to make 'Scoped' even more flexible.+--+-- @since 1.9.0.0+runScopedNew ::+ ∀ param effect r .+ (∀ q. param -> InterpreterFor effect (Opaque q ': r)) ->+ InterpreterFor (Scoped param effect) r+runScopedNew h =+ interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of+ Run w _ -> errorWithoutStackTrace $ "top level run with depth " ++ show w+ InScope param main ->+ wv (main 0 <$ s)+ & raiseUnder2+ & go 0+ & h param+ & interpretH (\(Opaque (OuterRun w _)) ->+ errorWithoutStackTrace $ "unhandled OuterRun with depth " ++ show w)+ & fmap ex+ where+ go' :: Word+ -> InterpreterFor+ (Opaque (OuterRun effect))+ (effect ': Opaque (OuterRun effect) ': r)+ go' depth =+ interpretWeaving \ (Weaving sr@(Opaque (OuterRun w act)) s wv ex ins) ->+ if w == depth then+ liftSem $ injWeaving $ Weaving act s (go' depth . wv) ex ins+ else+ liftSem $ injWeaving $ Weaving sr s (go' depth . wv) ex ins++ -- TODO investigate whether loopbreaker optimization is effective here+ go :: Word+ -> InterpreterFor+ (Scoped param effect)+ (effect ': Opaque (OuterRun effect) ': r)+ go depth =+ interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of+ Run w act+ | w == depth -> liftSem $ injWeaving $+ Weaving act s (go depth . wv) ex ins+ | otherwise -> liftSem $ injWeaving $+ Weaving (Opaque (OuterRun w act)) s (go depth . wv) ex ins+ InScope param main -> do+ let !depth' = depth + 1+ wv (main depth' <$ s)+ & go depth'+ & h param+ & raiseUnder2+ & go' depth+ & fmap ex+{-# INLINE runScopedNew #-}
src/Polysemy/State.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'State' effect module Polysemy.State ( -- * Effect State (..)@@ -28,15 +29,15 @@ , hoistStateIntoStateT ) where -import Control.Monad.ST+import Control.Monad.ST import qualified Control.Monad.Trans.State as S-import Data.IORef-import Data.STRef-import Data.Tuple (swap)-import Polysemy-import Polysemy.Internal-import Polysemy.Internal.Combinators-import Polysemy.Internal.Union+import Data.IORef+import Data.STRef+import Data.Tuple (swap)+import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Combinators+import Polysemy.Internal.Union ------------------------------------------------------------------------------@@ -48,17 +49,23 @@ -- Interpreters which require statefulness can 'Polysemy.reinterpret' -- themselves in terms of 'State', and subsequently call 'runState'. data State s m a where+ -- | Get the state. Get :: State s m s+ -- | Update the state. Put :: s -> State s m () makeSem ''State +------------------------------------------------------------------------------+-- | Apply a function to the state and return the result. gets :: forall s a r. Member (State s) r => (s -> a) -> Sem r a gets f = f <$> get {-# INLINABLE gets #-} +------------------------------------------------------------------------------+-- | Modify the state. modify :: Member (State s) r => (s -> s) -> Sem r () modify f = do s <- get
− src/Polysemy/State/Law.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Polysemy.State.Law where--import Polysemy-import Polysemy.Law-import Polysemy.State-import Control.Applicative-import Control.Arrow------------------------------------------------------------------------------------ | A collection of laws that show a `State` interpreter is correct.-prop_lawfulState- :: forall r s- . (Eq s, Show s, Arbitrary s, MakeLaw (State s) r)- => InterpreterFor (State s) r- -> Property-prop_lawfulState i12n = conjoin- [ runLaw i12n law_putTwice- , runLaw i12n law_getTwice- , runLaw i12n law_getPutGet- ]---law_putTwice- :: forall s r- . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)- => Law (State s) r-law_putTwice =- mkLaw- "put %1 >> put %2 >> get"- (\s s' -> put @s s >> put @s s' >> get @s)- "put %2 >> get"- (\_ s' -> put @s s' >> get @s)--law_getTwice- :: forall s r- . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)- => Law (State s) r-law_getTwice =- mkLaw- "liftA2 (,) get get"- (liftA2 (,) (get @s) (get @s))- "(id &&& id) <$> get"- ((id &&& id) <$> get @s)--law_getPutGet- :: forall s r- . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)- => Law (State s) r-law_getPutGet =- mkLaw- "get >>= put >> get"- (get @s >>= put @s >> get @s)- "get"- (get @s)-
src/Polysemy/Tagged.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}++-- | Description: The 'Tagged' effect and its interpreters module Polysemy.Tagged ( -- * Effect@@ -39,7 +41,7 @@ -- -> 'Sem' r a -- -> 'Sem' r a -- taggedLocal f m =--- 'tag' @k @('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m)+-- 'tag' \@k \@('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m) -- @ -- tag
src/Polysemy/Trace.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Trace' effect and its interpreters module Polysemy.Trace ( -- * Effect Trace (..)@@ -28,6 +29,7 @@ ------------------------------------------------------------------------------ -- | An effect for logging strings. data Trace m a where+ -- | Log a message. Trace :: String -> Trace m () makeSem ''Trace
− src/Polysemy/View.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Polysemy.View- ( -- * Effect- View (..)-- -- * Actions- , see-- -- * Interpretations- , viewToState- , viewToInput- ) where--import Polysemy-import Polysemy.Input-import Polysemy.State-import Polysemy.Tagged------------------------------------------------------------------------------------ | A 'View' is an expensive computation that should be cached.-data View v m a where- See :: View v m v--makeSem ''View------------------------------------------------------------------------------------ | Transform a 'View' into an 'Input'.-viewToInput- :: forall v i r a- . Member (Input i) r- => (i -> v)- -> Sem (View v ': r) a- -> Sem r a-viewToInput f = interpret $ \case- See -> f <$> input------------------------------------------------------------------------------------ | Get a 'View' as an exensive computation over an underlying 'State' effect.--- This 'View' is only invalidated when the underlying 'State' changes.-viewToState- :: forall v s r a- . Member (State s) r- => (s -> Sem r v)- -> Sem (View v ': r) a- -> Sem r a-viewToState f = do- evalState Dirty- . untag @"view" @(State (Cached v))- . intercept @(State s)- ( \case- Get -> get- Put s -> do- put s- tag @"view" @(State (Cached v)) $ put $ Dirty @v- )- . reinterpret @(View v)- ( \case- See -> do- dirty <- tagged @"view" $ get @(Cached v)- case dirty of- Dirty -> do- s <- get- v' <- raise $ f s- tagged @"view" $ put $ Cached v'- pure v'- Cached v -> pure v- )---data Cached a = Cached a | Dirty- deriving (Eq, Ord, Show, Functor)-
src/Polysemy/Writer.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections #-} +-- | Description: Interpreters for 'Writer' module Polysemy.Writer ( -- * Effect Writer (..)
− test/AsyncSpec.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE NumDecimals #-}--module AsyncSpec where--import Control.Concurrent.MVar-import Control.Monad-import Polysemy-import Polysemy.Async-import Polysemy.State-import Polysemy.Trace-import Test.Hspec---spec :: Spec-spec = describe "async" $ do- it "should thread state and not lock" $ do- (ts, (s, r)) <- runM- . runTraceList- . runState "hello"- . asyncToIO $ do- let message :: Member Trace r => Int -> String -> Sem r ()- message n msg = trace $ mconcat- [ show n, "> ", msg ]- ~[lock1, lock2] <- embed $- replicateM 2 newEmptyMVar- a1 <- async $ do- v <- get @String- message 1 v- put $ reverse v-- embed $ putMVar lock1 ()- embed $ takeMVar lock2- get >>= message 1-- get @String-- void $ async $ do- embed $ takeMVar lock1- get >>= message 2- put "pong"- embed $ putMVar lock2 ()-- await a1 <* put "final"-- ts `shouldContain` ["1> hello", "2> olleh", "1> pong"]- s `shouldBe` "final"- r `shouldBe` Just "pong"
test/BracketSpec.hs view
@@ -151,16 +151,6 @@ . runResource . runError @() -runTest2- :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a- -> IO ([String], ([Char], Either () a))-runTest2 = runM- . ignoreOutput- . runTraceList- . runState ""- . resourceToIO- . runError @()- runTest3 :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO, Final IO] a -> IO ([String], ([Char], Either () a))@@ -185,9 +175,6 @@ k z -- NOTE(sandy): These unsafeCoerces are safe, because we're just weakening -- the end of the union- it "via resourceToIO" $ do- z <- runTest2 $ unsafeCoerce m- k z it "via resourceToIOFinal" $ do z <- runTest3 $ unsafeCoerce m k z@@ -200,9 +187,6 @@ -> Spec testTheIOTwo name k m = do describe name $ do- it "via resourceToIO" $ do- z <- runTest2 m- k z -- NOTE(sandy): This unsafeCoerces are safe, because we're just weakening -- the end of the union it "via resourceToIOFinal" $ do
test/ErrorSpec.hs view
@@ -2,6 +2,7 @@ import qualified Control.Exception as X import Polysemy+import Polysemy.Async import Polysemy.Error import Polysemy.Resource import Test.Hspec@@ -28,11 +29,28 @@ it "should happen before Resource" $ do a <-- runM $ resourceToIO $ runError @MyExc $ do+ runFinal $ embedToFinal @IO $ resourceToIOFinal $ runError @MyExc $ do onException (fromException @MyExc $ do _ <- X.throwIO $ MyExc "hello" pure () ) $ pure $ error "this exception shouldn't happen" a `shouldBe` (Left $ MyExc "hello")+ describe "errorToIOFinal" $ do+ it "should catch errors only for the interpreted Error" $ do+ res1 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do+ raise $ throw () `catch` \() -> return ()+ res1 `shouldBe` Right (Right ())+ res2 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do+ raise (throw ()) `catch` \() -> return ()+ res2 `shouldBe` Left () + it "should propagate errors thrown in 'async'" $ do+ res1 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do+ a <- async $ throw ()+ await a+ res1 `shouldBe` (Left () :: Either () (Maybe ()))+ res2 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do+ a <- async $ throw ()+ await a `catch` \() -> return $ Just ()+ res2 `shouldBe` Right (Just ())
− test/InspectorSpec.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module InspectorSpec where--import Control.Monad-import Data.IORef-import Polysemy-import Polysemy.Error-import Polysemy.State-import Test.Hspec----data Callback m a where- Callback :: m String -> Callback m ()--makeSem ''Callback----spec :: Spec-spec = parallel $ describe "Inspector" $ do- it "should inspect State effects" $ do- withNewTTY $ \ref -> do- void . (runM .@ runCallback ref)- . runState False- $ do- embed $ pretendPrint ref "hello world"- callback $ show <$> get @Bool- modify not- callback $ show <$> get @Bool-- result <- readIORef ref- result `shouldContain` ["hello world"]- result `shouldContain` ["False", "True"]-- it "should not inspect thrown Error effects" $ do- withNewTTY $ \ref -> do- void . (runM .@ runCallback ref)- . runError @()- $ do- callback $ throw ()- callback $ pure "nice"-- result <- readIORef ref- result `shouldContain` [":(", "nice"]---runCallback- :: Member (Embed IO) r- => IORef [String]- -> (forall x. Sem r x -> IO x)- -> Sem (Callback ': r) a- -> Sem r a-runCallback ref lower = interpretH $ \case- Callback cb -> do- cb' <- runT cb- ins <- getInspectorT- embed $ doCB ref $ do- v <- lower .@ runCallback ref $ cb'- pure $ maybe ":(" id $ inspect ins v- getInitialStateT---doCB :: IORef [String] -> IO String -> IO ()-doCB ref m = m >>= pretendPrint ref---pretendPrint :: IORef [String] -> String -> IO ()-pretendPrint ref msg = modifyIORef ref (++ [msg])---withNewTTY :: (IORef [String] -> IO a) -> IO a-withNewTTY f = do- ref <- newIORef []- f ref-
− test/LawsSpec.hs
@@ -1,20 +0,0 @@-module LawsSpec where--import Polysemy-import Polysemy.Law-import Polysemy.State-import Polysemy.State.Law-import Test.Hspec--spec :: Spec-spec = parallel $ do- describe "State effects" $ do- it "runState should pass the laws" $- property $ prop_lawfulState @'[] $ fmap snd . runState @Int 0-- it "runLazyState should pass the laws" $- property $ prop_lawfulState @'[] $ fmap snd . runLazyState @Int 0-- it "stateToIO should pass the laws" $- property $ prop_lawfulState @'[Embed IO] $ fmap snd . stateToIO @Int 0-
+ test/ScopedSpec.hs view
@@ -0,0 +1,117 @@+{-# language TemplateHaskell, DerivingStrategies, GeneralizedNewtypeDeriving #-}++module ScopedSpec where++import Control.Concurrent.STM+import Polysemy+import Polysemy.Internal.Tactics+import Polysemy.Scoped+import Test.Hspec++newtype Par =+ Par { unPar :: Int }+ deriving stock (Eq, Show)+ deriving newtype (Num, Real, Enum, Integral, Ord)++data E :: Effect where+ E1 :: E m Int+ E2 :: E m Int++makeSem ''E++data F :: Effect where+ F :: F m Int++makeSem ''F++handleE ::+ Member (Embed IO) r =>+ TVar Int ->+ E m a ->+ Tactical effect m (F : r) a+handleE tv = \case+ E1 -> do+ i1 <- embed (readTVarIO tv)+ i2 <- f+ pureT (i1 + i2 + 10)+ E2 ->+ pureT (-1)++interpretF ::+ Member (Embed IO) r =>+ TVar Int ->+ InterpreterFor F r+interpretF tv =+ interpret \ F -> do+ embed (atomically (writeTVar tv 7))+ pure 5++scope ::+ Member (Embed IO) r =>+ Par ->+ (TVar Int -> Sem (F : r) a) ->+ Sem r a+scope (Par n) use = do+ tv <- embed (newTVarIO n)+ interpretF tv (use tv)++data HO :: Effect where+ Inc :: m a -> HO m a+ Ret :: HO m Int++makeSem ''HO++scopeHO :: () -> (() -> Sem r a) -> Sem r a+scopeHO () use =+ use ()++handleHO :: Int -> () -> HO m a -> Tactical HO m r a+handleHO n () = \case+ Inc ma -> raise . interpretH (handleHO (n + 1) ()) =<< runT ma+ Ret -> pureT n++data Esc :: Effect where+ Esc :: Esc m Int+makeSem ''Esc++data Indirect :: Effect where+ Indirect :: Indirect m Int+makeSem ''Indirect++interpretIndirect :: Member Esc r => InterpreterFor Indirect r+interpretIndirect = interpret \ Indirect -> esc++handleEsc :: Int -> Esc m a -> Sem r a+handleEsc i = \ Esc -> pure i++test_escape :: Sem (Scoped Int Esc ': r) Int+test_escape =+ scoped @Int @Esc 2+ $ interpretIndirect+ $ scoped @Int @Esc 1 indirect++spec :: Spec+spec = parallel do+ describe "Scoped" do+ it "local effects" do+ (i1, i2) <- runM $ interpretScopedWithH @'[F] @(TVar Int) @Par @E scope handleE do+ scoped @Par @E 20 do+ i1 <- e1+ i2 <- scoped @Par @E 23 e1+ pure (i1, i2)+ i1 `shouldBe` 35+ i2 `shouldBe` 38+ it "switch interpreter" do+ r <- runM $ interpretScopedH scopeHO (handleHO 1) do+ scoped_ @HO do+ inc do+ ret+ r `shouldBe` 2+ it "scoped depth" do+ r <- runM $ interpretScoped (flip ($)) handleEsc $ test_escape+ r `shouldBe` 2+ r' <- runM $ interpretScopedH'+ (\r h -> h r)+ (\i e -> liftT (handleEsc i e))+ $ test_escape+ r' `shouldBe` 2
test/TypeErrors.hs view
@@ -45,18 +45,3 @@ -- ... tooFewArgumentsReinterpret = () ------------------------------------------------------------------------------------- |--- >>> :{--- 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 = ()-
− test/ViewSpec.hs
@@ -1,40 +0,0 @@-module ViewSpec where--import Polysemy-import Polysemy.State-import Polysemy.Trace-import Polysemy.View-import Test.Hspec---check_see :: Members '[View String, Trace] r => Sem r ()-check_see = trace . ("saw " ++) =<< see--spec :: Spec-spec = parallel $ do- describe "View effect" $ do- it "should cache views" $ do- let a = run- . runTraceList- . runState @Int 0- . viewToState @String @Int (\i -> do- trace $ "caching " ++ show i- pure $ show i ) $ do- check_see- check_see- put @Int 3- trace "it's lazy"- put @Int 5- check_see- check_see- get @Int-- a `shouldBe` ([ "caching 0"- , "saw 0"- , "saw 0"- , "it's lazy"- , "caching 5"- , "saw 5"- , "saw 5"- ], (5, 5))-