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

[Guile-Lib PATCH 0/6] 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) to
the `log-msg' call, and have the default log formatter use it to
display the source location of the corresponding call.

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.


Maxim Cournoyer (6):
  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.
  logger: Call flush-log at the end of accept-log.

 configure.ac                  |   2 +-
 src/logging/logger.scm        |  90 +++++++++----
 unit-tests/guile-library.api  | 245 ++--------------------------------
 unit-tests/logging.logger.scm |  18 ++-
 unit-tests/update-api         |   2 +-
 5 files changed, 87 insertions(+), 270 deletions(-)


base-commit: 8d0196230f80afcf4da33917fe8ae390a1560931
-- 
2.41.0

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

[Maxim Cournoyer]

---

 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 2/6] Use /bin/sh in update-api script shebang.

[Maxim Cournoyer]

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

 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 3/6] 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.
---

 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 4/6] logging: Allow passing source properties to `log-msg'.

[Maxim Cournoyer]

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

[Guile-Lib PATCH 5/6] 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.
---

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

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 982c44d..5403531 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -299,9 +299,9 @@ syntactic wrapper (currently left to the user to implement)."
          (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 "): ")
+      (display " ")
+      (display (string-upcase (symbol->string lvl)))
+      (display ": ")
       (display str)
       (newline))))
 
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 6/6] logger: 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.

---

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

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 5403531..d9c3722 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -341,12 +341,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.  @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.
+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} 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 
@@ -358,7 +359,8 @@ override this behavior.")
 (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))))
+    (emit-log self ((log-formatter self) level time str source-properties))
+    (flush-log self)))
 
 ;; This should be overridden by all log handlers to actually
 ;; write out a string.
-- 
2.41.0