diff --git a/changelog.md b/changelog.md deleted file mode 100644 --- a/changelog.md +++ /dev/null @@ -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 `(< - Resumable err eff (Sem r) (Either err a) - --- |Infix alias for 'Resumable'. --- --- @ --- Member (Stopper !! Boom) r => --- @ -type eff !! err = - Resumable err eff diff --git a/lib/Polysemy/Resume/Data/Stop.hs b/lib/Polysemy/Resume/Data/Stop.hs deleted file mode 100644 --- a/lib/Polysemy/Resume/Data/Stop.hs +++ /dev/null @@ -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 diff --git a/lib/Polysemy/Resume/Effect/Resumable.hs b/lib/Polysemy/Resume/Effect/Resumable.hs new file mode 100644 --- /dev/null +++ b/lib/Polysemy/Resume/Effect/Resumable.hs @@ -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 diff --git a/lib/Polysemy/Resume/Effect/Stop.hs b/lib/Polysemy/Resume/Effect/Stop.hs new file mode 100644 --- /dev/null +++ b/lib/Polysemy/Resume/Effect/Stop.hs @@ -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 diff --git a/lib/Polysemy/Resume/Resumable.hs b/lib/Polysemy/Resume/Resumable.hs --- a/lib/Polysemy/Resume/Resumable.hs +++ b/lib/Polysemy/Resume/Resumable.hs @@ -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 :: 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,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) diff --git a/lib/Polysemy/Resume/Stop.hs b/lib/Polysemy/Resume/Stop.hs --- a/lib/Polysemy/Resume/Stop.hs +++ b/lib/Polysemy/Resume/Stop.hs @@ -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 #-} diff --git a/polysemy-resume.cabal b/polysemy-resume.cabal --- a/polysemy-resume.cabal +++ b/polysemy-resume.cabal @@ -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 -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 diff --git a/readme.md b/readme.md deleted file mode 100644 --- a/readme.md +++ /dev/null @@ -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! diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 () 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 @@ -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) diff --git a/test/Polysemy/Resume/Test/InterceptTest.hs b/test/Polysemy/Resume/Test/InterceptTest.hs new file mode 100644 --- /dev/null +++ b/test/Polysemy/Resume/Test/InterceptTest.hs @@ -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, (!!), ( + 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 fail ("first failed with: " <> show i) + i2 <- a2 !! pure + i3 <- a3 !! pure + pure (i1, i2, i3) + (3000, 13, 99) === i