diff --git a/effectful-core/src/Effectful/Error/Dynamic.hs b/effectful-core/src/Effectful/Error/Dynamic.hs index 5564d498..18c77e0e 100644 --- a/effectful-core/src/Effectful/Error/Dynamic.hs +++ b/effectful-core/src/Effectful/Error/Dynamic.hs @@ -14,7 +14,9 @@ module Effectful.Error.Dynamic , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ , catchError , handleError , tryError @@ -34,7 +36,8 @@ import Effectful.Error.Static qualified as E -- | Provide the ability to handle errors of type @e@. data Error e :: Effect where - ThrowError :: e -> Error e m a + -- | @since 2.4.0.0 + ThrowErrorWith :: (e -> String) -> e -> Error e m a CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a type instance DispatchOf (Error e) = Dynamic @@ -44,7 +47,7 @@ runError :: Eff (Error e : es) a -> Eff es (Either (E.CallStack, e) a) runError = reinterpret E.runError $ \env -> \case - ThrowError e -> E.throwError e + ThrowErrorWith display e -> E.throwErrorWith display e CatchError m h -> localSeqUnlift env $ \unlift -> do E.catchError (unlift m) (\cs -> unlift . h cs) @@ -81,13 +84,36 @@ runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case Left e -> handler e Right a -> pure a --- | Throw an error of type @e@. +-- | Throw an error of type @e@ along with a display function in case a +-- third-party code catches the internal exception and 'show's it. +-- +-- @since 2.4.0.0 +throwErrorWith + :: (HasCallStack, Error e :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display = withFrozenCallStack send . ThrowErrorWith display + +-- | Throw an error of type @e@ with 'show' as a display function. throwError + :: (HasCallStack, Error e :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = throwErrorWith show + +-- | Throw an error of type @e@ with no display function. +-- +-- @since 2.4.0.0 +throwError_ :: (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a -throwError e = withFrozenCallStack $ send (ThrowError e) +throwError_ = throwErrorWith (const "") -- | Handle an error of type @e@. catchError diff --git a/effectful-core/src/Effectful/Error/Static.hs b/effectful-core/src/Effectful/Error/Static.hs index f73aacff..cab09451 100644 --- a/effectful-core/src/Effectful/Error/Static.hs +++ b/effectful-core/src/Effectful/Error/Static.hs @@ -86,7 +86,9 @@ module Effectful.Error.Static , runErrorNoCallStackWith -- ** Operations + , throwErrorWith , throwError + , throwError_ , catchError , handleError , tryError @@ -161,15 +163,38 @@ runErrorNoCallStackWith handler m = runErrorNoCallStack m >>= \case Left e -> handler e Right a -> pure a --- | Throw an error of type @e@. +-- | Throw an error of type @e@ along with a display function in case a +-- third-party code catches the internal exception and 'show's it. +-- +-- @since 2.4.0.0 +throwErrorWith + :: forall e es a. (HasCallStack, Error e :> es) + => (e -> String) + -- ^ The display function. + -> e + -- ^ The error. + -> Eff es a +throwErrorWith display e = unsafeEff $ \es -> do + Error eid <- getEnv @(Error e) es + throwIO $ ErrorWrapper eid callStack (display e) (toAny e) + +-- | Throw an error of type @e@ with 'show' as a display function. throwError + :: forall e es a. (HasCallStack, Error e :> es, Show e) + => e + -- ^ The error. + -> Eff es a +throwError = throwErrorWith show + +-- | Throw an error of type @e@ with no display function. +-- +-- @since 2.4.0.0 +throwError_ :: forall e es a. (HasCallStack, Error e :> es) => e -- ^ The error. -> Eff es a -throwError e = unsafeEff $ \es -> do - Error eid <- getEnv @(Error e) es - throwIO $ ErrorWrapper eid callStack (toAny e) +throwError_ = throwErrorWith (const "") -- | Handle an error of type @e@. catchError @@ -222,21 +247,25 @@ tryHandler -> IO r -> IO r tryHandler ex eid0 handler next = case fromException ex of - Just (ErrorWrapper eid cs e) + Just (ErrorWrapper eid cs _ e) | eid0 == eid -> pure $ handler cs (fromAny e) | otherwise -> next Nothing -> next -data ErrorWrapper = ErrorWrapper !ErrorId CallStack Any +data ErrorWrapper = ErrorWrapper !ErrorId CallStack String Any + instance Show ErrorWrapper where - showsPrec p (ErrorWrapper _ cs _) - = ("Effectful.Error.Static.ErrorWrapper\n\n" ++) - . showsPrec p (prettyCallStack cs) + showsPrec _ (ErrorWrapper _ cs errRep _) + = ("Effectful.Error.Static.ErrorWrapper: " ++) + . (errRep ++) + . ("\n" ++) + . (prettyCallStack cs ++) + instance Exception ErrorWrapper catchErrorIO :: ErrorId -> IO a -> (CallStack -> e -> IO a) -> IO a catchErrorIO eid m handler = do - m `catch` \err@(ErrorWrapper etag cs e) -> do + m `catch` \err@(ErrorWrapper etag cs _ e) -> do if eid == etag then handler cs (fromAny e) else throwIO err diff --git a/effectful-plugin/tests/PluginTests.hs b/effectful-plugin/tests/PluginTests.hs index 47c5aad9..435bb783 100644 --- a/effectful-plugin/tests/PluginTests.hs +++ b/effectful-plugin/tests/PluginTests.hs @@ -63,7 +63,7 @@ oStrState = put "hello" err :: Error e :> es => Eff es Bool err = catchError - (throwError (error "")) + (throwError_ (error "")) (\_ _ -> pure True) errState :: (Num s, Error e :> es, State s :> es) => Eff es Bool