(Nils' Scheme Snippets)

(pp form) => unspecific
(pp-file string) => unspecific

(pp '(let ((a 1) (b 2)) (cons a b))) => unspecific
Side effect: Output:
(let ((a 1)
      (b 2))
  (cons a b))

; A pretty-printer for Scheme.
; Copyright (C) 2006,2007 Nils M Holm

(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 (quoted? x)
  (and (pair? x)
       (pair? (cdr x))
       (null? (cddr x))
       (memq (car x) '(quote quasiquote unquote unquote-splicing))
       #t))

(define (pp-list-length x)
  (cond
    ((vector? x)
      (+ 1 (pp-list-length (vector->list x))))
    ((not (pair? x))
      (pp-atom-length x))
    ((quoted? x)
      (if (eq? (car x) 'unquote-splicing)
          (+ 2 (pp-list-length (cadr x)))
          (+ 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)
  (if (atom? x)
      (pp-atom-length x)
      (pp-list-length x)))

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

(define (pp-atom x)
  (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)
      (newline)
      0)
    (else k)))

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

(define (pp-quote x n k)
  (display #\')
  (pp-datum (cadr x) n k #t))

(define (pp-quasiquote x n k)
  (display #\`)
  (pp-expr (cadr x) n k #t))

(define (pp-unquote x n k)
  (display #\,)
  (pp-expr (cadr x) n k #t))

(define (pp-unquote-splicing x n k)
  (display ",@")
  (pp-expr (cadr x) n k #t))

(define (print-quotation x n k)
  (case (car x)
    ((quote) (pp-quote x n k))
    ((quasiquote) (pp-quasiquote x n k))
    ((unquote) (pp-unquote x n k))
    ((unquote-splicing) (pp-unquote-splicing x n k))))

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

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

(define (pp-vertical-args x n k glue)
  (letrec
    ((pp-args
       (lambda (x n k)
         (let ((n (pp-expr (car x) n k #t)))
           (cond
             ((null? (cdr x)) n)
             (else (newline)
                   (indent 0 k)
                   (pp-args (cdr x) n k)))))))
    (indent k n)
    (display LP)
    (let ((k-new (pp-expr (car x) k k glue)))
      (cond
         (glue (display #\space))
         (else (newline)
               (indent 0 (+ 2 k))))
      (let ((k (pp-args (cdr x) n (if glue (+ 2 k-new) (+ 2 k)))))
        (display RP)
        (+ 1 k)))))

(define (any? p x)
  (letrec
    ((map-improper
       (lambda (f a)
         (letrec
           ((map-i
              (lambda (a r)
                (cond
                  ((null? a) (reverse r))
                  ((not (pair? a)) (append (reverse r)
                                           (list (f a))))
                  (else (map-i (cdr a)
                               (cons (f (car a)) r)))))))
           (map-i a '())))))
  (and (memq #t (map-improper p x)) #t)))

(define (pp-app x n k glue)
  (if (exceeds-margin? k x)
      (let* ((len (pp-length (car x)))
             (k-new (+ n len)))
        (if (and (> len 2)
                 (any? (lambda (x)
                         (exceeds-margin? k-new x))
                       (cdr x)))
            (pp-vertical-args x n k #f)
            (pp-vertical-args x n k #t)))
      (pp-datum x n k glue)))

(define (pp-body x n k glue)
  (cond
    ((null? x) k)
    (glue (pp-body (cdr x) n (pp-expr (car x) n k glue) #f))
    (else (newline)
          (pp-body (cdr x) n (pp-expr (car x) n 0 glue) #f))))

(define (pp-body x n k glue)
  (cond
    ((null? x) n)
    (glue (pp-body (cdr x) (pp-expr (car x) n k #t) k #f))
    (else (newline)
          (indent 0 k)
          (pp-body (cdr x) (pp-expr (car x) k k #t) k #f))))

(define (pp-lambda x n k)
  (display LP)
  (display "lambda ")
  (pp-expr (cadr x) (+ 2 k) (+ 8 k) #t)
  (let ((k (pp-body (cddr x) n (+ 2 k) #f)))
    (display RP)
    (+ 1 k)))

(define (remove-default x)
  (let ((c (reverse x)))
    (if (or (eq? (caar c) 'else)
            (eq? (caar c) #t))
        (reverse (cdr c))
        x)))

(define (pp-clauses kw x n k)
  (letrec
    ((pp-indented-clause
       (lambda (x n k)
         (display LP)
         (pp-expr (caar x) n (+ 1 k) #t)
         (let ((k (pp-body (cdar x) n (+ 2 k) #f)))
           (display RP)
           (+ 1 k))))
     (pp-inline-clause
       (lambda (x n k)
         (display LP)
         (let ((k (pp-expr (caar x) n (+ 1 k) #t)))
           (display #\space)
           (let ((k (pp-body (cdar x) n (+ 1 k) #t)))
             (display RP)
             (+ 1 k)))))
     (pp-clause
       (lambda (x n k)
         (let ((k (indent k n)))
           (cond
             ((> (length (car x)) 2)
               (pp-indented-clause x n k))
             ((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))))))
     (print-clauses
       (lambda (pr x n k)
         (let ((k (pr x n (indent k n))))
           (cond
             ((null? (cdr x))
               (display RP)
               (+ 1 k))
             (else (newline)
                   (print-clauses pr (cdr x) n 0))))))
    (multi-expr-clauses?
      (lambda (x)
        (any? (lambda (x)
                (> (length x) 2))
              (remove-default x))))
    (long-clauses?
      (lambda (x k)
        (any? (lambda (x)
                (exceeds-margin? k x))
              (remove-default x)))))
    (display LP)
    (display (if (eq? kw 'cond) "cond " "case "))
    (let ((printer (if (or (multi-expr-clauses? (cdr x))
                           (long-clauses? (cdr x) (+ k 2)))
                       pp-indented-clause
                       pp-inline-clause))
          (clauses (cond ((eq? kw 'cond)
                           (cdr x))
                         (else (pp-expr (cadr x) n (+ k 6) #t)
                               (cddr x)))))

      (newline)
      (print-clauses printer clauses (+ k 2) 0))))

(define (pp-if x n k)
  (cond
    ((exceeds-margin? k x)
      (display LP)
      (display "if ")
      (pp-expr (cadr x) (+ 4 n) (+ 4 k) #t)
      (newline)
      (let ((k (pp-expr (caddr x) (+ 4 n) 0 #f)))
        (cond
          ((null? (cdddr x))
            (display RP)
            (+ 1 k))
          (else (newline)
                (let ((k (pp-expr (cadddr x) (+ 4 n) 0 #f)))
                  (display RP)
                  (+ 1 k))))))
    (else (pp-app 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))
                 (display RP)
                 (+ 1 k))
               (else (newline)
                     (indent-args (cdr x) n 0 #f)))))))
      (cond
        ((or (and (> (length x) 1) (exceeds-margin? k x))
             always-split)
          (display LP)
          (display prefix)
          (indent-args (cdr x) (+ k pl) (+ k pl) #t))
        (else (pp-app 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)
         (pp-expr (caar x) n (+ 1 k) #t)
         (newline)
         (let ((k (pp-expr (cadar x) (+ 2 n) 0 #t)))
           (display RP)
           (+ 2 k))))
     (pp-let-data
       (lambda (x n k)
         (let ((k (pp-expr (caar x) n (+ 1 k) #t)))
           (display #\space)
           (let ((k (pp-expr (cadar x) (+ 2 n) (+ 1 k) #t)))
             (display RP)
             (+ 2 k)))))
     (pp-assoc
       (lambda (x n k)
         (let ((k (indent k n)))
           (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))
               (display RP)
               (+ 1 k))
             (else (newline)
                   (indent-bindings (cdr x) n 0)))))))
    (indent-bindings (cadr x) (+ n ind) k)
    (let ((k (pp-body (cddr x) n (+ 2 n) #f)))
      (display RP)
      (+ 1 k))))

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

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

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

(define (pp-define x n k)
  (cond
    ((pair? (cadr x))
      (display LP)
      (display "define ")
      (pp-datum (cadr x) n k #t)
      (let ((k (pp-body (cddr x) n (+ 2 k) #f)))
        (display RP)
        (+ 1 k)))
    (else (pp-app x n k #f))))

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

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

(define (pp-vector x)
  (display "#")
  (display LP)
  (let ((k (pp-members (vector->list x) n (+ 2 k))))
    (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) (pp-vector x))
      ((not (pair? x)) (+ k (pp-atom x)))
      ((quoted? x) (print-quotation x n k))
      ((eq? (car x) 'lambda) (pp-lambda x n k))
      ((eq? (car x) 'cond) (pp-clauses 'cond x n k))
      ((eq? (car x) 'case) (pp-clauses 'case 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 (pp-app x n k #t)))))

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

(define (pp-file file)
  (letrec
    ((pp*
       (lambda (x)
         (cond
           ((not (eof-object? x))
             (pp x)
             (let ((next (read)))
               (if (not (eof-object? next))
                   (newline))
               (pp* next)))))))
    (with-input-from-file
      file
      (lambda ()
        (pp* (read))))))