[PATCH] pretty-print: add syntax and gexp expressions.

[Carlos Durán Domínguez]

* module/ice-9/pretty-print.scm (pretty-print): Add #:macro-expr-alist.
To accept other quoted-like expressions.
* module/ice-9/pretty-print.scm (default-macro-expr-alist): New variable.
Used by ‘pretty-print’ to write quote, syntax and g-expressions.
* doc/ref/misc-modules.texi (Pretty Printing): Add #:macro-expr-alist.
* doc/ref/misc-modules.texi (Pretty Printing): Add ‘default-macro-expr-alist’.
---
 doc/ref/misc-modules.texi     | 21 +++++++++++++++
 module/ice-9/pretty-print.scm | 48 +++++++++++++++++++++++------------
 2 files changed, 53 insertions(+), 16 deletions(-)

diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi
index a6999466c..1b8ff844c 100644
--- a/doc/ref/misc-modules.texi
+++ b/doc/ref/misc-modules.texi
@@ -58,9 +58,30 @@ Print within the given @var{columns}.  The default is 79.
 
 @item @nicode{#:max-expr-width} @var{columns}
 The maximum width of an expression.  The default is 50.
+
+@item @nicode{#:macro-expr-alist} @var{macro-expr-alist}
+The alist of “quoted macros”, whose keys are symbols (@code{quote},
+@code{unquote}, @code{unsyntax}, etc), and their values are the string
+representation of the symbol (@code{"'"}, @code{","}, @code{#,},
+etc). The default values is @code{default-macro-expr-alist}.
 @end table
 @end deffn
 
+@defvr {Scheme Variable} default-macro-expr-alist
+@lisp
+'((quote             . "'")
+  (quasiquote        . "`")
+  (unquote           . ",")
+  (unquote-splicing  . ",@@")
+  (syntax            . "#'")
+  (quasisyntax       . "#`")
+  (unsyntax          . "#,")
+  (unsyntax-splicing . "#,@@")
+  (gexp              . "#~")
+  (ungexp            . "#$")
+  (ungexp-splicing   . "#$@@"))
+@end lisp
+@end defvr
 
 @cindex truncated printing
 Also exported by the @code{(ice-9 pretty-print)} module is
diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm
index 4bc951ebf..aa2e5c541 100644
--- a/module/ice-9/pretty-print.scm
+++ b/module/ice-9/pretty-print.scm
@@ -53,6 +53,22 @@
      (failure (string-concatenate-reverse strs)))))
 
 
+
+
+(define default-macro-expr-alist
+  '((quote             . "'")
+    (quasiquote        . "`")
+    (unquote           . ",")
+    (unquote-splicing  . ",@")
+    (syntax            . "#'")
+    (quasisyntax       . "#`")
+    (unsyntax          . "#,")
+    (unsyntax-splicing . "#,@")
+    (gexp              . "#~")
+    (ungexp            . "#$")
+    (ungexp-splicing   . "#$@")))
+
+
 
 
 ;; Parts of pretty-print derived from "genwrite.scm", from SLIB.
@@ -66,25 +82,31 @@
                        (width 79)
                        (max-expr-width 50)
                        (display? #f)
-                       (per-line-prefix ""))
+                       (per-line-prefix "")
+                       (macro-expr-alist default-macro-expr-alist))
   "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
 the current output port.  Formatting can be controlled by a number of
 keyword arguments: Each line in the output is preceded by the string
 PER-LINE-PREFIX, which is empty by default.  The output lines will be
 at most WIDTH characters wide; the default is 79.  If DISPLAY? is
 true, display rather than write representation will be used.
+MACRO-EXPR-ALIST must be an alist whose key is the symbol associated
+with the macro and the value is their string representation, the
+default value is DEFAULT-MACRO-EXPR-ALIST.
 
 Instead of with a keyword argument, you can also specify the output
 port directly after OBJ, like (pretty-print OBJ PORT)."
+  (define macro-element?
+    (let ((macro-lst (map car macro-expr-alist)))
+      (lambda (x)
+        (any (lambda (elem) (equal? x elem)) macro-lst))))
   (define (wr obj port)
     (define (wr-read-macro prefix x)
       (put-string port prefix)
       (wr x port))
     (match obj
-      (('quote x)            (wr-read-macro "'" x))
-      (('quasiquote x)       (wr-read-macro "`" x))
-      (('unquote x)          (wr-read-macro "," x))
-      (('unquote-splicing x) (wr-read-macro ",@" x))
+      (((? macro-element? macro) x)
+       (wr-read-macro (assq-ref macro-expr-alist macro) x))
       ((head . (rest ...))
        ;; A proper list: do our own list printing so as to catch read
        ;; macros that appear in the middle of the list.
@@ -125,10 +147,9 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
        (pr (vector->list obj) pp-pair))
       ((not (? pair?))
        (wr obj port))
-      (('quote x)            (put-string port "'") (pr x pp-pair))
-      (('quasiquote x)       (put-string port "`") (pr x pp-pair))
-      (('unquote x)          (put-string port ",") (pr x pp-pair))
-      (('unquote-splicing x) (put-string port ",@") (pr x pp-pair))
+      (((? macro-element? macro) x)
+       (put-string port (assq-ref macro-expr-alist macro))
+       (pr x pp-pair))
       (_
        ;; A pair (and possibly a list).  May have to split on multiple
        ;; lines.
@@ -142,7 +163,7 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
 
   (define (pp-expr expr)
     (match expr
-      (((or 'quote 'quasiquote 'unquote 'unquote-splicing) _)
+      (((? macro-element?) _)
        (pp-quote expr))
       (('lambda _ _ . _)         (pp-lambda expr))
       (('lambda* _ _ . _)        (pp-lambda expr))
@@ -197,12 +218,7 @@ port directly after OBJ, like (pretty-print OBJ PORT)."
   (define (pp-quote expr)
     (match obj
       ((head x)
-       (put-string port
-                   (match x
-                     ('quote "'")
-                     ('quasiquote "`")
-                     ('unquote ",")
-                     ('unquote-splicing ",@")))
+       (put-string port (assq-ref macro-expr-alist x))
        (pr x pp-expr))))
 
   (define (pp-lambda expr)
-- 
Carlos Durán Domínguez
GPG key: https://wurtshell.com/wurt.gpg