polysemy-resume 0.4.0.0 → 0.5.0.0
raw patch · 14 files changed
+300/−292 lines, 14 filesdep ~basedep ~incipit-coredep ~polysemy-testPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, incipit-core, polysemy-test
API changes (from Hackage documentation)
- Polysemy.Resume.Data.Resumable: [Resumable] :: forall err eff r a. Weaving eff (Sem r) a -> Resumable err eff (Sem r) (Either err a)
- Polysemy.Resume.Data.Resumable: data Resumable err eff :: Effect
- Polysemy.Resume.Data.Resumable: type eff !! err = Resumable err eff
- Polysemy.Resume.Data.Stop: [Stop] :: e -> Stop e m a
- Polysemy.Resume.Data.Stop: data Stop e :: Effect
+ Polysemy.Resume: interceptResumable :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). Member (Resumable err eff) r => FirstOrder eff "interceptResumable" => (forall x r0. eff (Sem r0) x -> Sem (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume: interceptResumableH :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). Member (Resumable err eff) r => (forall x r0. eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume: interceptResumableUsing :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). FirstOrder eff "interceptResumableUsing" => ElemOf (Resumable err eff) r -> (forall x r0. eff (Sem r0) x -> Sem (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume: interceptResumableUsingH :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). ElemOf (Resumable err eff) r -> (forall x r0. eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume: stopEitherAs :: Member (Stop err') r => err' -> Either err a -> Sem r a
+ Polysemy.Resume: stopToErrorWith :: Member (Error err') r => (err -> err') -> Sem (Stop err : r) a -> Sem r a
+ Polysemy.Resume: stopTryAny :: forall e r a. Members [Stop e, Embed IO] r => (Text -> e) -> IO a -> Sem r a
+ Polysemy.Resume: stopTryIO :: forall exc e r a. Exception exc => Members [Stop e, Embed IO] r => (Text -> e) -> IO a -> Sem r a
+ Polysemy.Resume: stopTryIOE :: forall exc e r a. Exception exc => Members [Stop e, Embed IO] r => (exc -> e) -> IO a -> Sem r a
+ Polysemy.Resume: stopTryIOError :: forall e r a. Members [Stop e, Embed IO] r => (Text -> e) -> IO a -> Sem r a
+ Polysemy.Resume.Effect.Resumable: [Resumable] :: forall err eff r a. Weaving eff (Sem r) a -> Resumable err eff (Sem r) (Either err a)
+ Polysemy.Resume.Effect.Resumable: data Resumable err eff :: Effect
+ Polysemy.Resume.Effect.Resumable: type eff !! err = Resumable err eff
+ Polysemy.Resume.Effect.Stop: [Stop] :: e -> Stop e m a
+ Polysemy.Resume.Effect.Stop: data Stop e :: Effect
+ Polysemy.Resume.Resumable: interceptResumable :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). Member (Resumable err eff) r => FirstOrder eff "interceptResumable" => (forall x r0. eff (Sem r0) x -> Sem (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume.Resumable: interceptResumableH :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). Member (Resumable err eff) r => (forall x r0. eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume.Resumable: interceptResumableUsing :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). FirstOrder eff "interceptResumableUsing" => ElemOf (Resumable err eff) r -> (forall x r0. eff (Sem r0) x -> Sem (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume.Resumable: interceptResumableUsingH :: forall (err :: Type) (eff :: Effect) (r :: EffectRow) (a :: Type). ElemOf (Resumable err eff) r -> (forall x r0. eff (Sem r0) x -> Tactical (Resumable err eff) (Sem r0) (Stop err : r) x) -> Sem r a -> Sem r a
+ Polysemy.Resume.Stop: stopEitherAs :: Member (Stop err') r => err' -> Either err a -> Sem r a
+ Polysemy.Resume.Stop: stopToErrorWith :: Member (Error err') r => (err -> err') -> Sem (Stop err : r) a -> Sem r a
+ Polysemy.Resume.Stop: stopTryAny :: forall e r a. Members [Stop e, Embed IO] r => (Text -> e) -> IO a -> Sem r a
+ Polysemy.Resume.Stop: stopTryIO :: forall exc e r a. Exception exc => Members [Stop e, Embed IO] r => (Text -> e) -> IO a -> Sem r a
+ Polysemy.Resume.Stop: stopTryIOE :: forall exc e r a. Exception exc => Members [Stop e, Embed IO] r => (exc -> e) -> IO a -> Sem r a
+ Polysemy.Resume.Stop: stopTryIOError :: forall e r a. Members [Stop e, Embed IO] r => (Text -> e) -> IO a -> Sem r a
- Polysemy.Resume: stop :: forall e_a4A5 r_a5Oh a_a4A7. MemberWithError (Stop e_a4A5) r_a5Oh => e_a4A5 -> Sem r_a5Oh a_a4A7
+ Polysemy.Resume: stop :: forall e_a4Ag r_a5Os a_a4Ai. MemberWithError (Stop e_a4Ag) r_a5Os => e_a4Ag -> Sem r_a5Os a_a4Ai
Files
- changelog.md +0/−15
- lib/Polysemy/Resume.hs +18/−4
- lib/Polysemy/Resume/Data/Resumable.hs +0/−19
- lib/Polysemy/Resume/Data/Stop.hs +0/−22
- lib/Polysemy/Resume/Effect/Resumable.hs +19/−0
- lib/Polysemy/Resume/Effect/Stop.hs +22/−0
- lib/Polysemy/Resume/Resumable.hs +66/−4
- lib/Polysemy/Resume/Resume.hs +2/−2
- lib/Polysemy/Resume/Stop.hs +68/−2
- polysemy-resume.cabal +29/−17
- readme.md +0/−205
- test/Main.hs +5/−1
- test/Polysemy/Resume/HigherOrderTest.hs +1/−1
- test/Polysemy/Resume/Test/InterceptTest.hs +70/−0
− changelog.md
@@ -1,15 +0,0 @@-# Unreleased--# 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 `(<<!)`.--# 0.1.0.0--* initial release
lib/Polysemy/Resume.hs view
@@ -1,13 +1,17 @@ module Polysemy.Resume ( -- * Introduction -- $intro- module Polysemy.Resume.Data.Stop,- module Polysemy.Resume.Data.Resumable,+ module Polysemy.Resume.Effect.Stop,+ module Polysemy.Resume.Effect.Resumable, -- * Resuming a Stopped Computation resume, (!!), interpretResumable, interpretResumableH,+ interceptResumable,+ interceptResumableH,+ interceptResumableUsing,+ interceptResumableUsingH, resumable, raiseResumable, resumableIO,@@ -40,10 +44,14 @@ module Polysemy.Resume.Stop, ) where -import Polysemy.Resume.Data.Resumable (Resumable, type (!!))-import Polysemy.Resume.Data.Stop (Stop (..), stop)+import Polysemy.Resume.Effect.Resumable (Resumable, type (!!))+import Polysemy.Resume.Effect.Stop (Stop (..), stop) import Polysemy.Resume.Resumable ( catchResumable,+ interceptResumable,+ interceptResumableH,+ interceptResumableUsing,+ interceptResumableUsingH, interpretResumable, interpretResumableH, raiseResumable,@@ -81,12 +89,18 @@ runStop, showStop, stopEither,+ stopEitherAs, stopEitherWith, stopNote, stopOnError, stopOnErrorWith, stopToError,+ stopToErrorWith, stopToIOFinal,+ stopTryIOE,+ stopTryIO,+ stopTryIOError,+ stopTryAny, ) -- $intro
− lib/Polysemy/Resume/Data/Resumable.hs
@@ -1,19 +0,0 @@-module Polysemy.Resume.Data.Resumable where--import Polysemy.Internal.Union (Weaving)---- |Effect that wraps another effect @eff@, marking it as throwing errors of type @err@ using--- 'Polysemy.Resume.Data.Stop.Stop'.-data Resumable err eff :: Effect where- Resumable ::- ∀ err eff r a .- Weaving eff (Sem r) a ->- Resumable err eff (Sem r) (Either err a)---- |Infix alias for 'Resumable'.------ @--- Member (Stopper !! Boom) r =>--- @-type eff !! err =- Resumable err eff
− lib/Polysemy/Resume/Data/Stop.hs
@@ -1,22 +0,0 @@-{-# options_haddock prune #-}---- |Description: Internal-module Polysemy.Resume.Data.Stop where---- |An effect similar to 'Polysemy.Error.Error' without the ability to be caught.--- Used to signal that an error is supposed to be expected by dependent programs.------ @--- interpretStopper ::--- Member (Stop Boom) r =>--- InterpreterFor Stopper r--- interpretStopper =--- interpret \\case--- StopBang -> stop (Bang 13)--- StopBoom -> stop (Boom "ouch")--- @-data Stop e :: Effect where- -- |Abort a computation with an error value.- Stop :: e -> Stop e m a--makeSem ''Stop
+ lib/Polysemy/Resume/Effect/Resumable.hs view
@@ -0,0 +1,19 @@+module Polysemy.Resume.Effect.Resumable where++import Polysemy.Internal.Union (Weaving)++-- |Effect that wraps another effect @eff@, marking it as throwing errors of type @err@ using+-- 'Polysemy.Resume.Data.Stop.Stop'.+data Resumable err eff :: Effect where+ Resumable ::+ ∀ err eff r a .+ Weaving eff (Sem r) a ->+ Resumable err eff (Sem r) (Either err a)++-- |Infix alias for 'Resumable'.+--+-- @+-- Member (Stopper !! Boom) r =>+-- @+type eff !! err =+ Resumable err eff
+ lib/Polysemy/Resume/Effect/Stop.hs view
@@ -0,0 +1,22 @@+{-# options_haddock prune #-}++-- |Description: Internal+module Polysemy.Resume.Effect.Stop where++-- |An effect similar to 'Polysemy.Error.Error' without the ability to be caught.+-- Used to signal that an error is supposed to be expected by dependent programs.+--+-- @+-- interpretStopper ::+-- Member (Stop Boom) r =>+-- InterpreterFor Stopper r+-- interpretStopper =+-- interpret \\case+-- StopBang -> stop (Bang 13)+-- StopBoom -> stop (Boom "ouch")+-- @+data Stop e :: Effect where+ -- |Abort a computation with an error value.+ Stop :: e -> Stop e m a++makeSem ''Stop
lib/Polysemy/Resume/Resumable.hs view
@@ -6,10 +6,10 @@ import Polysemy.Internal (Sem (Sem, runSem), liftSem, usingSem) import Polysemy.Internal.CustomErrors (FirstOrder) import Polysemy.Internal.Tactics (liftT, runTactics)-import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, inj, injWeaving, weave)+import Polysemy.Internal.Union (ElemOf, Weaving (Weaving), decomp, hoist, inj, injWeaving, membership, prjUsing, weave) -import Polysemy.Resume.Data.Resumable (Resumable (..))-import Polysemy.Resume.Data.Stop (Stop, stop)+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' =@@ -141,7 +141,6 @@ -- -- @ -- interpretStopperResumable ::--- Member (Stop Boom) r => -- InterpreterFor Stopper r -- interpretStopperResumable = -- interpretResumable \\case@@ -159,6 +158,69 @@ 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 ::
lib/Polysemy/Resume/Resume.hs view
@@ -1,8 +1,8 @@ -- |Resumption combinators, transforming an effect into 'Resumable' and 'Stop'. module Polysemy.Resume.Resume where -import Polysemy.Resume.Data.Resumable (Resumable)-import Polysemy.Resume.Data.Stop (Stop, stop)+import Polysemy.Resume.Effect.Resumable (Resumable)+import Polysemy.Resume.Effect.Stop (Stop, stop) import Polysemy.Resume.Resumable (runAsResumable) import Polysemy.Resume.Stop (runStop)
lib/Polysemy/Resume/Stop.hs view
@@ -9,7 +9,7 @@ import Polysemy.Internal.Union (Weaving (Weaving), decomp, hoist, weave) import qualified Text.Show -import Polysemy.Resume.Data.Stop (Stop (Stop), stop)+import Polysemy.Resume.Effect.Stop (Stop (Stop), stop) hush :: Either e a -> Maybe a hush (Right a) = Just a@@ -79,6 +79,16 @@ 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 =>@@ -117,13 +127,23 @@ 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 =- either throw pure <=< runStop+ stopToErrorWith id {-# inline stopToError #-} -- |Convert a program using 'Stop' to one using 'Error'.@@ -162,3 +182,49 @@ 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 #-}
polysemy-resume.cabal view
@@ -5,25 +5,28 @@ -- see: https://github.com/sol/hpack name: polysemy-resume-version: 0.4.0.0+version: 0.5.0.0 synopsis: Polysemy error tracking-description: Please see the readme on Github at <https://github.com/tek/polysemy-resume>-category: Experimental+description: See https://hackage.haskell.org/package/polysemy-resume/docs/Polysemy-Resume.html+category: Error+homepage: https://github.com/tek/polysemy-resume#readme+bug-reports: https://github.com/tek/polysemy-resume/issues author: Torsten Schmits-maintainer: tek@tryp.io-copyright: 2020 Torsten Schmits+maintainer: hackage@tryp.io+copyright: 2022 Torsten Schmits license: BSD-2-Clause-Patent license-file: LICENSE build-type: Simple-extra-source-files:- readme.md- changelog.md +source-repository head+ type: git+ location: https://github.com/tek/polysemy-resume+ library exposed-modules: Polysemy.Resume- Polysemy.Resume.Data.Resumable- Polysemy.Resume.Data.Stop+ Polysemy.Resume.Effect.Resumable+ Polysemy.Resume.Effect.Stop Polysemy.Resume.Resumable Polysemy.Resume.Resume Polysemy.Resume.Stop@@ -43,6 +46,7 @@ DeriveFoldable DeriveFunctor DeriveGeneric+ DeriveLift DeriveTraversable DerivingStrategies DerivingVia@@ -75,6 +79,7 @@ RankNTypes RecordWildCards RecursiveDo+ RoleAnnotations ScopedTypeVariables StandaloneDeriving TemplateHaskell@@ -87,14 +92,16 @@ UndecidableInstances UnicodeSyntax ViewPatterns- ghc-options: -flate-specialise -fspecialise-aggressively -Wall+ ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages build-depends:- base ==4.*- , incipit-core >=0.2+ base >=4.12 && <5+ , incipit-core >=0.3 , polysemy >=1.6 , transformers mixins: base hiding (Prelude)+ , incipit-core (IncipitCore as Prelude)+ , incipit-core hiding (IncipitCore) default-language: Haskell2010 test-suite polysemy-resume-unit@@ -103,6 +110,7 @@ other-modules: Polysemy.Resume.ExampleTest Polysemy.Resume.HigherOrderTest+ Polysemy.Resume.Test.InterceptTest hs-source-dirs: test default-extensions:@@ -119,6 +127,7 @@ DeriveFoldable DeriveFunctor DeriveGeneric+ DeriveLift DeriveTraversable DerivingStrategies DerivingVia@@ -151,6 +160,7 @@ RankNTypes RecordWildCards RecursiveDo+ RoleAnnotations ScopedTypeVariables StandaloneDeriving TemplateHaskell@@ -163,19 +173,21 @@ UndecidableInstances UnicodeSyntax ViewPatterns- ghc-options: -flate-specialise -fspecialise-aggressively -Wall -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends:- base ==4.*+ base >=4.12 && <5 , hedgehog- , incipit-core+ , incipit-core >=0.3 , polysemy , polysemy-plugin , polysemy-resume- , polysemy-test+ , polysemy-test >=0.6 , stm , tasty , tasty-hedgehog , text mixins: base hiding (Prelude)+ , incipit-core (IncipitCore as Prelude)+ , incipit-core hiding (IncipitCore) default-language: Haskell2010
− readme.md
@@ -1,205 +0,0 @@-# 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!
test/Main.hs view
@@ -1,13 +1,17 @@ module Main where import Polysemy.Resume.ExampleTest (test_example)+import Polysemy.Resume.HigherOrderTest (test_switchInterpreter)+import Polysemy.Resume.Test.InterceptTest (test_intercept) import Polysemy.Test (unitTest) import Test.Tasty (TestTree, defaultMain, testGroup) tests :: TestTree tests = testGroup "unit" [- unitTest "stop and resume" test_example+ unitTest "stop and resume" test_example,+ unitTest "switch higher order interpreter" test_switchInterpreter,+ unitTest "intercept" test_intercept ] main :: IO ()
test/Polysemy/Resume/HigherOrderTest.hs view
@@ -6,7 +6,7 @@ import Polysemy.Test (UnitTest, runTestAuto, (===)) import Polysemy.Resume (type (!!))-import Polysemy.Resume.Data.Stop (stop)+import Polysemy.Resume.Effect.Stop (stop) import Polysemy.Resume.Resumable (interpretResumableH) import Polysemy.Resume.Resume (resume)
+ test/Polysemy/Resume/Test/InterceptTest.hs view
@@ -0,0 +1,70 @@+{-# options_ghc -fplugin=Polysemy.Plugin #-}++module Polysemy.Resume.Test.InterceptTest where++import Control.Concurrent.STM (newTVarIO)+import Polysemy.Test (UnitTest, runTestAuto, (===))++import Polysemy.Resume.Effect.Resumable (type (!!))+import Polysemy.Resume.Effect.Stop (stop)+import Polysemy.Resume.Resumable (interceptResumable, interpretResumable)+import Polysemy.Resume.Resume (restop, (!!), (<!))++data A :: Effect where+ A1 :: A m Int+ A2 :: A m Int+ A3 :: A m Int++makeSem ''A++interpretA ::+ Member (AtomicState Int) r =>+ InterpreterFor (A !! Int) r+interpretA =+ interpretResumable \case+ A1 ->+ atomicGet >>= \case+ 5 -> stop 13+ n -> pure (n - 1000)+ A2 ->+ pure (-1)+ A3 ->+ pure (-1)++interceptA1 ::+ Members [A !! Int, AtomicState Int] r =>+ Sem r a ->+ Sem r a+interceptA1 =+ interceptResumable \case+ A1 ->+ atomicModify' (8 *) *> restop a1+ A2 -> do+ atomicPut 5+ restop a1+ A3 ->+ stop (23)++interceptA2 ::+ Members [A !! Int, AtomicState Int] r =>+ Sem r a ->+ Sem r a+interceptA2 =+ interceptResumable \case+ A1 ->+ atomicModify' (500 +) *> restop a1+ A2 ->+ restop a2+ A3 ->+ 99 <! a3++test_intercept :: UnitTest+test_intercept =+ runTestAuto do+ tv <- embed (newTVarIO 0)+ i <- runAtomicStateTVar tv $ interpretA $ interceptA1 $ interceptA2 do+ i1 <- a1 !! \ i -> fail ("first failed with: " <> show i)+ i2 <- a2 !! pure+ i3 <- a3 !! pure+ pure (i1, i2, i3)+ (3000, 13, 99) === i