-;;;; -*-scheme-*-
+;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010,
+;;;; 2012, 2013, 2014 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 pretty-print)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (rnrs bytevectors)
#:export (pretty-print
truncated-print))
(define genwrite:newline-str (make-string 1 #\newline))
-(define (generic-write obj display? width per-line-prefix output)
+(define (generic-write
+ obj display? width max-expr-width per-line-prefix output)
(define (read-macro? l)
(define (length1? l) (and (pair? l) (null? (cdr l))))
(and col (output str) (+ col (string-length str))))
(define (wr obj col)
- (cond ((and (pair? obj)
- (read-macro? obj))
- (wr (read-macro-body obj)
- (out (read-macro-prefix obj) col)))
- (else
- (out (object->string obj (if display? display write)) col))))
+ (let loop ((obj obj)
+ (col col))
+ (match obj
+ (((or 'quote 'quasiquote 'unquote 'unquote-splicing) body)
+ (wr body (out (read-macro-prefix obj) col)))
+ ((head . (rest ...))
+ ;; A proper list: do our own list printing so as to catch read
+ ;; macros that appear in the middle of the list.
+ (let ((col (loop head (out "(" col))))
+ (out ")"
+ (fold (lambda (i col)
+ (loop i (out " " col)))
+ col rest))))
+ (_
+ (out (object->string obj (if display? display write)) col)))))
(define (pp obj col)
(if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
(let ((result '())
(left (min (+ (- (- width col) extra) 1) max-expr-width)))
- (generic-write obj display? #f ""
+ (generic-write obj display? #f max-expr-width ""
(lambda (str)
(set! result (cons str result))
(set! left (- left (string-length str)))
(define (pp-DO expr col extra)
(pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+ (define (pp-SYNTAX-CASE expr col extra)
+ (pp-general expr col extra #t pp-expr-list #f pp-expr))
+
; define formatting style (change these to suit your style)
(define indent-general 2)
(define max-call-head-width 5)
- (define max-expr-width 50)
-
(define (style head)
(case head
- ((lambda let* letrec define) pp-LAMBDA)
+ ((lambda lambda* let* letrec define define* define-public
+ define-syntax let-syntax letrec-syntax with-syntax)
+ pp-LAMBDA)
((if set!) pp-IF)
((cond) pp-COND)
((case) pp-CASE)
((let) pp-LET)
((begin) pp-BEGIN)
((do) pp-DO)
+ ((syntax-rules) pp-LAMBDA)
+ ((syntax-case) pp-SYNTAX-CASE)
(else #f)))
(pr obj col 0 pp-expr))
#:key
(port (or port* (current-output-port)))
(width 79)
+ (max-expr-width 50)
(display? #f)
(per-line-prefix ""))
"Pretty-print OBJ on PORT, which is a keyword argument defaulting to
port directly after OBJ, like (pretty-print OBJ PORT)."
(generic-write obj display?
(- width (string-length per-line-prefix))
+ max-expr-width
per-line-prefix
(lambda (s) (display s port) #t)))
+\f
;; `truncated-print' was written in 2009 by Andy Wingo, and is not from
;; genwrite.scm.
(define* (truncated-print x #:optional port*
(width 79)
(display? #f)
(breadth-first? #f))
- "Print @var{obj}, truncating the output, if necessary, to make it fit
+ "Print @var{x}, truncating the output, if necessary, to make it fit
into @var{width} characters. By default, @var{x} will be printed using
@code{write}, though that behavior can be overriden via the
@var{display?} keyword argument.
The default behaviour is to print depth-first, meaning that the entire
-remaining width will be available to each sub-expressoin of @var{x} --
+remaining width will be available to each sub-expression of @var{x} --
e.g., if @var{x} is a vector, each member of @var{x}. One can attempt to
\"ration\" the available width, trying to allocate it equally to each
sub-expression, via the @var{breadth-first?} keyword argument."
- (define (print-sequence x width len ref next)
- (let lp ((x x)
- (width width)
- (i 0))
- (if (> i 0)
- (display #\space))
- (cond
- ((= i len)) ; catches 0-length case
- ((= i (1- len))
- (print (ref x i) (if (zero? i) width (1- width))))
- ((<= width 4)
- (display "..."))
- (else
- (let ((str (with-output-to-string
- (lambda ()
- (print (ref x i)
- (if breadth-first?
- (max 1
- (1- (floor (/ width (- len i)))))
- (- width 4)))))))
- (display str)
- (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
-
- (define (print-tree x width)
- ;; width is >= the width of # . #, which is 5
- (let lp ((x x)
- (width width))
- (cond
- ((or (not (pair? x)) (<= width 4))
- (display ". ")
- (print x (- width 2)))
- (else
- ;; width >= 5
- (let ((str (with-output-to-string
- (lambda ()
- (print (car x)
- (if breadth-first?
- (floor (/ (- width 3) 2))
- (- width 4)))))))
- (display str)
- (display " ")
- (lp (cdr x) (- width 1 (string-length str))))))))
-
- (define (truncate-string str width)
- ;; width is < (string-length str)
- (let lp ((fixes '(("#<" . ">")
- ("#(" . ")")
- ("(" . ")")
- ("\"" . "\""))))
- (cond
- ((null? fixes)
- "#")
- ((and (string-prefix? (caar fixes) str)
- (string-suffix? (cdar fixes) str)
- (>= (string-length str)
- width
- (+ (string-length (caar fixes))
- (string-length (cdar fixes))
- 3)))
- (format #f "~a~a...~a"
- (caar fixes)
- (substring str (string-length (caar fixes))
- (- width (string-length (cdar fixes)) 3))
- (cdar fixes)))
- (else
- (lp (cdr fixes))))))
-
- (define (print x width)
- (cond
- ((<= width 0)
- (error "expected a positive width" width))
- ((list? x)
- (cond
- ((>= width 5)
- (display "(")
- (print-sequence x (- width 2) (length x) (lambda (x i) (car x)) cdr)
- (display ")"))
- (else
- (display "#"))))
- ((vector? x)
- (cond
- ((>= width 6)
- (display "#(")
- (print-sequence x (- width 3) (vector-length x) vector-ref identity)
- (display ")"))
- (else
- (display "#"))))
- ((uniform-vector? x)
- (cond
- ((>= width 9)
- (format #t "#~a(" (uniform-vector-element-type x))
- (print-sequence x (- width 6) (uniform-vector-length x)
- uniform-vector-ref identity)
- (display ")"))
- (else
- (display "#"))))
- ((pair? x)
+ (define ellipsis
+ ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
+ ;; on the encoding of PORT.
+ (let ((e "…"))
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p (port-encoding port))
+ (display e p)))))
+ (lambda (key . args)
+ "..."))))
+
+ (let ((ellipsis-width (string-length ellipsis)))
+
+ (define (print-sequence x width len ref next)
+ (let lp ((x x)
+ (width width)
+ (i 0))
+ (if (> i 0)
+ (display #\space))
+ (cond
+ ((= i len)) ; catches 0-length case
+ ((and (= i (1- len)) (or (zero? i) (> width 1)))
+ (print (ref x i) (if (zero? i) width (1- width))))
+ ((<= width (+ 1 ellipsis-width))
+ (display ellipsis))
+ (else
+ (let ((str (with-output-to-string
+ (lambda ()
+ (print (ref x i)
+ (if breadth-first?
+ (max 1
+ (1- (floor (/ width (- len i)))))
+ (- width (+ 1 ellipsis-width))))))))
+ (display str)
+ (lp (next x) (- width 1 (string-length str)) (1+ i)))))))
+
+ (define (print-tree x width)
+ ;; width is >= the width of # . #, which is 5
+ (let lp ((x x)
+ (width width))
+ (cond
+ ((or (not (pair? x)) (<= width 4))
+ (display ". ")
+ (print x (- width 2)))
+ (else
+ ;; width >= 5
+ (let ((str (with-output-to-string
+ (lambda ()
+ (print (car x)
+ (if breadth-first?
+ (floor (/ (- width 3) 2))
+ (- width 4)))))))
+ (display str)
+ (display " ")
+ (lp (cdr x) (- width 1 (string-length str))))))))
+
+ (define (truncate-string str width)
+ ;; width is < (string-length str)
+ (let lp ((fixes '(("#<" . ">")
+ ("#(" . ")")
+ ("(" . ")")
+ ("\"" . "\""))))
+ (cond
+ ((null? fixes)
+ "#")
+ ((and (string-prefix? (caar fixes) str)
+ (string-suffix? (cdar fixes) str)
+ (>= (string-length str)
+ width
+ (+ (string-length (caar fixes))
+ (string-length (cdar fixes))
+ ellipsis-width)))
+ (format #f "~a~a~a~a"
+ (caar fixes)
+ (substring str (string-length (caar fixes))
+ (- width (string-length (cdar fixes))
+ ellipsis-width))
+ ellipsis
+ (cdar fixes)))
+ (else
+ (lp (cdr fixes))))))
+
+ (define (print x width)
(cond
- ((>= width 7)
- (display "(")
- (print-tree x (- width 2))
- (display ")"))
+ ((<= width 0)
+ (error "expected a positive width" width))
+ ((list? x)
+ (cond
+ ((>= width (+ 2 ellipsis-width))
+ (display "(")
+ (print-sequence x (- width 2) (length x)
+ (lambda (x i) (car x)) cdr)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((vector? x)
+ (cond
+ ((>= width (+ 3 ellipsis-width))
+ (display "#(")
+ (print-sequence x (- width 3) (vector-length x)
+ vector-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((bytevector? x)
+ (cond
+ ((>= width 9)
+ (format #t "#~a(" (array-type x))
+ (print-sequence x (- width 6) (array-length x)
+ array-ref identity)
+ (display ")"))
+ (else
+ (display "#"))))
+ ((pair? x)
+ (cond
+ ((>= width (+ 4 ellipsis-width))
+ (display "(")
+ (print-tree x (- width 2))
+ (display ")"))
+ (else
+ (display "#"))))
(else
- (display "#"))))
- (else
- (let* ((str (with-output-to-string
- (lambda () (if display? (display x) (write x)))))
- (len (string-length str)))
- (display (if (<= (string-length str) width)
- str
- (truncate-string str width)))))))
-
- (with-output-to-port port
- (lambda ()
- (print x width))))
+ (let* ((str (with-output-to-string
+ (lambda () (if display? (display x) (write x)))))
+ (len (string-length str)))
+ (display (if (<= (string-length str) width)
+ str
+ (truncate-string str width)))))))
+
+ (with-output-to-port port
+ (lambda ()
+ (print x width)))))
HCoop / bpt / guile.git / blobdiff