[Guile-Lib PATCH 4/6] logging: Allow passing source properties to `log-msg'.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

Note: this changes the API of the `accept-log' method by adding a new
positional argument to it.  `accept-log' is a "weak" public
interface (mostly intended for internal uses or logging handler
implementors), so this is deemed acceptable.

* src/logging/logger.scm (log-helper) [source-properties]: New
positional argument, which is passed to `accept-log'.
* src/logging/logger.scm (log-msg): Update doc.  Add two new variants
that accept source properties.  Annotate more LVL arguments with their
type to ensure proper resolution.
(default-log-formatter) [source-properties]: New optional argument,
that is formatted as a source location prefix when available.
(accept-log): Update doc.  Add new source-properties argument, and
pass it to the log-formatter procedure.
* unit-tests/logging.logger.scm
(test-log-with-source-properties): New test.
* unit-tests/guile-library.api: Regenerate.

---

 src/logging/logger.scm        | 82 ++++++++++++++++++++++++-----------
 unit-tests/guile-library.api  |  6 ++-
 unit-tests/logging.logger.scm | 12 +++++
 3 files changed, 72 insertions(+), 28 deletions(-)

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 7ff4f43..982c44d 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -1,5 +1,6 @@
 ;; (logging logger) -- write methods to log files
-;; Copyright (C) 2003  Richard Todd
+;; Copyright (C) 2003 Richard Todd
+;; Copyright (C) 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 
 ;; This program is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -68,6 +69,7 @@ INFO and WARN-level logs don't get through.
 (use-modules (logging logger)
              (logging rotating-log)
              (logging port-log)
+
              (scheme documentation)
              (oop goops))
 
@@ -143,6 +145,7 @@ INFO and WARN-level logs don't get through.
             close-log!
             )
   #:use-module (oop goops)
+  #:use-module (ice-9 match)
   #:use-module (scheme documentation))
 
 ;;; ----------------------------------------------------------------------
@@ -216,17 +219,17 @@ Handlers can always be added later via @code{add-handler!} calls.
   (levels #:init-form (make-hash-table 17) #:getter levels)
   (log-handlers  #:init-value '() #:accessor handlers #:init-keyword #:handlers))
 
-(define (log-helper lgr level objs)
+(define (log-helper lgr level objs source-properties)
   ;; the level must be enabled in the logger to proceed...
   (if (level-enabled? lgr level)
       (let ((cur-time (current-time)))
         (for-each (lambda (str)                    
-                    (if (not (string-null? str))
-
-                        ;; pass the string to each log handler for lgr
-                        (for-each (lambda (handler)
-                                    (accept-log handler level cur-time str))
-                                  (handlers lgr))))
+                    (unless (string-null? str)
+                      ;; pass the string to each log handler for lgr
+                      (for-each (lambda (handler)
+                                  (accept-log handler level cur-time str
+                                              source-properties))
+                                (handlers lgr))))
 
                   ;; split the string at newlines into different log statements
                   (string-split 
@@ -234,15 +237,17 @@ Handlers can always be added later via @code{add-handler!} calls.
                    #\nl)))))
 
 (define-generic-with-docs log-msg
-"@code{log-msg [lgr] lvl arg1 arg2 ...}.  Send a log message
-made up of the @code{display}'ed representation of the given
-arguments.  The log is generated at level @var{lvl}, which should
-be a symbol.  If the @var{lvl} is disabled, the log message is
+"@code{log-msg [lgr] [source-properties] lvl arg1 arg2 ...}.  Send a
+log message made up of the @code{display}'ed representation of the
+given arguments.  The log is generated at level @var{lvl}, which
+should be a symbol.  If the @var{lvl} is disabled, the log message is
 not generated.  Generated log messages are sent through each of
 @var{lgr}'s handlers.
 
-If the @var{lgr} parameter is omitted, then the default logger
-is used, if one is set.
+If the @var{lgr} parameter is omitted, then the default logger is
+used, if one is set.  If the @var{source-properties} argument is
+provided, it should be a source property alist containing the
+filename, line and column keys.
 
 As the args are @code{display}'ed, a large string is built up.  Then,
 the string is split at newlines and sent through the log handlers as
@@ -262,17 +267,38 @@ timestamps to log statements.
 
 (define-method (log-msg (lvl <symbol>) . objs)
   (if default-logger
-      (log-helper default-logger lvl objs)))
+      (log-helper default-logger lvl objs #f)))
+
+(define-method (log-msg (source-properties <pair>) (lvl <symbol>) . objs)
+  (if default-logger
+      (log-helper default-logger lvl objs source-properties)))
+
+(define-method (log-msg (lgr <logger>) (lvl <symbol>) . objs)
+  (log-helper lgr lvl objs #f))
 
-(define-method (log-msg (lgr <logger>) lvl . objs)
-  (log-helper lgr lvl objs))
+(define-method (log-msg (lgr <logger>) (source-properties <pair>)
+                        (lvl <symbol>) . objs)
+  (log-helper lgr lvl objs source-properties))
 
 ;; the default formatter makes a log statement like:
 ;; 2003/12/29 14:53:02 (CRITICAL): The servers are melting!
-(define (default-log-formatter lvl time str)
+(define* (default-log-formatter lvl time str #:optional source-properties)
+  "Default log formatting procedure.  For source properties to be
+available, they must be manually provided to `log-msg' via a suitable
+syntactic wrapper (currently left to the user to implement)."
   (with-output-to-string
     (lambda ()
       (display (strftime "%F %H:%M:%S" (localtime time)))
+      (match source-properties
+        (#f #f)
+        ;; Note: increment the source property zero-indexed line by 1,
+        ;; to comply with the GNU Standards guidelines (info
+        ;; '(standards) Errors').
+        ((('line . line) ('column . column))
+         ;; The file name may be missing (e.g. when evaluating at the REPL).
+         (format #t " ~a:~a:" (1+ line) column))
+        ((('filename . file-name) ('line . line) ('column . column))
+         (format #t " ~a:~a:~a:" file-name (1+ line) column)))
       (display " (")
       (display (symbol->string lvl))
       (display "): ")
@@ -314,10 +340,13 @@ registered handlers.")
 
 (define-generic-with-docs accept-log
 "@code{accept-log handler lvl time str}.  If @var{lvl} is
-enabled for @var{handler}, then @var{str} will be formatted and
-sent to the log via the @code{emit-log} method.  Formatting is
-done via the formatting function given at @var{handler}'s
-creation time, or by the default if none was given.
+enabled for @var{handler}, then @var{str} will be formatted and sent
+to the log via the @code{emit-log} method.  @var{source-properties}
+can be either @code{#f} or an association list containing the file
+name, line, and column source information provided to the
+@code{log-msg} call.  Formatting is done via the formatting function
+given at @var{handler}'s creation time, or by the default if none was
+given.
 
 This method should not normally need to be overridden by subclasses.
 This method should not normally be called by users of the logging 
@@ -326,11 +355,12 @@ override this behavior.")
 
 ;; This can be overridden by log handlers if this default behaviour
 ;; is not desired..
-(define-method (accept-log (self <log-handler>) level time str)
-  (if (level-enabled? self level)
-      (emit-log self ((log-formatter self) level time str))))
+(define-method (accept-log (self <log-handler>) level time str
+                           source-properties)
+  (when (level-enabled? self level)
+    (emit-log self ((log-formatter self) level time str source-properties))))
 
-;; This should be overridden by all log handlers to actually 
+;; This should be overridden by all log handlers to actually
 ;; write out a string.
 (define-generic-with-docs emit-log
 "@code{emit-log handler str}.  This method should be implemented
diff --git a/unit-tests/guile-library.api b/unit-tests/guile-library.api
index b52dd41..6235d94 100644
--- a/unit-tests/guile-library.api
+++ b/unit-tests/guile-library.api
@@ -90,7 +90,7 @@
      (<logger> class)
      (accept-log
        generic
-       (<log-handler> <top> <top> <top>))
+       (<log-handler> <top> <top> <top> <top>))
      (add-handler! generic (<logger> <log-handler>))
      (close-log!
        generic
@@ -114,7 +114,9 @@
        (<rotating-log>))
      (log-msg
        generic
-       (<logger> <top> . <top>)
+       (<logger> <pair> <symbol> . <top>)
+       (<logger> <symbol> . <top>)
+       (<pair> <symbol> . <top>)
        (<symbol> . <top>))
      (lookup-logger procedure (arity 1 0 #f))
      (open-log!
diff --git a/unit-tests/logging.logger.scm b/unit-tests/logging.logger.scm
index f1084b8..d26587c 100644
--- a/unit-tests/logging.logger.scm
+++ b/unit-tests/logging.logger.scm
@@ -1,6 +1,7 @@
 ;;; ----------------------------------------------------------------------
 ;;;    unit test
 ;;;    Copyright (C) 2003 Richard Todd
+;;;    Copyright (C) 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;;    This program is free software; you can redistribute it and/or modify
 ;;;    it under the terms of the GNU General Public License as published by
@@ -52,6 +53,17 @@
     (assert-equal "(CRITICAL): Hello!\n"
                   ;; skip over the time/date, since that will vary!
                   (substring (get-output-string strport) 20))))
+
+(define-method  (test-log-with-source-properties (self <test-logging>))
+  (let* ((strport (open-output-string))
+         (lgr     (make <logger> #:handlers (list (make <port-log> #:port strport))))
+         (source-properties '((filename . "unit-tests/logging.logger.scm")
+                              (line . 62)
+                              (column . 4))))
+    (open-log! lgr)
+    (log-msg lgr source-properties 'ERROR "Hello!")
+    (string-contains (get-output-string strport)
+                     " unit-tests/logging.logger.scm:63:4: ")))
   
 (exit-with-summary (run-all-defined-test-cases))
 
-- 
2.41.0