better warnings with proper condition classes when logging encounteres an error

Author: s-fleck

R/Logger.R

@@ -276,9 +276,13 @@ Logger <- R6::R6Class(
               ){
                 get("append", envir = app)(event)
               }
-            }, error = get("handle_exception", envir = self))
-          }
+            }, error = function(e) {
+              e$appender <- app
+              get("handle_exception", envir = self)(e)
+            }
+          )
         }
+      }
 
         invisible(msg)
       },
@@ -916,11 +920,13 @@ LoggerGlue <- R6::R6Class(
               ){
                 get("append", envir = app)(event)
               }
-            },
-              error = get("handle_exception", envir = self)
-            )
-          }
+            }, error = function(e) {
+              e$appender <- app
+              get("handle_exception", envir = self)(e)
+            }
+          )
         }
+      }
         invisible(msg)
       },
         error = get("handle_exception", envir = self)

R/default_functions.R

@@ -14,8 +14,40 @@
 #' tryCatch(stop("an error has occurred"), error = default_exception_handler)
 #'
 default_exception_handler <- function(e){
-  warning(
-    "[", format(Sys.time(), format = "%Y-%m-%d %H:%M:%OS3"), "] ",
-    "An error occurred during logging: ", e, call. = FALSE
+  ts <- paste0("[", format(Sys.time(), format = "%Y-%m-%d %H:%M:%OS3"), "]")
+
+  if ("appender" %in% names(e)){
+    res <- appendingFailedWarning(
+      paste(ts, paste(class_fmt(e$appender, ignore = c("Filterable", "R6", "Appender")), "encountered an error:", e$message)),
+      error = e
+    )
+  } else {
+    res <- loggingFailedWarning(
+      paste(ts, "an error occurred during logging:", e$message),
+      error = e
+    )
+  }
+  warning(res)
+}
+
+
+
+appendingFailedWarning <- function(message, class = NULL, call = NULL, ...){
+  warning_condition(
+    message = message,
+    class = union(class, "appendingFailedWarning"),
+    call = call,
+    ...
+  )
+}
+
+
+
+loggingFailedWarning <- function(message, class = NULL, call = NULL, ...){
+  warning_condition(
+    message = message,
+    class = union(class, "loggingFailedWarning"),
+    call = call,
+    ...
   )
 }

R/utils.R

@@ -269,4 +269,14 @@ error <- function(message, class, call = NULL, ...) {
     list(message = message, call = call, ...)
   )
 }
+
+
+
+
+warning_condition <- function(message, class, call = NULL, ...) {
+  structure(
+    class = union(class, c("warning", "condition")),
+    list(message = message, call = call, ...)
+  )
+}
 # nocov end

man/LayoutJson.Rd

@@ -387,8 +387,8 @@ test_that("Logger$log() dispatches to all appenders, even if some throw an error
     file = AppenderFile$new(file = tf)
   ))
 
-  expect_warning(ln$info("test_normal"))
-  expect_warning(ln$info("test_glue"))
+  expect_warning(ln$info("test_normal"), class = "appendingFailedWarning")
+  expect_warning(ln$info("test_glue"), class = "appendingFailedWarning")
 
   expect_true(any(grepl("test_normal", readLines(tf))))
   expect_true(any(grepl("test_glue", readLines(tf))))