diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md index 6bb6cf85..99df2f8d 100644 --- a/effectful-core/CHANGELOG.md +++ b/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 diff --git a/effectful-core/src/Effectful/Error/Dynamic.hs b/effectful-core/src/Effectful/Error/Dynamic.hs index c94bb70b..97c08d6a 100644 --- a/effectful-core/src/Effectful/Error/Dynamic.hs +++ b/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 "") +-- | 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 "") + -- | Handle an error of type @e@. catchError :: (HasCallStack, Error e :> es) diff --git a/effectful-core/src/Effectful/Error/Static.hs b/effectful-core/src/Effectful/Error/Static.hs index 3bfe8877..8b64e527 100644 --- a/effectful-core/src/Effectful/Error/Static.hs +++ b/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 "") +-- | 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 "") + -- | Handle an error of type @e@. catchError :: forall e es a. (HasCallStack, Error e :> es) diff --git a/effectful-core/src/Effectful/Internal/Effect/Dynamic.hs b/effectful-core/src/Effectful/Internal/Effect/Dynamic.hs index c8209076..a3bceaae 100644 --- a/effectful-core/src/Effectful/Internal/Effect/Dynamic.hs +++ b/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 diff --git a/effectful-core/src/Effectful/Labeled/Error.hs b/effectful-core/src/Effectful/Labeled/Error.hs index b386d0b6..4ce9f8a2 100644 --- a/effectful-core/src/Effectful/Labeled/Error.hs +++ b/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 "") +-- | 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 "") + -- | Handle an error of type @e@. catchError :: forall label e es a diff --git a/effectful/CHANGELOG.md b/effectful/CHANGELOG.md index 33cb0038..7dced0ae 100644 --- a/effectful/CHANGELOG.md +++ b/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 diff --git a/effectful/tests/ErrorTests.hs b/effectful/tests/ErrorTests.hs index c502f5cb..863654a7 100644 --- a/effectful/tests/ErrorTests.hs +++ b/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