polysemy-conc 0.10.0.0 → 0.11.0.0

raw patch · 5 files changed

+454/−282 lines, 5 filesdep ~polysemy-timedep ~stm-chansdep ~torsorPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: polysemy-time, stm-chans, torsor, unagi-chan

API changes (from Hackage documentation)

Files

• changelog.md +7/−0
• lib/Polysemy/Conc/Effect/SyncRead.hs +1/−0
• lib/Polysemy/Conc/Interpreter/Scoped.hs +165/−267
• polysemy-conc.cabal +12/−9
• test/Polysemy/Conc/Test/ScopedTest.hs +269/−6

@@ -1,3 +1,10 @@+# 0.11.0.0++## Breaking++* Tweak the implementation of `Scoped` interpreters to allow changing higher-order interpreters.+  Slightly changes the signature of some of them.+ # 0.10.0.0  ## Breaking

@@ -4,6 +4,7 @@ module Polysemy.Conc.Effect.SyncRead where  import Polysemy.Time (TimeUnit)+import Prelude hiding (empty)  -- |An interface to a shared variable ('MVar') that can only be read. data SyncRead (d :: Type) :: Effect where

@@ -6,7 +6,7 @@ import GHC.Err (errorWithoutStackTrace) import Polysemy.Internal (Sem (Sem), hoistSem, liftSem, runSem) import Polysemy.Internal.Sing (KnownList (singList))-import Polysemy.Internal.Tactics (liftT, runTactics)+import Polysemy.Internal.Tactics (liftT) import Polysemy.Internal.Union (   Union (Union),   Weaving (Weaving),@@ -15,9 +15,10 @@   hoist,   injWeaving,   injectMembership,+  weave,   ) import Polysemy.Membership (ElemOf)-import Polysemy.Resume (Stop, runStop, type (!!))+import Polysemy.Resume (Stop, interpretResumableH, runStop, type (!!)) import Polysemy.Resume.Effect.Resumable (Resumable (Resumable))  import Polysemy.Conc.Effect.Scoped (Scoped (InScope, Run))@@ -38,6 +39,19 @@   hoistSem $ \ (Union pr wav) -> hoist (restack n) (Union (n pr) wav) {-# inline restack #-} +exResumable ::+  Functor f =>+  f () ->+  (f (Either err a) -> x) ->+  (f' a' -> a) ->+  Sem r (Either err (f (f' a'))) ->+  Sem r x+exResumable s ex ex' =+  fmap $ ex . \case+    Right a -> Right . ex' <$> a+    Left err -> Left err <$ s+{-# inline exResumable #-}+ -- | 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.@@ -56,16 +70,19 @@   (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r x) ->   InterpreterFor (Scoped param effect) r interpretScopedH withResource scopedHandler =-  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@@ -160,32 +177,33 @@ -- >       liftT atomicGet interpretScopedWithH ::   ∀ extra resource param effect r r1 .-  r1 ~ (extra ++ r) =>   KnownList extra =>+  r1 ~ (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 effect) r 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'.@@ -238,46 +256,34 @@ -- 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:+-- /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 @withResource@ does. ----- > runScoped (\ initial use -> use =<< embed (newTVarIO initial)) runAtomicStateTVar+-- This renders @withResource@ 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@@ -299,30 +305,21 @@   (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r) x) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumableH withResource scopedHandler =-  run (errorWithoutStackTrace "top level run")+  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-    run :: resource -> InterpreterFor (Scoped param effect !! err) r-    run resource =-      interpretWeaving \ (Weaving (Resumable inner) s' dist' ex' ins') ->-        case inner of-          Weaving effect s dist ex ins -> do-            let-              handleScoped = \case-                Run act ->-                  scopedHandler resource act-                InScope param main ->-                  raise (withResource param \ resource' -> Compose <$> raise (run resource' (dist' (dist (main <$ s) <$ s'))))-              tac =-                runTactics-                (Compose (s <$ s'))-                (raise . raise . run resource . fmap Compose . dist' . fmap dist . getCompose)-                (ins <=< ins' . getCompose)-                (raise . run resource . fmap Compose . dist' . fmap dist . getCompose)-                (handleScoped effect)-              exFinal = ex' . \case-                Right (Compose a) -> Right . ex <$> a-                Left err -> Left err <$ s'-            exFinal <$> runStop tac+    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)))  -- |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@@ -352,63 +349,35 @@ -- 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 .-  r1 ~ (extra ++ (Stop err : r)) =>-  r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  KnownList extra =>+  ∀ 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) ->   InterpreterFor (Scoped param effect !! err) r interpretScopedResumableWithH withResource scopedHandler =-  run (errorWithoutStackTrace "top level run")+  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-    run :: resource -> InterpreterFor (Scoped param effect !! err) r-    run resource =-      interpretWeaving \ (Weaving (Resumable inner) s' dist' ex' ins') ->-        case inner of-          Weaving effect s dist ex ins -> do-            let-              handleScoped = \case-                Run _ ->-                  error "top level Run"-                InScope param main ->-                  raise $ withResource param \ resource' ->-                    Compose <$> inScope resource' (restack (injectMembership (singList @'[Scoped param effect !! err]) (singList @(extra ++ '[Stop err]))) (dist' (dist (main <$ s) <$ s')))-              tac =-                runTactics-                (Compose (s <$ s'))-                (raise . raise . run resource . fmap Compose . dist' . fmap dist . getCompose)-                (ins <=< ins' . getCompose)-                (raise . run resource . fmap Compose . dist' . fmap dist . getCompose)-                (handleScoped effect)-              exFinal = ex' . \case-                Right (Compose a) -> Right . ex <$> a-                Left err -> Left err <$ s'-            exFinal <$> runStop tac-    inScope :: resource -> InterpreterFor (Scoped param effect !! err) r1-    inScope resource =-      interpretWeaving \ (Weaving (Resumable inner) s' dist' ex' ins') ->-        case inner of-          Weaving effect s dist ex ins -> do-            let-              handleScoped = \case-                Run act ->-                  scopedHandler resource act-                InScope param main ->-                  raise $ restack (extendMembershipLeft (singList @extra)) $ withResource param \ resource' ->-                    Compose <$> inScope resource' (dist' (dist (main <$ s) <$ s'))-              tac =-                runTactics-                (Compose (s <$ s'))-                (raise . inScope resource . fmap Compose . dist' . fmap dist . getCompose)-                (ins <=< ins' . getCompose)-                (inScope resource . fmap Compose . dist' . fmap dist . getCompose)-                (handleScoped effect)-              exFinal = ex' . \case-                Right (Compose a) -> Right . ex <$> a-                Left err -> Left err <$ s'-            exFinal <$> runStop (raise tac)+    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')))  -- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are -- interpreted by the resource allocator.@@ -416,9 +385,7 @@ -- entire scope. interpretScopedResumableWith ::   ∀ extra param resource effect err r r1 .-  r1 ~ (extra ++ (Stop err : r)) =>   r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  KnownList extra =>   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) ->@@ -433,9 +400,7 @@ -- 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)) =>   r1 ~ ((extra ++ '[Stop err]) ++ r) =>-  KnownList extra =>   KnownList (extra ++ '[Stop err]) =>   (∀ x . param -> Sem r1 x -> Sem (Stop err : r) x) ->   (∀ r0 x . effect (Sem r0) x -> Sem r1 x) ->@@ -449,28 +414,20 @@ interpretResumableScopedH ::   ∀ param resource effect err r .   (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! err) (Sem r0) (Stop err : r) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScopedH withResource scopedHandler =-  run (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 <$> interpretResumableH (scopedHandler resource) (inScope $ raiseUnder $ wv (main <$ s))   where-    run :: resource -> InterpreterFor (Scoped param (effect !! err)) r-    run resource =-      interpretWeaving \ (Weaving inner s' dist' ex' ins') -> case inner of-        Run (Resumable (Weaving effect s dist ex ins)) ->-          exFinal <$> runStop (tac (scopedHandler resource effect))-          where-            tac =-              runTactics-              (Compose (s <$ s'))-              (raise . raise . run resource . fmap Compose . dist' . fmap dist . getCompose)-              (ins <=< ins' . getCompose)-              (raise . run resource . fmap Compose . dist' . fmap dist . getCompose)-            exFinal = ex' . \case-              Right (Compose a) -> Right . ex <$> a-              Left err -> Left err <$ s'-        InScope param main ->-          ex' <$> withResource param \ resource' -> run resource' (dist' (main <$ s'))+    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))  -- |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@@ -504,32 +461,30 @@   r1 ~ (extra ++ r) =>   KnownList extra =>   (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop err : r1) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! err) (Sem r0) (Stop err : r1) x) ->   InterpreterFor (Scoped param (effect !! err)) r interpretResumableScopedWithH withResource scopedHandler =   interpretWeaving \case-    Weaving (InScope param main) s dist ex _ ->-      ex <$> withResource param \ resource' -> inScope resource' (restack (injectMembership (singList @'[Scoped param (effect !! err)]) (singList @extra)) (dist (main <$ s)))+    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"+      errorWithoutStackTrace "top level Run"   where-    inScope :: resource -> InterpreterFor (Scoped param (effect !! err)) r1-    inScope resource =+    inScope :: InterpreterFor (Scoped param (effect !! err)) (effect !! err : r1)+    inScope =       interpretWeaving \case-        Weaving (Run (Resumable (Weaving effect s dist ex ins))) s' dist' ex' ins' ->-          exFinal <$> runStop (tac (scopedHandler resource effect))-          where-            tac =-              runTactics-              (Compose (s <$ s'))-              (raise . raise . inScope resource . fmap Compose . dist' . fmap dist . getCompose)-              (ins <=< ins' . getCompose)-              (raise . inScope resource . fmap Compose . dist' . fmap dist . getCompose)-            exFinal = ex' . \case-              Right (Compose a) -> Right . ex <$> a-              Left err -> Left err <$ s'         Weaving (InScope param main) s wv ex _ ->-          restack (extendMembershipLeft (singList @extra)) (ex <$> withResource param \ resource' -> inScope resource' (wv (main <$ s)))+          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  -- |Combined interpreter for 'Resumable' and 'Scoped' that allows the handler to use additional effects that are -- interpreted by the resource allocator.@@ -567,44 +522,24 @@ 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 (Sem r0) (Stop ei : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical (effect !! ei) (Sem r0) (Stop ei : Stop eo : r) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedRH withResource scopedHandler =-  run (errorWithoutStackTrace "top level run")+  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-    run :: resource -> InterpreterFor (Scoped param (effect !! ei) !! eo) r-    run resource =-      interpretWeaving \ (Weaving (Resumable (Weaving inner s' dist' ex' ins')) s'' dist'' ex'' ins'') -> case inner of-        Run (Resumable (Weaving effect s dist ex ins)) ->-          exFinal <$> runStop @ei (tac (scopedHandler resource effect))-          where-            tac =-              runTactics-              (Compose (Compose (s <$ s') <$ s''))-              (raise . raise . run resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)-              (ins <=< ins' . getCompose <=< ins'' . getCompose)-              (raise . run resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)-            exFinal = \case-              Right (Compose fffa) ->-                ex'' $ fffa <&> Right . \ (Compose ffa) ->-                  ex' (Right . ex <$> ffa)-              Left err ->-                ex'' (Right (ex' (Left err <$ s')) <$ s'')+    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-          let-            inScope =-                raise (withResource param \ resource' -> Compose <$> raise (run resource' (dist'' (dist' (main <$ s') <$ s''))))-            tac =-              runTactics-              (Compose (s' <$ s''))-              (raise . raise . run resource . fmap Compose . dist'' . fmap dist' . getCompose)-              (ins' <=< ins'' . getCompose)-              (raise . run resource . fmap Compose . dist'' . fmap dist' . getCompose)-              inScope-            exFinal = ex'' . \case-              Right (Compose a) -> Right . ex' <$> a-              Left err -> Left err <$ s''-          exFinal <$> runStop tac+          exResumable s ex ex' $ raise $ runStop $ withResource param \ resource ->+            interpretResumableH (scopedHandler resource) (raiseUnder (inScope $ wv (wv' (main <$ s') <$ s)))  -- |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@@ -613,7 +548,7 @@ 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 : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : Stop eo : r) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedR withResource scopedHandler =   interpretScopedRH withResource \ r e -> liftT (scopedHandler r e)@@ -627,7 +562,7 @@ interpretScopedR_ ::   ∀ param resource effect eo ei r .   (param -> Sem (Stop eo : r) resource) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : r) x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop ei : Stop eo : r) x) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedR_ resource =   interpretScopedR \ p use -> use =<< resource p@@ -638,72 +573,37 @@ -- 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 .+  ∀ 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 =>   KnownList (extra ++ '[Stop eo]) =>-  (∀ x . param -> (resource -> Sem r1 x) -> Sem (Stop eo : r) x) ->-  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) (Stop ei : r1) x) ->+  (∀ 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) ->   InterpreterFor (Scoped param (effect !! ei) !! eo) r interpretScopedRWithH withResource scopedHandler =-  run+  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-    run :: InterpreterFor (Scoped param (effect !! ei) !! eo) r-    run =-      interpretWeaving \ (Weaving (Resumable (Weaving inner s' dist' ex' ins')) s'' dist'' ex'' ins'') -> case inner of-        InScope param main -> do-            let-              ma =-                  raise $ withResource param \ resource ->-                    Compose <$> inScope resource (restack (injectMembership (singList @'[Scoped param (effect !! ei) !! eo]) (singList @(extra ++ '[Stop eo]))) (dist'' (dist' (main <$ s') <$ s'')))-              tac =-                runTactics-                (Compose (s' <$ s''))-                (raise . raise . run . fmap Compose . dist'' . fmap dist' . getCompose)-                (ins' <=< ins'' . getCompose)-                (raise . run . fmap Compose . dist'' . fmap dist' . getCompose)-                ma-              exFinal = ex'' . \case-                Right (Compose a) -> Right . ex' <$> a-                Left err -> Left err <$ s''-            exFinal <$> runStop tac-        _ ->-          error "top level Run"-    inScope :: resource -> InterpreterFor (Scoped param (effect !! ei) !! eo) r1-    inScope resource =-      interpretWeaving \ (Weaving (Resumable (Weaving inner s' dist' ex' ins')) s'' dist'' ex'' ins'') -> case inner of-        Run (Resumable (Weaving effect s dist ex ins)) ->-          exFinal <$> runStop @ei (tac (scopedHandler resource effect))-          where-            tac =-              runTactics-              (Compose (Compose (s <$ s') <$ s''))-              (raise . raise . inScope resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)-              (ins <=< ins' . getCompose <=< ins'' . getCompose)-              (raise . inScope resource . fmap Compose . fmap (fmap Compose) . dist'' . fmap dist' . fmap (fmap dist . getCompose) . getCompose)-            exFinal = \case-              Right (Compose fffa) ->-                ex'' $ fffa <&> Right . \ (Compose ffa) ->-                  ex' (Right . ex <$> ffa)-              Left err ->-                ex'' (Right (ex' (Left err <$ s')) <$ s'')-        InScope param main -> do-            let-              ma =-                raise $ restack (extendMembershipLeft (singList @(Stop eo : extra))) $ withResource param \ resource' ->-                  Compose <$> inScope resource' (dist'' (dist' (main <$ s') <$ s''))-              tac =-                runTactics-                (Compose (s' <$ s''))-                (raise . raise . inScope resource . fmap Compose . dist'' . fmap dist' . getCompose)-                (ins' <=< ins'' . getCompose)-                (raise . inScope resource . fmap Compose . dist'' . fmap dist' . getCompose)-                ma-              exFinal = ex'' . \case-                Right (Compose a) -> Right . ex' <$> a-                Left err -> Left err <$ s''-            exFinal <$> runStop tac+    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')))  -- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are -- interpreted by the resource allocator.@@ -714,7 +614,6 @@   ∀ extra param resource effect eo ei r r1 .   r1 ~ (extra ++ Stop eo : r) =>   r1 ~ ((extra ++ '[Stop eo]) ++ r) =>-  KnownList extra =>   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) ->@@ -732,7 +631,6 @@   ∀ extra param effect eo ei r r1 .   r1 ~ (extra ++ Stop eo : r) =>   r1 ~ ((extra ++ '[Stop eo]) ++ r) =>-  KnownList extra =>   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) ->

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.6.+-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack  name:           polysemy-conc-version:        0.10.0.0+version:        0.11.0.0 synopsis:       Polysemy effects for concurrency description:    See https://hackage.haskell.org/package/polysemy-conc/docs/Polysemy-Conc.html category:       Concurrency@@ -94,6 +94,7 @@       DisambiguateRecordFields       DoAndIfThenElse       DuplicateRecordFields+      EmptyCase       EmptyDataDecls       ExistentialQuantification       FlexibleContexts@@ -108,8 +109,9 @@       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns-      OverloadedStrings+      OverloadedLabels       OverloadedLists+      OverloadedStrings       PackageImports       PartialTypeSignatures       PatternGuards@@ -141,11 +143,11 @@     , incipit-core >=0.3     , polysemy >=1.6     , polysemy-resume >=0.5-    , polysemy-time >=0.3+    , polysemy-time >=0.5     , stm-    , stm-chans >=2-    , torsor >=0.1-    , unagi-chan >=0.4+    , stm-chans >=3 && <3.1+    , torsor ==0.1.*+    , unagi-chan ==0.4.*     , unix   mixins:       base hiding (Prelude)@@ -188,6 +190,7 @@       DisambiguateRecordFields       DoAndIfThenElse       DuplicateRecordFields+      EmptyCase       EmptyDataDecls       ExistentialQuantification       FlexibleContexts@@ -202,8 +205,9 @@       MultiParamTypeClasses       MultiWayIf       NamedFieldPuns-      OverloadedStrings+      OverloadedLabels       OverloadedLists+      OverloadedStrings       PackageImports       PartialTypeSignatures       PatternGuards@@ -243,7 +247,6 @@     , tasty     , tasty-hedgehog     , time-    , unagi-chan     , unix   mixins:       base hiding (Prelude)

@@ -3,12 +3,18 @@ module Polysemy.Conc.Test.ScopedTest where  import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO, writeTVar)-import Polysemy.Resume (Stop, stop, (!!))+import Polysemy.Resume (Stop, stop, (!!), resumeAs, resuming, type (!!), interpretResumableH) import Polysemy.Test (UnitTest, runTestAuto, unitTest, (===)) import Test.Tasty (TestTree, testGroup) -import Polysemy.Conc.Effect.Scoped (rescope, scoped)-import Polysemy.Conc.Interpreter.Scoped (interpretScoped, interpretScopedH', interpretScopedResumableWithH, interpretScopedWithH)+import Polysemy.Conc.Effect.Scoped (rescope, scoped, scoped_, Scoped)+import Polysemy.Conc.Interpreter.Scoped (+  interpretScoped,+  interpretScopedH,+  interpretScopedH',+  interpretScopedResumableWithH,+  interpretScopedWithH, interpretScopedResumableH, interpretResumableScopedH, interpretResumableScopedWithH, interpretScopedRH, interpretScopedRWithH,+  )  newtype Par =   Par { unPar :: Int }@@ -67,6 +73,53 @@     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 ->@@ -99,6 +152,165 @@     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 ->@@ -120,8 +332,8 @@   E2 ->     pureT 23 -test_scopedH :: UnitTest-test_scopedH =+test_scopedH' :: UnitTest+test_scopedH' =   runTestAuto $ interpretScopedH' scopeH handleH do     r <- scoped @_ @E 100 do       i1 <- e1@@ -165,10 +377,61 @@         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 "scopedResumableWith" test_scopedResumableWith+    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   ]