mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
fix scoped interpreters automatically recursively interpreting
This commit is contained in:
parent
0b508d0ee3
commit
2d88b937dd
@ -26,6 +26,8 @@
|
||||
`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
|
||||
|
||||
@ -34,7 +36,9 @@
|
||||
- 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)
|
||||
|
||||
|
@ -47,17 +47,19 @@ interpretScopedH ::
|
||||
(∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r x) ->
|
||||
InterpreterFor (Scoped param effect) r
|
||||
interpretScopedH withResource scopedHandler =
|
||||
-- TODO investigate whether loopbreaker optimization is effective here
|
||||
go (errorWithoutStackTrace "top level run")
|
||||
interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of
|
||||
Run _ -> errorWithoutStackTrace "top level run"
|
||||
InScope param main -> withResource param \ resource ->
|
||||
ex
|
||||
<$> interpretH (scopedHandler resource) (go $ raiseUnder $ wv (main <$ s))
|
||||
where
|
||||
go :: resource -> InterpreterFor (Scoped param effect) r
|
||||
go resource =
|
||||
-- TODO investigate whether loopbreaker optimization is effective here
|
||||
go :: InterpreterFor (Scoped param effect) (effect ': r)
|
||||
go =
|
||||
interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of
|
||||
Run act ->
|
||||
ex <$> runTactics s (raise . go resource . wv) ins (go resource . wv)
|
||||
(scopedHandler resource act)
|
||||
InScope param main ->
|
||||
withResource param \ resource' -> ex <$> go resource' (wv (main <$ s))
|
||||
Run act -> liftSem $ injWeaving $ Weaving act s (go . wv) ex ins
|
||||
InScope param main -> raise $ withResource param \ resource ->
|
||||
ex <$> interpretH (scopedHandler resource) (go $ wv (main <$ s))
|
||||
{-# inline interpretScopedH #-}
|
||||
|
||||
-- | Variant of 'interpretScopedH' that allows the resource acquisition function
|
||||
@ -159,24 +161,25 @@ interpretScopedWithH ::
|
||||
interpretScopedWithH withResource scopedHandler =
|
||||
interpretWeaving \case
|
||||
Weaving (InScope param main) s wv ex _ ->
|
||||
ex <$> withResource param \ resource -> inScope resource $
|
||||
restack
|
||||
(injectMembership
|
||||
(singList @'[Scoped param effect])
|
||||
(singList @extra)) $ wv (main <$ s)
|
||||
ex <$> withResource param \ resource ->
|
||||
interpretH (scopedHandler resource) $ inScope $
|
||||
restack
|
||||
(injectMembership
|
||||
(singList @'[Scoped param effect])
|
||||
(singList @(effect ': extra))) $ wv (main <$ s)
|
||||
_ ->
|
||||
errorWithoutStackTrace "top level Run"
|
||||
where
|
||||
inScope :: resource -> InterpreterFor (Scoped param effect) r1
|
||||
inScope resource =
|
||||
inScope :: InterpreterFor (Scoped param effect) (effect ': r1)
|
||||
inScope =
|
||||
interpretWeaving \case
|
||||
Weaving (InScope param main) s wv ex _ ->
|
||||
restack (extendMembershipLeft (singList @extra))
|
||||
(ex <$> withResource param \resource' ->
|
||||
inScope resource' (wv (main <$ s)))
|
||||
restack
|
||||
(extendMembershipLeft (singList @(effect ': extra)))
|
||||
(ex <$> withResource param \resource ->
|
||||
interpretH (scopedHandler resource) $ inScope $ wv (main <$ s))
|
||||
Weaving (Run act) s wv ex ins ->
|
||||
ex <$> runTactics s (raise . inScope resource . wv) ins (inScope resource . wv)
|
||||
(scopedHandler resource act)
|
||||
liftSem $ injWeaving $ Weaving act s (inScope . wv) ex ins
|
||||
{-# inline interpretScopedWithH #-}
|
||||
|
||||
-- | First-order variant of 'interpretScopedWithH'.
|
||||
@ -227,46 +230,34 @@ interpretScopedWith_ withResource scopedHandler =
|
||||
-- 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.
|
||||
-- /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.
|
||||
--
|
||||
-- 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
|
||||
-- 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 .
|
||||
(∀ x . param -> (resource -> Sem r x) -> Sem r x) ->
|
||||
(resource -> InterpreterFor effect r) ->
|
||||
InterpreterFor (Scoped param effect) r
|
||||
runScoped withResource scopedInterpreter =
|
||||
go (errorWithoutStackTrace "top level run")
|
||||
interpretWeaving \(Weaving effect s wv ex _) -> case effect of
|
||||
Run _ -> errorWithoutStackTrace "top level run"
|
||||
InScope param main -> withResource param \ resource ->
|
||||
ex <$> scopedInterpreter resource (go (raiseUnder $ wv (main <$ s)))
|
||||
where
|
||||
go :: resource -> InterpreterFor (Scoped param effect) r
|
||||
go resource =
|
||||
go :: InterpreterFor (Scoped param effect) (effect ': r)
|
||||
go =
|
||||
interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of
|
||||
Run act ->
|
||||
scopedInterpreter resource
|
||||
$ liftSem $ injWeaving $ Weaving act s (raise . go resource . wv) ex ins
|
||||
Run act -> liftSem $ injWeaving $ Weaving act s (go . wv) ex ins
|
||||
InScope param main ->
|
||||
withResource param \ resource' -> ex <$> go resource' (wv (main <$ s))
|
||||
raise $ withResource param \ resource ->
|
||||
ex <$> scopedInterpreter resource (go (wv (main <$ s)))
|
||||
{-# inline runScoped #-}
|
||||
|
||||
-- | Variant of 'runScoped' in which the resource allocator returns the resource
|
||||
|
@ -54,6 +54,21 @@ 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
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel do
|
||||
describe "Scoped" do
|
||||
@ -65,3 +80,9 @@ spec = parallel do
|
||||
pure (i1, i2)
|
||||
35 `shouldBe` i1
|
||||
38 `shouldBe` i2
|
||||
it "switch interpreter" do
|
||||
r <- runM $ interpretScopedH scopeHO (handleHO 1) do
|
||||
scoped_ @HO do
|
||||
inc do
|
||||
ret
|
||||
2 `shouldBe` r
|
||||
|
Loading…
Reference in New Issue
Block a user