mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-10-26 10:58:34 +03:00
Extend Scoped (#459)
* add variants of interpretScoped that allow additional local effects * add call site parameter to Scoped
This commit is contained in:
parent
f2c36c40cc
commit
76af343a96
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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 <https://hackage.haskell.org/package/polysemy-conc>,
|
||||
-- in which each program using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of the event channel;
|
||||
-- or a database transaction, in which a transaction handle is created for the wrapped program and passed
|
||||
-- to the interpreter for the database effect.
|
||||
-- An application for this is @Polysemy.Conc.Events@ from
|
||||
-- <https://hackage.haskell.org/package/polysemy-conc>, in which each program
|
||||
-- using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of
|
||||
-- the event channel; or a database transaction, in which a transaction handle
|
||||
-- is created for the wrapped program and passed to the interpreter for the
|
||||
-- database effect.
|
||||
--
|
||||
-- For a longer exposition, see <https://www.tweag.io/blog/2022-01-05-polysemy-scoped/>.
|
||||
--
|
||||
-- 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
|
||||
|
@ -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 #-}
|
||||
|
@ -1,4 +1,4 @@
|
||||
resolver: lts-16.31
|
||||
resolver: lts-19.23
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
Loading…
Reference in New Issue
Block a user