;;;; -*- coding: utf-8; mode: scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2004, 2006, 2009, 2010 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
(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))))
(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 max-call-head-width 5)
- (define max-expr-width 50)
-
(define (style head)
(case head
- ((lambda let* letrec define define-public
- define-syntax let-syntax letrec-syntax)
+ ((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)
#: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)))
\"ration\" the available width, trying to allocate it equally to each
sub-expression, via the @var{breadth-first?} keyword argument."
- ;; Make sure string ports are created with the right encoding.
- (with-fluids ((%default-port-encoding (port-encoding port)))
-
- (define ellipsis
- ;; Choose between `HORIZONTAL ELLIPSIS' (U+2026) and three dots, depending
- ;; on the encoding of PORT.
- (let ((e "…"))
- (catch 'encoding-error
- (lambda ()
- (with-output-to-string
- (lambda ()
- (display e))))
- (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-fluids ((%default-port-encoding (port-encoding port)))
- (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)
+ (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
- ((<= 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 "#"))))
- ((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)
- (cond
- ((>= width (+ 4 ellipsis-width))
- (display "(")
- (print-tree x (- width 2))
- (display ")"))
- (else
- (display "#"))))
+ ((= 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 () (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 ()
+ (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