polysemy-resume 0.6.0.0 → 0.7.0.0

raw patch · 5 files changed

+618/−181 lines, 5 filesdep ~polysemyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: polysemy

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• lib/Polysemy/Resume.hs +3/−0
• lib/Polysemy/Resume/Interpreter/Scoped.hs +157/−178
• polysemy-resume.cabal +4/−3
• test/Polysemy/Resume/Test/ScopedTest.hs +450/−0

@@ -1,5 +1,9 @@ # Unreleased +# 0.7.0.0++* Rewrite `Scoped` interpreters in Polysemy 1.9 style.+ # 0.6.0.0  * Add `replaceStop`, shorthand for `mapStop . const`.

@@ -4,6 +4,7 @@   -- $intro   module Polysemy.Resume.Effect.Stop,   module Polysemy.Resume.Effect.Resumable,+   -- * Resuming a Stopped Computation   resume,   (!!),@@ -34,9 +35,11 @@   interpretScopedRWith,   interpretScopedRWithH,   interpretScopedRWith_,+   -- * Partial Handlers   -- $partial   resumableOr,+   -- * Various Combinators   resumeAs,   (<!),

@@ -8,10 +8,12 @@ import GHC.Err (errorWithoutStackTrace) import Polysemy.Internal (liftSem, restack) import Polysemy.Internal.Combinators (interpretWeaving)-import Polysemy.Internal.Scoped (Scoped (InScope, Run))+import Polysemy.Internal.Scoped (OuterRun (OuterRun), Scoped (InScope, Run)) import Polysemy.Internal.Sing (KnownList (singList)) import Polysemy.Internal.Tactics (liftT)-import Polysemy.Internal.Union (Weaving (Weaving), extendMembershipLeft, injWeaving, injectMembership, weave)+import Polysemy.Internal.Union (Weaving (Weaving), injWeaving, injectMembership, weave)+import Polysemy.Opaque (Opaque (Opaque))+import Polysemy.Scoped (runScopedNew)  import Polysemy.Resume.Effect.Resumable (Resumable (Resumable), type (!!)) import Polysemy.Resume.Effect.Stop (Stop)@@ -31,38 +33,74 @@     Left err -> Left err <$ s {-# inline exResumable #-} +runScopedResumable ::+  ∀ param effect err r .+  (∀ q. param -> InterpreterFor effect (Stop err : Opaque q : r)) ->+  InterpreterFor (Scoped param effect !! err) r+runScopedResumable h =+  interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' _)) s wv ex _) -> case effect of+    Run w _ -> errorWithoutStackTrace $ "top level run with depth " ++ show w+    InScope param main ->+      wv (wv' (main 0 <$ s') <$ s)+        & raiseUnder2+        & go 0+        & raiseUnder+        & h param+        & runStop+        & interpretH (\(Opaque (OuterRun w _)) ->+            errorWithoutStackTrace $ "unhandled OuterRun with depth " ++ show w)+        & exResumable s ex ex'+  where+    go' ::+      Word ->+      InterpreterFor (Opaque (OuterRun effect)) (effect : Opaque (OuterRun effect) : r)+    go' depth =+      interpretWeaving \ (Weaving sr@(Opaque (OuterRun w act)) s wv ex ins) ->+        if w == depth then+          liftSem $ injWeaving $ Weaving act s (go' depth . wv) ex ins+        else+          liftSem $ injWeaving $ Weaving sr s (go' depth . wv) ex ins+    go ::+      Word ->+      InterpreterFor (Scoped param effect !! err) (effect : Opaque (OuterRun effect) : r)+    go depth =+      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of+        Run w act+          | w == depth ->+            ex . fmap Right <$> liftSem (weave s (go depth . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))+          | otherwise ->+            ex . fmap Right <$> liftSem (weave s (go depth . wv) ins (injWeaving (Weaving (Opaque (OuterRun w act)) s' wv' ex' ins')))+        InScope param main -> do+          let !depth' = depth + 1+          wv (wv' (main depth' <$ s') <$ s)+            & go depth'+            & raiseUnder+            & h param+            & runStop+            & raiseUnder2+            & go' depth+            & exResumable s ex ex'+{-# inline runScopedResumable #-}+ -- |Combined higher-order interpreter for 'Scoped' and 'Resumable'. -- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the -- entire scope. interpretScopedResumableH ::   ∀ param resource effect err r .-  (∀ x . param -> (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r) x) ->+  (∀ q x . param -> (resource -> Sem (Stop err : Opaque q : r) x) -> Sem (Stop err : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumableH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretH (scopedHandler resource) (raiseUnder (go $ raiseUnder $ wv ((wv' (main <$ s')) <$ s)))-    _ ->-      errorWithoutStackTrace "top level run"-  where-    go :: InterpreterFor (Scoped param effect !! err) (effect : r)-    go =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        Run act ->-          ex . fmap Right <$> liftSem (weave s (go . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))-        InScope param main -> do-          exResumable s ex ex' $ raise $ runStop $ withResource param \ resource ->-            interpretH (scopedHandler resource) (raiseUnder (go $ wv (wv' (main <$ s') <$ s)))+  runScopedResumable \ param sem ->+    withResource param \ r -> interpretH (scopedHandler r) sem  -- |Combined interpreter for 'Scoped' and 'Resumable'. -- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the -- entire scope. interpretScopedResumable ::   ∀ param resource effect err r .-  (∀ x . param -> (resource -> Sem (Stop err : r) x) -> Sem (Stop err : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  (∀ q x . param -> (resource -> Sem (Stop err : Opaque q : r) x) -> Sem (Stop err : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumable withResource scopedHandler =   interpretScopedResumableH withResource \ r e -> liftT (scopedHandler r e)@@ -73,8 +111,8 @@ -- In this variant, the resource allocator is a plain action. interpretScopedResumable_ ::   ∀ param resource effect err r .-  (param -> Sem (Stop err : r) resource) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  (∀ q . param -> Sem (Stop err : Opaque q : r) resource) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumable_ resource =   interpretScopedResumable \ p use -> use =<< resource p@@ -84,49 +122,34 @@ -- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the -- entire scope. interpretScopedResumableWithH ::-  ∀ extra param resource effect err r r1 extraerr .-  extraerr ~ (extra ++ '[Stop err]) =>-  r1 ~ (extraerr ++ r) =>-  KnownList (extra ++ '[Stop err]) =>-  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r1 x) ->+  ∀ extra param resource effect err r .+  KnownList extra =>+  (∀ q x . param -> (resource -> Sem (extra ++ Stop err : Opaque q : r) x) -> Sem (Stop err : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (extra ++ [Stop err, Opaque q] ++ r) x) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumableWithH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretH (scopedHandler resource) $ inScope $-          restack-            (injectMembership-             (singList @'[Scoped param effect !! err])-             (singList @(effect : extraerr))) $ wv (wv' (main <$ s') <$ s)-    _ ->-      errorWithoutStackTrace "top level Run"-  where-    inScope :: InterpreterFor (Scoped param effect !! err) (effect : r1)-    inScope =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        InScope param main ->-          restack-            (extendMembershipLeft (singList @(effect : extraerr))) $-            exResumable s ex ex' $ runStop $ withResource param \ resource ->-              interpretH (scopedHandler resource) (inScope $ wv (wv' (main <$ s') <$ s))-        Run act ->-          ex . fmap Right <$> liftSem (weave s (inScope . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))+  runScopedResumable \ param (sem :: Sem (effect : Stop err : Opaque q : r) x) ->+    withResource param \ resource ->+      interpretH (scopedHandler @q resource) $+      restack (injectMembership (singList @'[effect]) (singList @extra)) $+      sem  -- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are -- interpreted by the resource allocator. -- This allows 'Stop' to be sent from within the resource allocator so that the consumer receives it, terminating the -- entire scope. interpretScopedResumableWith ::-  ∀ extra param resource effect err r r1 .-  r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  KnownList (extra ++ '[Stop err]) =>-  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop err : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem r1 x) ->+  ∀ extra param resource effect err r .+  KnownList extra =>+  (∀ q x . param -> (resource -> Sem (extra ++ Stop err : Opaque q : r) x) -> Sem (Stop err : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (extra ++ Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumableWith withResource scopedHandler =-  interpretScopedResumableWithH @extra withResource \ r e -> liftT (scopedHandler r e)+  runScopedResumable \ param (sem :: Sem (effect : Stop err : Opaque q : r) x) ->+    withResource param \ resource ->+      sem+      & restack (injectMembership (singList @'[effect]) (singList @extra))+      & interpretH \ e -> liftT (scopedHandler @q resource e)  -- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are -- interpreted by the resource allocator.@@ -134,43 +157,38 @@ -- entire scope. -- In this variant, no resource is used and the allocator is a plain interpreter. interpretScopedResumableWith_ ::-  ∀ extra param effect err r r1 .-  r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  KnownList (extra ++ '[Stop err]) =>-  (∀ x . param -> Sem r1 x -> Sem (Stop err : r) x) ->-  (∀ r0 x . effect (Sem r0) x -> Sem r1 x) ->+  ∀ extra param effect err r .+  KnownList extra =>+  (∀ q x . param -> Sem (extra ++ Stop err : Opaque q : r) x -> Sem (Stop err : Opaque q : r) x) ->+  (∀ q r0 x . effect (Sem r0) x -> Sem (extra ++ Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumableWith_ extra scopedHandler =-  interpretScopedResumableWith @extra (\ p f -> extra p (f ())) (const scopedHandler)+  runScopedResumable \ param (sem :: Sem (effect : Stop err : Opaque q : r) x) ->+    extra @q param $+      sem+      & restack (injectMembership (singList @'[effect]) (singList @extra))+      & interpretH \ e -> liftT (scopedHandler @q e)  -- |Combined higher-order interpreter for 'Resumable' and 'Scoped'. -- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the -- scope. interpretResumableScopedH ::   ∀ param resource effect err r .-  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! err) (Sem r0) (Stop err : r) x) ->+  (∀ q x . param -> (resource -> Sem (Opaque q : r) x) -> Sem (Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! err) (Sem r0) (Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScopedH withResource scopedHandler =-  interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of-    Run _ -> errorWithoutStackTrace "top level run"-    InScope param main -> withResource param \ resource ->-      ex <$> interpretResumableH (scopedHandler resource) (inScope $ raiseUnder $ wv (main <$ s))-  where-    inScope :: InterpreterFor (Scoped param (effect !! err)) (effect !! err : r)-    inScope =-      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of-        Run act -> liftSem $ injWeaving $ Weaving act s (inScope . wv) ex ins-        InScope param main -> raise $ withResource param \ resource ->-          ex <$> interpretResumableH (scopedHandler resource) (inScope $ wv (main <$ s))+  runScopedNew \ param sem ->+    withResource param \ r ->+      interpretResumableH (scopedHandler r) sem  -- |Combined interpreter for 'Resumable' and 'Scoped'. -- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the -- scope. interpretResumableScoped ::   ∀ param resource effect err r .-  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  (∀ q x . param -> (resource -> Sem (Opaque q : r) x) -> Sem (Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScoped withResource scopedHandler =   interpretResumableScopedH withResource \ r e -> liftT (scopedHandler r e)@@ -182,58 +200,46 @@ interpretResumableScoped_ ::   ∀ param resource effect err r .   (param -> Sem r resource) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : Opaque q : r) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScoped_ resource =-  interpretResumableScoped \ p use -> use =<< resource p+  interpretResumableScoped \ p use -> use =<< raise (resource p)  -- |Combined higher-order interpreter for 'Resumable' and 'Scoped' that allows the handler to use additional effects -- that are interpreted by the resource allocator. -- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the -- scope. interpretResumableScopedWithH ::-  ∀ extra param resource effect err r r1 .-  r1 ~ (extra ++ r) =>+  ∀ extra param resource effect err r .   KnownList extra =>-  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! err) (Sem r0) (Stop err : r1) x) ->+  (∀ q x . param -> (resource -> Sem (extra ++ Opaque q : r) x) -> Sem (Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! err) (Sem r0) (Stop err : (extra ++ Opaque q : r)) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScopedWithH withResource scopedHandler =-  interpretWeaving \case-    Weaving (InScope param main) s wv ex _ ->-      ex <$> withResource param \ resource ->-        interpretResumableH (scopedHandler resource) $ inScope $-          restack-            (injectMembership-             (singList @'[Scoped param (effect !! err)])-             (singList @(effect !! err : extra))) $ wv (main <$ s)-    _ ->-      errorWithoutStackTrace "top level Run"-  where-    inScope :: InterpreterFor (Scoped param (effect !! err)) (effect !! err : r1)-    inScope =-      interpretWeaving \case-        Weaving (InScope param main) s wv ex _ ->-          restack-            (extendMembershipLeft (singList @(effect !! err : extra)))-            (ex <$> withResource param \resource ->-                interpretResumableH (scopedHandler resource) $ inScope $ wv (main <$ s))-        Weaving (Run act) s wv ex ins ->-          liftSem $ injWeaving $ Weaving act s (inScope . wv) ex ins+  runScopedNew \ param (sem :: Sem (effect !! err : Opaque q : r) x) ->+    withResource param \ resource ->+      sem+        & restack (injectMembership (singList @'[effect !! err]) (singList @extra))+        & interpretResumableH (scopedHandler @q resource)  -- |Combined interpreter for 'Resumable' and 'Scoped' that allows the handler to use additional effects that are -- interpreted by the resource allocator. -- In this variant, only the handler may send 'Stop', but this allows resumption to happen on each action inside of the -- scope. interpretResumableScopedWith ::-  ∀ extra param resource effect err r r1 .-  r1 ~ (extra ++ r) =>+  ∀ extra param resource effect err r .   KnownList extra =>-  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r1) x) ->+  (∀ q x . param -> (resource -> Sem (extra ++ Opaque q : r) x) -> Sem (Opaque q : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : (extra ++ r)) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScopedWith withResource scopedHandler =-  interpretResumableScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e)+  runScopedNew \ param (sem :: Sem (effect !! err : Opaque q : r) x) ->+    withResource param \resource ->+      sem+        & restack (injectMembership (singList @'[effect !! err]) (singList @extra))+        & interpretResumableH \ e ->+          liftT $+          restack (injectMembership @r (singList @(Stop err : extra)) (singList @'[Opaque q])) (scopedHandler resource e)  -- |Combined interpreter for 'Resumable' and 'Scoped' that allows the handler to use additional effects that are -- interpreted by the resource allocator.@@ -241,14 +247,13 @@ -- - Only the handler may send 'Stop', but this allows resumption to happen on each action inside of the scope. -- - No resource is used and the allocator is a plain interpreter. interpretResumableScopedWith_ ::-  ∀ extra param effect err r r1 .-  r1 ~ (extra ++ r) =>+  ∀ extra param effect err r .   KnownList extra =>-  (∀ x . param -> Sem r1 x -> Sem r x) ->-  (∀ r0 x . effect (Sem r0) x -> Sem (Stop err : r1) x) ->+  (∀ q x . param -> Sem (extra ++ Opaque q : r) x -> Sem (Opaque q : r) x) ->+  (∀ r0 x . effect (Sem r0) x -> Sem (Stop err : (extra ++ r)) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScopedWith_ extra scopedHandler =-  interpretResumableScopedWith @extra @param @() @effect @err @r @r1 (\ p f -> extra p (f ())) (const scopedHandler)+  interpretResumableScopedWith @extra @param @() @effect @err @r (\ p f -> extra p (f ())) (const scopedHandler)  -- |Combined higher-order interpreter for 'Resumable' and 'Scoped'. -- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the@@ -256,25 +261,13 @@ -- continuing the scope execution on resumption. interpretScopedRH ::   ∀ param resource effect eo ei r .-  (∀ x . param -> (resource -> Sem (Stop eo : r) x) -> Sem (Stop eo : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! ei) (Sem r0) (Stop ei : Stop eo : r) x) ->+  (∀ q x . param -> (resource -> Sem (Stop eo : Opaque q : r) x) -> Sem (Stop eo : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! ei) (Sem r0) (Stop ei : Stop eo : Opaque q : r) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedRH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretResumableH (scopedHandler resource) (raiseUnder (inScope $ raiseUnder $ wv (wv' (main <$ s') <$ s)))-    _ ->-      errorWithoutStackTrace "top level run"-  where-    inScope :: InterpreterFor (Scoped param (effect !! ei) !! eo) (effect !! ei : r)-    inScope =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        Run act ->-          ex . fmap Right <$> liftSem (weave s (inScope . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))-        InScope param main -> do-          exResumable s ex ex' $ raise $ runStop $ withResource param \ resource ->-            interpretResumableH (scopedHandler resource) (raiseUnder (inScope $ wv (wv' (main <$ s') <$ s)))+  runScopedResumable \ param sem ->+    withResource param \ r ->+      interpretResumableH (scopedHandler r) sem  -- |Combined interpreter for 'Scoped' and 'Resumable'. -- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the@@ -282,8 +275,8 @@ -- continuing the scope execution on resumption. interpretScopedR ::   ∀ param resource effect eo ei r .-  (∀ x . param -> (resource -> Sem (Stop eo : r) x) -> Sem (Stop eo : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : Stop eo : r) x) ->+  (∀ q x . param -> (resource -> Sem (Stop eo : Opaque q : r) x) -> Sem (Stop eo : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : Stop eo : Opaque q : r) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedR withResource scopedHandler =   interpretScopedRH withResource \ r e -> liftT (scopedHandler r e)@@ -297,10 +290,10 @@ interpretScopedR_ ::   ∀ param resource effect eo ei r .   (param -> Sem (Stop eo : r) resource) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : Stop eo : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : Stop eo : Opaque q : r) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedR_ resource =-  interpretScopedR \ p use -> use =<< resource p+  interpretScopedR \ p use -> use =<< raiseUnder (resource p)  -- |Combined higher-order interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects -- that are interpreted by the resource allocator.@@ -308,37 +301,17 @@ -- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail, -- continuing the scope execution on resumption. interpretScopedRWithH ::-  ∀ extra param resource effect eo ei r r1 extraerr .-  extraerr ~ (extra ++ '[Stop eo]) =>-  r1 ~ (extra ++ Stop eo : r) =>-  r1 ~ ((extra ++ '[Stop eo]) ++ r) =>-  KnownList (extra ++ '[Stop eo]) =>-  (∀ x . param -> (resource -> Sem (extra ++ Stop eo : r) x) -> Sem (Stop eo : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! ei) (Sem r0) (Stop ei : r1) x) ->+  ∀ extra param resource effect eo ei r .+  KnownList extra =>+  (∀ q x . param -> (resource -> Sem (extra ++ Stop eo : Opaque q : r) x) -> Sem (Stop eo : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! ei) (Sem r0) (Stop ei : (extra ++ Stop eo : Opaque q : r)) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedRWithH withResource scopedHandler =-  interpretWeaving \case-    Weaving (Resumable (Weaving (InScope param main) s' wv' ex' _)) s wv ex _ -> do-      exResumable s ex ex' $ runStop $ withResource param \ resource ->-        interpretResumableH (scopedHandler resource) $ inScope $-          restack-            (injectMembership-             (singList @'[Scoped param (effect !! ei) !! eo])-             (singList @(effect !! ei : extraerr))) $ wv (wv' (main <$ s') <$ s)-    _ ->-      errorWithoutStackTrace "top level Run"-  where-    inScope :: InterpreterFor (Scoped param (effect !! ei) !! eo) (effect !! ei : r1)-    inScope =-      interpretWeaving \ (Weaving (Resumable (Weaving effect s' wv' ex' ins')) s wv ex ins) -> case effect of-        InScope param main ->-          exResumable s ex ex' $-          restack (extendMembershipLeft (singList @(effect !! ei : extraerr))) $-          runStop $-          withResource param \ resource ->-            interpretResumableH (scopedHandler resource) (inScope $ wv (wv' (main <$ s') <$ s))-        Run act ->-          ex . fmap Right <$> liftSem (weave s (inScope . wv) ins (injWeaving (Weaving act s' wv' ex' ins')))+  runScopedResumable \ param (sem :: Sem (effect !! ei : Stop eo : Opaque q : r) x) ->+    withResource param \ resource ->+      sem+        & restack (injectMembership (singList @'[effect !! ei]) (singList @extra))+        & interpretResumableH (scopedHandler @q resource)  -- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are -- interpreted by the resource allocator.@@ -346,15 +319,18 @@ -- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail, -- continuing the scope execution on resumption. interpretScopedRWith ::-  ∀ extra param resource effect eo ei r r1 .-  r1 ~ (extra ++ Stop eo : r) =>-  r1 ~ ((extra ++ '[Stop eo]) ++ r) =>-  KnownList (extra ++ '[Stop eo]) =>-  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop eo : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : r1) x) ->+  ∀ extra param resource effect eo ei r .+  KnownList extra =>+  (∀ q x . param -> (resource -> Sem (extra ++ Stop eo : Opaque q : r) x) -> Sem (Stop eo : Opaque q : r) x) ->+  (∀ q r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : (extra ++ Stop eo : Opaque q : r)) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedRWith withResource scopedHandler =-  interpretScopedRWithH @extra withResource \ r e -> liftT (scopedHandler r e)+  runScopedResumable \ param (sem :: Sem (effect !! ei : Stop eo : Opaque q : r) x) ->+    withResource param \ resource ->+      sem+      & restack (injectMembership (singList @'[effect !! ei]) (singList @extra))+      & interpretResumableH \ e ->+        liftT (scopedHandler @q resource e)  -- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are -- interpreted by the resource allocator.@@ -363,12 +339,15 @@ --   continuing the scope execution on resumption. -- - The resource allocator is a plain action. interpretScopedRWith_ ::-  ∀ extra param effect eo ei r r1 .-  r1 ~ (extra ++ Stop eo : r) =>-  r1 ~ ((extra ++ '[Stop eo]) ++ r) =>-  KnownList (extra ++ '[Stop eo]) =>-  (∀ x . param -> Sem r1 x -> Sem (Stop eo : r) x) ->-  (∀ r0 x . effect (Sem r0) x -> Sem (Stop ei : r1) x) ->+  ∀ extra param effect eo ei r .+  KnownList extra =>+  (∀ q x . param -> Sem (extra ++ Stop eo : Opaque q : r) x -> Sem (Stop eo : Opaque q : r) x) ->+  (∀ q r0 x . effect (Sem r0) x -> Sem (Stop ei : (extra ++ Stop eo : Opaque q : r)) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedRWith_ extra scopedHandler =-  interpretScopedRWith @extra (\ p f -> extra p (f ())) (const scopedHandler)+  runScopedResumable \ param (sem :: Sem (effect !! ei : Stop eo : Opaque q : r) x) ->+    extra param do+      sem+        & restack (injectMembership (singList @'[effect !! ei]) (singList @extra))+        & interpretResumableH \ e ->+          liftT (scopedHandler @q e)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-resume-version:        0.6.0.0+version:        0.7.0.0 synopsis:       Polysemy error tracking description:    See https://hackage.haskell.org/package/polysemy-resume/docs/Polysemy-Resume.html category:       Error@@ -102,7 +102,7 @@   build-depends:       base >=4.12 && <5     , incipit-core >=0.4-    , polysemy ==1.8.*+    , polysemy ==1.9.*     , transformers   mixins:       base hiding (Prelude)@@ -117,6 +117,7 @@       Polysemy.Resume.ExampleTest       Polysemy.Resume.HigherOrderTest       Polysemy.Resume.Test.InterceptTest+      Polysemy.Resume.Test.ScopedTest   hs-source-dirs:       test   default-extensions:@@ -185,7 +186,7 @@   build-depends:       base >=4.12 && <5     , incipit-core >=0.4-    , polysemy ==1.8.*+    , polysemy ==1.9.*     , polysemy-plugin >=0.4.3 && <0.5     , polysemy-resume     , polysemy-test >=0.6

@@ -0,0 +1,450 @@+{-# options_ghc -fplugin=Polysemy.Plugin #-}++module Polysemy.Resume.Test.ScopedTest where++import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar)+import Polysemy.Scoped (+  Scoped,+  interpretScoped,+  interpretScopedH,+  interpretScopedH',+  interpretScopedWithH,+  rescope,+  scoped,+  scoped_,+  )+import Polysemy.Test (UnitTest, runTestAuto, unitTest, (===))+import Test.Tasty (TestTree, testGroup)++import Polysemy.Resume.Effect.Resumable (type (!!))+import Polysemy.Resume.Effect.Stop (Stop, stop)+import Polysemy.Resume.Interpreter.Resumable (interpretResumableH)+import Polysemy.Resume.Interpreter.Scoped (+  interpretResumableScopedH,+  interpretResumableScopedWithH,+  interpretScopedRH,+  interpretScopedRWithH,+  interpretScopedResumableH,+  interpretScopedResumableWithH,+  )+import Polysemy.Resume.Resume (resumeAs, resuming, (!!))++newtype Par =+  Par { unPar :: Int }+  deriving stock (Eq, Show)+  deriving newtype (Num, Real, Enum, Integral, Ord)++data E :: Effect where+  E1 :: E m Int+  E2 :: E m Int++makeSem ''E++data F :: Effect where+  F :: F m Int++makeSem ''F++handleE ::+  Member (Embed IO) r =>+  TVar Int ->+  E m a ->+  Tactical effect m (F : r) a+handleE tv = \case+  E1 -> do+    i1 <- embed (readTVarIO tv)+    i2 <- f+    pureT (i1 + i2 + 10)+  E2 ->+    pureT (-1)++interpretF ::+  Member (Embed IO) r =>+  TVar Int ->+  InterpreterFor F r+interpretF tv =+  interpret \ F -> do+    embed (atomically (writeTVar tv 7))+    pure 5++scope ::+  Member (Embed IO) r =>+  Par ->+  (TVar Int -> Sem (F : r) a) ->+  Sem r a+scope (Par n) use = do+  tv <- embed (newTVarIO n)+  interpretF tv (use tv)++test_scopedWith :: UnitTest+test_scopedWith =+  runTestAuto $ interpretScopedWithH @'[F] @_ @_ @E scope handleE do+    (i1, i2) <- scoped @_ @E 20 do+      i1 <- e1+      i2 <- scoped @_ @E 23 e1+      pure (i1, i2)+    35 === i1+    38 === i2++data H1 :: Effect where+  H1a :: m Int -> H1 m Int+  H1b :: H1 m Int+  H1c :: H1 m Int+  H1d :: m Int -> H1 m Int++makeSem ''H1++scopeH1 :: Int -> (Int -> Sem (Stop Int : r) a) -> Sem (Stop Int : r) a+scopeH1 p use =+  if p == (-1) then stop 500000 else use (p + 5)++handleH1 :: Int -> H1 m a -> Tactical H1 m (Stop Int : r) a+handleH1 n = \case+  H1a ma -> do+    i <- runTSimple ma+    pure (i <&> \ i' -> i' + n + 1)+  H1b ->+    pureT 50000+  H1c ->+    stop 100000+  H1d ma ->+    raise . interpretH (handleH1 (n + 1)) =<< runT ma++test_scopedResumable :: UnitTest+test_scopedResumable =+  runTestAuto $ interpretScopedResumableH @Int @Int @H1 @Int scopeH1 handleH1 do+    (i1, i2, i3, i4, i5) <- resumeAs @Int @(Scoped Int H1) (-50, -100, -200, -500, -700) $ scoped @Int @H1 20 do+      i1 <- h1a do+        h1b+      i2 <- resumeAs @Int @(Scoped Int H1) (-1000) $ scoped @Int @H1 23 do+        h1a do+          h1b+      i3 <- resuming pure $ scoped @Int @H1 5000 do+        h1a do+          h1c+      i4 <- resuming pure $ scoped @Int @H1 (-1) do+        h1b+      i5 <- h1d do+        h1a h1b+      pure (i1, i2, i3, i4, i5)+    50026 === i1+    50029 === i2+    100000 === i3+    500000 === i4+    50027 === i5++handleRE ::+  Member (Embed IO) r =>+  TVar Int ->+  E m a ->+  Tactical effect m (F : Stop Int : r) a+handleRE tv = \case+  E1 -> do+    i1 <- embed (readTVarIO tv)+    i2 <- f+    _ <- stop (i1 + i2)+    pureT (i1 + i2 + 10)+  E2 ->+    pureT =<< f++scopeR ::+  Member (Embed IO) r =>+  Par ->+  (TVar Int -> Sem (F : Stop Int : r) a) ->+  Sem (Stop Int : r) a+scopeR (Par n) use = do+  tv <- embed (newTVarIO n)+  _ <- interpretF tv (use tv)+  stop . (50 +) =<< embed (readTVarIO tv)++test_scopedResumableWith :: UnitTest+test_scopedResumableWith =+  runTestAuto $ interpretScopedResumableWithH @'[F] scopeR handleRE do+    i1 <- scoped 20 e1 !! pure+    i2 <- scoped 23 e2 !! pure+    25 === i1+    57 === i2++data Rs :: Effect where+  Rs1 :: m Int -> Rs m Int+  Rs2 :: Rs m Int+  Rs3 :: m Int -> Rs m Int+  Rs4 :: Rs m Int++makeSem ''Rs++scopeRs :: Int -> (Int -> Sem r a) -> Sem r a+scopeRs n use =+  use (n + 1)++handleRs :: Int -> Rs m a -> Tactical (Rs !! Int) m (Stop Int : r) a+handleRs n = \case+  Rs1 ma -> raise . interpretResumableH (handleRs (n + 1000000)) =<< runT ma+  Rs2 -> pureT (n + 20)+  Rs3 _ -> stop 200+  Rs4 -> stop 2000++test_resumableScoped :: UnitTest+test_resumableScoped =+  runTestAuto $ interpretResumableScopedH @Int @Int @Rs @Int scopeRs handleRs do+    (i1, i2, i3, i4, i5) <- scoped 10000 do+      i1 <- resuming pure $ rs1 do+        rs2+      i2 <- resuming pure $ rs3 do+        rs4+      i3 <- rs2 !! pure+      i4 <- resuming pure $ rs1 do+        rs4+      i5 <- raise $ scoped @Int @(Rs !! Int) 100000 do+        resumeAs 1000 $ rs1 rs2+      pure (i1, i2, i3, i4, i5)+    1010021 === i1+    200 === i2+    10021 === i3+    2000 === i4+    1100021 === i5++data Rsw :: Effect where+  Rsw1 :: m Int -> Rsw m Int+  Rsw2 :: Rsw m Int+  Rsw3 :: m Int -> Rsw m Int+  Rsw4 :: Rsw m Int++makeSem ''Rsw++data RswExtra :: Effect where+  RswExtra :: RswExtra m Int++makeSem ''RswExtra++scopeRsw :: Int -> (Int -> Sem (RswExtra : r) a) -> Sem r a+scopeRsw n use =+  interpret (\ RswExtra -> pure 20) $+  use (n + 1)++handleRsw ::+  Member RswExtra r =>+  Int ->+  Rsw m a ->+  Tactical (Rsw !! Int) m (Stop Int : r) a+handleRsw n = \case+  Rsw1 ma -> raise . interpretResumableH (handleRsw (n + 1000000)) =<< runT ma+  Rsw2 -> pureT . (n +) =<< rswExtra+  Rsw3 _ -> stop 200+  Rsw4 -> stop 2000++test_resumableScopedWith :: UnitTest+test_resumableScopedWith =+  runTestAuto $ interpretResumableScopedWithH @'[RswExtra] scopeRsw handleRsw do+    (i1, i2, i3, i4, i5) <- scoped 10000 do+      i1 <- resuming pure $ rsw1 do+        rsw2+      i2 <- resuming pure $ rsw3 do+        rsw4+      i3 <- rsw2 !! pure+      i4 <- resuming pure $ rsw1 do+        rsw4+      i5 <- raise $ scoped @Int @(Rsw !! Int) 100000 do+        resumeAs 1000 $ rsw1 rsw2+      pure (i1, i2, i3, i4, i5)+    1010021 === i1+    200 === i2+    10021 === i3+    2000 === i4+    1100021 === i5++data Rsr :: Effect where+  Rsr1 :: m Int -> Rsr m Int+  Rsr2 :: Rsr m Int+  Rsr3 :: m Int -> Rsr m Int+  Rsr4 :: Rsr m Int++makeSem ''Rsr++scopeRsr :: Int -> (Int -> Sem (Stop Double : r) a) -> Sem (Stop Double : r) a+scopeRsr n use =+  use (n + 1)++handleRsr :: Int -> Rsr m a -> Tactical (Rsr !! Int) m (Stop Int : r) a+handleRsr n = \case+  Rsr1 ma -> raise . interpretResumableH (handleRsr (n + 1000000)) =<< runT ma+  Rsr2 -> pureT (n + 20)+  Rsr3 _ -> stop 200+  Rsr4 -> stop 2000++test_scopedR :: UnitTest+test_scopedR =+  runTestAuto $ interpretScopedRH @Int @Int @Rsr @Double @Int scopeRsr handleRsr do+    (i1, i2, i3, i4, i5) <- resuming (\ i -> pure (round i, round i, round i, round i, round i)) $ scoped 10000 do+      i1 <- resuming pure $ rsr1 do+        rsr2+      i2 <- resuming pure $ rsr3 do+        rsr4+      i3 <- rsr2 !! pure+      i4 <- resuming pure $ rsr1 do+        rsr4+      i5 <- raise $ scoped @Int @(Rsr !! Int) 100000 do+        resumeAs 1000 $ rsr1 rsr2+      pure (i1, i2, i3, i4, i5)+    1010021 === i1+    200 === i2+    10021 === i3+    2000 === i4+    1100021 === i5++scopeRsrw :: Int -> (Int -> Sem (RswExtra : Stop Double : r) a) -> Sem (Stop Double : r) a+scopeRsrw n use =+  interpret (\ RswExtra -> pure 20) $+  use (n + 1)++handleRsrw :: Int -> Rsr m a -> Tactical (Rsr !! Int) m (Stop Int : r) a+handleRsrw n = \case+  Rsr1 ma -> raise . interpretResumableH (handleRsr (n + 1000000)) =<< runT ma+  Rsr2 -> pureT (n + 20)+  Rsr3 _ -> stop 200+  Rsr4 -> stop 2000++test_scopedRWith :: UnitTest+test_scopedRWith =+  runTestAuto $ interpretScopedRWithH @'[RswExtra] scopeRsrw handleRsrw do+    (i1, i2, i3, i4, i5) <- resuming (\ i -> pure (round i, round i, round i, round i, round i)) $ scoped 10000 do+      i1 <- resuming pure $ rsr1 do+        rsr2+      i2 <- resuming pure $ rsr3 do+        rsr4+      i3 <- rsr2 !! pure+      i4 <- resuming pure $ rsr1 do+        rsr4+      i5 <- raise $ scoped @Int @(Rsr !! Int) 100000 do+        resumeAs 1000 $ rsr1 rsr2+      pure (i1, i2, i3, i4, i5)+    1010021 === i1+    200 === i2+    10021 === i3+    2000 === i4+    1100021 === i5++scopeH ::+  Member (Embed IO) r =>+  Par ->+  (TVar Int -> Tactical e m r a) ->+  Tactical e m r a+scopeH (Par n) use = do+  tv <- embed (newTVarIO n)+  use tv++handleH ::+  Member (Embed IO) r =>+  TVar Int ->+  E (Sem r0) a ->+  Tactical e (Sem r0) r a+handleH tv = \case+  E1 -> do+    embed (atomically (modifyTVar' tv (+1)))+    pureT =<< embed (readTVarIO tv)+  E2 ->+    pureT 23++test_scopedH' :: UnitTest+test_scopedH' =+  runTestAuto $ interpretScopedH' scopeH handleH do+    r <- scoped @_ @E 100 do+      i1 <- e1+      i2 <- scoped @_ @E 200 e1+      i3 <- e1+      pure (i1, i2, i3)+    (101, 201, 102) === r++data RPar =+  RPar {+    rpD :: Double,+    rpB :: Bool+  }+  deriving stock (Eq, Show)++data RRes =+  RRes {+    rrD :: Double,+    rrI :: Int+  }+  deriving stock (Eq, Show)++scopeR1 :: RPar -> (RRes -> Sem r a) -> Sem r a+scopeR1 (RPar d b) use =+  use (RRes (d * 2) (if b then 1 else 2))++handleR1 :: RRes -> E m x -> Sem r x+handleR1 (RRes d i) = \case+  E1 -> pure (i + floor (d * 3))+  E2 -> pure (i + floor (d * 4))++rescopeP :: Int -> RPar+rescopeP i =+  RPar (fromIntegral i) False++test_rescope :: UnitTest+test_rescope =+  runTestAuto $ interpretScoped scopeR1 handleR1 do+    r <- rescope rescopeP do+      scoped @_ @E 100 do+        e1+    602 === r++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++test_higherOrder :: UnitTest+test_higherOrder =+  runTestAuto $ interpretScopedH scopeHO (handleHO 1) do+    r <- scoped_ @HO do+      inc do+        ret+    2 === r++data Esc :: Effect where+  Esc :: Esc m Int+makeSem ''Esc++data Indirect :: Effect where+  Indirect :: Indirect m Int+makeSem ''Indirect++interpretIndirect :: Member Esc r => InterpreterFor Indirect r+interpretIndirect = interpret \ Indirect -> esc++handleEsc :: Int -> Esc m a -> Sem r a+handleEsc i = \ Esc -> pure i++test_escape :: UnitTest+test_escape =+  runTestAuto $ interpretScoped (flip ($)) handleEsc $ scoped @_ @Esc 2 $ interpretIndirect do+    r <- scoped @_ @Esc 1 indirect+    2 === r++test_scoped :: TestTree+test_scoped =+  testGroup "scoped" [+    unitTest "scopedWith" test_scopedWith,+    unitTest "scopedResumable" test_scopedResumable,+    unitTest "scopedResumableWith" test_scopedResumableWith,+    unitTest "resumableScoped" test_resumableScoped,+    unitTest "resumableScopedWith" test_resumableScopedWith,+    unitTest "scopedR" test_scopedR,+    unitTest "scopedRWith" test_scopedRWith,+    unitTest "scopedH'" test_scopedH',+    unitTest "rescope" test_rescope,+    unitTest "switch higher-order interpreter" test_higherOrder+    -- unitTest "nested scope with other interpreter in between" test_escape+  ]