From 11c1d57eff3d74d300e4ff93b39166ede15ddfbb Mon Sep 17 00:00:00 2001
From: Andrzej Rybczak <andrzej@rybczak.net>
Date: Fri, 9 Aug 2024 14:04:35 +0200
Subject: [PATCH] Improve Show instance of Effectful.Error.Static.ErrorWrapper

For example, if a third-party library spawns worker threads and if a job throws,
it simply catches SomeException, logs it and retries the job later, as of today
internal exceptions representing errors of the `Error` effect wouldn't show any
info about the error, just the backtrace.

This fixes it at the cost of small API breakage.
---
 effectful-core/CHANGELOG.md                   |  7 +++
 effectful-core/src/Effectful/Error/Dynamic.hs | 34 +++++++++++--
 effectful-core/src/Effectful/Error/Static.hs  | 49 +++++++++++++++----
 effectful-core/src/Effectful/Labeled/Error.hs | 28 ++++++++++-
 effectful-plugin/tests/PluginTests.hs         |  2 +-
 5 files changed, 103 insertions(+), 17 deletions(-)

diff --git a/effectful-core/CHANGELOG.md b/effectful-core/CHANGELOG.md
index 7ac9468..57e9f58 100644
--- a/effectful-core/CHANGELOG.md
+++ b/effectful-core/CHANGELOG.md
@@ -6,8 +6,15 @@
 * Improve `Effectful.Labeled`, add `Effectful.Labeled.Error`,
   `Effectful.Labeled.Reader`, `Effectful.Labeled.State` and
   `Effectful.Labeled.Writer`.
+* Added `throwErrorWith` and `throwError_` to `Effectful.Error.Static` and
+  `Effectful.Error.Dynamic`.
 * **Breaking change**: `localSeqLend`, `localLend`, `localSeqBorrow` and
   `localBorrow` now take a list of effects instead of a single one.
+* **Breaking change**: `Effectful.Error.Static.throwError` now requires the
+  error type to have a `Show` constraint. If this is not the case for some of
+  your error types, use `throwError_` for them.
+* **Breaking change**: `ThrowError` operation from the dynamic version of the
+  `Error` effect was replaced with `ThrowErrorWith`.
 
 # effectful-core-2.3.1.0 (2024-06-07)
 * Drop support for GHC 8.8.
diff --git a/effectful-core/src/Effectful/Error/Dynamic.hs b/effectful-core/src/Effectful/Error/Dynamic.hs
index 69eb863..0e17e41 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@ and specify 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 = withFrozenCallStack 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_ = withFrozenCallStack throwErrorWith (const "<opaque>")
 
 -- | 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 c73158b..efe5402 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
@@ -162,15 +164,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@ and specify 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 = withFrozenCallStack 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_ = withFrozenCallStack throwErrorWith (const "<opaque>")
 
 -- | Handle an error of type @e@.
 catchError
@@ -223,21 +248,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-core/src/Effectful/Labeled/Error.hs b/effectful-core/src/Effectful/Labeled/Error.hs
index fef8114..b42d80c 100644
--- a/effectful-core/src/Effectful/Labeled/Error.hs
+++ b/effectful-core/src/Effectful/Labeled/Error.hs
@@ -13,7 +13,9 @@ module Effectful.Labeled.Error
   , runErrorNoCallStackWith
 
     -- ** Operations
+  , throwErrorWith
   , throwError
+  , throwError_
   , catchError
   , handleError
   , tryError
@@ -68,14 +70,36 @@ runErrorNoCallStackWith
   -> Eff es a
 runErrorNoCallStackWith = runLabeled @label . E.runErrorNoCallStackWith
 
--- | Throw an error of type @e@.
+-- | Throw an error of type @e@ and specify a display function in case a
+-- third-party code catches the internal exception and 'show's it.
+throwErrorWith
+  :: forall label e es a
+   . (HasCallStack, Labeled label (Error e) :> es)
+  => (e -> String)
+  -- ^ The display function.
+  -> e
+  -- ^ The error.
+  -> Eff es a
+throwErrorWith display =
+  withFrozenCallStack send . Labeled @label . ThrowErrorWith display
+
+-- | Throw an error of type @e@ with 'show' as a display function.
 throwError
+  :: forall label e es a
+   . (HasCallStack, Labeled label (Error e) :> es, Show e)
+  => e
+  -- ^ The error.
+  -> Eff es a
+throwError = withFrozenCallStack (throwErrorWith @label) show
+
+-- | Throw an error of type @e@ with no display function.
+throwError_
   :: forall label e es a
    . (HasCallStack, Labeled label (Error e) :> es)
   => e
   -- ^ The error.
   -> Eff es a
-throwError e = withFrozenCallStack $ send (Labeled @label $ ThrowError e)
+throwError_ = withFrozenCallStack (throwErrorWith @label) (const "<opaque>")
 
 -- | Handle an error of type @e@.
 catchError
diff --git a/effectful-plugin/tests/PluginTests.hs b/effectful-plugin/tests/PluginTests.hs
index 3a28bc0..7f46741 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