From 76af343a96741525fb5eee8642d32c65e3ccd7af Mon Sep 17 00:00:00 2001 From: KingoftheHomeless Date: Sun, 2 Oct 2022 18:49:17 +0200 Subject: [PATCH] Extend Scoped (#459) * add variants of interpretScoped that allow additional local effects * add call site parameter to Scoped --- polysemy-plugin/polysemy-plugin.cabal | 5 +- polysemy.cabal | 11 +- src/Polysemy/Internal.hs | 6 + src/Polysemy/Internal/Combinators.hs | 14 ++ src/Polysemy/Internal/Scoped.hs | 175 +++++++++++--- src/Polysemy/Scoped.hs | 324 ++++++++++++++++++++------ stack.yaml | 2 +- 7 files changed, 421 insertions(+), 116 deletions(-) diff --git a/polysemy-plugin/polysemy-plugin.cabal b/polysemy-plugin/polysemy-plugin.cabal index c7c04ba..bb9c894 100644 --- a/polysemy-plugin/polysemy-plugin.cabal +++ b/polysemy-plugin/polysemy-plugin.cabal @@ -1,6 +1,6 @@ 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.35.0. -- -- see: https://github.com/sol/hpack @@ -89,6 +89,7 @@ test-suite polysemy-plugin-test Paths_polysemy_plugin Build_doctests autogen-modules: + Paths_polysemy_plugin Build_doctests hs-source-dirs: test @@ -122,6 +123,6 @@ test-suite polysemy-plugin-test , should-not-typecheck >=2.1.0 && <3 , syb ==0.7.* , transformers >=0.5.2.0 && <0.6 + default-language: Haskell2010 if flag(corelint) ghc-options: -dcore-lint -dsuppress-all - default-language: Haskell2010 diff --git a/polysemy.cabal b/polysemy.cabal index eb7ae0c..1142e6e 100644 --- a/polysemy.cabal +++ b/polysemy.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.34.5. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -114,6 +114,7 @@ library , transformers >=0.5.2.0 && <0.6 , 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 @@ -125,7 +126,6 @@ library 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 @@ -150,6 +150,7 @@ test-suite polysemy-test Paths_polysemy Build_doctests autogen-modules: + Paths_polysemy Build_doctests hs-source-dirs: test @@ -175,10 +176,10 @@ test-suite polysemy-test async >=2.2 && <3 , base >=4.9 && <5 , containers >=0.5 && <0.7 - , doctest >=0.16.0.1 && <0.20 + , doctest >=0.16.0.1 && <0.19 , first-class-families >=0.5.0.0 && <0.9 , hspec >=2.6.0 && <3 - , inspection-testing >=0.4.2 && <0.6 + , inspection-testing >=0.4.2 && <0.5 , mtl >=2.2.2 && <3 , polysemy , stm ==2.* @@ -188,8 +189,8 @@ test-suite polysemy-test , transformers >=0.5.2.0 && <0.6 , 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 - default-language: Haskell2010 diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs index 3f534a3..fa42581 100644 --- a/src/Polysemy/Internal.hs +++ b/src/Polysemy/Internal.hs @@ -34,6 +34,7 @@ module Polysemy.Internal , usingSem , liftSem , hoistSem + , restack , Append , InterpreterFor , InterpretersFor @@ -343,6 +344,11 @@ hoistSem hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u {-# INLINE hoistSem #-} +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 diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs index b67751c..b5a4a8e 100644 --- a/src/Polysemy/Internal/Combinators.hs +++ b/src/Polysemy/Internal/Combinators.hs @@ -18,6 +18,7 @@ module Polysemy.Internal.Combinators , reinterpretH , reinterpret2H , reinterpret3H + , interpretWeaving -- * Conditional , interceptUsing @@ -28,6 +29,7 @@ module Polysemy.Internal.Combinators , 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 @@ -87,6 +89,18 @@ interpretH f (Sem m) = Sem $ \k -> m $ \u -> 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 -- 'stateful' for a more user-friendly variety of this function. diff --git a/src/Polysemy/Internal/Scoped.hs b/src/Polysemy/Internal/Scoped.hs index f10c916..e999cac 100644 --- a/src/Polysemy/Internal/Scoped.hs +++ b/src/Polysemy/Internal/Scoped.hs @@ -3,48 +3,157 @@ module Polysemy.Internal.Scoped where -import Polysemy.Internal (send, Member, InterpreterFor, Sem(Sem), runSem) import Data.Kind (Type) -import Polysemy.Internal.Kind (Effect) -import Polysemy.Internal.Union (Weaving, hoist, decomp) -import Control.Arrow ((>>>)) -import Polysemy.Internal.Combinators (transform) --- |@Scoped@ transforms a program so that @effect@ is associated with a @resource@ within that program. --- This requires the interpreter for @effect@ to be parameterized by @resource@ and constructed for every program using +import Polysemy + +-- | @Scoped@ transforms a program so that @effect@ is associated with a +-- @resource@ within that program. This requires the interpreter for @effect@ to +-- be parameterized by @resource@ and constructed for every program using -- @Scoped@ separately. -- --- 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. +-- 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 . -- --- Resource creation is performed by the function passed to 'Polysemy.Scoped.runScoped'. +-- 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@. -data Scoped (resource :: Type) (effect :: Effect) :: Effect where - Run :: ∀ resource effect m a . resource -> effect m a -> Scoped resource effect m a - InScope :: ∀ resource effect m a . (resource -> m a) -> Scoped resource effect m a +-- 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 resource 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 Handle 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 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. Note how the type of the effect changed, with the @resource@ +-- parameter being instantiated as @FilePath@ instead of @Handle@. +-- This change does not need to be anticipated in the business logic that uses +-- the scoped effect – as is visible in the signature of @prog@, the @resource@ +-- parameter is always chosen concretely by an interpreter. +-- +-- 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_ resource 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) (resource :: Type) (effect :: Effect) :: Effect where + Run :: ∀ param resource effect m a . resource -> effect m a -> + Scoped param resource effect m a + InScope :: ∀ param resource effect m a . param -> (resource -> m a) -> + Scoped param resource effect m a --- |Constructor for 'Scoped', taking a nested program and transforming all instances of @effect@ to --- @Scoped resource effect@. +-- |A convenience alias for a scope without parameters. +type Scoped_ resource effect = + Scoped () resource effect + +-- | Constructor for 'Scoped', taking a nested program and transforming all +-- instances of @effect@ to @'Scoped' param resource effect@. +-- +-- Please consult the documentation of 'Scoped' for details and examples. scoped :: - ∀ resource effect r . - Member (Scoped resource effect) r => + ∀ resource param effect r . + Member (Scoped param resource effect) r => + param -> InterpreterFor effect r -scoped main = - send $ InScope @resource @effect \ resource -> - transform @effect (Run resource) main +scoped param main = + send $ InScope @param @resource @effect param \ resource -> + transform @effect (Run @param resource) main +{-# inline scoped #-} + +-- | Constructor for 'Scoped_', taking a nested program and transforming all +-- instances of @effect@ to @'Scoped_' resource effect@. +-- +-- Please consult the documentation of 'Scoped' for details and examples. +scoped_ :: + ∀ resource effect r . + Member (Scoped_ resource effect) r => + InterpreterFor effect r +scoped_ = scoped @resource () +{-# 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 resource effect r . + Member (Scoped param1 resource effect) r => + (param0 -> param1) -> + InterpreterFor (Scoped param0 resource effect) r +rescope fp = + transform \case + Run res e -> Run @param1 res e + InScope p main -> InScope (fp p) main +{-# inline rescope #-} --- |Helper for @runScoped@. -interpretH' :: - ∀ e r . - (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) -> - InterpreterFor e r -interpretH' h (Sem m) = - Sem \ k -> m $ decomp >>> \case - Right wav -> runSem (h wav) k - Left g -> k $ hoist (interpretH' h) g diff --git a/src/Polysemy/Scoped.hs b/src/Polysemy/Scoped.hs index 9048e4b..a5eda37 100644 --- a/src/Polysemy/Scoped.hs +++ b/src/Polysemy/Scoped.hs @@ -1,100 +1,274 @@ +{-# language AllowAmbiguousTypes #-} + module Polysemy.Scoped ( -- * Effect Scoped, - -- * Constructor + -- * Constructors scoped, + scoped_, + rescope, -- * Interpreters - runScoped, - runScopedAs, interpretScopedH, + interpretScopedH', interpretScoped, interpretScopedAs, + interpretScopedWithH, + interpretScopedWith, + interpretScopedWith_, + runScoped, + runScopedAs, ) where -import Polysemy.Internal (InterpreterFor, Sem, liftSem, raise) -import Polysemy.Internal.Scoped (Scoped (Run, InScope), scoped, interpretH') -import Polysemy.Internal.Union (Weaving(Weaving), injWeaving) -import Polysemy.Internal.Tactics (Tactical, runTactics) +import Polysemy.Internal +import Polysemy.Internal.Sing +import Polysemy.Internal.Union +import Polysemy.Internal.Combinators +import Polysemy.Internal.Scoped +import Polysemy.Internal.Tactics --- |Interpreter for 'Scoped', taking a @resource@ allocation function and a parameterized interpreter for the plain --- @effect@. +-- | 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. -- --- >>> runScoped withResource scopedInterpreter --- --- @withResource@ is a callback function, allowing the user to acquire the resource for each program from other effects. --- --- @scopedInterpreter@ is a regular interpreter that is called with the @resource@ argument produced by @scope@. --- --- /Note/: This function will be called for each action in the program, so if the interpreter allocates any resources, --- they will be scoped to a single action. Move them to @withResource@ instead. -runScoped :: - ∀ resource effect r . - (∀ x . (resource -> Sem r x) -> Sem r x) -> - (resource -> InterpreterFor effect r) -> - InterpreterFor (Scoped resource effect) r -runScoped withResource scopedInterpreter = - run - where - run :: InterpreterFor (Scoped resource effect) r - run = - interpretH' \ (Weaving effect s wv ex ins) -> case effect of - Run resource act -> - scopedInterpreter resource (liftSem $ injWeaving $ Weaving act s (raise . run . wv) ex ins) - InScope main -> - ex <$> withResource \ resource -> run (wv (main resource <$ s)) - --- |Variant of 'runScoped' in which the resource allocator is a plain action. -runScopedAs :: - ∀ resource effect r . - Sem r resource -> - (resource -> InterpreterFor effect r) -> - InterpreterFor (Scoped resource effect) r -runScopedAs resource = - runScoped \ f -> f =<< resource - --- |Variant of 'runScoped' that takes a higher-order handler instead of an interpreter. +-- 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 effect r . - (∀ x . (resource -> Sem r x) -> Sem r x) -> + ∀ param resource 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'. + (∀ x . param -> (resource -> Sem r x) -> Sem r x) -> + -- | A handler like the one expected by 'interpretH' with an additional + -- parameter that contains the @resource@ allocated by the first argument. (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r x) -> - InterpreterFor (Scoped resource effect) r + InterpreterFor (Scoped param resource effect) r interpretScopedH withResource scopedHandler = - run + go where - run :: InterpreterFor (Scoped resource effect) r - run = - interpretH' \ (Weaving effect s wv ex ins) -> case effect of + go :: InterpreterFor (Scoped param resource effect) r + go = + interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of Run resource act -> - ex <$> runTactics s (raise . run . wv) ins (run . wv) (scopedHandler resource act) - InScope main -> - ex <$> withResource \ resource -> run (wv (main resource <$ s)) + ex <$> runTactics s (raise . go . wv) ins (go . wv) + (scopedHandler resource act) + InScope param main -> + withResource param \ resource -> ex <$> go (wv (main resource <$ s)) +{-# inline interpretScopedH #-} --- |Variant of 'runScoped' that takes a handler instead of an interpreter. +-- | 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 resource effect) (Sem r0) r x) -> + InterpreterFor (Scoped param resource effect) r +interpretScopedH' withResource scopedHandler = + interpretH \case + Run resource act -> + scopedHandler resource act + InScope param main -> + withResource param \ resource -> + runTSimple (main resource) +{-# inline interpretScopedH' #-} + +-- | First-order variant of 'interpretScopedH'. interpretScoped :: - ∀ resource effect r . - (∀ x . (resource -> Sem r x) -> Sem r x) -> - (∀ r0 x . resource -> effect (Sem r0) x -> Sem r x) -> - InterpreterFor (Scoped resource effect) r + ∀ resource param effect r . + (∀ x . param -> (resource -> Sem r x) -> Sem r x) -> + (∀ m x . resource -> effect m x -> Sem r x) -> + InterpreterFor (Scoped param resource effect) r interpretScoped withResource scopedHandler = - run - where - run :: InterpreterFor (Scoped resource effect) r - run = - interpretH' \ (Weaving effect s wv ex _) -> case effect of - Run resource act -> do - x <- scopedHandler resource act - pure (ex (x <$ s)) - InScope main -> - ex <$> withResource \ resource -> run (wv (main resource <$ s)) + interpretScopedH withResource \ r e -> liftT (scopedHandler r e) +{-# inline interpretScoped #-} - --- |Variant of 'interpretScoped' in which the resource allocator is a plain action. +-- | Variant of 'interpretScoped' in which the resource allocator is a plain +-- action. interpretScopedAs :: - ∀ resource effect r . - Sem r resource -> - (∀ r0 x . resource -> effect (Sem r0) x -> Sem r x) -> - InterpreterFor (Scoped resource effect) r + ∀ resource param effect r . + (param -> Sem r resource) -> + (∀ m x . resource -> effect m x -> Sem r x) -> + InterpreterFor (Scoped param resource effect) r interpretScopedAs resource = - interpretScoped \ f -> f =<< resource + interpretScoped \ p use -> use =<< 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 (MVar ()) (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 r1 . + (KnownList extra, r1 ~ Append extra r) => + (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) -> + (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r1 x) -> + InterpreterFor (Scoped param resource effect) r +interpretScopedWithH withResource scopedHandler = + interpretWeaving \case + Weaving (InScope param main) s wv ex _ -> + ex <$> withResource param \ resource -> inScope $ + restack + (injectMembership + (singList @'[Scoped param resource effect]) + (singList @extra)) $ wv (main resource <$ s) + _ -> + errorWithoutStackTrace "top level Run" + where + inScope :: InterpreterFor (Scoped param resource effect) r1 + inScope = + interpretWeaving \case + Weaving (InScope param main) s wv ex _ -> + restack (extendMembershipLeft (singList @extra)) + (ex <$> withResource param \resource -> + inScope (wv (main resource <$ s))) + Weaving (Run resource act) s wv ex ins -> + ex <$> runTactics s (raise . inScope . wv) ins (inScope . wv) + (scopedHandler resource act) +{-# 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 r1 . + (r1 ~ Append extra r, KnownList extra) => + (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) -> + (∀ m x . resource -> effect m x -> Sem r1 x) -> + InterpreterFor (Scoped param resource effect) r +interpretScopedWith withResource scopedHandler = + interpretScopedWithH @extra withResource \ r e -> liftT (scopedHandler r 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 r1 . + (r1 ~ Append extra r, KnownList extra) => + (∀ x . param -> Sem r1 x -> Sem r x) -> + (∀ m x . effect m x -> Sem r1 x) -> + InterpreterFor (Scoped param () effect) r +interpretScopedWith_ withResource scopedHandler = + interpretScopedWithH @extra (\ p f -> withResource p (f ())) \ () e -> liftT (scopedHandler e) +{-# 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/: The wrapped interpreter will be executed fully, including the +-- initializing code surrounding its handler, for each action in the program, so +-- if the interpreter allocates any resources, they will be scoped to a single +-- action. Move them to @withResource@ instead. +-- +-- For example, consider the following interpreter for +-- 'Polysemy.AtomicState.AtomicState': +-- +-- > atomicTVar :: Member (Embed IO) r => a -> InterpreterFor (AtomicState a) r +-- > atomicTVar initial sem = do +-- > tv <- embed (newTVarIO initial) +-- > runAtomicStateTVar tv sem +-- +-- If this interpreter were used for a scoped version of @AtomicState@ like +-- this: +-- +-- > runScoped (\ initial use -> use initial) \ initial -> atomicTVar initial +-- +-- Then the @TVar@ would be created every time an @AtomicState@ action is run, +-- not just when entering the scope. +-- +-- The proper way to implement this would be to rewrite the resource allocation: +-- +-- > runScoped (\ initial use -> use =<< embed (newTVarIO initial)) runAtomicStateTVar +runScoped :: + ∀ param resource effect r . + (∀ x . param -> (resource -> Sem r x) -> Sem r x) -> + (resource -> InterpreterFor effect r) -> + InterpreterFor (Scoped param resource effect) r +runScoped withResource scopedInterpreter = + go + where + go :: InterpreterFor (Scoped param resource effect) r + go = + interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of + Run resource act -> + scopedInterpreter resource + $ liftSem $ injWeaving $ Weaving act s (raise . go . wv) ex ins + InScope param main -> + withResource param \ resource -> ex <$> go (wv (main resource <$ s)) +{-# inline runScoped #-} + +-- | Variant of 'runScoped' in which the resource allocator returns the resource +-- rather tnen calling a continuation. +runScopedAs :: + ∀ param resource effect r . + (param -> Sem r resource) -> + (resource -> InterpreterFor effect r) -> + InterpreterFor (Scoped param resource effect) r +runScopedAs resource = runScoped \ p use -> use =<< resource p +{-# inline runScopedAs #-} diff --git a/stack.yaml b/stack.yaml index d12648c..e007792 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.31 +resolver: lts-19.23 packages: - .