[Guile-Lib PATCH v4 0/7] Make log-msg accept source properties for displaying source location

[Guile-Lib PATCH v4 0/7] Make log-msg accept source properties for displaying source location

[Maxim Cournoyer]

The main change of this series is adding the ability to pass source
properties (such as can be obtained via syntax-source in macros, for
example [0]) to the `log-msg' call, and have the default log formatter
use it to display the source location of the corresponding call.  The
procedure name where the log-msg call was made is also resolved and
made available to the log formatter.

It also fixes a few minor issues spotted while working with the
source, and calls `flush-log' at the end of `accept-log' to avoid
long delays caused by the default block buffering when the log traffic
is low.

[0]  https://issues.guix.gnu.org/68946

Changes in v4:
 - Reword commit messages per David's preference
 - log-helper's source-properties argument is now a keyword argument
 - original accept-log method restored (on top of new one)

Changes in v3:
 - Use (ice-9 format) for the default-log-formatter
 - Use a keyword argument for the source-properties
 - Add proc-name argument to default-log-formatter

Changes in v2:
 - Relax log-msg typing on source-properties, as it can also be #f

Maxim Cournoyer (7):
  configure.ac: Fix typo in message.
  Use /bin/sh in update-api script shebang.
  tests: guile-library.api: Re-generate.
  logging: Allow passing source properties to `log-msg'.
  logging: Adjust default log-formatter output.
  logging: Make procedure name available to the log formatter.
  logging: Call flush-log at the end of accept-log.

 configure.ac                  |   2 +-
 src/logging/logger.scm        | 109 ++++++++++-----
 unit-tests/guile-library.api  | 247 ++--------------------------------
 unit-tests/logging.logger.scm |  18 ++-
 unit-tests/update-api         |   2 +-
 5 files changed, 103 insertions(+), 275 deletions(-)


base-commit: 8d0196230f80afcf4da33917fe8ae390a1560931
-- 
2.41.0

[Guile-Lib PATCH v4 1/7] configure.ac: Fix typo in message.

[Maxim Cournoyer]

---

(no changes since v1)

 configure.ac | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/configure.ac b/configure.ac
index 7171296..e8f1bba 100644
--- a/configure.ac
+++ b/configure.ac
@@ -39,7 +39,7 @@ dnl distcheck' are aware it is a wip version.
 AC_INIT(
   [guile-lib],
   [0.2.7],
-  [guile-devel at gnu dor org])
+  [guile-devel at gnu dot org])
 
 AC_CONFIG_AUX_DIR([build-aux])
 AC_CONFIG_MACRO_DIR([m4])
-- 
2.41.0

[Guile-Lib PATCH v4 2/7] Use /bin/sh in update-api script shebang.

[Maxim Cournoyer]

* unit-tests/update-api: Replace /bin/bash with /bin/sh.
---

(no changes since v1)

 unit-tests/update-api | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/unit-tests/update-api b/unit-tests/update-api
index 8824c3f..392ce8b 100755
--- a/unit-tests/update-api
+++ b/unit-tests/update-api
@@ -1,4 +1,4 @@
-#!/bin/bash
+#!/bin/sh
 # -*- scheme -*-
 exec guile --debug -e main -s "$0" "$@"
 !#
-- 
2.41.0

[Guile-Lib PATCH v4 3/7] tests: guile-library.api: Re-generate.

[Maxim Cournoyer]

  The file was regenerated by running 'make -C unit-tests
  guile-library.api.update'.

* unit-tests/guile-library.api: Regenerate.
---

(no changes since v1)

 unit-tests/guile-library.api | 239 +----------------------------------
 1 file changed, 5 insertions(+), 234 deletions(-)

diff --git a/unit-tests/guile-library.api b/unit-tests/guile-library.api
index d0bdfe3..b52dd41 100644
--- a/unit-tests/guile-library.api
+++ b/unit-tests/guile-library.api
@@ -50,6 +50,9 @@
   ((htmlprag)
    (uses-interfaces)
    (typed-exports
+     (%default-parent-constraints <pair>)
+     (%parent-constraints procedure (arity 0 0 #f))
+     (%strict-tokenizer? procedure (arity 0 0 #f))
      (html->shtml procedure (arity 1 0 #f))
      (html->sxml procedure (arity 1 0 #f))
      (html->sxml-0nf procedure (arity 1 0 #f))
@@ -192,66 +195,6 @@
        (arity 2 2 #f))
      (breadth-first-search procedure (arity 3 0 #f))
      (depth-first-search procedure (arity 3 0 #f))))
-  ((statprof)
-   (uses-interfaces)
-   (typed-exports
-     (statprof-accumulated-time
-       procedure
-       (arity 0 0 #f))
-     (statprof-active? procedure (arity 0 0 #f))
-     (statprof-call-data->stats
-       procedure
-       (arity 1 0 #f))
-     (statprof-call-data-calls
-       procedure
-       (arity 1 0 #f))
-     (statprof-call-data-cum-samples
-       procedure
-       (arity 1 0 #f))
-     (statprof-call-data-name
-       procedure
-       (arity 1 0 #f))
-     (statprof-call-data-self-samples
-       procedure
-       (arity 1 0 #f))
-     (statprof-display procedure (arity 0 0 #t))
-     (statprof-display-anomolies
-       procedure
-       (arity 0 0 #f))
-     (statprof-fetch-call-tree
-       procedure
-       (arity 0 0 #f))
-     (statprof-fetch-stacks procedure (arity 0 0 #f))
-     (statprof-fold-call-data
-       procedure
-       (arity 2 0 #f))
-     (statprof-proc-call-data
-       procedure
-       (arity 1 0 #f))
-     (statprof-reset procedure (arity 3 0 #t))
-     (statprof-sample-count procedure (arity 0 0 #f))
-     (statprof-start procedure (arity 0 0 #f))
-     (statprof-stats-%-time-in-proc
-       procedure
-       (arity 1 0 #f))
-     (statprof-stats-calls procedure (arity 1 0 #f))
-     (statprof-stats-cum-secs-in-proc
-       procedure
-       (arity 1 0 #f))
-     (statprof-stats-cum-secs-per-call
-       procedure
-       (arity 1 0 #f))
-     (statprof-stats-proc-name
-       procedure
-       (arity 1 0 #f))
-     (statprof-stats-self-secs-in-proc
-       procedure
-       (arity 1 0 #f))
-     (statprof-stats-self-secs-per-call
-       procedure
-       (arity 1 0 #f))
-     (statprof-stop procedure (arity 0 0 #f))
-     (with-statprof macro)))
   ((string completion)
    (uses-interfaces)
    (typed-exports
@@ -290,185 +233,11 @@
        generic
        (<text-wrapper> <top>)
        (<top> . <top>))))
-  ((sxml apply-templates)
-   (uses-interfaces)
-   (typed-exports
-     (apply-templates procedure (arity 2 0 #f))))
-  ((sxml fold)
-   (uses-interfaces)
-   (typed-exports
-     (fold procedure (arity 3 0 #f))
-     (fold-layout procedure (arity 5 0 #f))
-     (fold-values procedure (arity 2 0 #t))
-     (foldt procedure (arity 3 0 #f))
-     (foldts procedure (arity 5 0 #f))
-     (foldts* procedure (arity 5 0 #f))
-     (foldts*-values procedure (arity 4 0 #t))))
-  ((sxml simple)
-   (uses-interfaces)
-   (typed-exports
-     (sxml->string procedure (arity 1 0 #f))
-     (sxml->xml procedure (arity 1 1 #f))
-     (universal-sxslt-rules <pair>)
-     (xml->sxml procedure (arity 0 1 #f))))
-  ((sxml ssax)
-   (uses-interfaces)
-   (typed-exports
-     (attlist->alist procedure (arity 1 0 #f))
-     (attlist-add procedure (arity 2 0 #f))
-     (attlist-fold procedure (arity 3 0 #f))
-     (attlist-null? procedure (arity 1 0 #f))
-     (attlist-remove-top procedure (arity 1 0 #f))
-     (make-empty-attlist procedure (arity 0 0 #f))
-     (ssax:complete-start-tag
-       procedure
-       (arity 5 0 #f))
-     (ssax:make-elem-parser macro)
-     (ssax:make-parser macro)
-     (ssax:make-pi-parser macro)
-     (ssax:read-attributes procedure (arity 2 0 #f))
-     (ssax:read-cdata-body procedure (arity 3 0 #f))
-     (ssax:read-char-data procedure (arity 4 0 #f))
-     (ssax:read-char-ref procedure (arity 1 0 #f))
-     (ssax:read-external-id procedure (arity 1 0 #f))
-     (ssax:read-markup-token procedure (arity 1 0 #f))
-     (ssax:read-pi-body-as-string
-       procedure
-       (arity 1 0 #f))
-     (ssax:reverse-collect-str-drop-ws
-       procedure
-       (arity 1 0 #f))
-     (ssax:skip-internal-dtd procedure (arity 1 0 #f))
-     (ssax:uri-string->symbol
-       procedure
-       (arity 1 0 #f))
-     (ssax:xml->sxml procedure (arity 2 0 #f))
-     (xml-token-head macro)
-     (xml-token-kind macro)
-     (xml-token? procedure (arity 1 0 #f))))
-  ((sxml ssax input-parse)
-   (uses-interfaces)
-   (typed-exports
-     (assert-curr-char procedure (arity 2 1 #f))
-     (next-token procedure (arity 2 2 #f))
-     (next-token-of procedure (arity 1 1 #f))
-     (peek-next-char procedure (arity 0 1 #f))
-     (read-string procedure (arity 1 1 #f))
-     (read-text-line procedure (arity 0 1 #f))
-     (skip-until procedure (arity 1 1 #f))
-     (skip-while procedure (arity 1 1 #f))))
-  ((sxml transform)
-   (uses-interfaces)
-   (typed-exports
-     (SRV:send-reply procedure (arity 0 0 #t))
-     (foldts procedure (arity 5 0 #f))
-     (post-order procedure (arity 2 0 #f))
-     (pre-post-order procedure (arity 2 0 #f))
-     (replace-range procedure (arity 3 0 #f))))
-  ((sxml xpath)
-   (uses-interfaces)
-   (typed-exports
-     (filter procedure (arity 1 0 #f))
-     (map-union procedure (arity 2 0 #f))
-     (node-closure procedure (arity 1 0 #f))
-     (node-eq? procedure (arity 1 0 #f))
-     (node-equal? procedure (arity 1 0 #f))
-     (node-join procedure (arity 0 0 #t))
-     (node-or procedure (arity 0 0 #t))
-     (node-parent procedure (arity 1 0 #f))
-     (node-pos procedure (arity 1 0 #f))
-     (node-reduce procedure (arity 0 0 #t))
-     (node-reverse procedure (arity 1 0 #f))
-     (node-self procedure (arity 1 0 #f))
-     (node-trace procedure (arity 1 0 #f))
-     (node-typeof? procedure (arity 1 0 #f))
-     (nodeset? procedure (arity 1 0 #f))
-     (select-kids procedure (arity 1 0 #f))
-     (sxpath procedure (arity 1 0 #f))
-     (take-after procedure (arity 1 0 #f))
-     (take-until procedure (arity 1 0 #f))))
   ((term ansi-color)
    (uses-interfaces)
    (typed-exports
      (color procedure (arity 0 0 #t))
      (colorize-string procedure (arity 1 0 #t))))
-  ((texinfo)
-   (uses-interfaces)
-   (typed-exports
-     (call-with-file-and-dir procedure (arity 2 0 #f))
-     (stexi->sxml procedure (arity 1 0 #f))
-     (texi->stexi procedure (arity 1 0 #f))
-     (texi-command-depth procedure (arity 2 0 #f))
-     (texi-command-specs <pair>)
-     (texi-fragment->stexi procedure (arity 1 0 #f))))
-  ((texinfo docbook)
-   (uses-interfaces)
-   (typed-exports
-     (*sdocbook->stexi-rules* <pair>)
-     (*sdocbook-block-commands* <pair>)
-     (filter-empty-elements procedure (arity 1 0 #f))
-     (replace-titles procedure (arity 1 0 #f))
-     (sdocbook-flatten procedure (arity 1 0 #f))))
-  ((texinfo html)
-   (uses-interfaces)
-   (typed-exports
-     (add-ref-resolver! procedure (arity 1 0 #f))
-     (stexi->shtml procedure (arity 1 0 #f))
-     (urlify procedure (arity 1 0 #f))))
-  ((texinfo indexing)
-   (uses-interfaces)
-   (typed-exports
-     (stexi-extract-index procedure (arity 3 0 #f))))
-  ((texinfo nodal-tree)
-   (uses-interfaces)
-   (typed-exports
-     (stexi->nodal-tree procedure (arity 0 0 #t))))
-  ((texinfo plain-text)
-   (uses-interfaces)
-   (typed-exports
-     (stexi->plain-text procedure (arity 1 0 #f))))
-  ((texinfo reflection)
-   (uses-interfaces)
-   (typed-exports
-     (module-stexi-documentation
-       procedure
-       (arity 0 0 #t))
-     (object-stexi-documentation
-       procedure
-       (arity 0 0 #t))
-     (package-stexi-documentation
-       procedure
-       (arity 0 0 #t))
-     (package-stexi-extended-menu
-       procedure
-       (arity 4 0 #f))
-     (package-stexi-generic-menu
-       procedure
-       (arity 2 0 #f))
-     (package-stexi-standard-copying
-       procedure
-       (arity 6 0 #f))
-     (package-stexi-standard-menu
-       procedure
-       (arity 4 0 #f))
-     (package-stexi-standard-prologue
-       procedure
-       (arity 7 0 #f))
-     (package-stexi-standard-titlepage
-       procedure
-       (arity 4 0 #f))
-     (script-stexi-documentation
-       procedure
-       (arity 1 0 #f))))
-  ((texinfo serialize)
-   (uses-interfaces)
-   (typed-exports
-     (stexi->texi procedure (arity 1 0 #f))))
-  ((text parse-lalr)
-   (uses-interfaces)
-   (typed-exports
-     (lalr-parser macro)
-     (print-states procedure (arity 0 0 #f))))
   ((unit-test)
    (uses-interfaces)
    (typed-exports
@@ -478,8 +247,10 @@
      (add generic
           (<test-suite> <test-case>)
           (<test-suite> <test-suite>))
+     (assert macro)
      (assert-equal procedure (arity 2 0 #f))
      (assert-exception macro)
+     (assert-false procedure (arity 1 0 #f))
      (assert-numeric-= procedure (arity 3 0 #f))
      (assert-true procedure (arity 1 0 #f))
      (exit-with-summary procedure (arity 1 0 #f))
-- 
2.41.0

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

[Maxim Cournoyer]

* src/logging/logger.scm (log-helper) [source-properties]: New
  positional argument, which is passed to `accept-log'.

  (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 keyword argument,
  that is formatted as a source location prefix when available.  Add
   #:allow-other-keys to signal users they should use such a signature
  to ensure forward compatibility.

  (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.

---

Changes in v4:
 - Reword commit messages per David's preference
 - log-helper's source-properties argument is now a keyword argument
 - original accept-log method restored (on top of new one)

Changes in v3:
 - Use (ice-9 format) for the default-log-formatter
 - Use a keyword argument for the source-properties
 - Add proc-name argument to default-log-formatter

Changes in v2:
 - Relax log-msg typing on source-properties, as it can also be #f

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

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 7ff4f43..e53661d 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 format)
   #: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 #:key 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
@@ -264,20 +269,39 @@ timestamps to log statements.
   (if default-logger
       (log-helper default-logger lvl objs)))
 
-(define-method (log-msg (lgr <logger>) lvl . objs)
+(define-method (log-msg source-properties (lvl <symbol>) . objs)
+  (if default-logger
+      (log-helper default-logger lvl objs
+                  #:source-properties source-properties)))
+
+(define-method (log-msg (lgr <logger>) (lvl <symbol>) . objs)
   (log-helper lgr lvl objs))
 
+(define-method (log-msg (lgr <logger>) source-properties
+                        (lvl <symbol>) . objs)
+  (log-helper lgr lvl objs
+              #:source-properties 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)
-  (with-output-to-string
-    (lambda ()
-      (display (strftime "%F %H:%M:%S" (localtime time)))
-      (display " (")
-      (display (symbol->string lvl))
-      (display "): ")
-      (display str)
-      (newline))))
+(define* (default-log-formatter lvl time str
+           #:key source-properties
+           #:allow-other-keys)
+  "Default log formatting procedure.  For source properties to be
+available, they must be manually provided to @code{log-msg} via a
+suitable syntax wrapper (currently left to the user to implement)."
+  (let ((file-name (assoc-ref source-properties 'filename))
+        ;; Note: increment the source property zero-indexed line by 1,
+        ;; to comply with the GNU Standards guidelines (info
+        ;; '(standards) Errors').
+        (line      (and=> (assoc-ref source-properties 'line) 1+))
+        (column    (assoc-ref source-properties 'column)))
+    (format #f "~a ~@[~a ~](~a): ~a~%"
+            (strftime "%F %H:%M:%S" (localtime time))
+            (and (or file-name line column)
+                (format #f "~@[~a:~]~@[~a:~]~@[~a:~]" file-name line column))
+            lvl
+            str)))
 
 (define-class-with-docs <log-handler> ()
 "This is the base class for all of the log handlers, and encompasses
@@ -314,10 +338,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} is
+optional; it 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 
@@ -327,10 +354,17 @@ 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))))
+  ;; Legacy variant without source-properties argument.
+  (when (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 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..594a1ab 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,8 +114,10 @@
        (<rotating-log>))
      (log-msg
        generic
-       (<logger> <top> . <top>)
-       (<symbol> . <top>))
+       (<logger> <symbol> . <top>)
+       (<logger> <top> <symbol> . <top>)
+       (<symbol> . <top>)
+       (<top> <symbol> . <top>))
      (lookup-logger procedure (arity 1 0 #f))
      (open-log!
        generic
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

[Guile-Lib PATCH v4 5/7] logging: Adjust default log-formatter output.

[Maxim Cournoyer]

  The log level is always in uppercase, and its surrounding parentheses
  are dropped.

* src/logging/logger.scm (default-log-formatter): Uppercase level and
  strip its surrounding parens.

* unit-tests/logging.logger.scm: Adjust expected output accordingly.
---

(no changes since v1)

 src/logging/logger.scm        | 2 +-
 unit-tests/logging.logger.scm | 6 +++---
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index e53661d..6a5b824 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -296,7 +296,7 @@ suitable syntax wrapper (currently left to the user to implement)."
         ;; '(standards) Errors').
         (line      (and=> (assoc-ref source-properties 'line) 1+))
         (column    (assoc-ref source-properties 'column)))
-    (format #f "~a ~@[~a ~](~a): ~a~%"
+    (format #f "~a ~@[~a ~]~:@(~a~): ~a~%"
             (strftime "%F %H:%M:%S" (localtime time))
             (and (or file-name line column)
                 (format #f "~@[~a:~]~@[~a:~]~@[~a:~]" file-name line column))
diff --git a/unit-tests/logging.logger.scm b/unit-tests/logging.logger.scm
index d26587c..2093bf2 100644
--- a/unit-tests/logging.logger.scm
+++ b/unit-tests/logging.logger.scm
@@ -30,7 +30,7 @@
          (lgr     (make <logger> #:handlers (list (make <port-log> #:port strport)))))
     (open-log! lgr)
     (log-msg lgr 'CRITICAL "Hello!")
-    (assert-equal "(CRITICAL): Hello!\n"
+    (assert-equal "CRITICAL: Hello!\n"
                   ;; skip over the time/date, since that will vary!
                   (substring (get-output-string strport) 20))))
 
@@ -41,7 +41,7 @@
     (set-default-logger! lgr)
     (log-msg 'CRITICAL "Hello!")
     (set-default-logger! #f)
-    (assert-equal "(CRITICAL): Hello!\n"
+    (assert-equal "CRITICAL: Hello!\n"
                   ;; skip over the time/date, since that will vary!
                   (substring (get-output-string strport) 20))))
 
@@ -50,7 +50,7 @@
          (lgr     (make <logger> #:handlers (list (make <port-log> #:port strport)))))
     (register-logger! "main" lgr)
     (log-msg (lookup-logger "main") 'CRITICAL "Hello!")
-    (assert-equal "(CRITICAL): Hello!\n"
+    (assert-equal "CRITICAL: Hello!\n"
                   ;; skip over the time/date, since that will vary!
                   (substring (get-output-string strport) 20))))
 
-- 
2.41.0

[Guile-Lib PATCH v4 6/7] logging: Make procedure name available to the log formatter.

[Maxim Cournoyer]

* src/logging/logger.scm (log-helper): Retrieve procedure name and
  pass it to `accept-log'.

  (default-log-formatter): Register new proc-name keyword argument, and
  include it in formatted message.

  (accept-log): New proc-name positional argument; pass it to
  log-formatter.

* unit-tests/guile-library.api: Regenerate.
---

(no changes since v1)

 src/logging/logger.scm       | 22 ++++++++++++++--------
 unit-tests/guile-library.api |  2 +-
 2 files changed, 15 insertions(+), 9 deletions(-)

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 6a5b824..b75d603 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -222,13 +222,14 @@ Handlers can always be added later via @code{add-handler!} calls.
 (define* (log-helper lgr level objs #:key source-properties)
   ;; the level must be enabled in the logger to proceed...
   (if (level-enabled? lgr level)
-      (let ((cur-time (current-time)))
+      (let ((cur-time (current-time))
+            (proc-name (frame-procedure-name (stack-ref (make-stack #t) 2))))
         (for-each (lambda (str)                    
                     (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))
+                                              source-properties proc-name))
                                 (handlers lgr))))
 
                   ;; split the string at newlines into different log statements
@@ -285,21 +286,25 @@ timestamps to log statements.
 ;; 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
-           #:key source-properties
+           #:key source-properties proc-name
            #:allow-other-keys)
   "Default log formatting procedure.  For source properties to be
 available, they must be manually provided to @code{log-msg} via a
-suitable syntax wrapper (currently left to the user to implement)."
+suitable syntax wrapper (currently left to the user to implement).
+@var{proc-name}, if available, is the name of the procedure the
+message was logged from."
   (let ((file-name (assoc-ref source-properties 'filename))
         ;; Note: increment the source property zero-indexed line by 1,
         ;; to comply with the GNU Standards guidelines (info
         ;; '(standards) Errors').
         (line      (and=> (assoc-ref source-properties 'line) 1+))
         (column    (assoc-ref source-properties 'column)))
-    (format #f "~a ~@[~a ~]~:@(~a~): ~a~%"
+    (format #f "~a ~@[~a ~]~@[(~a) ~]~:@(~a~): ~a~%"
             (strftime "%F %H:%M:%S" (localtime time))
             (and (or file-name line column)
-                (format #f "~@[~a:~]~@[~a:~]~@[~a:~]" file-name line column))
+                 (format #f "~@[~a:~]~@[~a:~]~@[~a:~]"
+                         file-name line column))
+            proc-name
             lvl
             str)))
 
@@ -359,10 +364,11 @@ override this behavior.")
     (emit-log self ((log-formatter self) level time str))))
 
 (define-method (accept-log (self <log-handler>) level time str
-                           source-properties)
+                           source-properties proc-name)
   (when (level-enabled? self level)
     (emit-log self ((log-formatter self) level time str
-                    #:source-properties source-properties))))
+                    #:source-properties source-properties
+                    #:proc-name proc-name))))
 
 ;; This should be overridden by all log handlers to actually
 ;; write out a string.
diff --git a/unit-tests/guile-library.api b/unit-tests/guile-library.api
index 594a1ab..e879b9d 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> <top>))
+       (<log-handler> <top> <top> <top> <top> <top>))
      (add-handler! generic (<logger> <log-handler>))
      (close-log!
        generic
-- 
2.41.0

[Guile-Lib PATCH v4 7/7] logging: Call flush-log at the end of accept-log.

[Maxim Cournoyer]

  This is to avoid long block buffering of log messages, which would
  causes the log messages to be delayed, which is likely to confuse
  users attempting to follow the logs in real time (see:
  https://lists.gnu.org/archive/html/guile-devel/2024-01/msg00000.html).

* src/logging/logger.scm (accept-log): Call flush-log after a log is
  emitted.  Update doc.

---

(no changes since v1)

 src/logging/logger.scm | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index b75d603..eee33a5 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -344,7 +344,9 @@ 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.  @var{source-properties} is
+to the log via the @code{emit-log} method.  @code{flush-port} is
+called after emitting a log to ensure users tailing the source file
+can see new messages in real time.  @var{source-properties} is
 optional; it 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
@@ -368,7 +370,8 @@ override this behavior.")
   (when (level-enabled? self level)
     (emit-log self ((log-formatter self) level time str
                     #:source-properties source-properties
-                    #:proc-name proc-name))))
+                    #:proc-name proc-name))
+    (flush-log self)))
 
 ;; This should be overridden by all log handlers to actually
 ;; write out a string.
-- 
2.41.0