Pretty printer

Location: contrib, 552 Lines

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009
; Placed in the Public Domain
; (pretty-print object <option> ...)  ==>  unspecific
; (pp object <option> ...)            ==>  unspecific
; (pp-file string <option> ...)       ==>  unspecific
; (pp-loop <option> ...)              ==>  unspecific
; (pp-string string <option> ...)     ==>  list
; (pp-string list <option> ...)       ==>  list
; (load-from-library "pretty-print.scm")
; Pretty-print Scheme objects, programs, or files. PRETTY-PRINT attempts
; to figure out whether OBJECT is a valid Scheme program. If so, it prints
; it as code and otherwise it prints it as data. The automatic detection
; can be disabled by passing an option to these procedures (see below).
; PP is just a less verbose name for PRETTY-PRINT.
; PP-FILE pretty-prints all objects in the file STRING.
; PP-LOOP pretty-prints all objects read from (current-input-stream).
; PP-STRING pretty-prints the form in STRING and returns a list
; containing one pretty-printed line per member (as strings).
; When a LIST is passed to PP-STRING instead of a STRING, it
; will assume it is a list of separate lines and append them with
; #\NEWLINEs in between.
; Any of these procedures accept the following <option>s that may be
; passed to it after the object to print:
; 'CODE       Print OBJECT as if it was a Scheme program.
; 'DATA       Print OBJECT as if it was a Scheme object.
; 'SIMPLE     Attempt to keep some special forms in a single line,
;             if they fit in one (IF, AND, OR, BEGIN, LAMBDA).
; 'MARGIN: n  Set the right margin to N. The printer will attempt
;             not to write any output beyond that margin. The default
;             margin is at column 72.
; 'INDENT: n  Indent all lines except for the first one by the given
;             number of blanks (for embedding in editors).
;             Send all output to the specified output port instead
;             of (current-output-port).
; NOTE: This program handles only a subset of R4RS Scheme correctly
; and removes all comments from its input program. Caveat utilitor.
; Example:   (pp-string '("(let ((a 1) (b 2))"
;                         "(cons a b))"))
;                                             ==> ("(let ((a 1)"
;                                                  "      (b 2))"
;                                                  "  (cons a b))")

(load-from-library "programp.scm")
(load-from-library "for-all.scm")
(load-from-library "read-from-string.scm")
(load-from-library "write-to-string.scm")
(load-from-library "string-unsplit.scm")

; If your Scheme does not support FLUID-LET or DEFINE-MACRO,
; there is an alternative implementation using SYNTAX-RULES in
; lib/fluid-let-sr.scm.

(load-from-library "fluid-let.scm")

(define *Input*   #f)
(define *Output*  #f)

(define *Convert-unreadable* #f)

(define (read-form)
  (if *Input*
      (let ((form (if (null? *Input*)
                      (read-from-string *Input*))))
        (cond ((pair? form)
                (set! *Input* (cdr form))
                (car form))
              ((null? form)
                (set! *Output* (list #f form *Input*))
                (set! *Input* '())

(define (end-of-input? x)
  (if *Input*
      (not x)
      (eof-object? x)))

(define pretty-print
  (let ((read-form     read-form)
        (end-of-input? end-of-input?))
    (lambda (form . options)

      (define *Margin* 72)
      (define *Offset* 0)
      (define *Column* 0)

      (define *Output-port* (current-output-port))
      (define *Print-as-code* #f)
      (define *Print-as-data* #f)
      (define *Print-newline* #f)
      (define *Really-print* #t)
      (define *Max-Column* 0)
      (define *Simple* #f)
      (define LP "(")
      (define RP ")")
      (define SP " ")
      (define (pr-char c)
        (if *Output*
            (if (char=? #\newline c)
                (begin (set-car! *Output*
                                 (list->string (reverse! (car *Output*))))
                       (set! *Output* (cons '() *Output*)))
                (set-car! *Output* (cons c (car *Output*))))
            (write-char c *Output-port*)))
      (define (pr-form x)
        (if *Output*
            (for-each pr-char
                      (string->list (display-to-string x)))
            (display x *Output-port*)))
      (define (atom? x)
        (and (not (pair? x))
             (not (null? x))
             (not (vector? x))))
      (define (object-length x)
        (string-length (write-to-string x)))
      (define (exceeds-margin? x . opt-lead)
        (let ((lead (if (null? opt-lead)
                        (car opt-lead))))
          (>= (+ *Column* lead (string-length (write-to-string x)))
      (define (spaces n)
        (and *Really-print*
             (or (zero? n)
                 (begin (pr-char #\space)
                        (spaces (- n 1))))))
      (define (linefeed)
        (if *Really-print*
            (pr-char #\newline))
        (set! *Max-Column* *Margin*)
        (spaces *Offset*)
        (set! *Column* *Offset*))
      (define (pr s)
        (if *Really-print*
            (pr-form s))
        (set! *Column* (+ *Column* (string-length s)))
        (if (> *Column* *Max-Column*)
            (set! *Max-Column* *Column*)))
      (define (really-simple? x)
        (or (not (list? x))
            (not (pair? x))
            (not (memq (car x) '(lambda cond case do if and or let
                                 let* letrec fluid-let begin)))))

      (define (pp-simple-form x)
        (if (or (not (list? x))
                (for-all really-simple? x))
            (let* ((s (write-to-string x))
                   (k (string-length s)))
              (if (and (> (+ *Column* k) *Margin*)
                       (> *Column* *Offset*))
              (pr s))
            (pp-inline-app x)))

      (define (pp-datum x)
        (cond ((or (null? x)
                   (symbol? x)
                   (boolean? x)
                   (char? x)
                   (number? x)
                   (string? x))
                (pp-simple-form x))
              ((vector? x)
                (if *Really-print*
                    (pr-char #\#))
                (fluid-let ((*Offset* (+ 1 *Offset*)))
                  (pp-pair(vector->list x))))
              ((pair? x)
                (pp-pair x))
              ((procedure? x)
                (pp-simple-form (string->symbol "#<procedure>")))
                (error "pretty-print: unknown type" x))))
      (define (pp-pair x)
        (pr LP)
        (fluid-let ((*Offset* (+ 1 *Offset*)))
          (let pp-members ((x x)
                           (s #f))
            (cond ((pair? x)
                    (if s
                        (if (or (pair? (car x))
                                (vector? (car x)))
                            (pr SP)))
                    (pp-datum (car x))
                    (pp-members (cdr x) #t))
                  ((not (null? x))
                    (pr " . ")
                    (pp-datum x)))))
          (pr RP))
      (define (pp-quote x q)
        (pr q)
        (fluid-let ((*Offset* (+ *Offset* (string-length q))))
          (if (program? (cadr x))
              (pp-form (cadr x))
              (pp-datum (cadr x)))))
      (define (pp-body x)
        (cond ((not (null? x))
                (pp-form (car x))
                (if (not (null? (cdr x)))
                (pp-body (cdr x)))))
      (define (pp-lambda x)
        (cond ((or (not *Simple*)
                   (> (length x) 3)
                   (exceeds-margin? x))
                (pr LP)
                (pr "lambda ")
                (fluid-let ((*Offset* (+ 2 *Offset*)))
                  (pp-datum (cadr x))
                  (pp-body (cddr x))
                  (pr RP)))
                (pp-simple-form x))))
      (define (fits-in-margin? formatter x)
        (fluid-let ((*Column*       *Column*)
                    (*Offset*       *Offset*)
                    (*Max-Column*   0)
                    (*Really-print* #f))
          (formatter x)
          (< *Max-Column* *Margin*)))

      (define (pp-inline-app x)
        (pr LP)
        (pp-simple-form (car x))
        (if (not (null? (cdr x)))
            (pr SP))
        (fluid-let ((*Offset* (+ 2 (object-length (car x)) *Offset*)))
          (pp-body (cdr x)))
        (pr RP))
      (define (pp-indented-app x)
        (pr LP)
        (fluid-let ((*Offset* (+ 1 *Offset*)))
          (pp-form (car x)))
        (let ((indent (if (pair? (car x)) 1 2)))
          (fluid-let ((*Offset* (+ indent *Offset*)))
            (if (not (null? (cdr x)))
            (pp-body (cdr x)))
          (pr RP)))
      (define (indented-style-preferred? x)
        (and (memq x '(call-with-current-continuation
      (define (pp-application x)
        (cond ((fits-in-margin? pp-simple-form x)
                (pp-simple-form x))
              ((indented-style-preferred? (car x))
                (pp-indented-app x))
              ((fits-in-margin? pp-inline-app x)
                (pp-inline-app x))
                (pp-indented-app x))))
      (define (pp-cond/case what x)
             (lambda (c*)
               (cond ((not (null? c*))
                       (pr LP)
                       (fluid-let ((*Offset* (+ 1 *Offset*)))
                         (if (eq? what 'cond)
                             (pp-form (caar c*))
                             (pp-datum (caar c*))))
                       (fluid-let ((*Offset* (+ 2 *Offset*)))
                         (if (and (eq? 'cond what)
                                  (pair? (cdar c*))
                                  (eq? '=> (cadar c*)))
                             (fluid-let ((*Offset* (+ 3 *Offset*)))
                               (pr "=> ")
                               (pp-body (cddar c*)))
                             (pp-body (cdar c*))))
                       (pr RP)
                       (if (not (null? (cdr c*)))
                       (print-clauses (cdr c*)))))))
          (pr LP)
          (pr (symbol->string what))
          (pr SP)
          (fluid-let ((*Offset* (+ (if (eq? what 'cond) 6 2)
            (if (eq? what 'case)
                (begin (pp-simple-form (cadr x))
            (let ((c* (if (eq? what 'cond)
                          (cdr x)
                          (cddr x))))
              (print-clauses c*)
              (pr RP)))))
      (define (pp-do x)
             (lambda (x first)
               (cond ((null? x)
                       (pp-simple-form (car x))
                       (print-inits (cdr x) #f))
                       (pp-simple-form (car x))
                       (print-inits (cdr x) #f)))))
             (init-part cadr)
             (test-part caddr)
             (do-body   cdddr))
          (pr LP)
          (pr "do ")
          (pr LP)
          (fluid-let ((*Offset* (+ 5 *Offset*)))
            (print-inits (init-part x) #t))
          (fluid-let ((*Offset* (+ 4 *Offset*)))
            (pr LP)
            (pp-form (car (test-part x)))
            (if (not (null? (cdr (test-part x))))
                (fluid-let ((*Offset* (+ 2 *Offset*)))
                  (pp-body (cdr (test-part x)))))
            (pr RP))
          (fluid-let ((*Offset* (+ 2 *Offset*)))
            (pp-body (do-body x)))
          (pr RP)))
      (define (pp-just-indent what x)
        (if (and *Simple*
                 (fits-in-margin? pp-simple-form x))
            (pp-simple-form x)
            (begin (pr LP)
                   (pr what)
                   (if (not (null? (cdr x)))
                       (pr SP))
                   (fluid-let ((*Offset* (+ 2 (string-length what) *Offset*)))
                     (let print ((x (cdr x)))
                       (cond ((not (null? x))
                               (pp-form (car x))
                               (if (not (null? (cdr x)))
                               (print (cdr x)))))
                     (pr RP)))))
      (define (pp-let-bindings b* rec)
        (pr LP)
        (fluid-let ((*Offset* (+ 1 *Offset*)))
          (let pp-bindings ((b* b*))
            (cond ((not (null? b*))
                    (pr LP)
                    (pp-simple-form (caar b*))
                    (cond ((and rec (pair? (cadar b*)))
                            (fluid-let ((*Offset* (+ 2 *Offset*)))
                              (pp-form (cadar b*))))
                            (pr SP)
                            (fluid-let ((*Offset* (+ 2
                                                     (object-length (caar b*))
                              (pp-form (cadar b*)))))
                    (pr RP)
                    (if (not (null? (cdr b*)))
                    (pp-bindings (cdr b*))))))
        (pr RP))
      (define (pp-let x)
        (pr LP)
        (pr "let ")
        (let* ((named?   (symbol? (cadr x)))
               (bind     (if named? (caddr x) (cadr x)))
               (body     (if named? (cdddr x) (cddr x)))
               (name-len (if named?
                             (+ 1 (object-length (cadr x)))
          (fluid-let ((*Offset* (+ 5 name-len *Offset*)))
            (if named?
                (begin (pp-simple-form (cadr x))
                       (pr SP)))
            (pp-let-bindings bind #f))
          (fluid-let ((*Offset* (+ 2 *Offset*)))
            (pp-body body))
          (pr RP)))
      (define (pp-let* x)
        (pr LP)
        (pr "let* ")
        (fluid-let ((*Offset* (+ 6 *Offset*)))
          (pp-let-bindings (cadr x) #f))
        (fluid-let ((*Offset* (+ 2 *Offset*)))
          (pp-body (cddr x)))
        (pr RP))
      (define (pp-letrec x)
        (pr LP)
        (pr "letrec ")
        (fluid-let ((*Offset* (+ 2 *Offset*)))
          (pp-let-bindings (cadr x) #t))
        (fluid-let ((*Offset* (+ 2 *Offset*)))
          (pp-body (cddr x)))
        (pr RP))
      (define (pp-fluid-let x)
        (pr LP)
        (pr "fluid-let ")
        (fluid-let ((*Offset* (+ 11 *Offset*)))
          (pp-let-bindings (cadr x) #f))
        (fluid-let ((*Offset* (+ 2 *Offset*)))
          (pp-body (cddr x)))
        (pr RP))
      (define (pp-define-etc what x)
        (pr LP)
        (pr what)
        (pr SP)
        (pp-simple-form (cadr x))
        (fluid-let ((*Offset* (+ 2 *Offset*)))
          (if (or (and (pair? (caddr x))
                       (eq? 'lambda  (caaddr x)))
                  (pair? (cadr x))
                  (exceeds-margin? x))
              (pr SP))
          (pp-body (cddr x)))
        (pr RP))
      (define (pp-syntax-rules x)
             (lambda (r*)
               (cond ((not (null? r*))
                       (pr LP)
                       (pp-datum (caar r*))
                       (fluid-let ((*Offset* (+ 2 *Offset*)))
                         (pp-form (cadar r*))
                         (pr RP))
                       (if (not (null? (cdr r*)))
                       (pp-rules (cdr r*)))))))
          (pr LP)
          (pr "syntax-rules ")
          (fluid-let ((*Offset* (+ 14 *Offset*)))
            (pp-datum (cadr x)))
          (fluid-let ((*Offset* (+ 2 *Offset*)))
            (pp-rules (cddr x))
            (pr RP))))
      (define (pp-form x)
        (if (not (pair? x))
            (pp-datum x)
            (case (car x)
              ((quote)            (pp-quote x "'"))
              ((quasiquote)       (pp-quote x "`"))
              ((unquote)          (pp-quote x ","))
              ((unquote-splicing) (pp-quote x ",@"))
              ((lambda)           (pp-lambda x))
              ((cond)             (pp-cond/case 'cond x))
              ((case)             (pp-cond/case 'case x))
              ((do)               (pp-do x))
              ((if)               (pp-just-indent "if" x))
              ((and)              (pp-just-indent "and" x))
              ((or)               (pp-just-indent "or" x))
              ((let)              (pp-let x))
              ((let*)             (pp-let* x))
              ((letrec)           (pp-letrec x))
              ((fluid-let)        (pp-fluid-let x))               ; S9fES ext.
              ((begin)            (pp-just-indent "begin" x))
              ((define)           (pp-define-etc "define" x))
              ((define-syntax)    (pp-define-etc "define-syntax" x))
              ((syntax-rules)     (pp-syntax-rules x))
              (else               (pp-application x)))))
        (set! *Column* 0)
        (set! *Offset* 0)
        (set! *Margin* 72)
        (set! *Print-as-code* #f)
        (set! *Print-as-data* #f)
        (set! *Print-newline* #f)
        (set! *Simple* #f)
        (set! *Convert-unreadable* #f)
        (let loop ((options options))
          (cond ((null? options)
                  (cond ((and *Print-as-code*
                          (error (string-append
                                   "pretty-print: please specify either the"
                                   " CODE or DATA option, but not both")))
                          (pp-form form))
                          (pp-datum form))
                        ((program? form)
                          (pp-form form))
                          (pp-datum form))))
                ((eq? 'code (car options))
                  (set! *Print-as-code* #t)
                  (loop (cdr options)))
                ((eq? 'data (car options))
                  (set! *Print-as-data* #t)
                  (loop (cdr options)))
                ((eq? 'linefeed (car options))
                  (set! *Print-newline* #t)
                  (loop (cdr options)))
                ((eq? 'simple (car options))
                  (set! *Simple* #t)
                  (loop (cdr options)))
                ((eq? 'indent: (car options))
                  (if (null? (cdr options))
                      (error "pretty-print: missing argument to INDENT:"))
                  (if (not (number? (cadr options)))
                      (error "pretty-print: non-numeric argument to INDENT:"))
                  (set! *Offset* (cadr options))
                  (loop (cddr options)))
                ((eq? 'margin: (car options))
                  (if (null? (cdr options))
                      (error "pretty-print: missing argument to MARGIN:"))
                  (if (not (number? (cadr options)))
                      (error "pretty-print: non-numeric argument to MARGIN:"))
                  (set! *Margin* (cadr options))
                  (loop (cddr options)))
                ((eq? 'output-port: (car options))
                  (if (null? (cdr options))
                      (error "pretty-print: missing argument to OUTPUT-PORT:"))
                  (if (not (output-port? (cadr options)))
                      (error "pretty-print: expected port in OUTPUT-PORT:"))
                  (set! *Output-port* (cadr options))
                  (loop (cddr options)))
                  (error "pretty-print: unknown option"
                         (car options)))))

(define pp pretty-print)

(define (pp-loop . options)
  (let pp* ((x (read-form)))
    (cond ((not (end-of-input? x))
            (apply pp x options)
            (let ((next (read-form)))
              (if (not (end-of-input? next))
                  (pp #f 'linefeed))
              (pp* next))))))

(define (pp-file file . options)
    (lambda ()
      (apply pp-loop options))))

(define (pp-string str* . options)
      (set! *Input* (if (string? str*)
                      (string-unsplit #\newline str*)))
      (set! *Output* (list '()))
      (apply pp-loop options)
      (reverse! (cdr *Output*)))

contact  |  privacy