Subject: exception printers - request for improvement

From: David Pirotte <[email-masked]>
Date: Wed, 13 Dec 2017 01:26:33 -0200

Hello,

	The attached patched is from Daniel Lloren, I'm just 'a messenger' (and added
	a comment in the source, preceding the new binding).

The proposed patch is to allow  exception printers user customization.

This has been very important, not to say vital, for those of us who manipulate large
structures, lists, arrays, sfri-4 bytevectors, ..., something we have been doing
locally ... but we need something for our users (aiscm, guile-cv ...), so they don't
have to patch guile locally... (most would be scared to do so and would not do it
anyway...).

Once applied, users can, for example, customize the raised exception system so it
uses truncated-print, either individually (in .guile), or guile admins can do
this globally (in share/guile-site/init.scm):

	(use-modules (ice-9 pretty-print))
                    
	(when (defined? 'exception-format)
	  (set! exception-format
	        (lambda (port fmt . args)
	          (for-each (lambda (arg)
	                      (truncated-print arg #:port port))
	              args))))

Maybe there is another/better approach, I don't know, but this works pretty well
for me...

Thanks,
David
From 772cc05b1fe481a43be4c17c90ed3788cf37d2a6 Mon Sep 17 00:00:00 2001
From: David Pirotte <[email-masked]>
Date: Wed, 13 Dec 2017 00:43:30 -0200
Subject: [PATCH 2/2] Allowing exception printers user customization

* module/ice-9/boot-9.scm (exception-format, dispatch-exception,
  exception-printers, scm-error-printer, syntax-error-printer,
  keyword-error-printer, getaddrinfo-error-printer, false-if-exception,
  make-record-type):  Instead of using 'format', let's define a specific
  format binding for exception printers, to allow its user
  customization.
---
 module/ice-9/boot-9.scm | 46 ++++++++++++++++++++++++++--------------------
 1 file changed, 26 insertions(+), 20 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 751a3bcd1..cbbedac15 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -326,6 +326,10 @@ If returning early, return the return value of F."
 
 (define format simple-format)
 
+;; instead of using the above, let's define a specific format binding
+;; for exception printers, to allow its user customization.
+(define exception-format simple-format)
+
 ;; this is scheme wrapping the C code so the final pred call is a tail call,
 ;; per SRFI-13 spec
 (define string-any
@@ -762,7 +766,7 @@ information is unavailable."
                        ((not (car args)) 1)
                        (else 0))))
      (else
-      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+      (exception-format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
               key args)
       (primitive-exit 1))))
 
@@ -865,8 +869,8 @@ for key @var{k}, then invoke @var{thunk}."
           (let ((filename (or (cadr source) "<unnamed port>"))
                 (line (caddr source))
                 (col (cdddr source)))
-            (format port "~a:~a:~a: " filename (1+ line) col))
-          (format port "ERROR: "))))
+            (exception-format port "~a:~a:~a: " filename (1+ line) col))
+          (exception-format port "ERROR: "))))
 
   (set! set-exception-printer!
         (lambda (key proc)
@@ -875,7 +879,7 @@ for key @var{k}, then invoke @var{thunk}."
   (set! print-exception
         (lambda (port frame key args)
           (define (default-printer)
-            (format port "Throw to key `~a' with args `~s'." key args))
+            (exception-format port "Throw to key `~a' with args `~s'." key args))
 
           (when frame
             (print-location frame port)
@@ -884,7 +888,7 @@ for key @var{k}, then invoke @var{thunk}."
                           (lambda () (frame-procedure-name frame))
                           (lambda _ #f))))
               (when name
-                (format port "In procedure ~a:\n" name))))
+                (exception-format port "In procedure ~a:\n" name))))
 
           (catch #t
             (lambda ()
@@ -893,7 +897,9 @@ for key @var{k}, then invoke @var{thunk}."
                     (printer port key args default-printer)
                     (default-printer))))
             (lambda (k . args)
-              (format port "Error while printing exception.")))
+              (exception-format
+               port "Error while printing exception `~a`: `~a' with args [~s]"
+               key k args)))
           (newline port)
           (force-output port))))
 
@@ -907,38 +913,38 @@ for key @var{k}, then invoke @var{thunk}."
     (apply (case-lambda
              ((subr msg args . rest)
               (if subr
-                  (format port "In procedure ~a: " subr))
-              (apply format port msg (or args '())))
+                  (exception-format port "In procedure ~a: " subr))
+              (apply exception-format port msg (or args '())))
              (_ (default-printer)))
            args))
 
   (define (syntax-error-printer port key args default-printer)
     (apply (case-lambda
              ((who what where form subform . extra)
-              (format port "Syntax error:\n")
+              (exception-format port "Syntax error:\n")
               (if where
                   (let ((file (or (assq-ref where 'filename) "unknown file"))
                         (line (and=> (assq-ref where 'line) 1+))
                         (col (assq-ref where 'column)))
-                    (format port "~a:~a:~a: " file line col))
-                  (format port "unknown location: "))
+                    (exception-format port "~a:~a:~a: " file line col))
+                  (exception-format port "unknown location: "))
               (if who
-                  (format port "~a: " who))
-              (format port "~a" what)
+                  (exception-format port "~a: " who))
+              (exception-format port "~a" what)
               (if subform
-                  (format port " in subform ~s of ~s" subform form)
+                  (exception-format port " in subform ~s of ~s" subform form)
                   (if form
-                      (format port " in form ~s" form))))
+                      (exception-format port " in form ~s" form))))
              (_ (default-printer)))
            args))
 
   (define (keyword-error-printer port key args default-printer)
     (let ((message (cadr args))
           (faulty  (car (cadddr args)))) ; I won't do it again, I promise.
-      (format port "~a: ~s" message faulty)))
+      (exception-format port "~a: ~s" message faulty)))
 
   (define (getaddrinfo-error-printer port key args default-printer)
-    (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
+    (exception-format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
 
   (set-exception-printer! 'goops-error scm-error-printer)
   (set-exception-printer! 'host-not-found scm-error-printer)
@@ -1066,11 +1072,11 @@ VALUE."
        (lambda (key . args)
          (for-each (lambda (s)
                      (if (not (string-null? s))
-                         (format (current-warning-port) ";;; ~a\n" s)))
+                         (exception-format (current-warning-port) ";;; ~a\n" s)))
                    (string-split
                     (call-with-output-string
                      (lambda (port)
-                       (format port template arg ...)
+                       (exception-format port template arg ...)
                        (print-exception port #f key args)))
                     #\newline))
          #f)))))
@@ -1229,7 +1235,7 @@ VALUE."
                 (if (= (length args) nfields)
                     (apply make-struct/no-tail rtd args)
                     (scm-error 'wrong-number-of-args
-                               (format #f "make-~a" type-name)
+                               (exception-format #f "make-~a" type-name)
                                "Wrong number of arguments" '() #f)))))))))
 
   (define (default-record-printer s p)
-- 
2.15.1