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

[Guile-Lib PATCH v2 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.

Changes in v2:
 - Relax log-msg typing on source-properties, as it can also be #f, for example
   when a file has not been byte compiled and syntax properties are unavailable

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  | 247 ++--------------------------------
 unit-tests/logging.logger.scm |  18 ++-
 unit-tests/update-api         |   2 +-
 5 files changed, 88 insertions(+), 271 deletions(-)


base-commit: 8d0196230f80afcf4da33917fe8ae390a1560931
-- 
2.41.0

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

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

---

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

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

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 7ff4f43..1e4f2e7 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 (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
+                        (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..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

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

[Maxim Cournoyer]

Hi,

Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:

> 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.
>
> ---
>
> Changes in v2:
>  - Relax log-msg typing on source-properties, as it can also be #f

[...]

Some extra thoughts on the v2 change described above:  perhaps instead
of dropping the class type from source-properties, it'd be
best to add two more define-method procedures, like so:

>  (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 (lvl <symbol>) . objs)
> +  (if default-logger
> +      (log-helper default-logger lvl objs source-properties)))

--8<---------------cut here---------------start------------->8---
(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 (source-properties <bool>) (lvl <symbol>) . objs)
  (if default-logger
      (log-helper default-logger lvl objs source-properties)))
--8<---------------cut here---------------end--------------->8---


As when using a syntactic wrapper for log-msg, source-properties would
typically be an alist, but may also be #f when running the code before
it was  byte compiled.

> +
> +(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
> +                        (lvl <symbol>) . objs)
> +  (log-helper lgr lvl objs source-properties))

Likewise here, we'd need:

--8<---------------cut here---------------start------------->8---
(define-method (log-msg (lgr <logger>) (source-properties <pair>)
                        (lvl <symbol>) . objs)
  (log-helper lgr lvl objs source-properties))

(define-method (log-msg (lgr <logger>) (source-properties <pair>)
                        (lvl <symbol>) . objs)
  (log-helper lgr lvl objs source-properties))
--8<---------------cut here---------------end--------------->8---


Is that too many methods though?  It seems the resolution mechanism is
probably fast enough to not matter.

Any thoughts?

-- 
Thanks,
Maxim

[Guile-Lib PATCH v2 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.
---

(no changes since v1)

 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 1e4f2e7..e57cd44 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 v2 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.

---

(no changes since v1)

 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 e57cd44..d61acf1 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

[Guile-Lib PATCH v3 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) 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.

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        | 107 ++++++++++-----
 unit-tests/guile-library.api  | 247 ++--------------------------------
 unit-tests/logging.logger.scm |  18 ++-
 unit-tests/update-api         |   2 +-
 5 files changed, 98 insertions(+), 278 deletions(-)


base-commit: 8d0196230f80afcf4da33917fe8ae390a1560931
-- 
2.41.0

[Guile-Lib PATCH v3 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 v3 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 v3 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 v3 4/7] 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 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 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        | 95 ++++++++++++++++++++++-------------
 unit-tests/guile-library.api  |  8 +--
 unit-tests/logging.logger.scm | 12 +++++
 3 files changed, 78 insertions(+), 37 deletions(-)

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 7ff4f43..7b32ffe 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 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,22 +267,39 @@ 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 (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
+                        (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)
-  (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 +336,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 +351,13 @@ 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 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 v3 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 7b32ffe..05850a9 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -294,7 +294,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 v3 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 05850a9..7085d26 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 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
@@ -283,21 +284,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)))
 
@@ -352,10 +357,11 @@ 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
-                           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 v3 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 | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

diff --git a/src/logging/logger.scm b/src/logging/logger.scm
index 7085d26..2384208 100644
--- a/src/logging/logger.scm
+++ b/src/logging/logger.scm
@@ -342,12 +342,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 
@@ -361,7 +362,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