polysemy-resume 0.1.0.1 → 0.1.0.2

raw patch · 9 files changed

+500/−82 lines, 9 filesdep ~polysemydep ~reludePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: polysemy, relude

API changes (from Hackage documentation)

Files

• lib/Polysemy/Resume.hs +16/−1
• lib/Polysemy/Resume/Data/Resumable.hs +3/−3
• lib/Polysemy/Resume/Resumable.hs +113/−25
• lib/Polysemy/Resume/Resume.hs +52/−16
• lib/Polysemy/Resume/Stop.hs +78/−14
• polysemy-resume.cabal +128/−18
• readme.md +32/−1
• test/Polysemy/Resume/ExampleTest.hs +4/−4
• test/Polysemy/Resume/HigherOrderTest.hs +74/−0

@@ -5,19 +5,24 @@   module Polysemy.Resume.Data.Resumable,   -- * Resuming a Stopped Computation   resume,+  interpretResumable,+  interpretResumableH,   resumable,+  raiseResumable,   resumableIO,   -- * Partial Handlers   -- $partial   resumableOr,   -- * Various Combinators   resumeAs,+  resume_,   resumeHoist,   resumeHoistAs,   resuming,   resumeHoistError,   resumeHoistErrorAs,   restop,+  resumeEither,   resumeError,   resumableError,   resumableFor,@@ -26,10 +31,13 @@   module Polysemy.Resume.Stop, ) where -import Polysemy.Resume.Data.Resumable (Resumable, type (!))+import Polysemy.Resume.Data.Resumable (Resumable, type (!!)) import Polysemy.Resume.Data.Stop (Stop(..), stop) import Polysemy.Resume.Resumable (   catchResumable,+  interpretResumable,+  interpretResumableH,+  raiseResumable,   resumable,   resumableError,   resumableFor,@@ -41,17 +49,24 @@   restop,   resume,   resumeAs,+  resumeEither,   resumeError,   resumeHoist,   resumeHoistAs,   resumeHoistError,   resumeHoistErrorAs,+  resume_,   resuming,   ) import Polysemy.Resume.Stop (+  mapStop,   runStop,+  showStop,   stopEither,+  stopEitherWith,+  stopNote,   stopOnError,+  stopOnErrorWith,   stopToError,   stopToIOFinal,   )

@@ -4,7 +4,7 @@  -- |Effect that wraps another effect @eff@, marking it as throwing errors of type @err@ using -- 'Polysemy.Resume.Data.Stop.Stop'.-data Resumable err eff m a where+data Resumable err eff :: Effect where   Resumable ::     ∀ err eff r a .     Weaving eff (Sem r) a ->@@ -13,7 +13,7 @@ -- |Infix alias for 'Resumable'. -- -- @--- Member (Stopper ! Boom) r =>+-- Member (Stopper !! Boom) r => -- @-type eff ! err =+type eff !! err =   Resumable err eff

@@ -1,13 +1,15 @@ module Polysemy.Resume.Resumable where -import Polysemy.Internal (Sem(Sem), liftSem, raise, raiseUnder, runSem, send)-import Polysemy.Internal.Union (Weaving(Weaving), decomp, hoist, inj, injWeaving, weave) -import Polysemy (Final)+import Polysemy (Final, Tactical) import Polysemy.Error (Error(Throw), catchJust)+import Polysemy.Internal (Sem(Sem, runSem), liftSem, raise, raiseUnder, send, 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.Resume.Data.Resumable (Resumable(..)) import Polysemy.Resume.Data.Stop (Stop, stop)-import Polysemy.Resume.Stop (runStop, stopOnError, stopToIOFinal)+import Polysemy.Resume.Stop (StopExc, runStop, stopOnError, stopToIOFinal)  distribEither ::   Functor f =>@@ -21,18 +23,35 @@     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: --+--   @+--   interpretEffResumable :: 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 ::-  ∀ (eff :: Effect) (err :: *) (r :: EffectRow) .+  ∀ (err :: *) (eff :: Effect) (r :: EffectRow) .   InterpreterFor eff (Stop err : r) ->   InterpreterFor (Resumable err eff) r-resumable interpreter sem =-  Sem \ k -> runSem sem \ u ->+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@@ -43,15 +62,32 @@         k g {-# INLINE resumable #-} +-- |Convenience combinator for turning an interpreter that doesn't use 'Stop' into a 'Resumable'.+raiseResumable ::+  ∀ (err :: *) (eff :: Effect) (r :: EffectRow) .+  InterpreterFor eff r ->+  InterpreterFor (Resumable err eff) r+raiseResumable interpreter (Sem m) =+  Sem \ k -> m \ u ->+    case decomp (hoist (raiseResumable interpreter) u) of+      Right (Weaving (Resumable e) s wv ex ins) ->+        distribEither s ex <$> runSem resultFromEff k+        where+          resultFromEff =+            fmap Right $ interpreter $ liftSem $ weave s (raise . wv) ins (injWeaving e)+      Left g ->+        k g+{-# INLINE raiseResumable #-}+ -- |Like 'resumable', but use exceptions instead of 'ExceptT'. resumableIO ::-  ∀ (eff :: Effect) (err :: *) (r :: EffectRow) .-  Typeable err =>+  ∀ (err :: *) (eff :: Effect) (r :: EffectRow) .+  Exception (StopExc err) =>   Member (Final IO) r =>   InterpreterFor eff (Stop err : r) ->   InterpreterFor (Resumable err eff) r-resumableIO interpreter sem =-  Sem \ k -> runSem sem \ u ->+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@@ -62,9 +98,61 @@         k g {-# INLINE resumableIO #-} +-- |Like 'interpretResumable', but for higher-order effects.+interpretResumableH ::+  ∀ (err :: *) (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)+        where+          tac =+            runTactics+            (Compose (s <$ sOuter))+            (raiseUnder . fmap Compose . distOuter . fmap dist . getCompose)+            (join . fmap ins . insOuter . getCompose)+            (raise . interpretResumableH handler . fmap Compose . distOuter . fmap dist . getCompose)+            (handler e)+          exFinal = exOuter . \case+            Right (getCompose -> 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 ::+--   Member (Stop Boom) r =>+--   InterpreterFor Stopper r+-- interpretStopperResumable =+--   interpretResumable \\case+--     StopBang -> stop (Bang 13)+--     StopBoom -> stop (Boom "ouch")+-- @+--+-- >>> run $ interpretStopperResumable (interpretResumer mainProgram)+-- 237+interpretResumable ::+  ∀ (err :: *) (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 (liftT . handler)+{-# INLINE interpretResumable #-}+ -- |Convert an interpreter for @eff@ that uses 'Error' into one using 'Stop' and wrap it using 'resumable'. resumableError ::-  ∀ eff err r .+  ∀ (err :: *) (eff :: Effect) r .   InterpreterFor eff (Error err : Stop err : r) ->   InterpreterFor (Resumable err eff) r resumableError interpreter =@@ -98,13 +186,13 @@ -- >>> runError (resumableFor bangOnly interpretStopper (interpretResumerPartial mainProgram)) -- Right 39 resumableOr ::-  ∀ eff err unhandled handled r .+  ∀ (err :: *) (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 =-  Sem \ k -> runSem sem \ u ->+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)@@ -122,7 +210,7 @@  -- |Variant of 'resumableOr' that uses 'Maybe' and rethrows the original error. resumableFor ::-  ∀ eff err handled r .+  ∀ (err :: *) (eff :: Effect) handled r .   Member (Error err) r =>   (err -> Maybe handled) ->   InterpreterFor eff (Stop err : r) ->@@ -136,12 +224,12 @@  -- |Reinterpreting variant of 'resumableFor'. catchResumable ::-  ∀ eff handled err r .+  ∀ (err :: *) (eff :: Effect) handled r .   Members [eff, Error err] r =>   (err -> Maybe handled) ->   InterpreterFor (Resumable handled eff) r-catchResumable canHandle sem =-  Sem \ k -> runSem sem \ u ->+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@@ -154,14 +242,14 @@  -- |Interpret an effect @eff@ by wrapping it in @Resumable@ and @Stop@ and leaving the rest up to the user. runAsResumable ::-  ∀ err eff r .+  ∀ (err :: *) (eff :: Effect) r .   Members [Resumable err eff, Stop err] r =>   InterpreterFor eff r-runAsResumable sem =-  Sem \ k -> runSem sem \ u ->-    case decomp (hoist runAsResumable u) of+runAsResumable (Sem m) =+  Sem \ k -> m \ u ->+    case decomp (hoist (runAsResumable @err @eff) u) of       Right wav ->-        runSem (either stop pure =<< send (Resumable wav)) k+        runSem (either (stop @err) pure =<< send (Resumable wav)) k       Left g ->         k g {-# INLINE runAsResumable #-}

@@ -1,6 +1,6 @@ module Polysemy.Resume.Resume where -import Polysemy (raiseUnder)+import Polysemy (raiseUnder2, raiseUnder) import Polysemy.Error (throw)  import Polysemy.Resume.Data.Resumable (Resumable)@@ -36,9 +36,19 @@   (err -> Sem r a) ->   Sem r a resume sem handler =-  either handler pure =<< runStop (runAsResumable (raiseUnder sem))+  either handler pure =<< runStop (runAsResumable @err (raiseUnder sem)) {-# INLINE resume #-} +-- Reinterpreting version of 'resume'.+resumeRe ::+  ∀ err eff r a .+  Sem (eff : r) a ->+  (err -> Sem (Resumable err eff : r) a) ->+  Sem (Resumable err eff : r) a+resumeRe sem handler =+  either handler pure =<< runStop (runAsResumable @err (raiseUnder2 sem))+{-# INLINE resumeRe #-}+ -- |Flipped variant of 'resume'. resuming ::   ∀ err eff r a .@@ -50,6 +60,16 @@   flip resume {-# INLINE resuming #-} +-- |Flipped variant of 'resumeRe'.+resumingRe ::+  ∀ err eff r a .+  (err -> Sem (Resumable err eff : r) a) ->+  Sem (eff : r) a ->+  Sem (Resumable err eff : r) a+resumingRe =+  flip resumeRe+{-# INLINE resumingRe #-}+ -- |Variant of 'resume' that unconditionally recovers with a constant value. resumeAs ::   ∀ err eff r a .@@ -58,12 +78,21 @@   Sem (eff : r) a ->   Sem r a resumeAs a =-  resuming \ _ -> pure a+  resuming @err \ _ -> pure a {-# INLINE resumeAs #-} +-- |Convenience specialization of 'resume' that silently discards errors for void programs.+resume_ ::+  ∀ err eff r .+  Member (Resumable err eff) r =>+  Sem (eff : r) () ->+  Sem r ()+resume_ =+  resumeAs @err ()+ -- |Variant of 'resume' that propagates the error to another 'Stop' effect after applying a function. resumeHoist ::-  ∀ err err' eff r a .+  ∀ err eff err' r a .   Members [Resumable err eff, Stop err'] r =>   (err -> err') ->   Sem (eff : r) a ->@@ -74,28 +103,35 @@  -- |Variant of 'resumeHoist' that uses a constant value. resumeHoistAs ::-  ∀ err err' eff r a .+  ∀ err eff err' r .   Members [Resumable err eff, Stop err'] r =>   err' ->-  Sem (eff : r) a ->-  Sem r a+  InterpreterFor eff r resumeHoistAs err =-  resumeHoist (const err)+  resumeHoist @err (const err) {-# INLINE resumeHoistAs #-}  -- |Variant of 'resumeHoist' that uses the unchanged error. restop ::-  ∀ err eff r a .+  ∀ err eff r .   Members [Resumable err eff, Stop err] r =>-  Sem (eff : r) a ->-  Sem r a+  InterpreterFor eff r restop =-  resumeHoist id+  resumeHoist @err id {-# INLINE restop #-} +-- |Variant of 'restop' that immediately produces an 'Either'.+resumeEither ::+  ∀ err eff r a .+  Member (Resumable err eff) r =>+  Sem (eff : r) a ->+  Sem r (Either err a)+resumeEither =+  runStop . restop @err . raiseUnder+ -- |Variant of 'resume' that propagates the error to an 'Error' effect after applying a function. resumeHoistError ::-  ∀ err err' eff r a .+  ∀ err eff err' r a .   Members [Resumable err eff, Error err'] r =>   (err -> err') ->   Sem (eff : r) a ->@@ -106,13 +142,13 @@  -- |Variant of 'resumeHoistError' that uses the unchanged error. resumeHoistErrorAs ::-  ∀ err err' eff r a .+  ∀ err eff err' r a .   Members [Resumable err eff, Error err'] r =>   err' ->   Sem (eff : r) a ->   Sem r a resumeHoistErrorAs err =-  resumeHoistError (const err)+  resumeHoistError @err (const err) {-# INLINE resumeHoistErrorAs #-}  -- |Variant of 'resumeHoistError' that uses the unchanged error.@@ -122,5 +158,5 @@   Sem (eff : r) a ->   Sem r a resumeError =-  resumeHoistError id+  resumeHoistError @err id {-# INLINE resumeError #-}

@@ -1,15 +1,15 @@ module Polysemy.Resume.Stop where +import Control.Exception (throwIO, try) import Control.Monad.Trans.Except (throwE) import Data.Typeable (typeRep) import Polysemy (Final) import Polysemy.Error (runError, throw) import Polysemy.Final (getInitialStateS, interpretFinal, runS, withStrategicToFinal)-import Polysemy.Internal (Sem(Sem))-import Polysemy.Internal.Union (Weaving(Weaving), decomp, weave)+import Polysemy.Internal (Sem(Sem), send, usingSem)+import Polysemy.Internal.Union (Weaving(Weaving), decomp, hoist, weave) import qualified Text.Show -import Control.Exception (throwIO, try) import Polysemy.Resume.Data.Stop (Stop(Stop), stop)  hush :: Either e a -> Maybe a@@ -30,30 +30,36 @@           throwE e {-# INLINE runStop #-} -newtype WrappedExc e =-  WrappedExc { unwrapExc :: e }+newtype StopExc e =+  StopExc { unStopExc :: e }   deriving (Typeable) -instance Typeable e => Show (WrappedExc e) where+instance {-# overlappable #-} Typeable e => Show (StopExc e) where   show =-    mappend "WrappedExc: " . show . typeRep+    mappend "StopExc: " . show . typeRep -instance Typeable e => Exception (WrappedExc e)+instance Show (StopExc Text) where+  show (StopExc e) =+    "StopExc " <> show e +instance {-# overlappable #-} Typeable e => Exception (StopExc e)++instance Exception (StopExc Text)+ runStopAsExcFinal ::-  Typeable e =>+  Exception (StopExc e) =>   Member (Final IO) r =>   Sem (Stop e : r) a ->   Sem r a runStopAsExcFinal =   interpretFinal \case     Stop e ->-      pure (throwIO (WrappedExc e))+      pure (throwIO (StopExc e)) {-# INLINE runStopAsExcFinal #-}  -- |Run 'Stop' by throwing exceptions. stopToIOFinal ::-  Typeable e =>+  Exception (StopExc e) =>   Member (Final IO) r =>   Sem (Stop e : r) a ->   Sem r (Either e a)@@ -61,17 +67,38 @@   withStrategicToFinal @IO do     m' <- runS (runStopAsExcFinal sem)     s <- getInitialStateS-    pure $ either ((<$ s) . Left . unwrapExc) (fmap Right) <$> try m'+    pure $ either ((<$ s) . Left . unStopExc) (fmap Right) <$> 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'. stopEither ::   Member (Stop err) r =>   Either err a ->   Sem r a stopEither =-  either stop pure+  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 =>@@ -81,6 +108,16 @@   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'. stopToError ::   Member (Error err) r =>@@ -92,10 +129,37 @@  -- |Convert a program using 'Stop' to one using 'Error'. stopToErrorIO ::-  Typeable err =>+  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 #-}

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.2.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack  name:           polysemy-resume-version:        0.1.0.1+version:        0.1.0.2 synopsis:       Polysemy error tracking description:    Please see the readme on Github at <https://github.com/tek/polysemy-resume> category:       Experimental@@ -28,25 +28,79 @@       Polysemy.Resume.Resumable       Polysemy.Resume.Resume       Polysemy.Resume.Stop-      Paths_polysemy_resume   other-modules:       Prelude+      Paths_polysemy_resume   autogen-modules:       Paths_polysemy_resume   hs-source-dirs:       lib-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLists PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns-  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -fplugin=Polysemy.Plugin+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -flate-specialise -fspecialise-aggressively -Wall   build-depends:-      base >=4 && <5-    , polysemy >=1.3.0-    , polysemy-plugin-    , relude >=0.7 && <0.8+      base ==4.*+    , polysemy ==1.5.*+    , relude >=0.7 && <1.2     , transformers   mixins:       base hiding (Prelude)-  if impl(ghc < 8.10)-    ghc-options: -O2   default-language: Haskell2010  test-suite polysemy-resume-unit@@ -54,19 +108,77 @@   main-is: Main.hs   other-modules:       Polysemy.Resume.ExampleTest+      Polysemy.Resume.HigherOrderTest       Paths_polysemy_resume   hs-source-dirs:       test-  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia DisambiguateRecordFields DoAndIfThenElse DuplicateRecordFields EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase LiberalTypeSynonyms MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLists PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns-  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin+  default-extensions:+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      OverloadedLists+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -threaded -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin   build-depends:-      base >=4 && <5+      base ==4.*     , hedgehog-    , polysemy >=1.3.0+    , polysemy ==1.5.*     , polysemy-plugin     , polysemy-resume     , polysemy-test-    , relude >=0.7 && <0.8+    , relude >=0.7 && <1.2     , tasty     , tasty-hedgehog     , text@@ -75,6 +187,4 @@       base hiding (Prelude)     , polysemy-resume hiding (Prelude)     , polysemy-resume (Polysemy.Resume.Prelude as Prelude)-  if impl(ghc < 8.10)-    ghc-options: -O2   default-language: Haskell2010

@@ -72,6 +72,12 @@       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@@ -105,6 +111,31 @@ 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@@ -171,4 +202,4 @@  # Thanks -to @KingOfTheHomeless for the meat of the implementation!+to @KingOfTheHomeless for providing the initial implementation and lots of consultation!

@@ -4,7 +4,7 @@ import Polysemy.Test (UnitTest, assertRight, runTestAuto, (===))  import Polysemy.Error (runError)-import Polysemy.Resume (Stop, resumable, resumableFor, resume, stop, type (!))+import Polysemy.Resume (Stop, resumable, resumableFor, resume, stop, type (!!))  data Stopper :: Effect where   StopBang :: Stopper m ()@@ -41,7 +41,7 @@     StopBoom -> stop (Boom "ouch")  interpretResumerPartialUnhandled ::-  Member (Stopper ! Blip) r =>+  Member (Stopper !! Blip) r =>   InterpreterFor Resumer r interpretResumerPartialUnhandled =   interpret \ MainProgram ->@@ -49,7 +49,7 @@       pure (num * 3)  interpretResumerPartial ::-  Member (Stopper ! Blip) r =>+  Member (Stopper !! Blip) r =>   InterpreterFor Resumer r interpretResumerPartial =   interpret \ MainProgram ->@@ -57,7 +57,7 @@       pure (num * 3)  interpretResumer ::-  Member (Stopper ! Boom) r =>+  Member (Stopper !! Boom) r =>   InterpreterFor Resumer r interpretResumer =   interpret \ MainProgram ->

@@ -0,0 +1,74 @@+{-# options_ghc -Wno-all #-}++module Polysemy.Resume.HigherOrderTest where++import Polysemy (makeSem, pureT, raise, raiseUnder, runT)+import Polysemy.AtomicState (+  AtomicState,+  atomicModify,+  runAtomicStateTVar,+  )+import Polysemy.Resource (Resource, finally)+import Polysemy.Resume (type (!!))+import Polysemy.Resume.Data.Stop (stop)+import Polysemy.Resume.Resumable (interpretResumable, interpretResumableH)+import Polysemy.Resume.Resume (restop, resume)+import Polysemy.Test (UnitTest, runTestAuto, (===))++import Polysemy.Resume.Data.Stop (Stop)+import Polysemy.Resume.Stop (stopNote)++data Eff :: Effect where+  Nest :: m a -> Eff m a+  Result :: Eff m Int++makeSem ''Eff++data Off :: Effect where+  Off :: Off m Int++makeSem ''Off++interpretEffNested ::+  InterpreterFor (Eff !! Text) r+interpretEffNested =+  interpretResumableH \case+    Nest _ ->+      stop "no"+    Result ->+      pureT 2++interpretEff ::+  InterpreterFor (Eff !! Text) r+interpretEff =+  interpretResumableH \case+    Nest ma -> do+      sem <- runT ma+      raise (interpretEffNested sem)+    Result ->+      pureT 1++interpretEffFinally ::+  Members [Resource, AtomicState Int] r =>+  InterpreterFor (Eff !! Text) r+interpretEffFinally sem =+  interpretEff (finally sem log)+  where+    log =+      atomicModify (1 +)++-- interpretOff ::+--   Member (Eff !! Text) r =>+--   InterpreterFor (Off !! Text) r+-- interpretOff sem =+--   restop (nest $ interpretResumable (\Off -> result) (raiseUnder sem))++test_switchInterpreter :: UnitTest+test_switchInterpreter =+  runTestAuto do+    tv <- newTVarIO 0+    (2 ===) =<< runAtomicStateTVar tv (interpretEffFinally (resume (nest (result >> result)) \ _ -> pure 3))+    (1 ===) =<< readTVarIO tv+    (3 ===) =<< interpretEff (resume (nest (nest result)) \ _ -> pure 3)+    (1 ===) =<< interpretEff (resume result \ _ -> pure 3)+    -- (2 ===) =<< interpretEff (interpretOff (resume off \ _ -> pure 3))