diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/bench/Poly.hs b/bench/Poly.hs deleted file mode 100644 --- a/bench/Poly.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -fwarn-all-missed-specializations #-} - -module Poly where - -import Polysemy -import Polysemy.Error -import Polysemy.Resource -import Polysemy.State -import Polysemy.Input -import Polysemy.Output - - -slowBeforeSpecialization :: Member (State Int) r => Sem r Int -slowBeforeSpecialization = do - n <- get - if n <= 0 - then pure n - else do - put $ n - 1 - slowBeforeSpecialization - -{-# SPECIALIZE slowBeforeSpecialization :: Sem '[State Int] Int #-} - - -countDown :: Int -> Int -countDown s = - fst . run . runState s $ slowBeforeSpecialization - -prog - :: Sem '[ State Bool - , Error Bool - , Resource - , Embed IO - ] Bool -prog = catch @Bool (throw True) (pure . not) - -zoinks :: IO (Either Bool Bool) -zoinks = fmap (fmap snd) - . (runM .@ lowerResource .@@ lowerError) - . runState False - $ prog - -data Console m a where - ReadLine :: Console m String - WriteLine :: String -> Console m () - -makeSem ''Console - -runConsoleBoring :: [String] -> Sem (Console ': r) a -> Sem r ([String], a) -runConsoleBoring inputs - = runOutputMonoid (:[]) - . runInputList inputs - . reinterpret2 - (\case - ReadLine -> maybe "" id <$> input - WriteLine msg -> output msg - ) - diff --git a/bench/countDown.hs b/bench/countDown.hs deleted file mode 100644 --- a/bench/countDown.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-} -module Main (main) where - -import Control.Monad (replicateM_) - -import qualified Control.Monad.Except as MTL -import qualified Control.Monad.State as MTL -import qualified Control.Monad.Free as Free - -import Criterion (bench, bgroup, whnf) -import Criterion.Main (defaultMain) - -import Control.Monad.Freer (Member, Eff, run, send) -import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton) -import Control.Monad.Freer.Error (runError, throwError) -import Control.Monad.Freer.State (get, put, runState) - -import qualified Poly as P - --------------------------------------------------------------------------------- - -- State Benchmarks -- --------------------------------------------------------------------------------- - -oneGet :: Int -> (Int, Int) -oneGet n = run (runState n get) - -oneGetMTL :: Int -> (Int, Int) -oneGetMTL = MTL.runState MTL.get - -countDown :: Int -> (Int, Int) -countDown start = run (runState start go) - where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go) - -countDownMTL :: Int -> (Int, Int) -countDownMTL = MTL.runState go - where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go) - --------------------------------------------------------------------------------- - -- Exception + State -- --------------------------------------------------------------------------------- -countDownExc :: Int -> Either String (Int,Int) -countDownExc start = run $ runError (runState start go) - where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go) - -countDownExcMTL :: Int -> Either String (Int,Int) -countDownExcMTL = MTL.runStateT go - where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go) - --------------------------------------------------------------------------------- - -- Freer: Interpreter -- --------------------------------------------------------------------------------- -data Http out where - Open :: String -> Http () - Close :: Http () - Post :: String -> Http String - Get :: Http String - -open' :: Member Http r => String -> Eff r () -open' = send . Open - -close' :: Member Http r => Eff r () -close' = send Close - -post' :: Member Http r => String -> Eff r String -post' = send . Post - -get' :: Member Http r => Eff r String -get' = send Get - -runHttp :: Eff (Http ': r) w -> Eff r w -runHttp (Val x) = pure x -runHttp (E u q) = case decomp u of - Right (Open _) -> runHttp (qApp q ()) - Right Close -> runHttp (qApp q ()) - Right (Post d) -> runHttp (qApp q d) - Right Get -> runHttp (qApp q "") - Left u' -> E u' (tsingleton (runHttp . qApp q )) - --------------------------------------------------------------------------------- - -- Free: Interpreter -- --------------------------------------------------------------------------------- -data FHttpT x - = FOpen String x - | FClose x - | FPost String (String -> x) - | FGet (String -> x) - deriving Functor - -type FHttp = Free.Free FHttpT - -fopen' :: String -> FHttp () -fopen' s = Free.liftF $ FOpen s () - -fclose' :: FHttp () -fclose' = Free.liftF $ FClose () - -fpost' :: String -> FHttp String -fpost' s = Free.liftF $ FPost s id - -fget' :: FHttp String -fget' = Free.liftF $ FGet id - -runFHttp :: FHttp a -> Maybe a -runFHttp (Free.Pure x) = pure x -runFHttp (Free.Free (FOpen _ n)) = runFHttp n -runFHttp (Free.Free (FClose n)) = runFHttp n -runFHttp (Free.Free (FPost s n)) = pure s >>= runFHttp . n -runFHttp (Free.Free (FGet n)) = pure "" >>= runFHttp . n - --------------------------------------------------------------------------------- - -- Benchmark Suite -- --------------------------------------------------------------------------------- -prog :: Member Http r => Eff r () -prog = open' "cats" >> get' >> post' "cats" >> close' - -prog' :: FHttp () -prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose' - -p :: Member Http r => Int -> Eff r () -p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close' - -p' :: Int -> FHttp () -p' count = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose' - -main :: IO () -main = - defaultMain [ - bgroup "Countdown Bench" [ - bench "discount" $ whnf P.countDown 10000 - , bench "freer-simple" $ whnf countDown 10000 - , bench "mtl" $ whnf countDownMTL 10000 - ] - ] diff --git a/polysemy.cabal b/polysemy.cabal --- a/polysemy.cabal +++ b/polysemy.cabal @@ -1,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 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 diff --git a/src/Polysemy.hs b/src/Polysemy.hs --- a/src/Polysemy.hs +++ b/src/Polysemy.hs @@ -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 diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs --- a/src/Polysemy/Async.hs +++ b/src/Polysemy/Async.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The effect 'Async', providing an interface to "Control.Concurrent.Async" module Polysemy.Async ( -- * Effect Async (..) @@ -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 . --- --- 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" #-} diff --git a/src/Polysemy/AtomicState.hs b/src/Polysemy/AtomicState.hs --- a/src/Polysemy/AtomicState.hs +++ b/src/Polysemy/AtomicState.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} + +-- | Description: The 'AtomicState' effect module Polysemy.AtomicState ( -- * Effect AtomicState (..) @@ -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 () diff --git a/src/Polysemy/Bundle.hs b/src/Polysemy/Bundle.hs --- a/src/Polysemy/Bundle.hs +++ b/src/Polysemy/Bundle.hs @@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Description: The 'Bundle' effect for bundling effects module Polysemy.Bundle ( -- * Effect Bundle (..) diff --git a/src/Polysemy/Embed.hs b/src/Polysemy/Embed.hs --- a/src/Polysemy/Embed.hs +++ b/src/Polysemy/Embed.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for the effect 'Embed' module Polysemy.Embed ( -- * Effect Embed (..) diff --git a/src/Polysemy/Embed/Type.hs b/src/Polysemy/Embed/Type.hs --- a/src/Polysemy/Embed/Type.hs +++ b/src/Polysemy/Embed/Type.hs @@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Embed' effect module Polysemy.Embed.Type ( -- * Effect Embed (..) diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs --- a/src/Polysemy/Error.hs +++ b/src/Polysemy/Error.hs @@ -1,6 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK prune #-} +-- | Description: The effect 'Error' and its interpreters module Polysemy.Error ( -- * Effect Error (..) @@ -23,22 +25,30 @@ , runError , mapError , errorToIOFinal - , lowerError ) where -import qualified Control.Exception as X +import qualified Control.Exception as X import Control.Monad import qualified Control.Monad.Trans.Except as E -import Data.Bifunctor (first) -import Data.Typeable +import Data.Unique (Unique, hashUnique, newUnique) +import GHC.Exts (Any) import Polysemy import Polysemy.Final import Polysemy.Internal import Polysemy.Internal.Union +import Unsafe.Coerce (unsafeCoerce) +------------------------------------------------------------------------------ +-- | This effect abstracts the throwing and catching of errors, leaving +-- it up to the interpreter whether to use exceptions or monad transformers +-- like 'E.ExceptT' to perform the short-circuiting mechanism. data Error e m a where + -- | Short-circuit the current program using the given error value. Throw :: e -> Error e m a + -- | Recover from an error that might have been thrown in the higher-order + -- action given by the first argument by passing the error to the handler + -- given by the second argument. Catch :: ∀ e m a. m a -> (e -> m a) -> Error e m a makeSem ''Error @@ -46,7 +56,7 @@ hush :: Either e a -> Maybe a hush (Right a) = Just a -hush (Left _) = Nothing +hush (Left _) = Nothing ------------------------------------------------------------------------------ @@ -57,7 +67,7 @@ :: Member (Error e) r => Either e a -> Sem r a -fromEither (Left e) = throw e +fromEither (Left e) = throw e fromEither (Right a) = pure a {-# INLINABLE fromEither #-} @@ -105,7 +115,7 @@ fromExceptionVia f m = do r <- embed $ X.try m case r of - Left e -> throw $ f e + Left e -> throw $ f e Right a -> pure a {-# INLINABLE fromExceptionVia #-} @@ -139,7 +149,7 @@ s <- getInitialStateS pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s)) case r of - Left e -> throw $ f e + Left e -> throw $ f e Right a -> pure a {-# INLINABLE fromExceptionSemVia #-} @@ -152,16 +162,16 @@ {-# INLINABLE note #-} ------------------------------------------------------------------------------ --- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@) --- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type --- @e@ was @'throw'@n and its value is @ex@. +-- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@) +-- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type +-- @e@ was @'throw'@n and its value is @ex@. try :: Member (Error e) r => Sem r a -> Sem r (Either e a) try m = catch (Right <$> m) (return . Left) {-# INLINABLE try #-} ------------------------------------------------------------------------------ -- | A variant of @'try'@ that takes an exception predicate to select which exceptions --- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, +-- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, -- it is re-@'throw'@n. tryJust :: Member (Error e) r => (e -> Maybe b) -> Sem r a -> Sem r (Either b a) tryJust f m = do @@ -170,14 +180,14 @@ Right v -> return (Right v) Left e -> case f e of Nothing -> throw e - Just b -> return $ Left b + Just b -> return $ Left b {-# INLINABLE tryJust #-} ------------------------------------------------------------------------------ --- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument --- which is an exception predicate, a function which selects which type of exceptions +-- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument +-- which is an exception predicate, a function which selects which type of exceptions -- we're interested in. -catchJust :: Member (Error e) r +catchJust :: Member (Error e) r => (e -> Maybe b) -- ^ Predicate to select exceptions -> Sem r a -- ^ Computation to run -> (b -> Sem r a) -- ^ Handler @@ -186,7 +196,7 @@ where handler e = case ef e of Nothing -> throw e - Just b -> bf b + Just b -> bf b {-# INLINABLE catchJust #-} ------------------------------------------------------------------------------ @@ -244,14 +254,24 @@ {-# INLINE mapError #-} -newtype WrappedExc e = WrappedExc { unwrapExc :: e } - deriving (Typeable) +data WrappedExc = WrappedExc !Unique Any -instance Typeable e => Show (WrappedExc e) where - show = mappend "WrappedExc: " . show . typeRep +instance Show WrappedExc where + show (WrappedExc uid _) = + "errorToIOFinal: Escaped opaque exception. Unique hash is: " <> + show (hashUnique uid) <> "This should only happen if the computation that " <> + "threw the exception was somehow invoked outside of the argument of 'errorToIOFinal'; " <> + "for example, if you 'async' an exceptional computation inside of the argument " <> + "provided to 'errorToIOFinal', and then 'await' on it *outside* of the argument " <> + "provided to 'errorToIOFinal'. If that or any similar shenanigans seems unlikely, " <> + "please open an issue on the GitHub repository." -instance (Typeable e) => X.Exception (WrappedExc e) +instance X.Exception WrappedExc +catchWithUid :: forall e a. Unique -> IO a -> (e -> IO a) -> IO a +catchWithUid uid m h = X.catch m $ \exc@(WrappedExc uid' e) -> + if uid == uid' then h (unsafeCoerce e) else X.throwIO exc +{-# INLINE catchWithUid #-} ------------------------------------------------------------------------------ -- | Run an 'Error' effect as an 'IO' 'X.Exception' through final 'IO'. This @@ -263,77 +283,31 @@ -- -- @since 1.2.0.0 errorToIOFinal - :: ( Typeable e - , Member (Final IO) r + :: forall e r a + . ( Member (Final IO) r ) => Sem (Error e ': r) a -> Sem r (Either e a) errorToIOFinal sem = withStrategicToFinal @IO $ do - m' <- runS (runErrorAsExcFinal sem) + m' <- bindS (`runErrorAsExcFinal` sem) s <- getInitialStateS - pure $ - either - ((<$ s) . Left . unwrapExc) - (fmap Right) - <$> X.try m' + pure $ do + uid <- newUnique + catchWithUid @e uid (fmap Right <$> m' (uid <$ s)) (pure . (<$ s) . Left) {-# INLINE errorToIOFinal #-} runErrorAsExcFinal :: forall e r a - . ( Typeable e - , Member (Final IO) r + . ( Member (Final IO) r ) - => Sem (Error e ': r) a + => Unique + -> Sem (Error e ': r) a -> Sem r a -runErrorAsExcFinal = interpretFinal $ \case - Throw e -> pure $ X.throwIO $ WrappedExc e +runErrorAsExcFinal uid = interpretFinal $ \case + Throw e -> pure $ X.throwIO $ WrappedExc uid (unsafeCoerce e) Catch m h -> do m' <- runS m h' <- bindS h s <- getInitialStateS - pure $ X.catch m' $ \(se :: WrappedExc e) -> - h' (unwrapExc se <$ s) + pure $ catchWithUid uid m' $ \e -> h' (e <$ s) {-# INLINE runErrorAsExcFinal #-} - ------------------------------------------------------------------------------- --- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is --- significantly faster than 'runError', at the cost of being less flexible. --- --- @since 1.0.0.0 -lowerError - :: ( Typeable e - , Member (Embed IO) r - ) - => (∀ x. Sem r x -> IO x) - -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is - -- likely some combination of 'runM' and other interpreters composed via - -- '.@'. - -> Sem (Error e ': r) a - -> Sem r (Either e a) -lowerError lower - = embed - . fmap (first unwrapExc) - . X.try - . (lower .@ runErrorAsExc) -{-# INLINE lowerError #-} -{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-} - - --- TODO(sandy): Can we use the new withLowerToIO machinery for this? -runErrorAsExc - :: forall e r a. ( Typeable e - , Member (Embed IO) r - ) - => (∀ x. Sem r x -> IO x) - -> Sem (Error e ': r) a - -> Sem r a -runErrorAsExc lower = interpretH $ \case - Throw e -> embed $ X.throwIO $ WrappedExc e - Catch main handle -> do - is <- getInitialStateT - m <- runT main - h <- bindT handle - let runIt = lower . runErrorAsExc lower - embed $ X.catch (runIt m) $ \(se :: WrappedExc e) -> - runIt $ h $ unwrapExc se <$ is -{-# INLINE runErrorAsExc #-} diff --git a/src/Polysemy/Fail.hs b/src/Polysemy/Fail.hs --- a/src/Polysemy/Fail.hs +++ b/src/Polysemy/Fail.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: 'Fail' interpreters module Polysemy.Fail ( -- * Effect Fail(..) diff --git a/src/Polysemy/Fail/Type.hs b/src/Polysemy/Fail/Type.hs --- a/src/Polysemy/Fail/Type.hs +++ b/src/Polysemy/Fail/Type.hs @@ -1,3 +1,11 @@ +-- | Description: 'Fail' effect module Polysemy.Fail.Type where +------------------------------------------------------------------------------ +-- | This effect abstracts the concept of 'Control.Monad.Fail.MonadFail', +-- which is a built-in mechanism that converts pattern matching errors to +-- calls to the current monad's instance of that class. +-- +-- The instance defined in "Polysemy.Internal" uses this effect to catch +-- those errors. newtype Fail m a = Fail String diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs --- a/src/Polysemy/Final.hs +++ b/src/Polysemy/Final.hs @@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} + +-- | Description: The effect 'Final' that allows embedding higher-order actions in +-- the final target monad of the effect stack module Polysemy.Final ( -- * Effect diff --git a/src/Polysemy/Fixpoint.hs b/src/Polysemy/Fixpoint.hs --- a/src/Polysemy/Fixpoint.hs +++ b/src/Polysemy/Fixpoint.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-} +-- | Description: Interpreters for 'Fixpoint' module Polysemy.Fixpoint ( -- * Effect Fixpoint (..) @@ -73,45 +74,3 @@ fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s {-# INLINE fixpointToFinal #-} ------------------------------------------------------------------------------- --- | Run a 'Fixpoint' effect purely. --- --- __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'. -runFixpoint - :: (∀ x. Sem r x -> x) - -> Sem (Fixpoint ': r) a - -> Sem r a -runFixpoint lower = interpretH $ \case - Fixpoint mf -> do - c <- bindT mf - s <- getInitialStateT - ins <- getInspectorT - pure $ fix $ \fa -> - lower . runFixpoint lower . c $ - fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s -{-# INLINE runFixpoint #-} -{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \ - \'Data.Functor.Identity.Identity' instead" #-} - - ------------------------------------------------------------------------------- --- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance. --- --- __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'. -runFixpointM - :: ( MonadFix m - , Member (Embed m) r - ) - => (∀ x. Sem r x -> m x) - -> Sem (Fixpoint ': r) a - -> Sem r a -runFixpointM lower = interpretH $ \case - Fixpoint mf -> do - c <- bindT mf - s <- getInitialStateT - ins <- getInspectorT - embed $ mfix $ \fa -> - lower . runFixpointM lower . c $ - fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s -{-# INLINE runFixpointM #-} -{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-} diff --git a/src/Polysemy/IO.hs b/src/Polysemy/IO.hs --- a/src/Polysemy/IO.hs +++ b/src/Polysemy/IO.hs @@ -1,20 +1,18 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: Compatibility with 'MonadIO' module Polysemy.IO ( -- * Interpretations embedToMonadIO - , lowerEmbedded ) where import Control.Monad.IO.Class import Polysemy import Polysemy.Embed -import Polysemy.Internal -import Polysemy.Internal.Union ------------------------------------------------------------------------------ --- The 'MonadIO' class is conceptually an interpretation of 'IO' to some +-- | The 'MonadIO' class is conceptually an interpretation of 'IO' to some -- other monad. This function reifies that intuition, by transforming an 'IO' -- effect into some other 'MonadIO'. -- @@ -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) diff --git a/src/Polysemy/Input.hs b/src/Polysemy/Input.hs --- a/src/Polysemy/Input.hs +++ b/src/Polysemy/Input.hs @@ -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 diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs --- a/src/Polysemy/Internal.hs +++ b/src/Polysemy/Internal.hs @@ -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 --- . --- --- 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 .@@ 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,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 diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs --- a/src/Polysemy/Internal/Combinators.hs +++ b/src/Polysemy/Internal/Combinators.hs @@ -2,6 +2,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The basic interpreter-building combinators module Polysemy.Internal.Combinators ( -- * First order interpret @@ -18,6 +19,7 @@ , reinterpretH , reinterpret2H , reinterpret3H + , interpretWeaving -- * Conditional , interceptUsing @@ -28,6 +30,7 @@ , lazilyStateful ) where +import Control.Arrow ((>>>)) import Control.Monad import qualified Control.Monad.Trans.State.Lazy as LS import qualified Control.Monad.Trans.State.Strict as S @@ -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 diff --git a/src/Polysemy/Internal/CustomErrors.hs b/src/Polysemy/Internal/CustomErrors.hs --- a/src/Polysemy/Internal/CustomErrors.hs +++ b/src/Polysemy/Internal/CustomErrors.hs @@ -4,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 diff --git a/src/Polysemy/Internal/CustomErrors/Redefined.hs b/src/Polysemy/Internal/CustomErrors/Redefined.hs --- a/src/Polysemy/Internal/CustomErrors/Redefined.hs +++ b/src/Polysemy/Internal/CustomErrors/Redefined.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_HADDOCK prune #-} ------------------------------------------------------------------------------ -- | This code is copied verbatim from 'Type.Errors' due to limitations in the diff --git a/src/Polysemy/Internal/Fixpoint.hs b/src/Polysemy/Internal/Fixpoint.hs --- a/src/Polysemy/Internal/Fixpoint.hs +++ b/src/Polysemy/Internal/Fixpoint.hs @@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Fixpoint' effect module Polysemy.Internal.Fixpoint where ------------------------------------------------------------------------------ diff --git a/src/Polysemy/Internal/Forklift.hs b/src/Polysemy/Internal/Forklift.hs deleted file mode 100644 --- a/src/Polysemy/Internal/Forklift.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE NumDecimals #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_HADDOCK not-home #-} - -module Polysemy.Internal.Forklift where - -import qualified Control.Concurrent.Async as A -import Control.Concurrent.Chan.Unagi -import Control.Concurrent.MVar -import Control.Exception -import Polysemy.Internal -import Polysemy.Internal.Union - - ------------------------------------------------------------------------------- --- | A promise for interpreting an effect of the union @r@ in another thread. --- --- @since 0.5.0.0 -data Forklift r = forall a. Forklift - { responseMVar :: MVar a - , request :: Union r (Sem r) a - } - - ------------------------------------------------------------------------------- --- | A strategy for automatically interpreting an entire stack of effects by --- just shipping them off to some other interpretation context. --- --- @since 0.5.0.0 -runViaForklift - :: Member (Embed IO) r - => InChan (Forklift r) - -> Sem r a - -> IO a -runViaForklift chan = usingSem $ \u -> do - case prj u of - Just (Weaving (Embed m) s _ ex _) -> - ex . (<$ s) <$> m - _ -> do - mvar <- newEmptyMVar - writeChan chan $ Forklift mvar u - takeMVar mvar -{-# INLINE runViaForklift #-} - - - ------------------------------------------------------------------------------- --- | Run an effect stack all the way down to 'IO' by running it in a new --- thread, and temporarily turning the current thread into an event poll. --- --- This function creates a thread, and so should be compiled with @-threaded@. --- --- @since 0.5.0.0 -withLowerToIO - :: Member (Embed IO) r - => ((forall x. Sem r x -> IO x) -> IO () -> IO a) - -- ^ A lambda that takes the lowering function, and a finalizing 'IO' - -- action to mark a the forked thread as being complete. The finalizing - -- action need not be called. - -> Sem r a -withLowerToIO action = do - (inchan, outchan) <- embed newChan - signal <- embed newEmptyMVar - - res <- embed $ A.async $ do - a <- action (runViaForklift inchan) - (putMVar signal ()) - `finally` (putMVar signal ()) - pure a - - let me = do - raced <- embed $ A.race (takeMVar signal) $ readChan outchan - case raced of - Left () -> embed $ A.wait res - Right (Forklift mvar req) -> do - resp <- liftSem req - embed $ putMVar mvar $ resp - me_b - {-# INLINE me #-} - - me_b = me - {-# NOINLINE me_b #-} - - me - diff --git a/src/Polysemy/Internal/Index.hs b/src/Polysemy/Internal/Index.hs --- a/src/Polysemy/Internal/Index.hs +++ b/src/Polysemy/Internal/Index.hs @@ -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) diff --git a/src/Polysemy/Internal/Kind.hs b/src/Polysemy/Internal/Kind.hs --- a/src/Polysemy/Internal/Kind.hs +++ b/src/Polysemy/Internal/Kind.hs @@ -1,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 diff --git a/src/Polysemy/Internal/NonDet.hs b/src/Polysemy/Internal/NonDet.hs --- a/src/Polysemy/Internal/NonDet.hs +++ b/src/Polysemy/Internal/NonDet.hs @@ -4,6 +4,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The 'NonDet' effect module Polysemy.Internal.NonDet where diff --git a/src/Polysemy/Internal/Scoped.hs b/src/Polysemy/Internal/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Scoped.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Description: The meta-effect 'Scoped' +module Polysemy.Internal.Scoped where + +import Data.Kind (Type) + +import Polysemy + +-- | @Scoped@ transforms a program so that an interpreter for @effect@ may +-- perform arbitrary actions, like resource management, before and after the +-- computation wrapped by a call to 'scoped' is executed. +-- +-- An application for this is @Polysemy.Conc.Events@ from +-- , in which each program +-- using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of +-- the event channel; or a database transaction, in which a transaction handle +-- is created for the wrapped program and passed to the interpreter for the +-- database effect. +-- +-- For a longer exposition, see . +-- Note that the interface has changed since the blog post was published: The +-- @resource@ parameter no longer exists. +-- +-- Resource allocation is performed by a function passed to +-- 'Polysemy.Scoped.interpretScoped'. +-- +-- The constructors are not intended to be used directly; the smart constructor +-- 'scoped' is used like a local interpreter for @effect@. 'scoped' takes an +-- argument of type @param@, which will be passed through to the interpreter, to +-- be used by the resource allocation function. +-- +-- As an example, imagine an effect for writing lines to a file: +-- +-- > data Write :: Effect where +-- > Write :: Text -> Write m () +-- > makeSem ''Write +-- +-- If we now have the following requirements: +-- +-- 1. The file should be opened and closed right before and after the part of +-- the program in which we write lines +-- 2. The file name should be specifiable at the point in the program where +-- writing begins +-- 3. We don't want to commit to IO, lines should be stored in memory when +-- running tests +-- +-- Then we can take advantage of 'Scoped' to write this program: +-- +-- > prog :: Member (Scoped FilePath Write) r => Sem r () +-- > prog = do +-- > scoped "file1.txt" do +-- > write "line 1" +-- > write "line 2" +-- > scoped "file2.txt" do +-- > write "line 1" +-- > write "line 2" +-- +-- Here 'scoped' creates a prompt for an interpreter to start allocating a +-- resource for @"file1.txt"@ and handling @Write@ actions using that resource. +-- When the 'scoped' block ends, the resource should be freed. +-- +-- The interpreter may look like this: +-- +-- > interpretWriteFile :: Members '[Resource, Embed IO] => InterpreterFor (Scoped FilePath Write) r +-- > interpretWriteFile = +-- > interpretScoped allocator handler +-- > where +-- > allocator name use = bracket (openFile name WriteMode) hClose use +-- > handler fileHandle (Write line) = embed (Text.hPutStrLn fileHandle line) +-- +-- Essentially, the @bracket@ is executed at the point where @scoped@ was +-- called, wrapping the following block. When the second @scoped@ is executed, +-- another call to @bracket@ is performed. +-- +-- The effect of this is that the operation that uses @Embed IO@ was moved from +-- the call site to the interpreter, while the interpreter may be executed at +-- the outermost layer of the app. +-- +-- This makes it possible to use a pure interpreter for testing: +-- +-- > interpretWriteOutput :: Member (Output (FilePath, Text)) r => InterpreterFor (Scoped FilePath Write) r +-- > interpretWriteOutput = +-- > interpretScoped (\ name use -> use name) \ name -> \case +-- > Write line -> output (name, line) +-- +-- Here we simply pass the name to the interpreter in the resource allocation +-- function. +-- +-- Now imagine that we drop requirement 2 from the initial list – we still want +-- the file to be opened and closed as late/early as possible, but the file name +-- is globally fixed. For this case, the @param@ type is unused, and the API +-- provides some convenience aliases to make your code more concise: +-- +-- > prog :: Member (Scoped_ Write) r => Sem r () +-- > prog = do +-- > scoped_ do +-- > write "line 1" +-- > write "line 2" +-- > scoped_ do +-- > write "line 1" +-- > write "line 2" +-- +-- The type 'Scoped_' and the constructor 'scoped_' simply fix @param@ to @()@. +data Scoped (param :: Type) (effect :: Effect) :: Effect where + Run :: ∀ param effect m a . Word -> effect m a -> Scoped param effect m a + InScope :: ∀ param effect m a . param -> (Word -> m a) -> Scoped param effect m a + +-- | An auxiliary effect for 'Scoped'. +data OuterRun (effect :: Effect) :: Effect where + OuterRun :: ∀ effect m a . Word -> effect m a -> OuterRun effect m a + +-- |A convenience alias for a scope without parameters. +type Scoped_ effect = + Scoped () effect + +-- | Constructor for 'Scoped', taking a nested program and transforming all +-- instances of @effect@ to @'Scoped' param effect@. +-- +-- Please consult the documentation of 'Scoped' for details and examples. +scoped :: + ∀ param effect r . + Member (Scoped param effect) r => + param -> + InterpreterFor effect r +scoped param main = + send $ InScope @param @effect param $ \w -> + transform @effect (Run @param w) main +{-# inline scoped #-} + +-- | Constructor for 'Scoped_', taking a nested program and transforming all +-- instances of @effect@ to @'Scoped_' effect@. +-- +-- Please consult the documentation of 'Scoped' for details and examples. +scoped_ :: + ∀ effect r . + Member (Scoped_ effect) r => + InterpreterFor effect r +scoped_ = scoped () +{-# inline scoped_ #-} + +-- | Transform the parameters of a 'Scoped' program. +-- +-- This allows incremental additions to the data passed to the interpreter, for +-- example to create an API that permits different ways of running an effect +-- with some fundamental parameters being supplied at scope creation and some +-- optional or specific parameters being selected by the user downstream. +rescope :: + ∀ param0 param1 effect r . + Member (Scoped param1 effect) r => + (param0 -> param1) -> + InterpreterFor (Scoped param0 effect) r +rescope fp = + transform \case + Run w e -> Run @param1 w e + InScope p main -> InScope (fp p) main +{-# inline rescope #-} + diff --git a/src/Polysemy/Internal/Sing.hs b/src/Polysemy/Internal/Sing.hs --- a/src/Polysemy/Internal/Sing.hs +++ b/src/Polysemy/Internal/Sing.hs @@ -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 diff --git a/src/Polysemy/Internal/Strategy.hs b/src/Polysemy/Internal/Strategy.hs --- a/src/Polysemy/Internal/Strategy.hs +++ b/src/Polysemy/Internal/Strategy.hs @@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The auxiliary effect 'Strategy' used for building interpreters +-- that embed 'Sem's in 'IO' callbacks module Polysemy.Internal.Strategy where import Polysemy.Internal @@ -7,7 +9,8 @@ import Polysemy.Internal.Tactics (Inspector(..)) - +------------------------------------------------------------------------------ +-- | See 'Strategic'. data Strategy m f n z a where GetInitialState :: Strategy m f n z (f ()) HoistInterpretation :: (a -> n b) -> Strategy m f n z (f a -> m (f b)) diff --git a/src/Polysemy/Internal/TH/Common.hs b/src/Polysemy/Internal/TH/Common.hs --- a/src/Polysemy/Internal/TH/Common.hs +++ b/src/Polysemy/Internal/TH/Common.hs @@ -4,8 +4,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: TH utilities for generating effect constructors module Polysemy.Internal.TH.Common ( ConLiftInfo (..) , getEffectMetadata @@ -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"] diff --git a/src/Polysemy/Internal/TH/Effect.hs b/src/Polysemy/Internal/TH/Effect.hs --- a/src/Polysemy/Internal/TH/Effect.hs +++ b/src/Polysemy/Internal/TH/Effect.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS_HADDOCK not-home #-} -- | This module provides Template Haskell functions for automatically generating --- effect operation functions (that is, functions that use 'send') from a given +-- effect operation functions (that is, functions that use 'Polysemy.send') from a given -- effect algebra. For example, using the @FileSystem@ effect from the example in -- the module documentation for "Polysemy", we can write the following: -- @@ -18,11 +18,11 @@ -- This will automatically generate (approximately) the following functions: -- -- @ --- readFile :: 'Member' FileSystem r => 'FilePath' -> 'Sem' r 'String' --- readFile a = 'send' (ReadFile a) +-- readFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'Polysemy.Sem' r 'String' +-- readFile a = 'Polysemy.send' (ReadFile a) -- --- writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Sem' r () --- writeFile a b = 'send' (WriteFile a b) +-- writeFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'String' -> 'Polysemy.Sem' r () +-- writeFile a b = 'Polysemy.send' (WriteFile a b) -- @ module Polysemy.Internal.TH.Effect ( makeSem @@ -31,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) diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs --- a/src/Polysemy/Internal/Tactics.hs +++ b/src/Polysemy/Internal/Tactics.hs @@ -2,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)) diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs --- a/src/Polysemy/Internal/Union.hs +++ b/src/Polysemy/Internal/Union.hs @@ -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 #-} diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs --- a/src/Polysemy/Internal/Writer.hs +++ b/src/Polysemy/Internal/Writer.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, TemplateHaskell, TupleSections #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_HADDOCK not-home, prune #-} + +-- | Description: The 'Writer' effect module Polysemy.Internal.Writer where import Control.Concurrent.STM @@ -20,8 +22,11 @@ ------------------------------------------------------------------------------ -- | An effect capable of emitting and intercepting messages. data Writer o m a where + -- | Write a message to the log. Tell :: o -> Writer o m () + -- | Return the log produced by the higher-order action. Listen :: ∀ o m a. m a -> Writer o m (o, a) + -- | Run the given action and apply the function it returns to the log. Pass :: m (o -> o, a) -> Writer o m a makeSem ''Writer @@ -148,8 +153,8 @@ -> o -> STM () writeListen tvar switch = \o -> do - alreadyCommited <- readTVar switch - unless alreadyCommited $ do + alreadyCommitted <- readTVar switch + unless alreadyCommitted $ do s <- readTVar tvar writeTVar tvar $! s <> o write o @@ -184,8 +189,8 @@ o <- readTVar tvar let !o' = f o -- Likely redundant, but doesn't hurt. - alreadyCommited <- readTVar switch - unless alreadyCommited $ + alreadyCommitted <- readTVar switch + unless alreadyCommitted $ write o' writeTVar switch True {-# INLINE commitPass #-} diff --git a/src/Polysemy/Law.hs b/src/Polysemy/Law.hs deleted file mode 100644 --- a/src/Polysemy/Law.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} - -#if __GLASGOW_HASKELL__ < 806 --- There is a bug in older versions of Haddock that don't allow documentation --- on GADT arguments. -#define HADDOCK -- -#else -#define HADDOCK -- ^ -#endif - -module Polysemy.Law - ( Law (..) - , runLaw - , MakeLaw (..) - , Citizen (..) - , printf - , module Test.QuickCheck - ) where - -import Control.Arrow (first) -import Data.Char -import Polysemy -import Test.QuickCheck - - ------------------------------------------------------------------------------- --- | Associates the name @r@ with the eventual type @a@. For example, --- @'Citizen' (String -> Bool) Bool@ can produce arbitrary @Bool@s by calling --- the given function with arbitrary @String@s. -class Citizen r a | r -> a where - -- | Generate two @a@s via two @r@s. Additionally, produce a list of strings - -- corresponding to any arbitrary arguments we needed to build. - getCitizen :: r -> r -> Gen ([String], (a, a)) - -instance {-# OVERLAPPING #-} Citizen (Sem r a -> b) (Sem r a -> b) where - getCitizen r1 r2 = pure ([], (r1, r2)) - -instance Citizen (Sem r a) (Sem r a) where - getCitizen r1 r2 = pure ([], (r1, r2)) - -instance (Arbitrary a, Show a, Citizen b r) => Citizen (a -> b) r where - getCitizen f1 f2 = do - a <- arbitrary - first (show a :) <$> getCitizen (f1 a) (f2 a) - - ------------------------------------------------------------------------------- --- | A law that effect @e@ must satisfy whenever it is in environment @r@. You --- can use 'runLaw' to transform these 'Law's into QuickCheck-able 'Property's. -data Law e r where - -- | A pure 'Law', that doesn't require any access to 'IO'. - Law - :: ( Eq a - , Show a - , Citizen i12n (Sem r x -> a) - , Citizen res (Sem (e ': r) x) - ) - => i12n - HADDOCK An interpretation from @'Sem' r x@ down to a pure value. This is - -- likely 'run'. - -> String - HADDOCK A string representation of the left-hand of the rule. This is - -- a formatted string, for more details, refer to 'printf'. - -> res - HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@, - -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this - -- is a function type, it's guaranteed to be called with the same - -- arguments that the right-handed side was called with. - -> String - HADDOCK A string representation of the right-hand of the rule. This is - -- a formatted string, for more details, refer to 'printf'. - -> res - HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@, - -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this - -- is a function type, it's guaranteed to be called with the same - -- arguments that the left-handed side was called with. - -> Law e r - -- | Like 'Law', but for 'IO'-accessing effects. - LawIO - :: ( Eq a - , Show a - , Citizen i12n (Sem r x -> IO a) - , Citizen res (Sem (e ': r) x) - ) - => i12n - HADDOCK An interpretation from @'Sem' r x@ down to an 'IO' value. This is - -- likely 'runM'. - -> String - HADDOCK A string representation of the left-hand of the rule. This is - -- a formatted string, for more details, refer to 'printf'. - -> res - HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@, - -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this - -- is a function type, it's guaranteed to be called with the same - -- arguments that the right-handed side was called with. - -> String - HADDOCK A string representation of the right-hand of the rule. This is - -- a formatted string, for more details, refer to 'printf'. - -> res - HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@, - -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this - -- is a function type, it's guaranteed to be called with the same - -- arguments that the left-handed side was called with. - -> Law e r - - ------------------------------------------------------------------------------- --- | A typeclass that provides the smart constructor 'mkLaw'. -class MakeLaw e r where - -- | A smart constructor for building 'Law's. - mkLaw - :: (Eq a, Show a, Citizen res (Sem (e ': r) a)) - => String - -> res - -> String - -> res - -> Law e r - -instance MakeLaw e '[] where - mkLaw = Law run - -instance MakeLaw e '[Embed IO] where - mkLaw = LawIO runM - - ------------------------------------------------------------------------------- --- | Produces a QuickCheck-able 'Property' corresponding to whether the given --- interpreter satisfies the 'Law'. -runLaw :: InterpreterFor e r -> Law e r -> Property -runLaw i12n (Law finish str1 a str2 b) = property $ do - (_, (lower, _)) <- getCitizen finish finish - (args, (ma, mb)) <- getCitizen a b - let run_it = lower . i12n - a' = run_it ma - b' = run_it mb - pure $ - counterexample - (mkCounterexampleString str1 a' str2 b' args) - (a' == b') -runLaw i12n (LawIO finish str1 a str2 b) = property $ do - (_, (lower, _)) <- getCitizen finish finish - (args, (ma, mb)) <- getCitizen a b - let run_it = lower . i12n - pure $ ioProperty $ do - a' <- run_it ma - b' <- run_it mb - pure $ - counterexample - (mkCounterexampleString str1 a' str2 b' args) - (a' == b') - - ------------------------------------------------------------------------------- --- | Make a string representation for a failing 'runLaw' property. -mkCounterexampleString - :: Show a - => String - -> a - -> String - -> a - -> [String] - -> String -mkCounterexampleString str1 a str2 b args = - mconcat - [ printf str1 args , " (result: " , show a , ")\n /= \n" - , printf str2 args , " (result: " , show b , ")" - ] - - ------------------------------------------------------------------------------- --- | A bare-boned implementation of printf. This function will replace tokens --- of the form @"%n"@ in the first string with @args !! n@. --- --- This will only work for indexes up to 9. --- --- For example: --- --- >>> printf "hello %1 %2% %3 %1" ["world", "50"] --- "hello world 50% %3 world" -printf :: String -> [String] -> String -printf str args = splitArgs str - where - splitArgs :: String -> String - splitArgs s = - case break (== '%') s of - (as, "") -> as - (as, _ : b : bs) - | isDigit b - , let d = read [b] - 1 - , d < length args - -> as ++ (args !! d) ++ splitArgs bs - (as, _ : bs) -> as ++ "%" ++ splitArgs bs - diff --git a/src/Polysemy/Membership.hs b/src/Polysemy/Membership.hs --- a/src/Polysemy/Membership.hs +++ b/src/Polysemy/Membership.hs @@ -1,3 +1,4 @@ +-- | Description: Reexports of membership related functionality module Polysemy.Membership ( -- * Witnesses ElemOf (..) diff --git a/src/Polysemy/NonDet.hs b/src/Polysemy/NonDet.hs --- a/src/Polysemy/NonDet.hs +++ b/src/Polysemy/NonDet.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for 'NonDet' module Polysemy.NonDet ( -- * Effect NonDet (..) diff --git a/src/Polysemy/Opaque.hs b/src/Polysemy/Opaque.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Opaque.hs @@ -0,0 +1,54 @@ +-- | The auxiliary effect 'Opaque' used by interpreters of 'Polysemy.Scoped.Scoped' +module Polysemy.Opaque ( + -- * Effect + Opaque(..), + + -- * Interpreters + toOpaque, + fromOpaque, + ) where + +import Polysemy + +-- | An effect newtype meant to be used to wrap polymorphic effect variables to +-- prevent them from jamming up resolution of 'Polysemy.Member'. +-- For example, consider: +-- +-- @ +-- badPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) () +-- badPut = 'Polysemy.State.put' () -- error +-- @ +-- +-- This fails to compile. This is because @e@ /could/ be +-- @'Polysemy.State.State' ()@' -- in which case the 'Polysemy.State.put' +-- should target it instead of the concretely provided +-- @'Polysemy.State.State' ()@; as the compiler can't know for sure which effect +-- should be targeted, the program is rejected. +-- There are various ways to resolve this, including using 'raise' or +-- 'Polysemy.Membership.subsumeUsing'. 'Opaque' provides another way: +-- +-- @ +-- okPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) () +-- okPut = 'fromOpaque' ('Polysemy.State.put' ()) -- OK +-- @ +-- +-- 'Opaque' is most useful as a tool for library writers, in the case where some +-- function of the library requires the user to work with an effect stack +-- containing some polymorphic effect variables. By wrapping the polymorphic +-- effect variables using 'Opaque', users of the function can use effects as +-- normal, without having to use 'raise' or 'Polysemy.Membership.subsumeUsing' +-- in order to have 'Polysemy.Member' resolve. The various interpreters of +-- 'Polysemy.Scoped.Scoped' are examples of such usage of 'Opaque'. +-- +-- @since 1.9.0.0 +newtype Opaque (e :: Effect) m a = Opaque (e m a) + +-- | Wrap 'Opaque' around the top effect of the effect stack +toOpaque :: Sem (e ': r) a -> Sem (Opaque e ': r) a +toOpaque = rewrite Opaque +{-# INLINE toOpaque #-} + +-- | Unwrap 'Opaque' around the top effect of the effect stack +fromOpaque :: Sem (Opaque e ': r) a -> Sem (e ': r) a +fromOpaque = rewrite (\(Opaque e) -> e) +{-# INLINE fromOpaque #-} diff --git a/src/Polysemy/Output.hs b/src/Polysemy/Output.hs --- a/src/Polysemy/Output.hs +++ b/src/Polysemy/Output.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, TemplateHaskell #-} +-- | Description: The 'Output' effect for sending side-effecting messages module Polysemy.Output ( -- * Effect Output (..) @@ -41,6 +42,7 @@ -- | An effect capable of sending messages. Useful for streaming output and for -- logging. data Output o m a where + -- | Output a message. Output :: o -> Output o m () makeSem ''Output diff --git a/src/Polysemy/Reader.hs b/src/Polysemy/Reader.hs --- a/src/Polysemy/Reader.hs +++ b/src/Polysemy/Reader.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Reader' effect and its interpreters module Polysemy.Reader ( -- * Effect Reader (..) @@ -23,12 +24,16 @@ ------------------------------------------------------------------------------ -- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'. data Reader i m a where + -- | Get the environment. Ask :: Reader i m i + -- | Transform the environment. Local :: (i -> i) -> m a -> Reader i m a makeSem ''Reader +------------------------------------------------------------------------------ +-- | Apply a function to the environment and return the result. asks :: forall i j r. Member (Reader i) r => (i -> j) -> Sem r j asks f = f <$> ask {-# INLINABLE asks #-} diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs --- a/src/Polysemy/Resource.hs +++ b/src/Polysemy/Resource.hs @@ -1,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 #-} diff --git a/src/Polysemy/Scoped.hs b/src/Polysemy/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Scoped.hs @@ -0,0 +1,329 @@ +{-# language AllowAmbiguousTypes, BangPatterns #-} + +-- | Description: Interpreters for 'Scoped' +module Polysemy.Scoped ( + -- * Effect + Scoped, + Scoped_, + + -- * Constructors + scoped, + scoped_, + rescope, + + -- * Interpreters + runScopedNew, + interpretScopedH, + interpretScopedH', + interpretScoped, + interpretScopedAs, + interpretScopedWithH, + interpretScopedWith, + interpretScopedWith_, + runScoped, + runScopedAs, +) where + +import Data.Function ((&)) +import Data.Sequence (Seq(..)) +import qualified Data.Sequence as S + +import Polysemy.Opaque +import Polysemy.Internal +import Polysemy.Internal.Sing +import Polysemy.Internal.Union +import Polysemy.Internal.Combinators +import Polysemy.Internal.Scoped +import Polysemy.Internal.Tactics + +-- | Construct an interpreter for a higher-order effect wrapped in a 'Scoped', +-- given a resource allocation function and a parameterized handler for the +-- plain effect. +-- +-- This combinator is analogous to 'interpretH' in that it allows the handler to +-- use the 'Tactical' environment and transforms the effect into other effects +-- on the stack. +interpretScopedH :: + ∀ resource param effect r . + -- | A callback function that allows the user to acquire a resource for each + -- computation wrapped by 'scoped' using other effects, with an additional + -- argument that contains the call site parameter passed to 'scoped'. + (∀ q x . param -> + (resource -> Sem (Opaque q ': r) x) -> + Sem (Opaque q ': r) x) -> + -- | A handler like the one expected by 'interpretH' with an additional + -- parameter that contains the @resource@ allocated by the first argument. + (∀ q r0 x . resource -> + effect (Sem r0) x -> + Tactical effect (Sem r0) (Opaque q ': r) x) -> + InterpreterFor (Scoped param effect) r +interpretScopedH withResource scopedHandler = runScopedNew \param sem -> + withResource param \r -> interpretH (scopedHandler r) sem +{-# inline interpretScopedH #-} + +-- | Variant of 'interpretScopedH' that allows the resource acquisition function +-- to use 'Tactical'. +interpretScopedH' :: + ∀ resource param effect r . + (∀ e r0 x . param -> (resource -> Tactical e (Sem r0) r x) -> + Tactical e (Sem r0) r x) -> + (∀ r0 x . + resource -> effect (Sem r0) x -> + Tactical (Scoped param effect) (Sem r0) r x) -> + InterpreterFor (Scoped param effect) r +interpretScopedH' withResource scopedHandler = + go 0 Empty + where + go :: Word -> Seq resource -> InterpreterFor (Scoped param effect) r + go depth resources = + interpretH \case + Run w act -> + scopedHandler (S.index resources (fromIntegral w)) act + InScope param main | !depth' <- depth + 1 -> + withResource param \ resource -> + raise . go depth' (resources :|> resource) =<< runT (main depth) +{-# inline interpretScopedH' #-} + +-- | First-order variant of 'interpretScopedH'. +interpretScoped :: + ∀ resource param effect r . + (∀ q x . param -> + (resource -> Sem (Opaque q ': r) x) -> + Sem (Opaque q ': r) x) -> + (∀ m x . resource -> effect m x -> Sem r x) -> + InterpreterFor (Scoped param effect) r +interpretScoped withResource scopedHandler = + interpretScopedH withResource \ r e -> liftT (raise (scopedHandler r e)) +{-# inline interpretScoped #-} + +-- | Variant of 'interpretScoped' in which the resource allocator is a plain +-- action. +interpretScopedAs :: + ∀ resource param effect r . + (param -> Sem r resource) -> + (∀ m x . resource -> effect m x -> Sem r x) -> + InterpreterFor (Scoped param effect) r +interpretScopedAs resource = + interpretScoped \ p use -> use =<< raise (resource p) +{-# inline interpretScopedAs #-} + +-- | Higher-order interpreter for 'Scoped' that allows the handler to use +-- additional effects that are interpreted by the resource allocator. +-- +-- /Note/: It is necessary to specify the list of local interpreters with a type +-- application; GHC won't be able to figure them out from the type of +-- @withResource@. +-- +-- As an example for a higher order effect, consider a mutexed concurrent state +-- effect, where an effectful function may lock write access to the state while +-- making it still possible to read it: +-- +-- > data MState s :: Effect where +-- > MState :: (s -> m (s, a)) -> MState s m a +-- > MRead :: MState s m s +-- > +-- > makeSem ''MState +-- +-- We can now use an 'Polysemy.AtomicState.AtomicState' to store the current +-- value and lock write access with an @MVar@. Since the state callback is +-- effectful, we need a higher order interpreter: +-- +-- > withResource :: +-- > Member (Embed IO) r => +-- > s -> +-- > (MVar () -> Sem (AtomicState s : r) a) -> +-- > Sem r a +-- > withResource initial use = do +-- > tv <- embed (newTVarIO initial) +-- > lock <- embed (newMVar ()) +-- > runAtomicStateTVar tv $ use lock +-- > +-- > interpretMState :: +-- > ∀ s r . +-- > Members [Resource, Embed IO] r => +-- > InterpreterFor (Scoped s (MState s)) r +-- > interpretMState = +-- > interpretScopedWithH @'[AtomicState s] withResource \ lock -> \case +-- > MState f -> +-- > bracket_ (embed (takeMVar lock)) (embed (tryPutMVar lock ())) do +-- > s0 <- atomicGet +-- > res <- runTSimple (f s0) +-- > Inspector ins <- getInspectorT +-- > for_ (ins res) \ (s, _) -> atomicPut s +-- > pure (snd <$> res) +-- > MRead -> +-- > liftT atomicGet +interpretScopedWithH :: + ∀ extra resource param effect r . + KnownList extra => + (∀ q x . + param -> + (resource -> Sem (Append extra (Opaque q ': r)) x) -> + Sem (Opaque q ': r) x) -> + (∀ q r0 x . + resource -> + effect (Sem r0) x -> + Tactical effect (Sem r0) (Append extra (Opaque q ': r)) x) -> + InterpreterFor (Scoped param effect) r +interpretScopedWithH withResource scopedHandler = runScopedNew + \param (sem :: Sem (effect ': Opaque q ': r) x) -> + withResource param \resource -> + sem + & restack + (injectMembership (singList @'[effect]) (singList @extra)) + & interpretH (scopedHandler @q resource) +{-# inline interpretScopedWithH #-} + +-- | First-order variant of 'interpretScopedWithH'. +-- +-- /Note/: It is necessary to specify the list of local interpreters with a type +-- application; GHC won't be able to figure them out from the type of +-- @withResource@: +-- +-- > data SomeAction :: Effect where +-- > SomeAction :: SomeAction m () +-- > +-- > foo :: InterpreterFor (Scoped () SomeAction) r +-- > foo = +-- > interpretScopedWith @[Reader Int, State Bool] localEffects \ () -> \case +-- > SomeAction -> put . (> 0) =<< ask @Int +-- > where +-- > localEffects () use = evalState False (runReader 5 (use ())) +interpretScopedWith :: + ∀ extra param resource effect r. + KnownList extra => + (∀ q x . + param -> + (resource -> Sem (Append extra (Opaque q ': r)) x) -> + Sem (Opaque q ': r) x) -> + (∀ m x . resource -> effect m x -> Sem (Append extra r) x) -> + InterpreterFor (Scoped param effect) r +interpretScopedWith withResource scopedHandler = runScopedNew + \param (sem :: Sem (effect ': Opaque q ': r) x) -> + withResource param \resource -> + sem + & restack + (injectMembership (singList @'[effect]) (singList @extra)) + & interpretH \e -> liftT $ + restack + (injectMembership @r (singList @extra) (singList @'[Opaque q])) + (scopedHandler resource e) +{-# inline interpretScopedWith #-} + +-- | Variant of 'interpretScopedWith' in which no resource is used and the +-- resource allocator is a plain interpreter. +-- This is useful for scopes that only need local effects, but no resources in +-- the handler. +-- +-- See the /Note/ on 'interpretScopedWithH'. +interpretScopedWith_ :: + ∀ extra param effect r . + KnownList extra => + (∀ q x . + param -> + Sem (Append extra (Opaque q ': r)) x -> + Sem (Opaque q ': r) x) -> + (∀ m x . effect m x -> Sem (Append extra r) x) -> + InterpreterFor (Scoped param effect) r +interpretScopedWith_ withResource scopedHandler = + interpretScopedWith @extra + (\ p f -> withResource p (f ())) + (\ () -> scopedHandler) +{-# inline interpretScopedWith_ #-} + +-- | Variant of 'interpretScoped' that uses another interpreter instead of a +-- handler. +-- +-- This is mostly useful if you want to reuse an interpreter that you cannot +-- easily rewrite (like from another library). If you have full control over the +-- implementation, 'interpretScoped' should be preferred. +-- +-- /Note/: In previous versions of Polysemy, the wrapped interpreter was +-- executed fully, including the initializing code surrounding its handler, +-- for each action in the program. However, new and continuing discoveries +-- regarding 'Scoped' has allowed the improvement of having the interpreter be +-- used only once per use of 'scoped', and have it cover the same scope of +-- actions that the resource allocator does. +-- +-- This renders the resource allocator practically redundant; for the moment, +-- the API surrounding 'Scoped' remains the same, but work is in progress to +-- revamp the entire API of 'Scoped'. +runScoped :: + ∀ resource param effect r . + (∀ q x . param -> (resource -> Sem (Opaque q ': r) x) -> Sem (Opaque q ': r) x) -> + (∀ q . resource -> InterpreterFor effect (Opaque q ': r)) -> + InterpreterFor (Scoped param effect) r +runScoped withResource scopedInterpreter = runScopedNew \param sem -> + withResource param (\r -> scopedInterpreter r sem) +{-# inline runScoped #-} + +-- | Variant of 'runScoped' in which the resource allocator returns the resource +-- rather than calling a continuation. +runScopedAs :: + ∀ resource param effect r . + (param -> Sem r resource) -> + (∀ q. resource -> InterpreterFor effect (Opaque q ': r)) -> + InterpreterFor (Scoped param effect) r +runScopedAs resource = runScoped \ p use -> use =<< raise (resource p) +{-# inline runScopedAs #-} + +-- | Run a 'Scoped' effect by specifying the interpreter to be used at every +-- use of 'scoped'. +-- +-- This interpretation of 'Scoped' is powerful enough to subsume all other +-- interpretations of 'Scoped' (except 'interpretScopedH'' which works +-- differently from all other interpretations) while also being much simpler. +-- +-- Consider this a sneak-peek of the future of 'Scoped'. In the API rework +-- planned for 'Scoped', the effect and its interpreters will be further +-- expanded to make 'Scoped' even more flexible. +-- +-- @since 1.9.0.0 +runScopedNew :: + ∀ param effect r . + (∀ q. param -> InterpreterFor effect (Opaque q ': r)) -> + InterpreterFor (Scoped param effect) r +runScopedNew h = + interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of + Run w _ -> errorWithoutStackTrace $ "top level run with depth " ++ show w + InScope param main -> + wv (main 0 <$ s) + & raiseUnder2 + & go 0 + & h param + & interpretH (\(Opaque (OuterRun w _)) -> + errorWithoutStackTrace $ "unhandled OuterRun with depth " ++ show w) + & fmap ex + where + go' :: Word + -> InterpreterFor + (Opaque (OuterRun effect)) + (effect ': Opaque (OuterRun effect) ': r) + go' depth = + interpretWeaving \ (Weaving sr@(Opaque (OuterRun w act)) s wv ex ins) -> + if w == depth then + liftSem $ injWeaving $ Weaving act s (go' depth . wv) ex ins + else + liftSem $ injWeaving $ Weaving sr s (go' depth . wv) ex ins + + -- TODO investigate whether loopbreaker optimization is effective here + go :: Word + -> InterpreterFor + (Scoped param effect) + (effect ': Opaque (OuterRun effect) ': r) + go depth = + interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of + Run w act + | w == depth -> liftSem $ injWeaving $ + Weaving act s (go depth . wv) ex ins + | otherwise -> liftSem $ injWeaving $ + Weaving (Opaque (OuterRun w act)) s (go depth . wv) ex ins + InScope param main -> do + let !depth' = depth + 1 + wv (main depth' <$ s) + & go depth' + & h param + & raiseUnder2 + & go' depth + & fmap ex +{-# INLINE runScopedNew #-} diff --git a/src/Polysemy/State.hs b/src/Polysemy/State.hs --- a/src/Polysemy/State.hs +++ b/src/Polysemy/State.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'State' effect module Polysemy.State ( -- * Effect State (..) @@ -28,15 +29,15 @@ , hoistStateIntoStateT ) where -import Control.Monad.ST +import Control.Monad.ST import qualified Control.Monad.Trans.State as S -import Data.IORef -import Data.STRef -import Data.Tuple (swap) -import Polysemy -import Polysemy.Internal -import Polysemy.Internal.Combinators -import Polysemy.Internal.Union +import Data.IORef +import Data.STRef +import Data.Tuple (swap) +import Polysemy +import Polysemy.Internal +import Polysemy.Internal.Combinators +import Polysemy.Internal.Union ------------------------------------------------------------------------------ @@ -48,17 +49,23 @@ -- Interpreters which require statefulness can 'Polysemy.reinterpret' -- themselves in terms of 'State', and subsequently call 'runState'. data State s m a where + -- | Get the state. Get :: State s m s + -- | Update the state. Put :: s -> State s m () makeSem ''State +------------------------------------------------------------------------------ +-- | Apply a function to the state and return the result. gets :: forall s a r. Member (State s) r => (s -> a) -> Sem r a gets f = f <$> get {-# INLINABLE gets #-} +------------------------------------------------------------------------------ +-- | Modify the state. modify :: Member (State s) r => (s -> s) -> Sem r () modify f = do s <- get diff --git a/src/Polysemy/State/Law.hs b/src/Polysemy/State/Law.hs deleted file mode 100644 --- a/src/Polysemy/State/Law.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Polysemy.State.Law where - -import Polysemy -import Polysemy.Law -import Polysemy.State -import Control.Applicative -import Control.Arrow - - ------------------------------------------------------------------------------- --- | A collection of laws that show a `State` interpreter is correct. -prop_lawfulState - :: forall r s - . (Eq s, Show s, Arbitrary s, MakeLaw (State s) r) - => InterpreterFor (State s) r - -> Property -prop_lawfulState i12n = conjoin - [ runLaw i12n law_putTwice - , runLaw i12n law_getTwice - , runLaw i12n law_getPutGet - ] - - -law_putTwice - :: forall s r - . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r) - => Law (State s) r -law_putTwice = - mkLaw - "put %1 >> put %2 >> get" - (\s s' -> put @s s >> put @s s' >> get @s) - "put %2 >> get" - (\_ s' -> put @s s' >> get @s) - -law_getTwice - :: forall s r - . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r) - => Law (State s) r -law_getTwice = - mkLaw - "liftA2 (,) get get" - (liftA2 (,) (get @s) (get @s)) - "(id &&& id) <$> get" - ((id &&& id) <$> get @s) - -law_getPutGet - :: forall s r - . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r) - => Law (State s) r -law_getPutGet = - mkLaw - "get >>= put >> get" - (get @s >>= put @s >> get @s) - "get" - (get @s) - diff --git a/src/Polysemy/Tagged.hs b/src/Polysemy/Tagged.hs --- a/src/Polysemy/Tagged.hs +++ b/src/Polysemy/Tagged.hs @@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Description: The 'Tagged' effect and its interpreters module Polysemy.Tagged ( -- * Effect @@ -39,7 +41,7 @@ -- -> 'Sem' r a -- -> 'Sem' r a -- taggedLocal f m = --- 'tag' @k @('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m) +-- 'tag' \@k \@('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m) -- @ -- tag diff --git a/src/Polysemy/Trace.hs b/src/Polysemy/Trace.hs --- a/src/Polysemy/Trace.hs +++ b/src/Polysemy/Trace.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Trace' effect and its interpreters module Polysemy.Trace ( -- * Effect Trace (..) @@ -28,6 +29,7 @@ ------------------------------------------------------------------------------ -- | An effect for logging strings. data Trace m a where + -- | Log a message. Trace :: String -> Trace m () makeSem ''Trace diff --git a/src/Polysemy/View.hs b/src/Polysemy/View.hs deleted file mode 100644 --- a/src/Polysemy/View.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Polysemy.View - ( -- * Effect - View (..) - - -- * Actions - , see - - -- * Interpretations - , viewToState - , viewToInput - ) where - -import Polysemy -import Polysemy.Input -import Polysemy.State -import Polysemy.Tagged - - ------------------------------------------------------------------------------- --- | A 'View' is an expensive computation that should be cached. -data View v m a where - See :: View v m v - -makeSem ''View - - ------------------------------------------------------------------------------- --- | Transform a 'View' into an 'Input'. -viewToInput - :: forall v i r a - . Member (Input i) r - => (i -> v) - -> Sem (View v ': r) a - -> Sem r a -viewToInput f = interpret $ \case - See -> f <$> input - - ------------------------------------------------------------------------------- --- | Get a 'View' as an exensive computation over an underlying 'State' effect. --- This 'View' is only invalidated when the underlying 'State' changes. -viewToState - :: forall v s r a - . Member (State s) r - => (s -> Sem r v) - -> Sem (View v ': r) a - -> Sem r a -viewToState f = do - evalState Dirty - . untag @"view" @(State (Cached v)) - . intercept @(State s) - ( \case - Get -> get - Put s -> do - put s - tag @"view" @(State (Cached v)) $ put $ Dirty @v - ) - . reinterpret @(View v) - ( \case - See -> do - dirty <- tagged @"view" $ get @(Cached v) - case dirty of - Dirty -> do - s <- get - v' <- raise $ f s - tagged @"view" $ put $ Cached v' - pure v' - Cached v -> pure v - ) - - -data Cached a = Cached a | Dirty - deriving (Eq, Ord, Show, Functor) - diff --git a/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs --- a/src/Polysemy/Writer.hs +++ b/src/Polysemy/Writer.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections #-} +-- | Description: Interpreters for 'Writer' module Polysemy.Writer ( -- * Effect Writer (..) diff --git a/test/AsyncSpec.hs b/test/AsyncSpec.hs deleted file mode 100644 --- a/test/AsyncSpec.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE NumDecimals #-} - -module AsyncSpec where - -import Control.Concurrent.MVar -import Control.Monad -import Polysemy -import Polysemy.Async -import Polysemy.State -import Polysemy.Trace -import Test.Hspec - - -spec :: Spec -spec = describe "async" $ do - it "should thread state and not lock" $ do - (ts, (s, r)) <- runM - . runTraceList - . runState "hello" - . asyncToIO $ do - let message :: Member Trace r => Int -> String -> Sem r () - message n msg = trace $ mconcat - [ show n, "> ", msg ] - ~[lock1, lock2] <- embed $ - replicateM 2 newEmptyMVar - a1 <- async $ do - v <- get @String - message 1 v - put $ reverse v - - embed $ putMVar lock1 () - embed $ takeMVar lock2 - get >>= message 1 - - get @String - - void $ async $ do - embed $ takeMVar lock1 - get >>= message 2 - put "pong" - embed $ putMVar lock2 () - - await a1 <* put "final" - - ts `shouldContain` ["1> hello", "2> olleh", "1> pong"] - s `shouldBe` "final" - r `shouldBe` Just "pong" diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs --- a/test/BracketSpec.hs +++ b/test/BracketSpec.hs @@ -151,16 +151,6 @@ . runResource . runError @() -runTest2 - :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a - -> IO ([String], ([Char], Either () a)) -runTest2 = runM - . ignoreOutput - . runTraceList - . runState "" - . resourceToIO - . runError @() - runTest3 :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO, Final IO] a -> IO ([String], ([Char], Either () a)) @@ -185,9 +175,6 @@ k z -- NOTE(sandy): These unsafeCoerces are safe, because we're just weakening -- the end of the union - it "via resourceToIO" $ do - z <- runTest2 $ unsafeCoerce m - k z it "via resourceToIOFinal" $ do z <- runTest3 $ unsafeCoerce m k z @@ -200,9 +187,6 @@ -> Spec testTheIOTwo name k m = do describe name $ do - it "via resourceToIO" $ do - z <- runTest2 m - k z -- NOTE(sandy): This unsafeCoerces are safe, because we're just weakening -- the end of the union it "via resourceToIOFinal" $ do diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -2,6 +2,7 @@ import qualified Control.Exception as X import Polysemy +import Polysemy.Async import Polysemy.Error import Polysemy.Resource import Test.Hspec @@ -28,11 +29,28 @@ it "should happen before Resource" $ do a <- - runM $ resourceToIO $ runError @MyExc $ do + runFinal $ embedToFinal @IO $ resourceToIOFinal $ runError @MyExc $ do onException (fromException @MyExc $ do _ <- X.throwIO $ MyExc "hello" pure () ) $ pure $ error "this exception shouldn't happen" a `shouldBe` (Left $ MyExc "hello") + describe "errorToIOFinal" $ do + it "should catch errors only for the interpreted Error" $ do + res1 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do + raise $ throw () `catch` \() -> return () + res1 `shouldBe` Right (Right ()) + res2 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do + raise (throw ()) `catch` \() -> return () + res2 `shouldBe` Left () + it "should propagate errors thrown in 'async'" $ do + res1 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do + a <- async $ throw () + await a + res1 `shouldBe` (Left () :: Either () (Maybe ())) + res2 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do + a <- async $ throw () + await a `catch` \() -> return $ Just () + res2 `shouldBe` Right (Just ()) diff --git a/test/InspectorSpec.hs b/test/InspectorSpec.hs deleted file mode 100644 --- a/test/InspectorSpec.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module InspectorSpec where - -import Control.Monad -import Data.IORef -import Polysemy -import Polysemy.Error -import Polysemy.State -import Test.Hspec - - - -data Callback m a where - Callback :: m String -> Callback m () - -makeSem ''Callback - - - -spec :: Spec -spec = parallel $ describe "Inspector" $ do - it "should inspect State effects" $ do - withNewTTY $ \ref -> do - void . (runM .@ runCallback ref) - . runState False - $ do - embed $ pretendPrint ref "hello world" - callback $ show <$> get @Bool - modify not - callback $ show <$> get @Bool - - result <- readIORef ref - result `shouldContain` ["hello world"] - result `shouldContain` ["False", "True"] - - it "should not inspect thrown Error effects" $ do - withNewTTY $ \ref -> do - void . (runM .@ runCallback ref) - . runError @() - $ do - callback $ throw () - callback $ pure "nice" - - result <- readIORef ref - result `shouldContain` [":(", "nice"] - - -runCallback - :: Member (Embed IO) r - => IORef [String] - -> (forall x. Sem r x -> IO x) - -> Sem (Callback ': r) a - -> Sem r a -runCallback ref lower = interpretH $ \case - Callback cb -> do - cb' <- runT cb - ins <- getInspectorT - embed $ doCB ref $ do - v <- lower .@ runCallback ref $ cb' - pure $ maybe ":(" id $ inspect ins v - getInitialStateT - - -doCB :: IORef [String] -> IO String -> IO () -doCB ref m = m >>= pretendPrint ref - - -pretendPrint :: IORef [String] -> String -> IO () -pretendPrint ref msg = modifyIORef ref (++ [msg]) - - -withNewTTY :: (IORef [String] -> IO a) -> IO a -withNewTTY f = do - ref <- newIORef [] - f ref - diff --git a/test/LawsSpec.hs b/test/LawsSpec.hs deleted file mode 100644 --- a/test/LawsSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ -module LawsSpec where - -import Polysemy -import Polysemy.Law -import Polysemy.State -import Polysemy.State.Law -import Test.Hspec - -spec :: Spec -spec = parallel $ do - describe "State effects" $ do - it "runState should pass the laws" $ - property $ prop_lawfulState @'[] $ fmap snd . runState @Int 0 - - it "runLazyState should pass the laws" $ - property $ prop_lawfulState @'[] $ fmap snd . runLazyState @Int 0 - - it "stateToIO should pass the laws" $ - property $ prop_lawfulState @'[Embed IO] $ fmap snd . stateToIO @Int 0 - diff --git a/test/ScopedSpec.hs b/test/ScopedSpec.hs new file mode 100644 --- /dev/null +++ b/test/ScopedSpec.hs @@ -0,0 +1,117 @@ +{-# language TemplateHaskell, DerivingStrategies, GeneralizedNewtypeDeriving #-} + +module ScopedSpec where + +import Control.Concurrent.STM +import Polysemy +import Polysemy.Internal.Tactics +import Polysemy.Scoped +import Test.Hspec + +newtype Par = + Par { unPar :: Int } + deriving stock (Eq, Show) + deriving newtype (Num, Real, Enum, Integral, Ord) + +data E :: Effect where + E1 :: E m Int + E2 :: E m Int + +makeSem ''E + +data F :: Effect where + F :: F m Int + +makeSem ''F + +handleE :: + Member (Embed IO) r => + TVar Int -> + E m a -> + Tactical effect m (F : r) a +handleE tv = \case + E1 -> do + i1 <- embed (readTVarIO tv) + i2 <- f + pureT (i1 + i2 + 10) + E2 -> + pureT (-1) + +interpretF :: + Member (Embed IO) r => + TVar Int -> + InterpreterFor F r +interpretF tv = + interpret \ F -> do + embed (atomically (writeTVar tv 7)) + pure 5 + +scope :: + Member (Embed IO) r => + Par -> + (TVar Int -> Sem (F : r) a) -> + Sem r a +scope (Par n) use = do + tv <- embed (newTVarIO n) + interpretF tv (use tv) + +data HO :: Effect where + Inc :: m a -> HO m a + Ret :: HO m Int + +makeSem ''HO + +scopeHO :: () -> (() -> Sem r a) -> Sem r a +scopeHO () use = + use () + +handleHO :: Int -> () -> HO m a -> Tactical HO m r a +handleHO n () = \case + Inc ma -> raise . interpretH (handleHO (n + 1) ()) =<< runT ma + Ret -> pureT n + +data Esc :: Effect where + Esc :: Esc m Int +makeSem ''Esc + +data Indirect :: Effect where + Indirect :: Indirect m Int +makeSem ''Indirect + +interpretIndirect :: Member Esc r => InterpreterFor Indirect r +interpretIndirect = interpret \ Indirect -> esc + +handleEsc :: Int -> Esc m a -> Sem r a +handleEsc i = \ Esc -> pure i + +test_escape :: Sem (Scoped Int Esc ': r) Int +test_escape = + scoped @Int @Esc 2 + $ interpretIndirect + $ scoped @Int @Esc 1 indirect + +spec :: Spec +spec = parallel do + describe "Scoped" do + it "local effects" do + (i1, i2) <- runM $ interpretScopedWithH @'[F] @(TVar Int) @Par @E scope handleE do + scoped @Par @E 20 do + i1 <- e1 + i2 <- scoped @Par @E 23 e1 + pure (i1, i2) + i1 `shouldBe` 35 + i2 `shouldBe` 38 + it "switch interpreter" do + r <- runM $ interpretScopedH scopeHO (handleHO 1) do + scoped_ @HO do + inc do + ret + r `shouldBe` 2 + it "scoped depth" do + r <- runM $ interpretScoped (flip ($)) handleEsc $ test_escape + r `shouldBe` 2 + r' <- runM $ interpretScopedH' + (\r h -> h r) + (\i e -> liftT (handleEsc i e)) + $ test_escape + r' `shouldBe` 2 diff --git a/test/TypeErrors.hs b/test/TypeErrors.hs --- a/test/TypeErrors.hs +++ b/test/TypeErrors.hs @@ -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 = () - diff --git a/test/ViewSpec.hs b/test/ViewSpec.hs deleted file mode 100644 --- a/test/ViewSpec.hs +++ /dev/null @@ -1,40 +0,0 @@ -module ViewSpec where - -import Polysemy -import Polysemy.State -import Polysemy.Trace -import Polysemy.View -import Test.Hspec - - -check_see :: Members '[View String, Trace] r => Sem r () -check_see = trace . ("saw " ++) =<< see - -spec :: Spec -spec = parallel $ do - describe "View effect" $ do - it "should cache views" $ do - let a = run - . runTraceList - . runState @Int 0 - . viewToState @String @Int (\i -> do - trace $ "caching " ++ show i - pure $ show i ) $ do - check_see - check_see - put @Int 3 - trace "it's lazy" - put @Int 5 - check_see - check_see - get @Int - - a `shouldBe` ([ "caching 0" - , "saw 0" - , "saw 0" - , "it's lazy" - , "caching 5" - , "saw 5" - , "saw 5" - ], (5, 5)) -