diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 diff --git a/lib/Polysemy/Conc/Effect/SyncRead.hs b/lib/Polysemy/Conc/Effect/SyncRead.hs --- a/lib/Polysemy/Conc/Effect/SyncRead.hs +++ b/lib/Polysemy/Conc/Effect/SyncRead.hs @@ -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 diff --git a/lib/Polysemy/Conc/Interpreter/Scoped.hs b/lib/Polysemy/Conc/Interpreter/Scoped.hs --- a/lib/Polysemy/Conc/Interpreter/Scoped.hs +++ b/lib/Polysemy/Conc/Interpreter/Scoped.hs @@ -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) -> diff --git a/polysemy-conc.cabal b/polysemy-conc.cabal --- a/polysemy-conc.cabal +++ b/polysemy-conc.cabal @@ -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) diff --git a/test/Polysemy/Conc/Test/ScopedTest.hs b/test/Polysemy/Conc/Test/ScopedTest.hs --- a/test/Polysemy/Conc/Test/ScopedTest.hs +++ b/test/Polysemy/Conc/Test/ScopedTest.hs @@ -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 ]