diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,7 +1,13 @@ # Changelog for polysemy +## 1.5.0.0 (2021-03-30) -## Unreleased changes +### Breaking Changes +* Dropped support for GHC 8.4 + +### Other Changes +- Added `InterpretersFor` as a shorthand for interpreters consuming multiple effects +- Added `runTSimple` and `bindTSimple`, which are simplified variants of `runT` and `bindT` ## 1.4.0.0 (2020-10-31) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,14 +11,6 @@ [![Hackage](https://img.shields.io/hackage/v/polysemy-plugin.svg?logo=haskell&label=polysemy-plugin)](https://hackage.haskell.org/package/polysemy-plugin) [![Zulip chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://funprog.zulipchat.com/#narrow/stream/216942-Polysemy) -## Dedication - -> The word 'good' has many meanings. For example, if a man were to shoot his -> grandmother at a range of five hundred yards, I should call him a good shot, -> but not necessarily a good man. -> -> Gilbert K. Chesterton - ## Overview `polysemy` is a library for writing high-power, low-boilerplate domain specific @@ -228,6 +220,50 @@ - TypeFamilies ``` +## Building with Nix + +The project provides a basic nix config for building in development. +It is defined as a [flake] with backwards compatibility stubs in `default.nix` and `shell.nix`. + +To build the main library or plugin: + +```bash +nix-build -A polysemy +nix-build -A polysemy-plugin +``` + +Flake version: + +```bash +nix build +nix build '.#polysemy-plugin' +``` + +To inspect a dependency: + +```bash +nix repl + +> p = import ./. +> p.unagi-chan +``` + +To run a shell command with all dependencies in the environment: + +```bash +nix-shell --pure +nix-shell --pure --run 'cabal v2-haddock polysemy' +nix-shell --pure --run ghcid +``` + +Flake version: + +```bash +nix develop -i # just enter a shell +nix develop -i -c cabal v2-haddock polysemy +nix develop -i -c haskell-language-server-wrapper # start HLS for your IDE +``` + ## *What about performance?* ([TL;DR](#tldr)) Previous versions of this `README` mentioned **the library being** @@ -319,3 +355,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 diff --git a/polysemy.cabal b/polysemy.cabal --- a/polysemy.cabal +++ b/polysemy.cabal @@ -1,222 +1,257 @@ -cabal-version: 2.0 -name: polysemy -version: 1.4.0.0 -license: BSD3 -license-file: LICENSE -copyright: 2019 Sandy Maguire -maintainer: sandy@sandymaguire.me -author: Sandy Maguire -homepage: https://github.com/polysemy-research/polysemy#readme -bug-reports: https://github.com/polysemy-research/polysemy/issues -synopsis: Higher-order, low-boilerplate free monads. -description: - Please see the README on GitHub at +cabal-version: 2.0 -category: Language -build-type: Custom +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: polysemy +version: 1.5.0.0 +synopsis: Higher-order, low-boilerplate free monads. +description: Please see the README on GitHub at +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 Sandy Maguire +license: BSD3 +license-file: LICENSE +build-type: Custom extra-source-files: README.md ChangeLog.md source-repository head - type: git - location: https://github.com/polysemy-research/polysemy + type: git + location: https://github.com/polysemy-research/polysemy custom-setup - setup-depends: - Cabal >=3.0.1.0 && <3.1, - base >=4.9 && <5, - cabal-doctest >=1.0.6 && <1.1 + setup-depends: + Cabal + , 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 - default: False - manual: True + description: Dump HTML for the core generated by GHC during compilation + manual: True + default: False flag error-messages - description: Provide custom error messages - manual: True + description: Provide custom error messages + manual: True + default: True library - exposed-modules: - Polysemy - Polysemy.Async - Polysemy.AtomicState - Polysemy.Bundle - Polysemy.Embed - Polysemy.Embed.Type - Polysemy.Error - Polysemy.Fail - Polysemy.Fail.Type - Polysemy.Final - Polysemy.Fixpoint - Polysemy.Input - Polysemy.Internal - Polysemy.Internal.Bundle - Polysemy.Internal.Combinators - Polysemy.Internal.CustomErrors - Polysemy.Internal.CustomErrors.Redefined - Polysemy.Internal.Fixpoint - Polysemy.Internal.Forklift - Polysemy.Internal.Kind - Polysemy.Internal.NonDet - Polysemy.Internal.Strategy - Polysemy.Internal.Tactics - Polysemy.Internal.TH.Common - Polysemy.Internal.TH.Effect - Polysemy.Internal.Union - Polysemy.Internal.Writer - Polysemy.IO - Polysemy.Law - Polysemy.Membership - Polysemy.NonDet - Polysemy.Output - Polysemy.Reader - Polysemy.Resource - Polysemy.State - Polysemy.State.Law - Polysemy.Tagged - Polysemy.Trace - Polysemy.View - Polysemy.Writer - - hs-source-dirs: src - other-modules: - Polysemy.Internal.PluginLookup - Paths_polysemy - - autogen-modules: Paths_polysemy - default-language: Haskell2010 + exposed-modules: + Polysemy + Polysemy.Async + Polysemy.AtomicState + Polysemy.Bundle + Polysemy.Embed + Polysemy.Embed.Type + Polysemy.Error + Polysemy.Fail + Polysemy.Fail.Type + Polysemy.Final + Polysemy.Fixpoint + Polysemy.Input + Polysemy.Internal + Polysemy.Internal.Bundle + Polysemy.Internal.Combinators + Polysemy.Internal.CustomErrors + Polysemy.Internal.CustomErrors.Redefined + Polysemy.Internal.Fixpoint + Polysemy.Internal.Forklift + Polysemy.Internal.Kind + Polysemy.Internal.NonDet + Polysemy.Internal.Strategy + Polysemy.Internal.Tactics + Polysemy.Internal.TH.Common + Polysemy.Internal.TH.Effect + Polysemy.Internal.Union + Polysemy.Internal.Writer + Polysemy.IO + Polysemy.Law + Polysemy.Membership + Polysemy.NonDet + Polysemy.Output + Polysemy.Reader + Polysemy.Resource + Polysemy.State + Polysemy.State.Law + Polysemy.Tagged + Polysemy.Trace + Polysemy.View + Polysemy.Writer + other-modules: + Polysemy.Internal.PluginLookup + Paths_polysemy + autogen-modules: + Paths_polysemy + hs-source-dirs: + src + default-extensions: + DataKinds + DeriveFunctor + FlexibleContexts + GADTs + LambdaCase + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeOperators + TypeFamilies + UnicodeSyntax + ghc-options: -Wall + build-depends: + QuickCheck >=2.11.3 && <3 + , async >=2.2 && <3 + , base >=4.9 && <5 + , containers >=0.5 && <0.7 + , first-class-families >=0.5.0.0 && <0.9 + , mtl >=2.2.2 && <3 + , stm ==2.* + , syb ==0.7.* + , template-haskell >=2.12.0.0 && <3 + , th-abstraction >=0.3.1.0 && <0.5 + , transformers >=0.5.2.0 && <0.6 + , type-errors >=0.2.0.0 + , type-errors-pretty >=0.0.0.0 && <0.1 + , unagi-chan >=0.4.0.0 && <0.5 + if impl(ghc < 8.6) default-extensions: - DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds - RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications - TypeOperators TypeFamilies UnicodeSyntax - - ghc-options: -Wall + MonadFailDesugaring + TypeInType + if flag(dump-core) + ghc-options: -fplugin=DumpCore -fplugin-opt=DumpCore:core-html build-depends: - QuickCheck >=2.11.3 && <3, - async >=2.2 && <3, - base >=4.9 && <5, - containers >=0.5 && <0.7, - first-class-families >=0.5.0.0 && <0.9, - mtl >=2.2.2 && <3, - stm ==2.*, - syb ==0.7.*, - template-haskell >=2.12.0.0 && <3, - th-abstraction >=0.3.1.0 && <0.5, - transformers >=0.5.2.0 && <0.6, - type-errors >=0.2.0.0 && <0.3, - type-errors-pretty >=0.0.0.0 && <0.1, - unagi-chan >=0.4.0.0 && <0.5 - - if impl(ghc <8.6) - default-extensions: MonadFailDesugaring TypeInType - - if flag(dump-core) - ghc-options: -fplugin=DumpCore -fplugin-opt=DumpCore:core-html - build-depends: dump-core >=0.1.3.2 && <0.2 - - if impl(ghc <8.2.2) - build-depends: unsupported-ghc-version >1 && <1 - - if flag(error-messages) - cpp-options: -DCABAL_SERIOUSLY_CMON_MATE - - else - cpp-options: -DNO_ERROR_MESSAGES + dump-core + if impl(ghc < 8.2.2) + build-depends: + unsupported-ghc-version >1 && <1 + if flag(error-messages) + cpp-options: -DCABAL_SERIOUSLY_CMON_MATE + else + cpp-options: -DNO_ERROR_MESSAGES + default-language: Haskell2010 test-suite polysemy-test - type: exitcode-stdio-1.0 - main-is: Main.hs - build-tool-depends: hspec-discover:hspec-discover >=2.0 - hs-source-dirs: test - other-modules: - AlternativeSpec - AsyncSpec - BracketSpec - DoctestSpec - ErrorSpec - FailSpec - FinalSpec - FixpointSpec - FusionSpec - HigherOrderSpec - InspectorSpec - InterceptSpec - KnownRowSpec - LawsSpec - OutputSpec - ThEffectSpec - TypeErrors - ViewSpec - WriterSpec - Paths_polysemy - Build_doctests - - autogen-modules: Build_doctests - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + AlternativeSpec + AsyncSpec + BracketSpec + DoctestSpec + ErrorSpec + FailSpec + FinalSpec + FixpointSpec + FusionSpec + HigherOrderSpec + InspectorSpec + InterceptSpec + KnownRowSpec + LawsSpec + OutputSpec + TacticsSpec + ThEffectSpec + TypeErrors + ViewSpec + WriterSpec + Paths_polysemy + Build_doctests + autogen-modules: + Build_doctests + hs-source-dirs: + test + default-extensions: + DataKinds + DeriveFunctor + FlexibleContexts + GADTs + LambdaCase + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeOperators + TypeFamilies + UnicodeSyntax + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover >=2.0 + build-depends: + QuickCheck >=2.11.3 && <3 + , async >=2.2 && <3 + , base >=4.9 && <5 + , containers >=0.5 && <0.7 + , doctest >=0.16.0.1 && <0.17 + , first-class-families >=0.5.0.0 && <0.9 + , hspec >=2.6.0 && <3 + , inspection-testing >=0.4.2 && <0.5 + , 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 + , type-errors >=0.2.0.0 + , type-errors-pretty >=0.0.0.0 && <0.1 + , unagi-chan >=0.4.0.0 && <0.5 + if impl(ghc < 8.6) default-extensions: - DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds - RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications - TypeOperators TypeFamilies UnicodeSyntax - - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - QuickCheck >=2.11.3 && <3, - async >=2.2 && <3, - base >=4.9 && <5, - containers >=0.5 && <0.7, - doctest >=0.16.0.1 && <0.17, - first-class-families >=0.5.0.0 && <0.9, - hspec >=2.6.0 && <3, - inspection-testing >=0.4.2 && <0.5, - mtl >=2.2.2 && <3, - polysemy -any, - stm ==2.*, - syb ==0.7.*, - template-haskell >=2.12.0.0 && <3, - th-abstraction >=0.3.1.0 && <0.5, - transformers >=0.5.2.0 && <0.6, - type-errors >=0.2.0.0 && <0.3, - type-errors-pretty >=0.0.0.0 && <0.1, - unagi-chan >=0.4.0.0 && <0.5 - - if impl(ghc <8.6) - default-extensions: MonadFailDesugaring TypeInType + MonadFailDesugaring + TypeInType + default-language: Haskell2010 benchmark polysemy-bench - type: exitcode-stdio-1.0 - main-is: countDown.hs - hs-source-dirs: bench - other-modules: - Poly - Paths_polysemy - - default-language: Haskell2010 + 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 + , type-errors-pretty >=0.0.0.0 && <0.1 + , unagi-chan >=0.4.0.0 && <0.5 + if impl(ghc < 8.6) default-extensions: - DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds - RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications - TypeOperators TypeFamilies UnicodeSyntax - - build-depends: - QuickCheck >=2.11.3 && <3, - async >=2.2 && <3, - base >=4.9 && <5, - containers >=0.5 && <0.7, - criterion >=1.5.6.2 && <1.6, - first-class-families >=0.5.0.0 && <0.9, - free >=5.1.3 && <5.2, - freer-simple >=1.2.1.1 && <1.3, - mtl >=2.2.2 && <2.3, - polysemy -any, - stm ==2.*, - syb ==0.7.*, - template-haskell >=2.12.0.0 && <3, - th-abstraction >=0.3.1.0 && <0.5, - transformers >=0.5.2.0 && <0.6, - type-errors >=0.2.0.0 && <0.3, - type-errors-pretty >=0.0.0.0 && <0.1, - unagi-chan >=0.4.0.0 && <0.5 - - if impl(ghc <8.6) - default-extensions: MonadFailDesugaring TypeInType + MonadFailDesugaring + TypeInType + default-language: Haskell2010 diff --git a/src/Polysemy.hs b/src/Polysemy.hs --- a/src/Polysemy.hs +++ b/src/Polysemy.hs @@ -12,6 +12,7 @@ -- * Type synonyms for user convenience , InterpreterFor + , InterpretersFor -- * Interoperating With Other Monads -- ** Embed @@ -137,6 +138,8 @@ , WithTactics , getInitialStateT , pureT + , runTSimple + , bindTSimple , runT , bindT , getInspectorT diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs --- a/src/Polysemy/Internal.hs +++ b/src/Polysemy/Internal.hs @@ -34,7 +34,9 @@ , usingSem , liftSem , hoistSem + , Append , InterpreterFor + , InterpretersFor , (.@) , (.@@) ) where @@ -579,6 +581,11 @@ {-# INLINE runM #-} +type family Append l r where + Append (a ': l) r = a ': (Append l r) + Append '[] r = r + + ------------------------------------------------------------------------------ -- | Type synonym for interpreters that consume an effect without changing the -- return value. Offered for user convenience. @@ -590,6 +597,12 @@ -- => 'InterpreterFor' Teletype r -- @ type InterpreterFor e r = ∀ a. Sem (e ': r) a -> Sem r a + + +------------------------------------------------------------------------------ +-- | Variant of 'InterpreterFor' that takes a list of effects. +-- @since 1.5.0.0 +type InterpretersFor es r = ∀ a. Sem (Append es r) a -> Sem r a ------------------------------------------------------------------------------ diff --git a/src/Polysemy/Internal/Bundle.hs b/src/Polysemy/Internal/Bundle.hs --- a/src/Polysemy/Internal/Bundle.hs +++ b/src/Polysemy/Internal/Bundle.hs @@ -2,15 +2,15 @@ {-# OPTIONS_HADDOCK not-home #-} -module Polysemy.Internal.Bundle where +module Polysemy.Internal.Bundle ( + module Polysemy.Internal.Bundle, + Append, +) where import Data.Proxy import Polysemy +import Polysemy.Internal (Append) import Polysemy.Internal.Union - -type family Append l r where - Append (a ': l) r = a ': (Append l r) - Append '[] r = r extendMembership :: forall r r' e. ElemOf e r -> ElemOf e (Append r r') extendMembership Here = Here diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs --- a/src/Polysemy/Internal/Combinators.hs +++ b/src/Polysemy/Internal/Combinators.hs @@ -80,12 +80,11 @@ -- already in 'Sem'. -> Sem (e ': r) a -> Sem r a -interpretH f (Sem m) = m $ \u -> +interpretH f (Sem m) = Sem $ \k -> m $ \u -> case decomp u of - Left x -> liftSem $ hoist (interpretH f) x + Left x -> k $ hoist (interpretH f) x Right (Weaving e s d y v) -> do - a <- runTactics s d v $ f e - pure $ y a + fmap y $ usingSem k $ runTactics s d v (interpretH f . d) $ f e {-# INLINE interpretH #-} ------------------------------------------------------------------------------ @@ -166,12 +165,13 @@ -- ^ A natural transformation from the handled effect to the new effect. -> Sem (e1 ': r) a -> Sem (e2 ': r) a -reinterpretH f (Sem m) = Sem $ \k -> m $ \u -> +reinterpretH f sem = Sem $ \k -> runSem sem $ \u -> case decompCoerce u of Left x -> k $ hoist (reinterpretH f) $ x Right (Weaving e s d y v) -> do - a <- usingSem k $ runTactics s (raiseUnder . d) v $ f e - pure $ y a + fmap y $ usingSem k + $ runTactics s (raiseUnder . d) v (reinterpretH f . d) + $ f e {-# INLINE[3] reinterpretH #-} -- TODO(sandy): Make this fuse in with 'stateful' directly. @@ -208,8 +208,9 @@ case decompCoerce u of Left x -> k $ weaken $ hoist (reinterpret2H f) $ x Right (Weaving e s d y v) -> do - a <- usingSem k $ runTactics s (raiseUnder2 . d) v $ f e - pure $ y a + fmap y $ usingSem k + $ runTactics s (raiseUnder2 . d) v (reinterpret2H f . d) + $ f e {-# INLINE[3] reinterpret2H #-} @@ -241,9 +242,10 @@ reinterpret3H f (Sem m) = Sem $ \k -> m $ \u -> case decompCoerce u of Left x -> k . weaken . weaken . hoist (reinterpret3H f) $ x - Right (Weaving e s d y v) -> do - a <- usingSem k $ runTactics s (raiseUnder3 . d) v $ f e - pure $ y a + Right (Weaving e s d y v) -> + fmap y $ usingSem k + $ runTactics s (raiseUnder3 . d) v (reinterpret3H f . d) + $ f e {-# INLINE[3] reinterpret3H #-} @@ -342,7 +344,9 @@ interceptUsingH pr f (Sem m) = Sem $ \k -> m $ \u -> case prjUsing pr u of Just (Weaving e s d y v) -> - usingSem k $ y <$> runTactics s (raise . d) v (f e) + fmap y $ usingSem k + $ runTactics s (raise . d) v (interceptUsingH pr f . d) + $ f e Nothing -> k $ hoist (interceptUsingH pr f) u {-# INLINE interceptUsingH #-} diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs --- a/src/Polysemy/Internal/Tactics.hs +++ b/src/Polysemy/Internal/Tactics.hs @@ -8,7 +8,9 @@ , getInspectorT , Inspector (..) , runT + , runTSimple , bindT + , bindTSimple , pureT , liftT , runTactics @@ -77,9 +79,10 @@ type WithTactics e f m r = Tactics f m (e ': r) ': r data Tactics f n r m a where - GetInitialState :: Tactics f n r m (f ()) - HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b)) - GetInspector :: Tactics f n r m (Inspector f) + GetInitialState :: Tactics f n r m (f ()) + HoistInterpretation :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b)) + HoistInterpretationH :: (a -> n b) -> f a -> Tactics f n r m (f b) + GetInspector :: Tactics f n r m (Inspector f) ------------------------------------------------------------------------------ @@ -146,7 +149,27 @@ pure $ na' istate {-# INLINE runT #-} +------------------------------------------------------------------------------ +-- | Run a monadic action in a 'Tactical' environment. The stateful environment +-- used will be the same one that the effect is initally run in. +-- Use 'bindTSimple' if you'd prefer to explicitly manage your stateful +-- environment. +-- +-- This is a less flexible but significantly simpler variant of 'runT'. +-- Instead of returning a 'Sem' action corresponding to the provided action, +-- 'runTSimple' runs the action immediately. +-- +-- @since 1.5.0.0 +runTSimple :: m a + -- ^ The monadic action to lift. This is usually a parameter in your + -- effect. + -> Tactical e m r a +runTSimple na = do + istate <- getInitialStateT + bindTSimple (const na) istate +{-# INLINE runTSimple #-} + ------------------------------------------------------------------------------ -- | Lift a kleisli action into the stateful environment. You can use -- 'bindT' to get an effect parameter of the form @a -> m b@ into something @@ -163,7 +186,31 @@ bindT f = send $ HoistInterpretation f {-# INLINE bindT #-} +------------------------------------------------------------------------------ +-- | Lift a kleisli action into the stateful environment. +-- You can use 'bindTSimple' to execute an effect parameter of the form +-- @a -> m b@ by providing the result of a `runTSimple` or another +-- `bindTSimple`. +-- +-- This is a less flexible but significantly simpler variant of 'bindT'. +-- Instead of returning a 'Sem' kleisli action corresponding to the +-- provided kleisli action, 'bindTSimple' runs the kleisli action immediately. +-- +-- @since 1.5.0.0 +bindTSimple + :: forall m f r e a b + . (a -> m b) + -- ^ The monadic continuation to lift. This is usually a parameter in + -- your effect. + -- + -- Continuations executed via 'bindTSimple' will run in the same + -- environment which produced the @a@. + -> f a + -> Sem (WithTactics e f m r) (f b) +bindTSimple f s = send @(Tactics _ _ (e ': r)) $ HoistInterpretationH f s +{-# INLINE bindTSimple #-} + ------------------------------------------------------------------------------ -- | Internal function to create first-order interpreter combinators out of -- higher-order ones. @@ -185,15 +232,18 @@ => f () -> (∀ x. f (m x) -> Sem r2 (f x)) -> (∀ x. f x -> Maybe x) + -> (∀ x. f (m x) -> Sem r (f x)) -> Sem (Tactics f m r2 ': r) a -> Sem r a -runTactics s d v (Sem m) = m $ \u -> +runTactics s d v d' (Sem m) = Sem $ \k -> m $ \u -> case decomp u of - Left x -> liftSem $ hoist (runTactics s d v) x + Left x -> k $ hoist (runTactics s d v d') x Right (Weaving GetInitialState s' _ y _) -> pure $ y $ s <$ s' Right (Weaving (HoistInterpretation na) s' _ y _) -> do pure $ y $ (d . fmap na) <$ s' + Right (Weaving (HoistInterpretationH na fa) s' _ y _) -> do + (y . (<$ s')) <$> runSem (d' (fmap na fa)) k Right (Weaving GetInspector s' _ y _) -> do pure $ y $ Inspector v <$ s' {-# INLINE runTactics #-} diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs --- a/src/Polysemy/Resource.hs +++ b/src/Polysemy/Resource.hs @@ -55,7 +55,7 @@ -- -- cf. 'Control.Exception.bracket' and 'Control.Exception.bracket_' -- --- @since TODO +-- @since 1.5.0.0 bracket_ :: Member Resource r => Sem r a -- ^ computation to run first diff --git a/test/TacticsSpec.hs b/test/TacticsSpec.hs new file mode 100644 --- /dev/null +++ b/test/TacticsSpec.hs @@ -0,0 +1,22 @@ +module TacticsSpec where + +import Polysemy +import Polysemy.Internal (send) +import Test.Hspec + +data TestE :: Effect where + TestE :: m a -> (a -> m b) -> TestE m b + +interpretTestE :: InterpreterFor TestE r +interpretTestE = + interpretH $ \case + TestE ma f -> do + a <- runTSimple ma + bindTSimple f a + +spec :: Spec +spec = parallel $ describe "runTH and bindTH" $ do + it "should act as expected" $ do + r <- runM (interpretTestE (send (TestE (pure 5) (pure . (9 +))))) + print r + (14 :: Int) `shouldBe` r