mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

pretty-print: inline some handling of read macros

Browse source 
* module/ice-9/pretty-print.scm (generic-write): Not really sure why
read macros are duplicated, but this is a refactor to use more match and
less cadr.
This commit is contained in:
Andy Wingo 2023-05-26 11:43:45 +02:00
parent ec3bf4e2ba
commit 03344ce431
1 changed files with 21 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

56
module/ice-9/pretty-print.scm
View file

@ -35,33 +35,18 @@
(define (generic-write (define (generic-write
obj display? width max-expr-width per-line-prefix output) obj display? width max-expr-width per-line-prefix output)
(define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l))))
(let ((head (car l)) (tail (cdr l)))
(case head
((quote quasiquote unquote unquote-splicing) (length1? tail))
(else #f))))
(define (read-macro-body l)
(cadr l))
(define (read-macro-prefix l)
(let ((head (car l)))
(case head
((quote) "'")
((quasiquote) "`")
((unquote) ",")
((unquote-splicing) ",@"))))
(define (out str col) (define (out str col)
(and col (output str) (+ col (string-length str)))) (and col (output str) (+ col (string-length str))))
(define (wr obj col) (define (wr obj col)
(let loop ((obj obj) (let loop ((obj obj)
(col col)) (col col))
(define (wr-read-macro prefix x) (wr x (out prefix col)))
(match obj (match obj
(((or 'quote 'quasiquote 'unquote 'unquote-splicing) body) (('quote x) (wr-read-macro "'" x))
(wr body (out (read-macro-prefix obj) col))) (('quasiquote x) (wr-read-macro "`" x))
(('unquote x) (wr-read-macro "," x))
(('unquote-splicing x) (wr-read-macro ",@" x))
((head . (rest ...)) ((head . (rest ...))
;; A proper list: do our own list printing so as to catch read ;; A proper list: do our own list printing so as to catch read
;; macros that appear in the middle of the list. ;; macros that appear in the middle of the list.
@ -107,21 +92,22 @@
(wr obj col))) (wr obj col)))
(define (pp-expr expr col extra) (define (pp-expr expr col extra)
(if (read-macro? expr) (define (pp-read-macro prefix x)
(pr (read-macro-body expr) (pr x (out prefix col) extra pp-expr))
(out (read-macro-prefix expr) col) (match expr
extra (('quote x) (pp-read-macro "'" x))
pp-expr) (('quasiquote x) (pp-read-macro "`" x))
(let ((head (car expr))) (('unquote x) (pp-read-macro "," x))
(if (symbol? head) (('unquote-splicing x) (pp-read-macro ",@" x))
(let ((proc (style head))) (((? symbol? head) . _)
(if proc (let ((proc (style head)))
(proc expr col extra) (if proc
(if (> (string-length (symbol->string head)) (proc expr col extra)
max-call-head-width) (if (> (string-length (symbol->string head))
(pp-general expr col extra #f #f #f pp-expr) max-call-head-width)
(pp-call expr col extra pp-expr)))) (pp-general expr col extra #f #f #f pp-expr)
(pp-list expr col extra pp-expr))))) (pp-call expr col extra pp-expr)))))
(_ (pp-list expr col extra pp-expr))))
; (head item1 ; (head item1
; item2 ; item2