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
|
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
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
@ -89,6 +89,7 @@ test-suite polysemy-plugin-test
|
|||||||
Paths_polysemy_plugin
|
Paths_polysemy_plugin
|
||||||
Build_doctests
|
Build_doctests
|
||||||
autogen-modules:
|
autogen-modules:
|
||||||
|
Paths_polysemy_plugin
|
||||||
Build_doctests
|
Build_doctests
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
test
|
||||||
@ -122,6 +123,6 @@ test-suite polysemy-plugin-test
|
|||||||
, should-not-typecheck >=2.1.0 && <3
|
, should-not-typecheck >=2.1.0 && <3
|
||||||
, syb ==0.7.*
|
, syb ==0.7.*
|
||||||
, transformers >=0.5.2.0 && <0.6
|
, transformers >=0.5.2.0 && <0.6
|
||||||
|
default-language: Haskell2010
|
||||||
if flag(corelint)
|
if flag(corelint)
|
||||||
ghc-options: -dcore-lint -dsuppress-all
|
ghc-options: -dcore-lint -dsuppress-all
|
||||||
default-language: Haskell2010
|
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
cabal-version: 2.0
|
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
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
@ -114,6 +114,7 @@ library
|
|||||||
, transformers >=0.5.2.0 && <0.6
|
, transformers >=0.5.2.0 && <0.6
|
||||||
, type-errors >=0.2.0.0
|
, type-errors >=0.2.0.0
|
||||||
, unagi-chan >=0.4.0.0 && <0.5
|
, unagi-chan >=0.4.0.0 && <0.5
|
||||||
|
default-language: Haskell2010
|
||||||
if impl(ghc < 8.6)
|
if impl(ghc < 8.6)
|
||||||
default-extensions:
|
default-extensions:
|
||||||
MonadFailDesugaring
|
MonadFailDesugaring
|
||||||
@ -125,7 +126,6 @@ library
|
|||||||
if impl(ghc < 8.2.2)
|
if impl(ghc < 8.2.2)
|
||||||
build-depends:
|
build-depends:
|
||||||
unsupported-ghc-version >1 && <1
|
unsupported-ghc-version >1 && <1
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
test-suite polysemy-test
|
test-suite polysemy-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
@ -150,6 +150,7 @@ test-suite polysemy-test
|
|||||||
Paths_polysemy
|
Paths_polysemy
|
||||||
Build_doctests
|
Build_doctests
|
||||||
autogen-modules:
|
autogen-modules:
|
||||||
|
Paths_polysemy
|
||||||
Build_doctests
|
Build_doctests
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
test
|
test
|
||||||
@ -175,10 +176,10 @@ test-suite polysemy-test
|
|||||||
async >=2.2 && <3
|
async >=2.2 && <3
|
||||||
, base >=4.9 && <5
|
, base >=4.9 && <5
|
||||||
, containers >=0.5 && <0.7
|
, 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
|
, first-class-families >=0.5.0.0 && <0.9
|
||||||
, hspec >=2.6.0 && <3
|
, hspec >=2.6.0 && <3
|
||||||
, inspection-testing >=0.4.2 && <0.6
|
, inspection-testing >=0.4.2 && <0.5
|
||||||
, mtl >=2.2.2 && <3
|
, mtl >=2.2.2 && <3
|
||||||
, polysemy
|
, polysemy
|
||||||
, stm ==2.*
|
, stm ==2.*
|
||||||
@ -188,8 +189,8 @@ test-suite polysemy-test
|
|||||||
, transformers >=0.5.2.0 && <0.6
|
, transformers >=0.5.2.0 && <0.6
|
||||||
, type-errors >=0.2.0.0
|
, type-errors >=0.2.0.0
|
||||||
, unagi-chan >=0.4.0.0 && <0.5
|
, unagi-chan >=0.4.0.0 && <0.5
|
||||||
|
default-language: Haskell2010
|
||||||
if impl(ghc < 8.6)
|
if impl(ghc < 8.6)
|
||||||
default-extensions:
|
default-extensions:
|
||||||
MonadFailDesugaring
|
MonadFailDesugaring
|
||||||
TypeInType
|
TypeInType
|
||||||
default-language: Haskell2010
|
|
||||||
|
@ -34,6 +34,7 @@ module Polysemy.Internal
|
|||||||
, usingSem
|
, usingSem
|
||||||
, liftSem
|
, liftSem
|
||||||
, hoistSem
|
, hoistSem
|
||||||
|
, restack
|
||||||
, Append
|
, Append
|
||||||
, InterpreterFor
|
, InterpreterFor
|
||||||
, InterpretersFor
|
, InterpretersFor
|
||||||
@ -343,6 +344,11 @@ hoistSem
|
|||||||
hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u
|
hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u
|
||||||
{-# INLINE hoistSem #-}
|
{-# 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
|
-- | Introduce an arbitrary number of effects on top of the effect stack. This
|
||||||
|
@ -18,6 +18,7 @@ module Polysemy.Internal.Combinators
|
|||||||
, reinterpretH
|
, reinterpretH
|
||||||
, reinterpret2H
|
, reinterpret2H
|
||||||
, reinterpret3H
|
, reinterpret3H
|
||||||
|
, interpretWeaving
|
||||||
|
|
||||||
-- * Conditional
|
-- * Conditional
|
||||||
, interceptUsing
|
, interceptUsing
|
||||||
@ -28,6 +29,7 @@ module Polysemy.Internal.Combinators
|
|||||||
, lazilyStateful
|
, lazilyStateful
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Control.Arrow ((>>>))
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import qualified Control.Monad.Trans.State.Lazy as LS
|
import qualified Control.Monad.Trans.State.Lazy as LS
|
||||||
import qualified Control.Monad.Trans.State.Strict as S
|
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
|
fmap y $ usingSem k $ runTactics s d v (interpretH f . d) $ f e
|
||||||
{-# INLINE interpretH #-}
|
{-# 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
|
-- | A highly-performant combinator for interpreting an effect statefully. See
|
||||||
-- 'stateful' for a more user-friendly variety of this function.
|
-- 'stateful' for a more user-friendly variety of this function.
|
||||||
|
@ -3,48 +3,157 @@
|
|||||||
|
|
||||||
module Polysemy.Internal.Scoped where
|
module Polysemy.Internal.Scoped where
|
||||||
|
|
||||||
import Polysemy.Internal (send, Member, InterpreterFor, Sem(Sem), runSem)
|
|
||||||
import Data.Kind (Type)
|
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.
|
import Polysemy
|
||||||
-- This requires the interpreter for @effect@ to be parameterized by @resource@ and constructed for every program using
|
|
||||||
|
-- | @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.
|
-- @Scoped@ separately.
|
||||||
--
|
--
|
||||||
-- An application for this is @Polysemy.Conc.Events@ from <https://hackage.haskell.org/package/polysemy-conc>,
|
-- 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;
|
-- <https://hackage.haskell.org/package/polysemy-conc>, in which each program
|
||||||
-- or a database transaction, in which a transaction handle is created for the wrapped program and passed
|
-- using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of
|
||||||
-- to the interpreter for the database effect.
|
-- 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/>.
|
-- 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
|
-- The constructors are not intended to be used directly; the smart constructor
|
||||||
-- interpreter for @effect@.
|
-- 'scoped' is used like a local interpreter for @effect@. 'scoped' takes an
|
||||||
data Scoped (resource :: Type) (effect :: Effect) :: Effect where
|
-- argument of type @param@, which will be passed through to the interpreter, to
|
||||||
Run :: ∀ resource effect m a . resource -> effect m a -> Scoped resource effect m a
|
-- be used by the resource allocation function.
|
||||||
InScope :: ∀ resource effect m a . (resource -> m a) -> Scoped resource effect m a
|
--
|
||||||
|
-- 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
|
-- |A convenience alias for a scope without parameters.
|
||||||
-- @Scoped resource effect@.
|
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 ::
|
scoped ::
|
||||||
∀ resource effect r .
|
∀ resource param effect r .
|
||||||
Member (Scoped resource effect) r =>
|
Member (Scoped param resource effect) r =>
|
||||||
|
param ->
|
||||||
InterpreterFor effect r
|
InterpreterFor effect r
|
||||||
scoped main =
|
scoped param main =
|
||||||
send $ InScope @resource @effect \ resource ->
|
send $ InScope @param @resource @effect param \ resource ->
|
||||||
transform @effect (Run resource) main
|
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 (
|
module Polysemy.Scoped (
|
||||||
-- * Effect
|
-- * Effect
|
||||||
Scoped,
|
Scoped,
|
||||||
|
|
||||||
-- * Constructor
|
-- * Constructors
|
||||||
scoped,
|
scoped,
|
||||||
|
scoped_,
|
||||||
|
rescope,
|
||||||
|
|
||||||
-- * Interpreters
|
-- * Interpreters
|
||||||
runScoped,
|
|
||||||
runScopedAs,
|
|
||||||
interpretScopedH,
|
interpretScopedH,
|
||||||
|
interpretScopedH',
|
||||||
interpretScoped,
|
interpretScoped,
|
||||||
interpretScopedAs,
|
interpretScopedAs,
|
||||||
|
interpretScopedWithH,
|
||||||
|
interpretScopedWith,
|
||||||
|
interpretScopedWith_,
|
||||||
|
runScoped,
|
||||||
|
runScopedAs,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Polysemy.Internal (InterpreterFor, Sem, liftSem, raise)
|
import Polysemy.Internal
|
||||||
import Polysemy.Internal.Scoped (Scoped (Run, InScope), scoped, interpretH')
|
import Polysemy.Internal.Sing
|
||||||
import Polysemy.Internal.Union (Weaving(Weaving), injWeaving)
|
import Polysemy.Internal.Union
|
||||||
import Polysemy.Internal.Tactics (Tactical, runTactics)
|
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
|
-- | Construct an interpreter for a higher-order effect wrapped in a 'Scoped',
|
||||||
-- @effect@.
|
-- given a resource allocation function and a parameterized handler for the
|
||||||
|
-- plain effect.
|
||||||
--
|
--
|
||||||
-- >>> runScoped withResource scopedInterpreter
|
-- This combinator is analogous to 'interpretH' in that it allows the handler to
|
||||||
--
|
-- use the 'Tactical' environment and transforms the effect into other effects
|
||||||
-- @withResource@ is a callback function, allowing the user to acquire the resource for each program from other effects.
|
-- on the stack.
|
||||||
--
|
|
||||||
-- @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.
|
|
||||||
interpretScopedH ::
|
interpretScopedH ::
|
||||||
∀ resource effect r .
|
∀ param resource effect r .
|
||||||
(∀ x . (resource -> Sem r x) -> Sem r x) ->
|
-- | 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) ->
|
(∀ 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 =
|
interpretScopedH withResource scopedHandler =
|
||||||
run
|
go
|
||||||
where
|
where
|
||||||
run :: InterpreterFor (Scoped resource effect) r
|
go :: InterpreterFor (Scoped param resource effect) r
|
||||||
run =
|
go =
|
||||||
interpretH' \ (Weaving effect s wv ex ins) -> case effect of
|
interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of
|
||||||
Run resource act ->
|
Run resource act ->
|
||||||
ex <$> runTactics s (raise . run . wv) ins (run . wv) (scopedHandler resource act)
|
ex <$> runTactics s (raise . go . wv) ins (go . wv)
|
||||||
InScope main ->
|
(scopedHandler resource act)
|
||||||
ex <$> withResource \ resource -> run (wv (main resource <$ s))
|
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 ::
|
interpretScoped ::
|
||||||
∀ resource effect r .
|
∀ resource param effect r .
|
||||||
(∀ x . (resource -> Sem r x) -> Sem r x) ->
|
(∀ x . param -> (resource -> Sem r x) -> Sem r x) ->
|
||||||
(∀ r0 x . resource -> effect (Sem r0) x -> Sem r x) ->
|
(∀ m x . resource -> effect m x -> Sem r x) ->
|
||||||
InterpreterFor (Scoped resource effect) r
|
InterpreterFor (Scoped param resource effect) r
|
||||||
interpretScoped withResource scopedHandler =
|
interpretScoped withResource scopedHandler =
|
||||||
run
|
interpretScopedH withResource \ r e -> liftT (scopedHandler r e)
|
||||||
where
|
{-# inline interpretScoped #-}
|
||||||
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))
|
|
||||||
|
|
||||||
|
-- | Variant of 'interpretScoped' in which the resource allocator is a plain
|
||||||
-- |Variant of 'interpretScoped' in which the resource allocator is a plain action.
|
-- action.
|
||||||
interpretScopedAs ::
|
interpretScopedAs ::
|
||||||
∀ resource effect r .
|
∀ resource param effect r .
|
||||||
Sem r resource ->
|
(param -> Sem r resource) ->
|
||||||
(∀ r0 x . resource -> effect (Sem r0) x -> Sem r x) ->
|
(∀ m x . resource -> effect m x -> Sem r x) ->
|
||||||
InterpreterFor (Scoped resource effect) r
|
InterpreterFor (Scoped param resource effect) r
|
||||||
interpretScopedAs resource =
|
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:
|
packages:
|
||||||
- .
|
- .
|
||||||
|
Loading…
Reference in New Issue
Block a user