pp

Language: R5RS Scheme

Purpose: Pretty-print SketchyLISP (and some Scheme) programs.
 
Because PP uses read to parse expressions, it strips all comments from its input programs.

Implementation:

(define Right-margin 72)

(define LP #\()
(define RP #\))

(define (atom? x)
  (and (not (pair? x))
       (not (null? x))
       (not (vector? x))))

(define (pp-atom-length x)
  (cond ((null? x) 2)
    ((number? x)
      (string-length (number->string x)))
    ((string? x)
      (+ 2 (string-length x)))
    ((char? x)
      (cond ((char=? x #\newline) 9)
        ((char=? x #\space) 7)
        (else 3)))
    ((boolean? x) 2)
    ((symbol? x)
      (string-length (symbol->string x)))
    (else (bottom (list 'unknown 'atom: x)))))

(define (pp-list-length x)
  (cond ((vector? x)
      (+ 1 (pp-list-length (vector->list x))))
    ((not (pair? x))
      (pp-atom-length x))
    ((eq? (car x) 'quote)
      (+ 1 (pp-list-length (cadr x))))
    (else (+ 1 (pp-list-length (car x))
               (let ((k (pp-list-length (cdr x))))
                 (if (atom? (cdr x)) (+ 4 k) k))))))

(define (pp-length x)
  (cond ((atom? x) (pp-atom-length x))
    (else (pp-list-length x))))

(define (spaces n)
  (or (zero? n)
      (begin (display #\space)
             (spaces (- n 1)))))

(define (pp-atom x)
  (begin (write x)
         (pp-atom-length x)))

(define (exceeds-margin k x)
  (>= (+ k (pp-length x))
      Right-margin))

(define (linewrap k x)
  (cond ((zero? k) k)
    ((exceeds-margin k x)
      (begin (newline) 0))
    (else k)))

(define (indent k n)
  (cond ((not (zero? k)) k)
    ((< k n) (begin (spaces (- n k)) n))
    (else k)))

(define (pp-members x n k)
  (cond ((null? x) k)
    ((not (pair? x))
      (begin (display ". ")
             (+ 2 k (pp-atom x))))
    (else (let* ((k (pp-expr (car x) (+ 2 n) k #f))
                 (k (cond ((null? (cdr x)) k)
                      ((> k 0) (begin (display #\space)
                                      (+ 1 k)))
                      (else 0))))
          (pp-members (cdr x) n k)))))

(define (pp-list x n k glue)
  (let* ((k (if glue k (linewrap k x)))
         (k (indent k n)))
      (cond ((not (pair? x))
          (+ k (pp-atom x)))
        (else (begin (display LP)
                     (let ((k (pp-members x k (+ 1 k))))
                       (begin (display RP)
                              (+ 1 k))))))))

(define (pp-quote x n k)
  (begin (display #\')
         (pp-expr (cadr x) n (+ 1 k) #t)))

(define (pp-lambda x n k)
  (begin (display LP)
         (display "lambda ")
         (pp-expr (cadr x) (+ 2 k) (+ 8 k) #t)
         (newline)
         (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f)))
           (begin (display RP)
                  (+ 1 k)))))

(define (pp-cond x n k)
  (letrec
    ((pp-indented-clause
       (lambda (x n k)
         (begin (display LP)
                (pp-expr (caar x) n (+ 1 k) #t)
                (newline)
                (let ((k (pp-expr (cadar x) (+ 2 n) 0 #f)))
                  (begin (display RP)
                         (+ 1 k))))))
     (pp-inline-clause
       (lambda (x n k)
         (begin (display LP)
                (let ((k (pp-expr (caar x) n (+ 1 k) #t)))
                  (begin (display #\space)
                         (let ((k (pp-expr (cadar x)
                                    (+ 1 k) (+ 1 k) #t)))
                           (begin (display RP)
                                  (+ 1 k))))))))
     (pp-clause
       (lambda (x n k)
         (let ((k (indent k n)))
           (cond ((and (exceeds-margin k (car x))
                       (not (eq? (caar x) #t))
                       (not (eq? (caar x) 'else)))
               (pp-indented-clause x n k))
             (else (pp-inline-clause x n k))))))
     (indent-clauses
       (lambda (x n k)
         (let ((k (pp-clause x n k)))
           (cond ((null? (cdr x))
               (begin (display RP)
                      (+ 1 k)))
             (else (begin (newline)
                          (indent-clauses (cdr x) n 0))))))))
    (begin (display LP)
           (display "cond ")
           (indent-clauses (cdr x) (+ k 2) (+ k 6)))))

(define (pp-if x n k)
  (cond ((exceeds-margin k x)
      (begin (display LP)
             (display "if ")
             (pp-expr (cadr x) (+ 4 n) (+ 4 k) #t)
             (newline)
             (pp-expr (caddr x) (+ 4 n) 0 #f)
             (newline)
             (let ((k (pp-expr (cadddr x) (+ 4 n) 0 #f)))
               (begin (display RP)
                      (+ 1 k)))))
    (else (pp-list x n k #t))))

(define (pp-indented x n k prefix always-split)
  (let ((pl (+ 1 (string-length prefix))))
    (letrec
      ((indent-args
         (lambda (x n k glue)
           (let ((k (pp-expr (car x) n k glue)))
             (cond ((null? (cdr x))
                 (begin (display RP)
                        (+ 1 k)))
               (else (begin (newline)
                            (indent-args (cdr x) n 0 #f))))))))
      (cond ((or (and (> (length x) 1) (exceeds-margin k x))
                 always-split)
          (begin (display LP)
                 (display prefix)
                 (indent-args (cdr x) (+ k pl) (+ k pl) #t)))
        (else (pp-list x (+ k pl) k #f))))))

(define (pp-and x n k)
  (pp-indented x n k "and " #f))

(define (pp-or x n k)
  (pp-indented x n k "or " #f))

(define (pp-begin x n k)
  (pp-indented x n k "begin " #t))

(define (pp-let-body x n k ind)
  (letrec
    ((lambda?
       (lambda (x)
         (and (pair? x) (eq? 'lambda (car x)))))
     (pp-let-procedure
       (lambda (x n k)
         (begin (pp-expr (caar x) n (+ 1 k) #t)
                (newline)
                (let ((k (pp-expr (cadar x) (+ 2 n) 0 #t)))
                  (begin (display RP)
                         (+ 2 k))))))
     (pp-let-data
       (lambda (x n k)
         (let ((k (pp-expr (caar x) n (+ 1 k) #t)))
           (begin (display #\space)
                  (let ((k (pp-expr (cadar x) (+ 2 n) (+ 1 k) #t)))
                    (begin (display RP)
                           (+ 2 k)))))))
     (pp-assoc
       (lambda (x n k)
         (let ((k (indent k n)))
           (begin (display LP)
                  (cond ((lambda? (cadar x))
                      (pp-let-procedure x n k))
                    (else (pp-let-data x n k)))))))
     (indent-bindings
       (lambda (x n k)
         (let ((k (pp-assoc x n k)))
           (cond ((null? (cdr x))
               (begin (display RP)
                      (+ 1 k)))
             (else (begin (newline)
                          (indent-bindings (cdr x) n 0))))))))
    (let ((k (indent-bindings (cadr x) (+ n ind) k)))
      (begin (newline)
             (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f)))
               (begin (display RP)
                      (+ 2 k)))))))

(define (pp-let x n k)
  (begin (display LP)
         (display "let ")
         (display LP)
         (pp-let-body x k (+ 6 k) 6)))

(define (pp-let* x n k)
  (begin (display LP)
         (display "let* ")
         (display LP)
         (pp-let-body x k (+ 7 k) 7)))

(define (pp-letrec x n k)
  (begin (display LP)
         (display "letrec ")
         (newline)
         (let ((k (indent 0 (+ k 2))))
           (begin (display LP)
                  (pp-let-body x n (+ 1 k) 3)))))

(define (pp-define x n k)
  (cond ((pair? (cadr x))
      (begin (display LP)
             (display "define ")
             (pp-list (cadr x) n k #t)
             (newline)
             (let ((k (pp-expr (caddr x) (+ 2 n) 0 #f)))
               (begin (display RP)
                      (+ 1 k)))))
    (else (pp-list x n k #f))))

(define (pp-define-syntax x n k)
  (begin (display LP)
         (display "define-syntax ")
         (pp-list (cadr x) n k #t)
         (newline)
         (let ((k (pp-expr (caddr x) (+ 2 k) 0 #f)))
           (begin (display RP)
                  (+ 1 k)))))

(define (pp-syntax-rules x n k)
  (letrec
    ((pp-rules
       (lambda (x n k)
         (cond ((null? x) k)
           (else (begin (indent 0 n)
                        (display LP)
                        (pp-list (caar x) n (+ 1 k) #t)
                        (newline)
                        (let* ((k (pp-list (cadar x) (+ 2 n) 0 #f)))
                          (cond ((null? (cdr x))
                              (begin (display RP)
                                     (pp-rules (cdr x) n k)))
                            (else (begin (newline)
                                         (pp-rules (cdr x) n 0)))))))))))
    (begin (display LP)
           (display "syntax-rules ")
           (pp-list (cadr x) (+ 16 k) (+ 14 k) #t)
           (newline)
           (let ((k (pp-rules (cddr x) (+ 2 k) (+ 2 n k))))
             (begin (display RP)
                    (+ 2 k))))))

(define (pp-expr x n k glue)
  (let* ((k (if glue k (linewrap k x)))
         (k (indent k n)))
    (cond ((vector? x)
        (begin (display "#")
               (display LP)
               (let ((k (pp-members (vector->list x) n (+ 2 k))))
                 (begin (display RP)
                        (+ 2 k)))))
      ((not (pair? x)) (+ k (pp-atom x)))
      ((eq? (car x) 'quote) (pp-quote x n k))
      ((eq? (car x) 'lambda) (pp-lambda x n k))
      ((eq? (car x) 'cond) (pp-cond x n k))
      ((eq? (car x) 'if) (pp-if x n k))
      ((eq? (car x) 'and) (pp-and x n k))
      ((eq? (car x) 'or) (pp-or x n k))
      ((eq? (car x) 'let) (pp-let x n k))
      ((eq? (car x) 'let*) (pp-let* x n k))
      ((eq? (car x) 'letrec) (pp-letrec x n k))
      ((eq? (car x) 'begin) (pp-begin x n k))
      ((eq? (car x) 'define) (pp-define x n k))
      ((eq? (car x) 'define-syntax) (pp-define-syntax x n k))
      ((eq? (car x) 'syntax-rules) (pp-syntax-rules x n k))
      (else (begin (display LP)
                   (let ((k (pp-members x n (+ 1 k))))
                     (begin (display RP)
                            (+ 1 k))))))))

(define (pp x)
  (begin (pp-expr x 0 0 #f)
         (newline)))

(define (main)
  (letrec
    ((pp*
       (lambda (x)
         (and (not (eof-object? x))
              (begin (pp x)
                     (let ((next (read)))
                       (begin (cond ((not (eof-object? next))
                                  (newline))
                                (else #f))
                              (pp* next))))))))
    (pp* (read))))

Example:

(pp '(let ((a 1) (b 2)) (lambda (x) (list x a b)))) 
=> #<void>
; Output:
; (let ((a 1)
;       (b 2))
;   (lambda (x)
;     (list x a b)))