Add rethrowError and friends for throwing errors with a given CallStack

effectful-core/CHANGELOG.md

@@ -33,6 +33,9 @@
   state from outside of the effect, manage an explicit `MVar'` yourself.
 * Tighten pre-requisites for `unconsEnv` and `unreplaceEnv`.
 * Add `localLendBorrow` to `Effectful.Dispatch.Dynamic`.
+* Add `rethrowErrorWith`, `rethrowError` and `rethrowError_` (along with the
+  corresponding `RethrowErrorWith` operation of the dynamic `Error` effect) for
+  throwing errors with a given `CallStack`.
 * Require `primitive` >= 0.9.0.0.
 * Remove `SharedSuffix` constraints from functions in
   `Effectful.Dispatch.Dynamic` and deprecate the class, as runtime sanity

effectful-core/src/Effectful/Error/Dynamic.hs

@@ -18,6 +18,9 @@ module Effectful.Error.Dynamic
   , throwErrorWith
   , throwError
   , throwError_
+  , rethrowErrorWith
+  , rethrowError
+  , rethrowError_
   , catchError
   , handleError
   , tryError
@@ -43,6 +46,7 @@ runError
   -> Eff es (Either (E.CallStack, e) a)
 runError = reinterpret E.runError $ \env -> \case
   ThrowErrorWith display e -> E.throwErrorWith display e
+  RethrowErrorWith display cs e -> E.rethrowErrorWith display cs e
   CatchError m h -> localSeqUnlift env $ \unlift -> do
     E.catchError (unlift m) (\cs -> unlift . h cs)
 
@@ -113,6 +117,51 @@ throwError_
   -> Eff es a
 throwError_ = withFrozenCallStack throwErrorWith (const "<opaque>")
 
+-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a
+-- display function in case a third-party code catches the internal exception
+-- and 'show's it.
+--
+-- Useful e.g. when you want to catch an error and rethrow it converted to a
+-- different type without losing the original 'E.CallStack'.
+--
+-- @since 2.7.0.0
+rethrowErrorWith
+  :: Error e :> es
+  => (e -> String)
+  -- ^ The display function.
+  -> E.CallStack
+  -- ^ The 'E.CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowErrorWith display cs = send . RethrowErrorWith display cs
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a
+-- display function.
+--
+-- @since 2.7.0.0
+rethrowError
+  :: (Error e :> es, Show e)
+  => E.CallStack
+  -- ^ The 'E.CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowError = rethrowErrorWith show
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and no display
+-- function.
+--
+-- @since 2.7.0.0
+rethrowError_
+  :: Error e :> es
+  => E.CallStack
+  -- ^ The 'E.CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowError_ = rethrowErrorWith (const "<opaque>")
+
 -- | Handle an error of type @e@.
 catchError
   :: (HasCallStack, Error e :> es)

effectful-core/src/Effectful/Error/Static.hs

@@ -89,6 +89,9 @@ module Effectful.Error.Static
   , throwErrorWith
   , throwError
   , throwError_
+  , rethrowErrorWith
+  , rethrowError
+  , rethrowError_
   , catchError
   , handleError
   , tryError
@@ -193,6 +196,53 @@ throwError_
   -> Eff es a
 throwError_ = withFrozenCallStack throwErrorWith (const "<opaque>")
 
+-- | Throw an error of type @e@ with the given 'CallStack' and specify a
+-- display function in case a third-party code catches the internal exception
+-- and 'show's it.
+--
+-- Useful e.g. when you want to catch an error and rethrow it converted to a
+-- different type without losing the original 'CallStack'.
+--
+-- @since 2.7.0.0
+rethrowErrorWith
+  :: forall e es a. Error e :> es
+  => (e -> String)
+  -- ^ The display function.
+  -> CallStack
+  -- ^ The 'CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowErrorWith display cs e = do
+  Error eid <- getStaticRep @(Error e)
+  throwIO $ ErrorWrapper eid cs (display e) (toAny e)
+
+-- | Throw an error of type @e@ with the given 'CallStack' and 'show' as a
+-- display function.
+--
+-- @since 2.7.0.0
+rethrowError
+  :: forall e es a. (Error e :> es, Show e)
+  => CallStack
+  -- ^ The 'CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowError = rethrowErrorWith show
+
+-- | Throw an error of type @e@ with the given 'CallStack' and no display
+-- function.
+--
+-- @since 2.7.0.0
+rethrowError_
+  :: forall e es a. Error e :> es
+  => CallStack
+  -- ^ The 'CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowError_ = rethrowErrorWith (const "<opaque>")
+
 -- | Handle an error of type @e@.
 catchError
   :: forall e es a. (HasCallStack, Error e :> es)

effectful-core/src/Effectful/Internal/Effect/Dynamic.hs

@@ -19,6 +19,8 @@ import Effectful.Internal.Monad
 data Error e :: Effect where
   -- | @since 2.4.0.0
   ThrowErrorWith :: (e -> String) -> e -> Error e m a
+  -- | @since 2.7.0.0
+  RethrowErrorWith :: (e -> String) -> CallStack -> e -> Error e m a
   CatchError :: m a -> (CallStack -> e -> m a) -> Error e m a
 
 type instance DispatchOf (Error e) = Dynamic

effectful-core/src/Effectful/Labeled/Error.hs

@@ -16,6 +16,9 @@ module Effectful.Labeled.Error
   , throwErrorWith
   , throwError
   , throwError_
+  , rethrowErrorWith
+  , rethrowError
+  , rethrowError_
   , catchError
   , handleError
   , tryError
@@ -106,6 +109,55 @@ throwError_
   -> Eff es a
 throwError_ = withFrozenCallStack (throwErrorWith @label) (const "<opaque>")
 
+-- | Throw an error of type @e@ with the given 'E.CallStack' and specify a
+-- display function in case a third-party code catches the internal exception
+-- and 'show's it.
+--
+-- Useful e.g. when you want to catch an error and rethrow it converted to a
+-- different type without losing the original 'E.CallStack'.
+--
+-- @since 2.7.0.0
+rethrowErrorWith
+  :: forall label e es a
+   . Labeled label (Error e) :> es
+  => (e -> String)
+  -- ^ The display function.
+  -> E.CallStack
+  -- ^ The 'E.CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowErrorWith display cs =
+  send . Labeled @label . RethrowErrorWith display cs
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and 'show' as a
+-- display function.
+--
+-- @since 2.7.0.0
+rethrowError
+  :: forall label e es a
+   . (Labeled label (Error e) :> es, Show e)
+  => E.CallStack
+  -- ^ The 'E.CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowError = rethrowErrorWith @label show
+
+-- | Throw an error of type @e@ with the given 'E.CallStack' and no display
+-- function.
+--
+-- @since 2.7.0.0
+rethrowError_
+  :: forall label e es a
+   . Labeled label (Error e) :> es
+  => E.CallStack
+  -- ^ The 'E.CallStack' to attach to the error.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+rethrowError_ = rethrowErrorWith @label (const "<opaque>")
+
 -- | Handle an error of type @e@.
 catchError
   :: forall label e es a

effectful/CHANGELOG.md

@@ -36,6 +36,9 @@
   state from outside of the effect, manage an explicit `MVar'` yourself.
 * Tighten pre-requisites for `unconsEnv` and `unreplaceEnv`.
 * Add `localLendBorrow` to `Effectful.Dispatch.Dynamic`.
+* Add `rethrowErrorWith`, `rethrowError` and `rethrowError_` (along with the
+  corresponding `RethrowErrorWith` operation of the dynamic `Error` effect) for
+  throwing errors with a given `CallStack`.
 * Require `primitive` >= 0.9.0.0.
 * Remove `SharedSuffix` constraints from functions in
   `Effectful.Dispatch.Dynamic` and deprecate the class, as runtime sanity

effectful/tests/ErrorTests.hs

@@ -12,6 +12,7 @@ errorTests :: TestTree
 errorTests = testGroup "Error"
   [ testCase "different handlers are independent" test_independentHandlers
   , testCase "call stack of dynamic throwError doesn't show internal details" test_dynamicThrowErrorCallStack
+  , testCase "rethrowError attaches the given call stack" test_rethrowError
   ]
 
 test_independentHandlers :: Assertion
@@ -30,6 +31,20 @@ test_dynamicThrowErrorCallStack = do
     [("throwError", _)] -> pure ()
     _ -> assertFailure $ "invalid call stack: " ++ prettyCallStack cs
 
+test_rethrowError :: Assertion
+test_rethrowError = runEff $ do
+  result <- runError @Int . runError @String $ do
+    originalThrow `catchError` \cs (_ :: String) -> rethrowError cs (42 :: Int)
+  liftIO $ case result of
+    Left (cs, e) -> do
+      assertEqual "rethrown error" 42 e
+      assertBool "stack trace points to the original throw" $
+        "originalThrow" == fst (last $ getCallStack cs)
+    Right _ -> assertFailure "error not rethrown"
+  where
+    originalThrow :: (HasCallStack, Error String :> es) => Eff es a
+    originalThrow = throwError "oops"
+
 ----------------------------------------
 -- Helpers