tools.scm

;;;;	A Very Tiny Pretty Printer (VtPP) for Mini-Scheme
;;;
;;;	Date written    28-Nov-1989 by Akira Kida
;;;     Date revised    24-Jan-1990 by Atsushi Moriwaki
;;;	Date revised	17-May-1994 by Akira Kida
;;;

;; Columns of display device.
(define *pp-display-width* 80)

;; Margin of display-width
;;  8 means 80% of *pp-display-width*, i.e., if *pp-display-width* is
;;  set to 80, the result is 64. The prety-print procedure will watch
;;  for the current output column, and if the output seem to exceed
;;  this limit, it tries to insert newlines somewhere in the current
;;  sub-list. However, sometimes this may fail, and output may get even
;;  longer than *pp-display-width*.  This is a feature, not a bug. :-)
(define *pp-display-margin* 8)

;; Number of elements will possibly be displayed in one line.
;; pretty-print will never display more then this number of elements
;; on a single physical line.  There is no feature around this. :-)
(define *pp-display-elements* 12)


;;; print n spaces
(define (spaces n)
  (if (positive? n)
    (begin
      (display " ")
      (spaces (- n 1)))))


;;; get definition of a procedure or a macro
(define (getd symbol)
  (if (not (symbol? symbol))
      (error "getd: expects symbol value"))
  (let ((code (eval symbol)))
    (cond
     ;; since a closure is also a macro, we should check macro first.
     ((macro? code)
	(let ((def (get-closure-code code)))
	  (cons 'macro (list symbol def))))
     ((closure? code)
	(let ((def (get-closure-code code)))
	  (cons
	   'define
	   (cons
	    (cons symbol (car (cdr def)))
	    (cdr (cdr def))))))
     (else
      ;; if symbol is not a macro nor closure, 
      ;; we shall generate error function call code.
      (list 'error "Not a S-Expression procedure:" (list 'quote symbol))))))


;;; pretty printer main procedure
;;;
(define (pretty-print a-list)
  ; List of procedures which need exceptional handling.
  ; Structure or each element in the list is
  ; 
  ;     (name . special-indentation)
  ;
  ;     where name is a symbol and
  ;     special-indentation is an integer.
  ;
  ; #1 Standard format, non special case.
  ;  (proc
  ;    arg1
  ;    arg2
  ;    arg3)
  ;
  ; #2 Format for special-indentation == 0
  ;  (proc arg1
  ;    arg2
  ;    arg3)
  ;
  ; #3 Format for special-indentation == 1
  ;  (proc arg1
  ;        arg2
  ;        arg3)
  ;
  ; #4 Format for let style = 2
  ;  (let ((x .....)
  ;        (y .....))
  ;    <....>
  ;    <....>)
  ;
  (define exception
    '((lambda . 0) (if . 0) (and . 1)
      (or . 1) (let . 2) (case . 0)
      (define . 0) (macro . 0)
      (map . 0) (apply . 0)
      (eq? . 1) (eqv? . 1) (set! . 0)
      (let* . 2) (letrec . 2)
      (* . 1) (/ . 1) (+ . 1) (- . 1)
      (= . 1) (< . 1) (> . 1) (<= . 1) (>= . 1)
      (do . 2)
      (call-with-input-file . 0) (call-with-output-file . 0)))
  ; special quote abbrev.
  (define special
    '((quote 1 . "'") (quasiquote 1 . "`")
      (unquote 2 . ",") (unquote-splicing 2 . ",@"))) 
  ; calculate appropriate margins
  (define pp-margin (/ (* *pp-display-width* *pp-display-margin*) 10))
  ; check whether the number of elements exceeds n or not.
  (define (less-than-n-elements? a-list n)
    ; count elements in a-list at most (n+1)
    (define (up-to-nth a-list n c)
      (cond
        ((null? a-list) c)
        ((pair? a-list)
          (set! c (up-to-nth (car a-list) n c))
          (if (< n c)
            c
            (up-to-nth (cdr a-list) n c)))
        (else (+ c 1))))
    (< (up-to-nth a-list n 0) n))
  ; check if the length is fit within n columns or not.
  (define (fit-in-n-width? a-list n)
    (< (print-width a-list) n))
  ; indent and pretty-print
  (define (do-pp a-list col)
    (spaces col)
    (pp-list a-list col 2))
  ;; main logic.
  (define (pp-list a-list col step)
    (cond
      ((atom? a-list) (write a-list))     ; atom
      ((and (assq (car a-list) special)
            (pair? (cdr a-list))
            (null? (cddr a-list)))   ; check for proper quote etc.
        (let ((s (assq (car a-list) special)))
          (display (cddr s))             ; display using abbrev.
          (pp-list
            (cadr a-list)
            (+ col (- (print-width (cddr s)) 2))
            (cadr s))))
      ((and (less-than-n-elements? a-list *pp-display-elements*)
	    (fit-in-n-width? a-list (- pp-margin col)))
	(display "(")
	(do-pp (car a-list) 0)
	(pp-args #f (cdr a-list) 1))
      (else                               ; long list.
        (let* ((sym (car a-list))
               (ex-col (assq sym exception)))
          (if (pair? ex-col)              ; check for exception.,
            (case (cdr ex-col)
              ((0 1)
                (display "(")
                (write sym)
                (display " ")
                (pp-list (cadr a-list) (+ col 2 (print-width sym)) 2)
                (pp-args
		  #t
                  (cdr (cdr a-list))
                  (+ col 2 (if (zero? (cdr ex-col)) 0 (print-width sym)))))
              ((2)
                (display "(")
                (write sym)
                (display " ")
                (if (symbol? (cadr a-list))
                  (begin ; named let
                    (write (cadr a-list))
                    (display " ")
                    (pp-list
                      (caddr a-list)
                      (+ col 3 (print-width sym) (print-width (cadr a-list)))
                      1)
                    (pp-args #t (cdddr a-list) (+ col 2)))
                  (begin ; usual let
                    (pp-list (cadr a-list) (+ col 2 (print-width sym)) 1)
                    (pp-args #t (cddr a-list) (+ col 2)))))
              (else
                (error "Illegal exception")))
            (begin                        ; normal case.
              (display "(")
              (pp-list (car a-list) (+ col 1) 2)
              (pp-args #t (cdr a-list) (+ col step))))))))
  ;; display arguments
  (define (pp-args nl a-list col)
    (cond
      ((null? a-list) (display ")"))
      ((pair? a-list)
	(if nl (newline))
        (do-pp (car a-list) col)
        (pp-args nl (cdr a-list) col))
      (else
        (display " . ")
        (write a-list)
        (display ")"))))
  ;;
  ;; main of pretty-print begins here.
  ;;
  (do-pp a-list 0)
  (newline))



;;; pretty print procedure(s)/macro(s).
;;;   (pretty 'a-symbol)        ; pretty print a procedure or macro
;;;   (pretty '(sym1 sym2 ...)) ; pretty print procedures and/or macros
(define (pretty symbols)
  (if (pair? symbols)
    (for-each
      (lambda (x) (pretty-print (getd x)) (newline))
      symbols)
    (pretty-print (getd symbols))))



;;; pretty print user-interface
;;;
;;; usage:
;;;  (pp sym1 sym2 ...)  ; obtain procedure/macro definitions in sequence
;;;
;;; Note: pp never evaluate its argument, so you do not have to specify
;;;       (pp 'proc-name). Use (pp proc-name) instead.
;;;
(macro pp (lambda (pp-macro)
  `(pretty ',(cdr pp-macro))))