-;;;; -*-scheme-*-
+;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006 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
;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 pretty-print)
- :use-module (ice-9 optargs)
- :export (pretty-print))
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (rnrs bytevectors)
+ #:export (pretty-print
+ truncated-print))
+
;; From SLIB.
(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))
(rev-string-append l 0))
-(define (pretty-print obj . opts)
+(define* (pretty-print obj #:optional port*
+ #: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
the current output port. Formatting can be controlled by a number of
keyword arguments: Each line in the output is preceded by the string
Instead of with a keyword argument, you can also specify the output
port directly after OBJ, like (pretty-print OBJ PORT)."
- (if (pair? opts)
- (if (keyword? (car opts))
- (apply pretty-print-with-keys obj opts)
- (apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
- (pretty-print-with-keys obj)))
-
-(define* (pretty-print-with-keys obj
- #:key
- (port (current-output-port))
- (width 79)
- (display? #f)
- (per-line-prefix ""))
(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*
+ #:key
+ (port (or port* (current-output-port)))
+ (width 79)
+ (display? #f)
+ (breadth-first? #f))
+ "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-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 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 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
+ (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