diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,30 @@ +# Unreleased + +# 0.6.0.0 + +* Add `replaceStop`, shorthand for `mapStop . const`. +* Add `∀` to `Stop` interpreters. +* Add resumers that transform to `Fail`. +* Move `Scoped` interpreters from `polysemy-conc`, since `Scoped` is now in `polysemy`. +* Support GHC 9.4. + +# 0.5.0.0 + +* Add interceptors. +* Change modules for effects to `Polysemy.Resume.Effect`. +* Add `stopEitherAs`. +* Add exception catching `stop` combinators. + +# 0.2.0.0 + +* Add combinators `resumeOr` and `resumingOr`, which take an additional branch for the success case. +* Improve `raiseResumable`: + * Don't discard resources + * Allow interpreter to change type of `a` +* Add operator versions of `resume` (`!!`) and `resumeAs` (``). +* Add combinators `resumeWith` and `resumingWith` that ignore the error and execute an action, plus their operator + variants `(!>>)` and `(<), (!>>), ( Sem r b) -> + Sem (eff : r) a -> + Sem r b + +type InterpreterTrans eff eff' r = + InterpreterTrans' eff eff' r r + +distribEither :: + Functor f => + f () -> + (f (Either err a) -> res) -> + Either err (f a) -> + res +distribEither initialState result = + result . \case + Right fa -> Right <$> fa + Left err -> Left err <$ initialState +{-# inline distribEither #-} + +-- | Convert a bare interpreter for @eff@, which (potentially) uses 'Stop' to signal errors, into an interpreter for +-- 'Resumable'. +-- /Beware/: This will display unsound behaviour if: +-- * the interpreter is wrapped with actions of another effect, as in: +-- +-- @ +-- interpretEff :: InterpreterFor Eff r +-- ... +-- +-- interpretEffResumable :: InterpreterFor (Resumable Text Eff) r +-- interpretEffResumable sem = +-- resumable (interpretEff (sem `finally` releaseResources)) +-- @ +-- +-- In this case, @releaseResources@ will be called after /every/ use of @Eff@ in @sem@, not after the entire thunk. +-- +-- * the interpreter of a higher-order effect uses a different interpreter after using @runT@/@bindT@. +-- In this case, it will use the original interpreter instead. +-- +-- If your use case matches one of these conditions, you'll need to use 'interpretResumable'. +-- +-- >>> run $ resumable interpretStopper (interpretResumer mainProgram) +-- 237 +resumable :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . + InterpreterFor eff (Stop err : r) -> + InterpreterFor (Resumable err eff) r +resumable interpreter (Sem m) = + Sem \ k -> m \ u -> + case decomp (hoist (resumable interpreter) u) of + Right (Weaving (Resumable e) s wv ex ins) -> + distribEither s ex <$> runSem resultFromEff k + where + resultFromEff = + runStop $ interpreter $ liftSem $ weave s (raise . raise . wv) ins (injWeaving e) + Left g -> + k g +{-# inline resumable #-} + +-- | Convenience combinator for turning an interpreter that doesn't use 'Stop' into a 'Resumable'. +raiseResumable :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . + InterpreterTrans (Resumable err eff) eff r +raiseResumable interpreter = + interpreter . normalize . raiseUnder + where + normalize :: InterpreterFor (Resumable err eff) (eff : r) + normalize (Sem m) = + Sem \ k -> m \ u -> + case decomp (hoist normalize u) of + Right (Weaving (Resumable e) s wv ex ins) -> + ex . fmap Right <$> (usingSem k $ liftSem $ weave s wv ins (injWeaving e)) + Left g -> + k g + {-# inline normalize #-} +{-# inline raiseResumable #-} + +-- | Like 'resumable', but use exceptions instead of 'Control.Monad.Trans.ExceptT'. +resumableIO :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . + Exception (StopExc err) => + Member (Final IO) r => + InterpreterFor eff (Stop err : r) -> + InterpreterFor (Resumable err eff) r +resumableIO interpreter (Sem m) = + Sem \ k -> m \ u -> + case decomp (hoist (resumable interpreter) u) of + Right (Weaving (Resumable e) s wv ex ins) -> + distribEither s ex <$> runSem resultFromEff k + where + resultFromEff = + stopToIOFinal $ interpreter $ liftSem $ weave s (raise . raise . wv) ins (injWeaving e) + Left g -> + k g +{-# inline resumableIO #-} + +-- | Like 'interpretResumable', but for higher-order effects. +interpretResumableH :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . + -- | This handler function has @'Stop' err@ in its stack, allowing it to absorb errors. + (∀ x r0 . eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> + InterpreterFor (Resumable err eff) r +interpretResumableH handler (Sem m) = + Sem \ k -> m \ u -> + case decomp u of + Left there -> + k (hoist (interpretResumableH handler) there) + Right (Weaving (Resumable (Weaving e s dist ex ins)) sOuter distOuter exOuter insOuter) -> + usingSem k (exFinal <$> runStop (tac (handler e))) + where + tac = + runTactics + (Compose (s <$ sOuter)) + (raiseUnder . fmap Compose . distOuter . fmap dist . getCompose) + (ins <=< insOuter . getCompose) + (raise . interpretResumableH handler . fmap Compose . distOuter . fmap dist . getCompose) + exFinal = exOuter . \case + Right (Compose a) -> Right . ex <$> a + Left err -> Left err <$ sOuter +{-# inline interpretResumableH #-} + +-- | Create an interpreter for @'Resumable' err eff@ by supplying a handler function for @eff@, analogous to +-- 'Polysemy.interpret'. +-- If the handler throws errors with 'Stop', they will be absorbed into 'Resumable', to be caught by +-- 'Polysemy.Resume.resume' in a downstream interpreter. +-- +-- @ +-- interpretStopperResumable :: +-- InterpreterFor Stopper r +-- interpretStopperResumable = +-- interpretResumable \\case +-- StopBang -> stop (Bang 13) +-- StopBoom -> stop (Boom "ouch") +-- @ +-- +-- >>> run $ interpretStopperResumable (interpretResumer mainProgram) +-- 237 +interpretResumable :: + ∀ (err :: Type) (eff :: Effect) r . + FirstOrder eff "interpretResumable" => + (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : r) x) -> + InterpreterFor (Resumable err eff) r +interpretResumable handler = + interpretResumableH \ e -> liftT (handler e) +{-# inline interpretResumable #-} + +-- | Interceptor variant of 'interpretResumableH'. +interceptResumableUsingH :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . + ElemOf (Resumable err eff) r -> + (∀ x r0 . eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> + Sem r a -> + Sem r a +interceptResumableUsingH proof handler (Sem m) = + Sem \ k -> m \ u -> + case prjUsing proof u of + Nothing -> + k (hoist (interceptResumableUsingH proof handler) u) + Just (Weaving (Resumable (Weaving e s dist ex ins)) sOuter distOuter exOuter insOuter) -> + usingSem k (exFinal <$> runStop (tac (handler e))) + where + tac = + runTactics + (Compose (s <$ sOuter)) + (raise . raise . fmap Compose . distOuter . fmap dist . getCompose) + (ins <=< insOuter . getCompose) + (raise . interceptResumableUsingH proof handler . fmap Compose . distOuter . fmap dist . getCompose) + exFinal = exOuter . \case + Right (Compose a) -> Right . ex <$> a + Left err -> Left err <$ sOuter +{-# inline interceptResumableUsingH #-} + +-- | Interceptor variant of 'interpretResumable'. +interceptResumableUsing :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . + FirstOrder eff "interceptResumableUsing" => + ElemOf (Resumable err eff) r -> + (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : r) x) -> + Sem r a -> + Sem r a +interceptResumableUsing proof f = + interceptResumableUsingH proof \ e -> + liftT (f e) +{-# inline interceptResumableUsing #-} + +-- | Interceptor variant of 'interpretResumableH'. +interceptResumableH :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . + Member (Resumable err eff) r => + (∀ x r0 . eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> + Sem r a -> + Sem r a +interceptResumableH = + interceptResumableUsingH membership +{-# inline interceptResumableH #-} + +-- | Interceptor variant of 'interpretResumable'. +interceptResumable :: + ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . + Member (Resumable err eff) r => + FirstOrder eff "interceptResumable" => + (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : r) x) -> + Sem r a -> + Sem r a +interceptResumable f = + interceptResumableH \ e -> + liftT (f e) +{-# inline interceptResumable #-} + +-- | Convert an interpreter for @eff@ that uses 'Error' into one using 'Stop' and wrap it using 'resumable'. +resumableError :: + ∀ (err :: Type) (eff :: Effect) r . + InterpreterFor eff (Error err : Stop err : r) -> + InterpreterFor (Resumable err eff) r +resumableError interpreter = + resumable (stopOnError . interpreter . raiseUnder) +{-# inline resumableError #-} + +-- | Convert an interpreter for @eff@ that throws errors of type @err@ into a @Resumable@, but limiting the errors +-- handled by consumers to the type @handled@, which rethrowing 'Error's of type @unhandled@. +-- +-- The function @canHandle@ determines how the errors are split. +-- +-- @ +-- newtype Blip = +-- Blip { unBlip :: Int } +-- deriving (Eq, Show) +-- +-- bangOnly :: Boom -> Either Text Blip +-- bangOnly = \\case +-- Bang n -> Right (Blip n) +-- Boom msg -> Left msg +-- +-- interpretResumerPartial :: +-- Member (Resumable Blip Stopper) r => +-- InterpreterFor Resumer r +-- interpretResumerPartial = +-- interpret \\ MainProgram -> +-- resume (192 \<$ stopBang) \\ (Blip num) -> +-- pure (num * 3) +-- @ +-- +-- >>> runError (resumableFor bangOnly interpretStopper (interpretResumerPartial mainProgram)) +-- Right 39 +resumableOr :: + ∀ (err :: Type) (eff :: Effect) unhandled handled r . + Member (Error unhandled) r => + (err -> Either unhandled handled) -> + InterpreterFor eff (Stop err : r) -> + InterpreterFor (Resumable handled eff) r +resumableOr canHandle interpreter (Sem m) = + Sem \ k -> m \ u -> + case decomp (hoist (resumableOr canHandle interpreter) u) of + Right (Weaving (Resumable e) s wv ex ins) -> + distribEither s ex <$> (tryHandle =<< runSem resultFromEff k) + where + tryHandle = \case + Left err -> + either (k . inj . Throw) (pure . Left) (canHandle err) + Right a -> + pure (Right a) + resultFromEff = + runStop $ interpreter $ liftSem $ weave s (raise . raise . wv) ins (injWeaving e) + Left g -> + k g +{-# inline resumableOr #-} + +-- | Variant of 'resumableOr' that uses 'Maybe' and rethrows the original error. +resumableFor :: + ∀ (err :: Type) (eff :: Effect) handled r . + Member (Error err) r => + (err -> Maybe handled) -> + InterpreterFor eff (Stop err : r) -> + InterpreterFor (Resumable handled eff) r +resumableFor canHandle = + resumableOr canHandle' + where + canHandle' err = + maybeToRight err (canHandle err) +{-# inline resumableFor #-} + +-- | Reinterpreting variant of 'resumableFor'. +catchResumable :: + ∀ (err :: Type) (eff :: Effect) handled r . + Members [eff, Error err] r => + (err -> Maybe handled) -> + InterpreterFor (Resumable handled eff) r +catchResumable canHandle (Sem m) = + Sem \ k -> m \ u -> + case decomp (hoist (catchResumable canHandle) u) of + Right (Weaving (Resumable e) s wv ex ins) -> + distribEither s ex <$> runSem resultFromEff k + where + resultFromEff = + catchJust canHandle (fmap Right $ liftSem $ weave s wv ins (injWeaving e)) (pure . Left) + Left g -> + k g +{-# inline catchResumable #-} + +-- | Interpret an effect @eff@ by wrapping it in @Resumable@ and @Stop@ and leaving the rest up to the user. +runAsResumable :: + ∀ (err :: Type) (eff :: Effect) r . + Members [Resumable err eff, Stop err] r => + InterpreterFor eff r +runAsResumable (Sem m) = + Sem \ k -> m \ u -> + case decomp (hoist (runAsResumable @err @eff) u) of + Right wav -> + runSem (either (stop @err) pure =<< send (Resumable wav)) k + Left g -> + k g +{-# inline runAsResumable #-} diff --git a/lib/Polysemy/Resume/Interpreter/Scoped.hs b/lib/Polysemy/Resume/Interpreter/Scoped.hs new file mode 100644 --- /dev/null +++ b/lib/Polysemy/Resume/Interpreter/Scoped.hs @@ -0,0 +1,374 @@ +{-# options_haddock prune #-} + +-- |Description: Interpreters for 'Scoped' in combination with 'Resumable' +-- +-- @since 0.6.0.0 +module Polysemy.Resume.Interpreter.Scoped where + +import GHC.Err (errorWithoutStackTrace) +import Polysemy.Internal (liftSem, restack) +import Polysemy.Internal.Combinators (interpretWeaving) +import Polysemy.Internal.Scoped (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.Resume.Effect.Resumable (Resumable (Resumable), type (!!)) +import Polysemy.Resume.Effect.Stop (Stop) +import Polysemy.Resume.Interpreter.Resumable (interpretResumableH) +import Polysemy.Resume.Interpreter.Stop (runStop) + +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 #-} + +-- |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) -> + 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))) + +-- |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) -> + InterpreterFor (Scoped param effect !! err) r +interpretScopedResumable withResource scopedHandler = + interpretScopedResumableH withResource \ r e -> liftT (scopedHandler r e) + +-- |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. +-- 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) -> + InterpreterFor (Scoped param effect !! err) r +interpretScopedResumable_ resource = + interpretScopedResumable \ p use -> use =<< 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. +-- 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) -> + 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'))) + +-- |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) -> + InterpreterFor (Scoped param effect !! err) r +interpretScopedResumableWith withResource scopedHandler = + interpretScopedResumableWithH @extra withResource \ r e -> liftT (scopedHandler r e) + +-- |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. +-- 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) -> + InterpreterFor (Scoped param effect !! err) r +interpretScopedResumableWith_ extra scopedHandler = + interpretScopedResumableWith @extra (\ p f -> extra p (f ())) (const scopedHandler) + +-- |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) -> + 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)) + +-- |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) -> + InterpreterFor (Scoped param (effect !! err)) r +interpretResumableScoped withResource scopedHandler = + interpretResumableScopedH withResource \ r e -> liftT (scopedHandler r e) + +-- |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. +-- - The resource allocator is a plain action. +interpretResumableScoped_ :: + ∀ param resource effect err r . + (param -> Sem r resource) -> + (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r) x) -> + InterpreterFor (Scoped param (effect !! err)) r +interpretResumableScoped_ resource = + interpretResumableScoped \ p use -> use =<< 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) => + 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) -> + 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 + +-- |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) => + KnownList extra => + (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) -> + (∀ r0 x . resource -> effect (Sem r0) x -> Sem (Stop err : r1) x) -> + InterpreterFor (Scoped param (effect !! err)) r +interpretResumableScopedWith withResource scopedHandler = + interpretResumableScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e) + +-- |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. +-- - No resource is used and the allocator is a plain interpreter. +interpretResumableScopedWith_ :: + ∀ extra param effect err r r1 . + r1 ~ (extra ++ r) => + KnownList extra => + (∀ x . param -> Sem r1 x -> Sem r x) -> + (∀ r0 x . effect (Sem r0) x -> Sem (Stop err : r1) x) -> + InterpreterFor (Scoped param (effect !! err)) r +interpretResumableScopedWith_ extra scopedHandler = + interpretResumableScopedWith @extra @param @() @effect @err @r @r1 (\ 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 +-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail, +-- 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) -> + 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))) + +-- |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 +-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail, +-- 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) -> + InterpreterFor (Scoped param (effect !! ei) !! eo) r +interpretScopedR withResource scopedHandler = + interpretScopedRH withResource \ r e -> liftT (scopedHandler r e) + +-- |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 +-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail, +-- continuing the scope execution on resumption. +-- - The resource allocator is a plain action. +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) -> + InterpreterFor (Scoped param (effect !! ei) !! eo) r +interpretScopedR_ resource = + interpretScopedR \ p use -> use =<< 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. +-- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the +-- 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) -> + 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'))) + +-- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are +-- interpreted by the resource allocator. +-- In this variant, both the handler and the scope may send different errors via 'Stop', encoding the concept that the +-- 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) -> + InterpreterFor (Scoped param (effect !! ei) !! eo) r +interpretScopedRWith withResource scopedHandler = + interpretScopedRWithH @extra withResource \ r e -> liftT (scopedHandler r e) + +-- |Combined interpreter for 'Scoped' and 'Resumable' that allows the handler to use additional effects that are +-- interpreted by the resource allocator. +-- - Both the handler and the scope may send different errors via 'Stop', encoding the concept that the +-- resource allocation may fail to prevent the scope from being executed, and each individual scoped action may fail, +-- 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) -> + InterpreterFor (Scoped param (effect !! ei) !! eo) r +interpretScopedRWith_ extra scopedHandler = + interpretScopedRWith @extra (\ p f -> extra p (f ())) (const scopedHandler) diff --git a/lib/Polysemy/Resume/Interpreter/Stop.hs b/lib/Polysemy/Resume/Interpreter/Stop.hs new file mode 100644 --- /dev/null +++ b/lib/Polysemy/Resume/Interpreter/Stop.hs @@ -0,0 +1,254 @@ +{-# options_haddock prune #-} + +-- |Description: Interpreters for 'Stop'. +module Polysemy.Resume.Interpreter.Stop where + +import qualified Control.Exception as Base +import Control.Exception (throwIO) +import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT, throwE) +import Data.Typeable (typeRep) +import Polysemy.Final (getInitialStateS, interpretFinal, runS, withStrategicToFinal) +import Polysemy.Internal (Sem (Sem), usingSem) +import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, weave) +import qualified Text.Show + +import Polysemy.Resume.Effect.Stop (Stop (Stop), stop) + +-- |Equivalent of 'runError'. +runStop :: + Sem (Stop err : r) a -> + Sem r (Either err a) +runStop (Sem m) = + Sem \ k -> + runExceptT $ m \ u -> + case decomp u of + Left x -> + ExceptT $ k $ weave (Right ()) (either (pure . Left) runStop) rightToMaybe x + Right (Weaving (Stop err) _ _ _ _) -> + throwE err +{-# inline runStop #-} + +-- | Internal type used to tag exceptions thrown by 'Stop' interpreters. +newtype StopExc err = + StopExc { unStopExc :: err } + deriving stock (Typeable) + +instance {-# overlappable #-} Typeable err => Show (StopExc err) where + show = + mappend "StopExc: " . show . typeRep + +instance Show (StopExc Text) where + show (StopExc err) = + "StopExc " <> show err + +instance {-# overlappable #-} Typeable err => Exception (StopExc err) + +instance Exception (StopExc Text) + +-- |Run 'Stop' by throwing exceptions. +runStopAsExcFinal :: + ∀ err r a . + Exception (StopExc err) => + Member (Final IO) r => + Sem (Stop err : r) a -> + Sem r a +runStopAsExcFinal = + interpretFinal \case + Stop err -> + pure (throwIO (StopExc err)) +{-# inline runStopAsExcFinal #-} + +-- |Run 'Stop' by throwing and catching exceptions. +stopToIOFinal :: + ∀ err r a . + Exception (StopExc err) => + Member (Final IO) r => + Sem (Stop err : r) a -> + Sem r (Either err a) +stopToIOFinal sem = + withStrategicToFinal @IO do + m' <- runS (runStopAsExcFinal sem) + s <- getInitialStateS + pure $ either ((<$ s) . Left . unStopExc) (fmap Right) <$> Base.try m' +{-# inline stopToIOFinal #-} + +-- |Stop if the argument is 'Left', transforming the error with @f@. +stopEitherWith :: + ∀ err err' r a . + Member (Stop err') r => + (err -> err') -> + Either err a -> + Sem r a +stopEitherWith f = + either (stop . f) pure +{-# inline stopEitherWith #-} + +-- |Stop if the argument is 'Left', using the supplied error. +stopEitherAs :: + ∀ err err' r a . + Member (Stop err') r => + err' -> + Either err a -> + Sem r a +stopEitherAs err = + stopEitherWith (const err) +{-# inline stopEitherAs #-} + +-- |Stop if the argument is 'Left'. +stopEither :: + ∀ err r a . + Member (Stop err) r => + Either err a -> + Sem r a +stopEither = + stopEitherWith id +{-# inline stopEither #-} + +-- |Stop with the supplied error if the argument is 'Nothing'. +stopNote :: + ∀ err r a . + Member (Stop err) r => + err -> + Maybe a -> + Sem r a +stopNote err = + maybe (stop err) pure +{-# inline stopNote #-} + +-- |Convert a program using regular 'Error's to one using 'Stop'. +stopOnError :: + ∀ err r a . + Member (Stop err) r => + Sem (Error err : r) a -> + Sem r a +stopOnError = + stopEither <=< runError +{-# inline stopOnError #-} + +-- |Convert a program using regular 'Error's to one using 'Stop'. +stopOnErrorWith :: + ∀ err err' r a . + Member (Stop err') r => + (err -> err') -> + Sem (Error err : r) a -> + Sem r a +stopOnErrorWith f = + stopEitherWith f <=< runError +{-# inline stopOnErrorWith #-} + +-- |Convert a program using 'Stop' to one using 'Error', transforming the error with the supplied function. +stopToErrorWith :: + ∀ err err' r a . + Member (Error err') r => + (err -> err') -> + Sem (Stop err : r) a -> + Sem r a +stopToErrorWith f = + either (throw . f) pure <=< runStop +{-# inline stopToErrorWith #-} + +-- |Convert a program using 'Stop' to one using 'Error'. +stopToError :: + ∀ err r a . + Member (Error err) r => + Sem (Stop err : r) a -> + Sem r a +stopToError = + stopToErrorWith id +{-# inline stopToError #-} + +-- |Convert a program using 'Stop' to one using 'Error'. +stopToErrorIO :: + ∀ err r a . + Exception (StopExc err) => + Members [Error err, Final IO] r => + Sem (Stop err : r) a -> + Sem r a +stopToErrorIO = + either throw pure <=< stopToIOFinal +{-# inline stopToErrorIO #-} + +-- |Map over the error type in a 'Stop'. +mapStop :: + ∀ err e' r a . + Member (Stop e') r => + (err -> e') -> + Sem (Stop err : r) a -> + Sem r a +mapStop f (Sem m) = + Sem \ k -> m \ u -> + case decomp u of + Left x -> + k (hoist (mapStop f) x) + Right (Weaving (Stop err) _ _ _ _) -> + usingSem k (send $ Stop (f err)) +{-# inline mapStop #-} + +-- |Replace the error in a 'Stop' with another type. +replaceStop :: + ∀ err e' r a . + Member (Stop e') r => + e' -> + Sem (Stop err : r) a -> + Sem r a +replaceStop e' = + mapStop (const e') +{-# inline replaceStop #-} + +-- |Convert the error type in a 'Stop' to 'Text'. +showStop :: + ∀ err r a . + Show err => + Member (Stop Text) r => + Sem (Stop err : r) a -> + Sem r a +showStop = + mapStop @err @Text show +{-# inline showStop #-} + +-- |Convert an 'IO' exception to 'Stop' using the provided transformation. +stopTryIOE :: + ∀ exc err r a . + Exception exc => + Members [Stop err, Embed IO] r => + (exc -> err) -> + IO a -> + Sem r a +stopTryIOE f = + stopEitherWith f <=< tryIOE @exc +{-# inline stopTryIOE #-} + +-- |Convert an 'IO' exception of type @err@ to 'Stop' using the provided transformation from 'Text'. +stopTryIO :: + ∀ exc err r a . + Exception exc => + Members [Stop err, Embed IO] r => + (Text -> err) -> + IO a -> + Sem r a +stopTryIO f = + stopEitherWith f <=< tryIO @exc +{-# inline stopTryIO #-} + +-- |Convert an 'IO' exception of type 'Control.Exception.IOError' to 'Stop' using the provided transformation from +-- 'Text'. +stopTryIOError :: + ∀ err r a . + Members [Stop err, Embed IO] r => + (Text -> err) -> + IO a -> + Sem r a +stopTryIOError f = + stopEitherWith f <=< tryIOError +{-# inline stopTryIOError #-} + +-- |Convert an 'IO' exception to 'Stop' using the provided transformation from 'Text'. +stopTryAny :: + ∀ err r a . + Members [Stop err, Embed IO] r => + (Text -> err) -> + IO a -> + Sem r a +stopTryAny f = + stopEitherWith f <=< tryAny +{-# inline stopTryAny #-} diff --git a/lib/Polysemy/Resume/Resumable.hs b/lib/Polysemy/Resume/Resumable.hs deleted file mode 100644 --- a/lib/Polysemy/Resume/Resumable.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# options_ghc -Wno-redundant-constraints #-} - -module Polysemy.Resume.Resumable where - -import Polysemy.Error (Error (Throw)) -import Polysemy.Internal (Sem (Sem, runSem), liftSem, usingSem) -import Polysemy.Internal.CustomErrors (FirstOrder) -import Polysemy.Internal.Tactics (liftT, runTactics) -import Polysemy.Internal.Union (ElemOf, Weaving (Weaving), decomp, hoist, inj, injWeaving, membership, prjUsing, weave) - -import Polysemy.Resume.Effect.Resumable (Resumable (..)) -import Polysemy.Resume.Effect.Stop (Stop, stop) -import Polysemy.Resume.Stop (StopExc, runStop, stopOnError, stopToIOFinal) - -type InterpreterTrans' eff eff' r r' = - ∀ a b . - (Sem (eff' : r') a -> Sem r b) -> - Sem (eff : r) a -> - Sem r b - -type InterpreterTrans eff eff' r = - InterpreterTrans' eff eff' r r - -distribEither :: - Functor f => - f () -> - (f (Either err a) -> res) -> - Either err (f a) -> - res -distribEither initialState result = - result . \case - Right fa -> Right <$> fa - Left err -> Left err <$ initialState -{-# inline distribEither #-} - --- |Convert a bare interpreter for @eff@, which (potentially) uses 'Stop' to signal errors, into an interpreter for --- 'Resumable'. --- /Beware/: This will display unsound behaviour if: --- * the interpreter is wrapped with actions of another effect, as in: --- --- @ --- interpretEff :: InterpreterFor Eff r --- ... --- --- interpretEffResumable :: InterpreterFor (Resumable Text Eff) r --- interpretEffResumable sem = --- resumable (interpretEff (sem `finally` releaseResources)) --- @ --- --- In this case, @releaseResources@ will be called after /every/ use of @Eff@ in @sem@, not after the entire thunk. --- --- * the interpreter of a higher-order effect uses a different interpreter after using @runT@/@bindT@. --- In this case, it will use the original interpreter instead. --- --- If your use case matches one of these conditions, you'll need to use 'interpretResumable'. --- --- >>> run $ resumable interpretStopper (interpretResumer mainProgram) --- 237 -resumable :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . - InterpreterFor eff (Stop err : r) -> - InterpreterFor (Resumable err eff) r -resumable interpreter (Sem m) = - Sem \ k -> m \ u -> - case decomp (hoist (resumable interpreter) u) of - Right (Weaving (Resumable e) s wv ex ins) -> - distribEither s ex <$> runSem resultFromEff k - where - resultFromEff = - runStop $ interpreter $ liftSem $ weave s (raise . raise . wv) ins (injWeaving e) - Left g -> - k g -{-# inline resumable #-} - --- |Convenience combinator for turning an interpreter that doesn't use 'Stop' into a 'Resumable'. -raiseResumable :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . - InterpreterTrans (Resumable err eff) eff r -raiseResumable interpreter = - interpreter . normalize . raiseUnder - where - normalize :: InterpreterFor (Resumable err eff) (eff : r) - normalize (Sem m) = - Sem \ k -> m \ u -> - case decomp (hoist normalize u) of - Right (Weaving (Resumable e) s wv ex ins) -> - ex . fmap Right <$> (usingSem k $ liftSem $ weave s wv ins (injWeaving e)) - Left g -> - k g - {-# inline normalize #-} -{-# inline raiseResumable #-} - --- |Like 'resumable', but use exceptions instead of 'ExceptT'. -resumableIO :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . - Exception (StopExc err) => - Member (Final IO) r => - InterpreterFor eff (Stop err : r) -> - InterpreterFor (Resumable err eff) r -resumableIO interpreter (Sem m) = - Sem \ k -> m \ u -> - case decomp (hoist (resumable interpreter) u) of - Right (Weaving (Resumable e) s wv ex ins) -> - distribEither s ex <$> runSem resultFromEff k - where - resultFromEff = - stopToIOFinal $ interpreter $ liftSem $ weave s (raise . raise . wv) ins (injWeaving e) - Left g -> - k g -{-# inline resumableIO #-} - --- |Like 'interpretResumable', but for higher-order effects. -interpretResumableH :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) . - -- |This handler function has @'Stop' err@ in its stack, allowing it to absorb errors. - (∀ x r0 . eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> - InterpreterFor (Resumable err eff) r -interpretResumableH handler (Sem m) = - Sem \ k -> m \ u -> - case decomp u of - Left there -> - k (hoist (interpretResumableH handler) there) - Right (Weaving (Resumable (Weaving e s dist ex ins)) sOuter distOuter exOuter insOuter) -> - usingSem k (exFinal <$> runStop (tac (handler e))) - where - tac = - runTactics - (Compose (s <$ sOuter)) - (raiseUnder . fmap Compose . distOuter . fmap dist . getCompose) - (ins <=< insOuter . getCompose) - (raise . interpretResumableH handler . fmap Compose . distOuter . fmap dist . getCompose) - exFinal = exOuter . \case - Right (Compose a) -> Right . ex <$> a - Left err -> Left err <$ sOuter -{-# inline interpretResumableH #-} - --- |Create an interpreter for @'Resumable' err eff@ by supplying a handler function for @eff@, analogous to --- 'Polysemy.interpret'. --- If the handler throws errors with 'Stop', they will be absorbed into 'Resumable', to be caught by --- 'Polysemy.Resume.resume' in a downstream interpreter. --- --- @ --- interpretStopperResumable :: --- InterpreterFor Stopper r --- interpretStopperResumable = --- interpretResumable \\case --- StopBang -> stop (Bang 13) --- StopBoom -> stop (Boom "ouch") --- @ --- --- >>> run $ interpretStopperResumable (interpretResumer mainProgram) --- 237 -interpretResumable :: - ∀ (err :: Type) (eff :: Effect) r . - FirstOrder eff "interpretResumable" => - (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : r) x) -> - InterpreterFor (Resumable err eff) r -interpretResumable handler = - interpretResumableH \ e -> liftT (handler e) -{-# inline interpretResumable #-} - --- |Interceptor variant of 'interpretResumableH'. -interceptResumableUsingH :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . - ElemOf (Resumable err eff) r -> - (∀ x r0 . eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> - Sem r a -> - Sem r a -interceptResumableUsingH proof handler (Sem m) = - Sem \ k -> m \ u -> - case prjUsing proof u of - Nothing -> - k (hoist (interceptResumableUsingH proof handler) u) - Just (Weaving (Resumable (Weaving e s dist ex ins)) sOuter distOuter exOuter insOuter) -> - usingSem k (exFinal <$> runStop (tac (handler e))) - where - tac = - runTactics - (Compose (s <$ sOuter)) - (raise . raise . fmap Compose . distOuter . fmap dist . getCompose) - (ins <=< insOuter . getCompose) - (raise . interceptResumableUsingH proof handler . fmap Compose . distOuter . fmap dist . getCompose) - exFinal = exOuter . \case - Right (Compose a) -> Right . ex <$> a - Left err -> Left err <$ sOuter -{-# inline interceptResumableUsingH #-} - --- |Interceptor variant of 'interpretResumable'. -interceptResumableUsing :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . - FirstOrder eff "interceptResumableUsing" => - ElemOf (Resumable err eff) r -> - (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : r) x) -> - Sem r a -> - Sem r a -interceptResumableUsing proof f = - interceptResumableUsingH proof \ e -> - liftT (f e) -{-# inline interceptResumableUsing #-} - --- |Interceptor variant of 'interpretResumableH'. -interceptResumableH :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . - Member (Resumable err eff) r => - (∀ x r0 . eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> - Sem r a -> - Sem r a -interceptResumableH = - interceptResumableUsingH membership -{-# inline interceptResumableH #-} - --- |Interceptor variant of 'interpretResumable'. -interceptResumable :: - ∀ (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type) . - Member (Resumable err eff) r => - FirstOrder eff "interceptResumable" => - (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : r) x) -> - Sem r a -> - Sem r a -interceptResumable f = - interceptResumableH \ e -> - liftT (f e) -{-# inline interceptResumable #-} - --- |Convert an interpreter for @eff@ that uses 'Error' into one using 'Stop' and wrap it using 'resumable'. -resumableError :: - ∀ (err :: Type) (eff :: Effect) r . - InterpreterFor eff (Error err : Stop err : r) -> - InterpreterFor (Resumable err eff) r -resumableError interpreter = - resumable (stopOnError . interpreter . raiseUnder) -{-# inline resumableError #-} - --- |Convert an interpreter for @eff@ that throws errors of type @err@ into a @Resumable@, but limiting the errors --- handled by consumers to the type @handled@, which rethrowing 'Error's of type @unhandled@. --- --- The function @canHandle@ determines how the errors are split. --- --- @ --- newtype Blip = --- Blip { unBlip :: Int } --- deriving (Eq, Show) --- --- bangOnly :: Boom -> Either Text Blip --- bangOnly = \\case --- Bang n -> Right (Blip n) --- Boom msg -> Left msg --- --- interpretResumerPartial :: --- Member (Resumable Blip Stopper) r => --- InterpreterFor Resumer r --- interpretResumerPartial = --- interpret \\ MainProgram -> --- resume (192 \<$ stopBang) \\ (Blip num) -> --- pure (num * 3) --- @ --- --- >>> runError (resumableFor bangOnly interpretStopper (interpretResumerPartial mainProgram)) --- Right 39 -resumableOr :: - ∀ (err :: Type) (eff :: Effect) unhandled handled r . - Member (Error unhandled) r => - (err -> Either unhandled handled) -> - InterpreterFor eff (Stop err : r) -> - InterpreterFor (Resumable handled eff) r -resumableOr canHandle interpreter (Sem m) = - Sem \ k -> m \ u -> - case decomp (hoist (resumableOr canHandle interpreter) u) of - Right (Weaving (Resumable e) s wv ex ins) -> - distribEither s ex <$> (tryHandle =<< runSem resultFromEff k) - where - tryHandle = \case - Left err -> - either (k . inj . Throw) (pure . Left) (canHandle err) - Right a -> - pure (Right a) - resultFromEff = - runStop $ interpreter $ liftSem $ weave s (raise . raise . wv) ins (injWeaving e) - Left g -> - k g -{-# inline resumableOr #-} - --- |Variant of 'resumableOr' that uses 'Maybe' and rethrows the original error. -resumableFor :: - ∀ (err :: Type) (eff :: Effect) handled r . - Member (Error err) r => - (err -> Maybe handled) -> - InterpreterFor eff (Stop err : r) -> - InterpreterFor (Resumable handled eff) r -resumableFor canHandle = - resumableOr canHandle' - where - canHandle' err = - maybeToRight err (canHandle err) -{-# inline resumableFor #-} - --- |Reinterpreting variant of 'resumableFor'. -catchResumable :: - ∀ (err :: Type) (eff :: Effect) handled r . - Members [eff, Error err] r => - (err -> Maybe handled) -> - InterpreterFor (Resumable handled eff) r -catchResumable canHandle (Sem m) = - Sem \ k -> m \ u -> - case decomp (hoist (catchResumable canHandle) u) of - Right (Weaving (Resumable e) s wv ex ins) -> - distribEither s ex <$> runSem resultFromEff k - where - resultFromEff = - catchJust canHandle (fmap Right $ liftSem $ weave s wv ins (injWeaving e)) (pure . Left) - Left g -> - k g -{-# inline catchResumable #-} - --- |Interpret an effect @eff@ by wrapping it in @Resumable@ and @Stop@ and leaving the rest up to the user. -runAsResumable :: - ∀ (err :: Type) (eff :: Effect) r . - Members [Resumable err eff, Stop err] r => - InterpreterFor eff r -runAsResumable (Sem m) = - Sem \ k -> m \ u -> - case decomp (hoist (runAsResumable @err @eff) u) of - Right wav -> - runSem (either (stop @err) pure =<< send (Resumable wav)) k - Left g -> - k g -{-# inline runAsResumable #-} diff --git a/lib/Polysemy/Resume/Resume.hs b/lib/Polysemy/Resume/Resume.hs --- a/lib/Polysemy/Resume/Resume.hs +++ b/lib/Polysemy/Resume/Resume.hs @@ -1,17 +1,17 @@ --- |Resumption combinators, transforming an effect into 'Resumable' and 'Stop'. +-- | Resumption combinators, transforming an effect into 'Resumable' and 'Stop'. module Polysemy.Resume.Resume where import Polysemy.Resume.Effect.Resumable (Resumable) import Polysemy.Resume.Effect.Stop (Stop, stop) -import Polysemy.Resume.Resumable (runAsResumable) -import Polysemy.Resume.Stop (runStop) +import Polysemy.Resume.Interpreter.Resumable (runAsResumable) +import Polysemy.Resume.Interpreter.Stop (runStop) --- |Execute the action of a regular effect @eff@ so that any error of type @err@ that maybe be thrown by the (unknown) +-- | Execute the action of a regular effect @eff@ so that any error of type @err@ that maybe be thrown by the (unknown) -- interpreter used for @eff@ will be caught here and handled by the @handler@ argument. -- This is similar to 'Polysemy.Error.catch' with the additional guarantee that the error will have to be explicitly -- matched, therefore preventing accidental failure to handle an error and bubbling it up to @main@. -- It also imposes a membership of @Resumable err eff@ on the program, requiring the interpreter for @eff@ to be adapted --- with 'Polysemy.Resume.Resumable.resumable'. +-- with 'Polysemy.Resume.Interpreter.Resumable.resumable'. -- -- @ -- data Resumer :: Effect where @@ -37,7 +37,7 @@ either handler pure =<< runStop (runAsResumable @err (raiseUnder sem)) {-# inline resume #-} --- |Operator version of 'resume'. +-- | Operator version of 'resume'. -- -- @since 0.2.0.0 (!!) :: @@ -50,7 +50,7 @@ resume {-# inline (!!) #-} --- Reinterpreting version of 'resume'. +-- | Reinterpreting version of 'resume'. resumeRe :: ∀ err eff r a . Sem (eff : r) a -> @@ -60,7 +60,7 @@ either handler pure =<< runStop (runAsResumable @err (raiseUnder2 sem)) {-# inline resumeRe #-} --- |Flipped variant of 'resume'. +-- | Flipped variant of 'resume'. resuming :: ∀ err eff r a . Member (Resumable err eff) r => @@ -71,7 +71,7 @@ flip resume {-# inline resuming #-} --- |Flipped variant of 'resumeRe'. +-- | Flipped variant of 'resumeRe'. resumingRe :: ∀ err eff r a . (err -> Sem (Resumable err eff : r) a) -> @@ -81,7 +81,7 @@ flip resumeRe {-# inline resumingRe #-} --- |Variant of 'resume' that unconditionally recovers with a constant value. +-- | Variant of 'resume' that unconditionally recovers with a constant value. resumeAs :: ∀ err eff r a . Member (Resumable err eff) r => @@ -92,7 +92,7 @@ resuming @err \ _ -> pure a {-# inline resumeAs #-} --- |Operator version of 'resumeAs'. +-- | Operator version of 'resumeAs'. -- -- @since 0.2.0.0 () :: @@ -116,7 +116,7 @@ (!>) = flip (resumeAs @err) --- |Convenience specialization of 'resume' that silently discards errors for void programs. +-- | Convenience specialization of 'resume' that silently discards errors for void programs. resume_ :: ∀ err eff r . Member (Resumable err eff) r => @@ -125,7 +125,7 @@ resume_ = resumeAs @err () --- |Variant of 'resume' that unconditionally recovers with an action. +-- | Variant of 'resume' that unconditionally recovers with an action. -- -- @since 0.2.0.0 resumeWith :: @@ -138,7 +138,7 @@ resume @err ma (const ma') {-# inline resumeWith #-} --- |Operator variant of 'resumeWith'. +-- | Operator variant of 'resumeWith'. -- -- @since 0.2.0.0 (!>>) :: @@ -151,7 +151,7 @@ resumeWith @err {-# inline (!>>) #-} --- |Variant of 'resuming' that unconditionally recovers with an action. +-- | Variant of 'resuming' that unconditionally recovers with an action. -- -- @since 0.2.0.0 resumingWith :: @@ -164,7 +164,7 @@ resume @err ma (const ma') {-# inline resumingWith #-} --- |Operator variant of 'resumingWith'. +-- | Operator variant of 'resumingWith'. -- -- @since 0.2.0.0 (< @@ -188,7 +188,7 @@ resuming (stop . f) {-# inline resumeHoist #-} --- |Variant of 'resumeHoist' that uses a constant value. +-- | Variant of 'resumeHoist' that uses a constant value. resumeHoistAs :: ∀ err eff err' r . Members [Resumable err eff, Stop err'] r => @@ -198,7 +198,7 @@ resumeHoist @err (const err) {-# inline resumeHoistAs #-} --- |Variant of 'resumeHoist' that uses the unchanged error. +-- | Variant of 'resumeHoist' that uses the unchanged error. restop :: ∀ err eff r . Members [Resumable err eff, Stop err] r => @@ -207,7 +207,7 @@ resumeHoist @err id {-# inline restop #-} --- |Variant of 'resume' that immediately produces an 'Either'. +-- | Variant of 'resume' that immediately produces an 'Either'. resumeEither :: ∀ err eff r a . Member (Resumable err eff) r => @@ -216,7 +216,7 @@ resumeEither ma = resuming (pure . Left) (Right <$> ma) --- |Variant of 'resume' that takes a branch for error and success. +-- | Variant of 'resume' that takes a branch for error and success. -- This allows the success branch to contain other resumptions. -- -- @since 0.2.0.0 @@ -232,7 +232,7 @@ Right a -> fb a Left e -> err e --- |Variant of 'resuming' that takes a branch for error and success. +-- | Variant of 'resuming' that takes a branch for error and success. -- This allows the success branch to contain other resumptions. -- -- @since 0.2.0.0 @@ -246,7 +246,7 @@ resumingOr err ma fb = resumeOr ma fb err --- |Variant of 'resume' that propagates the error to an 'Error' effect after applying a function. +-- | Variant of 'resume' that propagates the error to an 'Error' effect after applying a function. resumeHoistError :: ∀ err eff err' r a . Members [Resumable err eff, Error err'] r => @@ -257,7 +257,7 @@ resuming (throw . f) {-# inline resumeHoistError #-} --- |Variant of 'resumeHoistError' that uses the unchanged error. +-- | Variant of 'resumeHoistError' that uses the unchanged error. resumeHoistErrorAs :: ∀ err eff err' r a . Members [Resumable err eff, Error err'] r => @@ -268,7 +268,7 @@ resumeHoistError @err (const err) {-# inline resumeHoistErrorAs #-} --- |Variant of 'resumeHoistError' that uses the unchanged error. +-- | Variant of 'resumeHoistError' that uses the unchanged error. resumeError :: ∀ err eff r a . Members [Resumable err eff, Error err] r => @@ -277,3 +277,43 @@ resumeError = resumeHoistError @err id {-# inline resumeError #-} + +-- | Transform 'Stop' to 'Fail' using the supplied error message rendering function. +stopToFailWith :: + ∀ err r . + Member Fail r => + (err -> Text) -> + InterpreterFor (Stop err) r +stopToFailWith f = + either (fail . toString . f) pure <=< runStop +{-# inline stopToFailWith #-} + +-- | Resume a computation, converting 'Stop' to 'Fail'. +resumeFailWith :: + ∀ err eff r . + Members [Fail, Resumable err eff] r => + (err -> Text) -> + InterpreterFor eff r +resumeFailWith f = + resuming (fail . toString . f) +{-# inline resumeFailWith #-} + +-- | Transform 'Stop' to 'Fail' using 'show'. +stopToFail :: + ∀ err r . + Show err => + Member Fail r => + InterpreterFor (Stop err) r +stopToFail = + stopToFailWith show +{-# inline stopToFail #-} + +-- | Resume a computation, converting 'Stop' to 'Fail' using 'show'. +resumeFail :: + ∀ err eff r . + Show err => + Members [Fail, Resumable err eff] r => + InterpreterFor eff r +resumeFail = + resumeFailWith @err show +{-# inline resumeFail #-} diff --git a/lib/Polysemy/Resume/Stop.hs b/lib/Polysemy/Resume/Stop.hs deleted file mode 100644 --- a/lib/Polysemy/Resume/Stop.hs +++ /dev/null @@ -1,230 +0,0 @@ -module Polysemy.Resume.Stop where - -import qualified Control.Exception as Base -import Control.Exception (throwIO) -import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT, throwE) -import Data.Typeable (typeRep) -import Polysemy.Final (getInitialStateS, interpretFinal, runS, withStrategicToFinal) -import Polysemy.Internal (Sem (Sem), usingSem) -import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, weave) -import qualified Text.Show - -import Polysemy.Resume.Effect.Stop (Stop (Stop), stop) - -hush :: Either e a -> Maybe a -hush (Right a) = Just a -hush (Left _) = Nothing - --- |Equivalent of 'runError'. -runStop :: - Sem (Stop e : r) a -> - Sem r (Either e a) -runStop (Sem m) = - Sem \ k -> - runExceptT $ m \ u -> - case decomp u of - Left x -> - ExceptT $ k $ weave (Right ()) (either (pure . Left) runStop) hush x - Right (Weaving (Stop e) _ _ _ _) -> - throwE e -{-# inline runStop #-} - -newtype StopExc e = - StopExc { unStopExc :: e } - deriving (Typeable) - -instance {-# overlappable #-} Typeable e => Show (StopExc e) where - show = - mappend "StopExc: " . show . typeRep - -instance Show (StopExc Text) where - show (StopExc e) = - "StopExc " <> show e - -instance {-# overlappable #-} Typeable e => Exception (StopExc e) - -instance Exception (StopExc Text) - -runStopAsExcFinal :: - Exception (StopExc e) => - Member (Final IO) r => - Sem (Stop e : r) a -> - Sem r a -runStopAsExcFinal = - interpretFinal \case - Stop e -> - pure (throwIO (StopExc e)) -{-# inline runStopAsExcFinal #-} - --- |Run 'Stop' by throwing exceptions. -stopToIOFinal :: - Exception (StopExc e) => - Member (Final IO) r => - Sem (Stop e : r) a -> - Sem r (Either e a) -stopToIOFinal sem = - withStrategicToFinal @IO do - m' <- runS (runStopAsExcFinal sem) - s <- getInitialStateS - pure $ either ((<$ s) . Left . unStopExc) (fmap Right) <$> Base.try m' -{-# inline stopToIOFinal #-} - --- |Stop if the argument is 'Left', transforming the error with @f@. -stopEitherWith :: - Member (Stop err') r => - (err -> err') -> - Either err a -> - Sem r a -stopEitherWith f = - either (stop . f) pure -{-# inline stopEitherWith #-} - --- |Stop if the argument is 'Left', using the supplied error. -stopEitherAs :: - Member (Stop err') r => - err' -> - Either err a -> - Sem r a -stopEitherAs e = - stopEitherWith (const e) -{-# inline stopEitherAs #-} - --- |Stop if the argument is 'Left'. -stopEither :: - Member (Stop err) r => - Either err a -> - Sem r a -stopEither = - stopEitherWith id -{-# inline stopEither #-} - --- |Stop with the supplied error if the argument is 'Nothing'. -stopNote :: - Member (Stop err) r => - err -> - Maybe a -> - Sem r a -stopNote err = - maybe (stop err) pure -{-# inline stopNote #-} - --- |Convert a program using regular 'Error's to one using 'Stop'. -stopOnError :: - Member (Stop err) r => - Sem (Error err : r) a -> - Sem r a -stopOnError = - stopEither <=< runError -{-# inline stopOnError #-} - --- |Convert a program using regular 'Error's to one using 'Stop'. -stopOnErrorWith :: - Member (Stop err') r => - (err -> err') -> - Sem (Error err : r) a -> - Sem r a -stopOnErrorWith f = - stopEitherWith f <=< runError -{-# inline stopOnErrorWith #-} - --- |Convert a program using 'Stop' to one using 'Error', transforming the error with the supplied function. -stopToErrorWith :: - Member (Error err') r => - (err -> err') -> - Sem (Stop err : r) a -> - Sem r a -stopToErrorWith f = - either (throw . f) pure <=< runStop -{-# inline stopToErrorWith #-} - --- |Convert a program using 'Stop' to one using 'Error'. -stopToError :: - Member (Error err) r => - Sem (Stop err : r) a -> - Sem r a -stopToError = - stopToErrorWith id -{-# inline stopToError #-} - --- |Convert a program using 'Stop' to one using 'Error'. -stopToErrorIO :: - Exception (StopExc err) => - Members [Error err, Final IO] r => - Sem (Stop err : r) a -> - Sem r a -stopToErrorIO = - either throw pure <=< stopToIOFinal -{-# inline stopToErrorIO #-} - --- |Map over the error type in a 'Stop'. -mapStop :: - ∀ e e' r a . - Member (Stop e') r => - (e -> e') -> - Sem (Stop e : r) a -> - Sem r a -mapStop f (Sem m) = - Sem \ k -> m \ u -> - case decomp u of - Left x -> - k (hoist (mapStop f) x) - Right (Weaving (Stop e) _ _ _ _) -> - usingSem k (send $ Stop (f e)) -{-# inline mapStop #-} - --- |Convert the error type in a 'Stop' to 'Text'. -showStop :: - ∀ e r a . - Show e => - Member (Stop Text) r => - Sem (Stop e : r) a -> - Sem r a -showStop = - mapStop @e @Text show -{-# inline showStop #-} - --- |Convert an 'IO' exception to 'Stop' using the provided transformation. -stopTryIOE :: - ∀ exc e r a . - Exception exc => - Members [Stop e, Embed IO] r => - (exc -> e) -> - IO a -> - Sem r a -stopTryIOE f = - stopEitherWith f <=< tryIOE @exc -{-# inline stopTryIOE #-} - --- |Convert an 'IO' exception of type @e@ to 'Stop' using the provided transformation from 'Text'. -stopTryIO :: - ∀ exc e r a . - Exception exc => - Members [Stop e, Embed IO] r => - (Text -> e) -> - IO a -> - Sem r a -stopTryIO f = - stopEitherWith f <=< tryIO @exc -{-# inline stopTryIO #-} - --- |Convert an 'IO' exception of type 'IOError' to 'Stop' using the provided transformation from 'Text'. -stopTryIOError :: - ∀ e r a . - Members [Stop e, Embed IO] r => - (Text -> e) -> - IO a -> - Sem r a -stopTryIOError f = - stopEitherWith f <=< tryIOError -{-# inline stopTryIOError #-} - --- |Convert an 'IO' exception to 'Stop' using the provided transformation from 'Text'. -stopTryAny :: - ∀ e r a . - Members [Stop e, Embed IO] r => - (Text -> e) -> - IO a -> - Sem r a -stopTryAny f = - stopEitherWith f <=< tryAny -{-# inline stopTryAny #-} diff --git a/polysemy-resume.cabal b/polysemy-resume.cabal --- a/polysemy-resume.cabal +++ b/polysemy-resume.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.35.0. -- -- see: https://github.com/sol/hpack name: polysemy-resume -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Polysemy error tracking description: See https://hackage.haskell.org/package/polysemy-resume/docs/Polysemy-Resume.html category: Error @@ -17,6 +17,9 @@ license: BSD-2-Clause-Patent license-file: LICENSE build-type: Simple +extra-source-files: + changelog.md + readme.md source-repository head type: git @@ -27,9 +30,10 @@ Polysemy.Resume Polysemy.Resume.Effect.Resumable Polysemy.Resume.Effect.Stop - Polysemy.Resume.Resumable + Polysemy.Resume.Interpreter.Resumable + Polysemy.Resume.Interpreter.Scoped + Polysemy.Resume.Interpreter.Stop Polysemy.Resume.Resume - Polysemy.Resume.Stop hs-source-dirs: lib default-extensions: @@ -53,6 +57,7 @@ DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields + EmptyCase EmptyDataDecls ExistentialQuantification FlexibleContexts @@ -67,8 +72,9 @@ MultiParamTypeClasses MultiWayIf NamedFieldPuns - OverloadedStrings + OverloadedLabels OverloadedLists + OverloadedStrings PackageImports PartialTypeSignatures PatternGuards @@ -95,8 +101,8 @@ ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages build-depends: base >=4.12 && <5 - , incipit-core >=0.3 - , polysemy >=1.6 + , incipit-core >=0.4 + , polysemy ==1.8.* , transformers mixins: base hiding (Prelude) @@ -134,6 +140,7 @@ DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields + EmptyCase EmptyDataDecls ExistentialQuantification FlexibleContexts @@ -148,8 +155,9 @@ MultiParamTypeClasses MultiWayIf NamedFieldPuns - OverloadedStrings + OverloadedLabels OverloadedLists + OverloadedStrings PackageImports PartialTypeSignatures PatternGuards @@ -176,16 +184,13 @@ ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.12 && <5 - , hedgehog - , incipit-core >=0.3 - , polysemy - , polysemy-plugin + , incipit-core >=0.4 + , polysemy ==1.8.* + , polysemy-plugin >=0.4.3 && <0.5 , polysemy-resume , polysemy-test >=0.6 , stm , tasty - , tasty-hedgehog - , text mixins: base hiding (Prelude) , incipit-core (IncipitCore as Prelude) diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,205 @@ +# About + +This library provides the Polysemy effects 'Resumable' and 'Stop' for the +purpose of safely connecting throwing and catching errors across different +interpreters. + +# Example + +Given these two effects and an error: + +```haskell +import Polysemy.Resume (Resumable, Stop, resumable, resumableFor, resume, runStop, stop) + +data Stopper :: Effect where + StopBang :: Stopper m () + StopBoom :: Stopper m () + +makeSem ''Stopper + +data Resumer :: Effect where + MainProgram :: Resumer m Int + +makeSem ''Resumer + +data Boom = + Boom { unBoom :: Text } + | + Bang { unBang :: Int } + deriving (Eq, Show) +``` + +we implement an interpreter for `Stopper` that may throw the error `Boom`, but +we do not want to hardcode that fact into the effect constructors, as in: + +```haskell +data Stopper :: Effect where + StopBang :: Stopper m (Either Boom ()) +``` + +because we might want to provide alternative interpreters that do not have this +requirement, and `Boom` might contain information about the interpreter +implementation that we don't want to leak into the effect signature. + +On the other hand, having no guarantee that the consumer program knows about or +catches the error requires us to manually ensure we handle them at the +appropriate location. +This is especially critical due to the fact that using `catch` requires an +`Error` membership, which in turn requires the `Error` to be handled outside of +the consumer again, hiding any new uses of the throwing interpreter in another +part of the program. + +A first attempt at making this situation safer is to introduce a wrapping +effect: + +```haskell +data Resumable err eff m a where + Resumable :: + ∀ err eff r a . + Weaving eff (Sem r) a -> + Resumable err eff (Sem r) (Either err a) +``` + +which we now use instead of the raw `eff` in consumers: + +```haskell +interpretResumer :: + Member (Resumable Boom Stopper) r => + InterpreterFor Resumer r +interpretResumer = + interpret \ MainProgram -> + resume (192 <$ stopBang) \ _ -> + pure 237 +``` + +For a nicer syntax, there is a type alias for `Resumable`: + +```haskell +Member (Stopper !! Boom) r => +``` + +We have now marked the interpreter for `Resumer`, which consumes `Stopper`, as +being capable of handling the `Boom` error when it occurs in `Stopper`. +The function `resume` takes an error handler as its second argument with which +we can catch `Boom`. + +The interpreter for `Stopper` could look like this: + +```haskell +interpretStopper :: + Member (Stop Boom) r => + InterpreterFor Stopper r +interpretStopper = + interpret \case + StopBang -> stop (Bang 13) + StopBoom -> stop (Boom "ouch") +``` + +Instead of `Error`, we are using `Stop` here, which is identical except for not +providing `Catch`. +This only serves to be more explicit about the intention of the error, but +a regular `Error` can be converted with `stopOnError`. + +In order to convert this interpreter to a `Resumable`, we use `resumable`: + +```haskell +>>> run $ resumable interpretStopper (interpretResumer mainProgram) +237 +``` + +`resumable` weaves `interpretStopper` and its `Stop` together into +a `Resumable`, which is then consumed entirely by `resume` inside +`interpretResumer`, so no additional effects have to be handled. + +## Higher-Order Effects + +Converting an interpreter with `resumable` only works in rather simple +conditions. +If there are higher-order effects involved, you may get incorrect semantics, +for example when inserting a `finally` around the entire resumable program: + +```haskell +resumable (interpretStopper (sem `finally` releaseResources)) +``` + +In this case, `releaseResources` is executed after each use of `StopBang` or +`StopBoom`. +This requires the use of `interpretResumable` and `interpretResumableH`, which +take handler functions like `interpret`: + +```haskell +interpretStopper :: + InterpreterFor (Stopper !! Boom) r +interpretStopper = + interpretResumable \case + StopBang -> stop (Bang 13) + StopBoom -> stop (Boom "ouch") +``` + +## Partial Error Handling + +Of course, one requirement in the problem description still remains +unsatisfied: We might want to hide implementation details of `interpretStopper` +from consumers. +We can do that by transforming the `Boom` error into a more abstract version at +the interpretation site: + +```haskell +newtype Blip = + Blip { unBlip :: Int } + deriving (Eq, Show) + +bangOnly :: Boom -> Maybe Blip +bangOnly = \case + Bang n -> Just (Blip n) + Boom _ -> Nothing +``` + +Now `Boom` might have contained information about e.g. an http client backend, +and we're transforming that into an error that just says "http error". +If a consumer also deals with that backend, we might keep that information. + +This modified error can now be used for `Resumable`. +First, we change the `Resumer` interpreter to use `Blip`: + +```haskell +interpretResumerPartial :: + Member (Resumable Blip Stopper) r => + InterpreterFor Resumer r +interpretResumerPartial = + interpret \ MainProgram -> + resume (192 <$ stopBang) \ (Blip num) -> + pure (num * 3) +``` + +Then we use a different adapter function for `interpretStopper`: + +```haskell +>>> runError (resumableFor bangOnly interpretStopper (interpretResumerPartial mainProgram)) +Right 39 +``` + +`resumableFor` transforms the error and passes it to the consumer if it is +a `Just`, and rethrows it if not. +Since the error was only partially handled and unhandled errors get thrown as +`Error`, we have to call `runError` on the result, to obtain an `Either`. + +If the consumer uses a constructor that throws an unhandled variant of the +error, it propagates to the call site: + +```haskell +interpretResumerPartialUnhandled :: + Member (Resumable Blip Stopper) r => + InterpreterFor Resumer r +interpretResumerPartialUnhandled = + interpret \ MainProgram -> + resume (192 <$ stopBoom) \ (Blip num) -> + pure (num * 3) + +>>> runError ((resumableFor bangOnly interpretStopper) (interpretResumerPartialUnhandled mainProgram)) +Left (Boom "ouch") +``` + +# Thanks + +to @KingOfTheHomeless for providing the initial implementation and lots of consultation! diff --git a/test/Polysemy/Resume/HigherOrderTest.hs b/test/Polysemy/Resume/HigherOrderTest.hs --- a/test/Polysemy/Resume/HigherOrderTest.hs +++ b/test/Polysemy/Resume/HigherOrderTest.hs @@ -7,7 +7,7 @@ import Polysemy.Resume (type (!!)) import Polysemy.Resume.Effect.Stop (stop) -import Polysemy.Resume.Resumable (interpretResumableH) +import Polysemy.Resume.Interpreter.Resumable (interpretResumableH) import Polysemy.Resume.Resume (resume) data Eff :: Effect where diff --git a/test/Polysemy/Resume/Test/InterceptTest.hs b/test/Polysemy/Resume/Test/InterceptTest.hs --- a/test/Polysemy/Resume/Test/InterceptTest.hs +++ b/test/Polysemy/Resume/Test/InterceptTest.hs @@ -7,7 +7,7 @@ import Polysemy.Resume.Effect.Resumable (type (!!)) import Polysemy.Resume.Effect.Stop (stop) -import Polysemy.Resume.Resumable (interceptResumable, interpretResumable) +import Polysemy.Resume.Interpreter.Resumable (interceptResumable, interpretResumable) import Polysemy.Resume.Resume (restop, (!!), (