From mboxrd@z Thu Jan  1 00:00:00 1970
Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail
From: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Newsgroups: gmane.lisp.guile.devel
Subject: [Guile-Lib PATCH 4/6] logging: Allow passing source properties to
 `log-msg'.
Date: Mon,  5 Feb 2024 14:40:34 -0500
Message-ID: <20240205194049.7757-5-maxim.cournoyer@gmail.com>
References: <20240205194049.7757-1-maxim.cournoyer@gmail.com>
Mime-Version: 1.0
Content-Transfer-Encoding: 8bit
Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214";
	logging-data="19834"; mail-complaints-to="usenet@ciao.gmane.io"
Cc: David Pirotte <david@altosw.be>,
 Maxim Cournoyer <maxim.cournoyer@gmail.com>
To: guile-devel@gnu.org
Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Mon Feb 05 20:41:55 2024
Return-path: <guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org>
Envelope-to: guile-devel@m.gmane-mx.org
Original-Received: from lists.gnu.org ([209.51.188.17])
	by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
	(Exim 4.92)
	(envelope-from <guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org>)
	id 1rX4qp-0004w4-EJ
	for guile-devel@m.gmane-mx.org; Mon, 05 Feb 2024 20:41:55 +0100
Original-Received: from localhost ([::1] helo=lists1p.gnu.org)
	by lists.gnu.org with esmtp (Exim 4.90_1)
	(envelope-from <guile-devel-bounces@gnu.org>)
	id 1rX4q7-0005sq-DU; Mon, 05 Feb 2024 14:41:11 -0500
Original-Received: from eggs.gnu.org ([2001:470:142:3::10])
 by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <maxim.cournoyer@gmail.com>)
 id 1rX4q5-0005sC-6F
 for guile-devel@gnu.org; Mon, 05 Feb 2024 14:41:09 -0500
Original-Received: from mail-qk1-x72e.google.com ([2607:f8b0:4864:20::72e])
 by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128)
 (Exim 4.90_1) (envelope-from <maxim.cournoyer@gmail.com>)
 id 1rX4q3-0003cY-2h
 for guile-devel@gnu.org; Mon, 05 Feb 2024 14:41:08 -0500
Original-Received: by mail-qk1-x72e.google.com with SMTP id
 af79cd13be357-7856cce021dso80316185a.1
 for <guile-devel@gnu.org>; Mon, 05 Feb 2024 11:41:06 -0800 (PST)
DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;
 d=gmail.com; s=20230601; t=1707162065; x=1707766865; darn=gnu.org;
 h=content-transfer-encoding:mime-version:references:in-reply-to
 :message-id:date:subject:cc:to:from:from:to:cc:subject:date
 :message-id:reply-to;
 bh=wGacpw+TG3wJ6dMBsDRmLF1gZ8pKOmZxAMTzmqjpxXQ=;
 b=N8vhPjcRf4IbIE1Mv0P6uc0H1KrxSEeZA0/2r8Me1w1bEKrErnEbzlDmS5dJ/ti9IE
 qgbbiPfQ7RPV+71+5WnxnXZwGa2JFe04U/TFl6qB/O3gXHJjJXsADNSt7ADRFtyuc4Vp
 xdp8diAkX911MuoOEo0yMEAdw3JcCp5o1a8FC5OkFb0NgUaJLsApUTJlmGxdPAmoVcJJ
 M2iXtq5foHwYex9iu9IY251Q41hj1hK+mJWButSF16J8hOq37tOqPOkYzL+3LvpcrpMh
 QyD59Sfo9RIRZSOLHnOma35o7+nEy9cy5jRqtNZVX903cPgZW3YrTbQ5c2ZjpdyB2uQA
 kb5w==
X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;
 d=1e100.net; s=20230601; t=1707162065; x=1707766865;
 h=content-transfer-encoding:mime-version:references:in-reply-to
 :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc
 :subject:date:message-id:reply-to;
 bh=wGacpw+TG3wJ6dMBsDRmLF1gZ8pKOmZxAMTzmqjpxXQ=;
 b=TibuHH/CuHaYbUHjFwaPlrdoihrmykEwuXSx4vvydW9Vtu6dzpSmmIGzn667bOxtPI
 GLT9w/dCKA9Ndhi5kE8POXsnT/XUqhXDdI4QZKQQ4BDWPusWUlWBxpKaOQdQo30xJ+by
 apRktwqFIcGY3SvuXl8OdE6LaQrV6kf9Xljudb2VdEpr4Iof+lTuUiwrNQQAyitdomkW
 CSikxrYgkmn2V0vrtUbbEKNYJ0dgDdIlDDfkIJ5RK57GNB40l3507NlWZBYNTVZ8b3HD
 o2acYWY3V5nOiCOfWAkxlef+n+z6YpcFJ1HSKkWaO3DfK7pnTdr8wdyzCeJdA1TGtL8P
 Pgrg==
X-Gm-Message-State: AOJu0YyhqeSD5MS/Z5nsxpvD1hqA4gP1Ra67AmsFlrC66xuUkpO/1avH
 Hf9n/LFX1FxBlbWOUSEHnVZfwe++np8v+oZTlJek70XU2kOi6tkgLzO/LwdE
X-Google-Smtp-Source: AGHT+IF712ZSrytVmXXB5n0yMTCUvSvqU1JCGR4MY1S1ZqetRQDPE91O9K66Z8GIXTnPKWvKZGkaMg==
X-Received: by 2002:a05:620a:3859:b0:783:e15d:6203 with SMTP id
 po25-20020a05620a385900b00783e15d6203mr378566qkn.78.1707162065598; 
 Mon, 05 Feb 2024 11:41:05 -0800 (PST)
X-Forwarded-Encrypted: i=0;
 AJvYcCUDphYGWZhfNntejXg81qhd7jJDufAo1Lff+nERf+QM57dncLZsHf+h5JKDY6vjzarjEcUWrTNiL+9I1li3HdqWLVM/ozeTVEpg
Original-Received: from localhost.localdomain (dsl-10-130-152.b2b2c.ca. [72.10.130.152])
 by smtp.gmail.com with ESMTPSA id
 a12-20020a05620a102c00b00783da2644besm217367qkk.136.2024.02.05.11.41.04
 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256);
 Mon, 05 Feb 2024 11:41:05 -0800 (PST)
X-Mailer: git-send-email 2.41.0
In-Reply-To: <20240205194049.7757-1-maxim.cournoyer@gmail.com>
Received-SPF: pass client-ip=2607:f8b0:4864:20::72e;
 envelope-from=maxim.cournoyer@gmail.com; helo=mail-qk1-x72e.google.com
X-Spam_score_int: -20
X-Spam_score: -2.1
X-Spam_bar: --
X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1,
 DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001,
 RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001,
 T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no
X-Spam_action: no action
X-BeenThere: guile-devel@gnu.org
X-Mailman-Version: 2.1.29
Precedence: list
List-Id: "Developers list for Guile,
 the GNU extensibility library" <guile-devel.gnu.org>
List-Unsubscribe: <https://lists.gnu.org/mailman/options/guile-devel>,
 <mailto:guile-devel-request@gnu.org?subject=unsubscribe>
List-Archive: <https://lists.gnu.org/archive/html/guile-devel>
List-Post: <mailto:guile-devel@gnu.org>
List-Help: <mailto:guile-devel-request@gnu.org?subject=help>
List-Subscribe: <https://lists.gnu.org/mailman/listinfo/guile-devel>,
 <mailto:guile-devel-request@gnu.org?subject=subscribe>
Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org
Original-Sender: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org
Xref: news.gmane.io gmane.lisp.guile.devel:22293
Archived-At: <http://permalink.gmane.org/gmane.lisp.guile.devel/22293>

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