; The LAML library and programs are written by Kurt Normark, Aalborg University, Denmark.
; Copyright (C) 2000,  Kurt Normark, normark@s.auc.dk.
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; GNU General Public License for more details.
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;;;; This is a Lisp pretty printing library, which especially is oriented towards Scheme.<p> ;;;; The pretty printer handles all aspects of Scheme which has special lexical syntax: lists, pairs (dot notation), booleans, chars, ;;;; vectors, and quasi quotation (backquoting). In addition, the pretty printing function handles Scheme special forms ;;;; such as cond, let, define, if, etc. <p> ;;;; A few parameters (global variables) control the pretty printer.<p> ;;;; Conventional comments, read by the this pretty printer, are lost. ;;;; This library assumes that comments are represented as syntactical forms like (comment!!! n "A comment"). ;;;; The LAML schemedoc tool contains a procedure lexical-to-syntactical-comments! which converts conventional, semicolon Lisp ;;;; comments to the syntactical comments expected by the pretty printing library. ;;;; The variable syntactical-comment-symbol (and the variable COMMENT-FORM-START in SchemeDoc) allows you to control ;;;; the prefix symbol of syntactical comments.<p> ;;;; The important top level functions of this library are pretty-print-lisp-file and pretty-print-lisp-form. <p> ;;;; Internally, the pretty printer adds pretty-print tokens (strings or chars) to a list, which finally is reversed and linearized ;;;; into a string.<p> ;;;; This library relies on the general library (not loaded by this library).<p> ;;;; In the laml.scm file there are LAML procedures <a href = "../../man/laml.html#scheme-pp">scheme-pp</a> ;;;; and <a href="../../man/laml.html#scheme-pp-simple">scheme-pp-simple</a> which pretty print Scheme and Lisp files. ;;;; <kbd>pp-scheme</kbd> handles comments properly. These are the most top-level Scheme pretty printing procedures in the ;;;; LAML system. ;;;; .title Reference Manual of the Scheme Pretty Printing Library
;;; Pretty printing parameters. ;;; The variables in this section controls the pretty printing.

(define indentation-delta 3)
(define use-single-lining #t)
(define prefered-maximum-width 90)
(define syntactical-comment-symbol 'comment!!!)
;;; Top level pretty printing functions. ;;; In this section you will find the important, overall pretty printing functions.

(define (pretty-print-lisp-file in-file-path . optional-parameters) (let ((out-file-path (optional-parameter 1 optional-parameters in-file-path))) (let ((form-list (file-read-all in-file-path)) ) (write-text-file (source-aggreated-text-with-interspacing (map pretty-print-lisp-form form-list) form-list) out-file-path)))) (define (source-aggreated-text-with-interspacing pp-res-list form-list) (source-aggreated-text-with-interspacing-1 pp-res-list form-list "")) (define (source-aggreated-text-with-interspacing-1 pp-res-list form-list res) (if (null? pp-res-list) res (let ((this-pp-contr (car pp-res-list)) (this-form (car form-list)) (double-cr (string-append (as-string #\newline) (as-string #\newline))) ) (source-aggreated-text-with-interspacing-1 (cdr pp-res-list) (cdr form-list) (if (syntactical-comment-form? this-form) (string-append res this-pp-contr) (string-append res this-pp-contr double-cr))))))
(define (pretty-print-lisp-form form) (set! res '()) (pretty-print-lisp-form-1 form 0 #f) (linearize-pp-result (reverse res)))
(define (pretty-print-lisp-string str) (let ((temp-file-path (string-append (laml-temp-file-path) "lisp-form-string.lsp"))) (write-text-file str temp-file-path) (let ((form (file-read temp-file-path))) (pretty-print-lisp-form form)))) ; ------------------------------------------------------------------- ; The internal result list
(define res '()) (define (add-to-res x) (set! res (cons x res))) (define (remove-from-res i) (if (> i 0) (begin (set! res (cdr res)) (remove-from-res (- i 1))))) (define (linearize-pp-result lst) (apply string-append (map as-string lst))) (define (add-white-space single-lining?) (if single-lining? (add-to-res #\space) (add-to-res #\newline))) ; ------------------------------------------------------------------ ; Internal Lisp pretty-printing stuff
; The central, internal lisp pretty printing function.
(define (pretty-print-lisp-form-1 form start-col single-lining?) (cond ((symbol? form) (add-to-res (as-string form))) ((number? form) (add-to-res (as-string form))) ((string? form) (add-to-res (string-it (string-quote-protect form)))) ((char? form) (add-to-res (char-it form))) ; scheme specific
((boolean? form) (add-to-res (bool-it form))) ; scheme specific
((vector? form) (vector-it form start-col single-lining?)) ((quote-form? form) ; (quote x)
(add-to-res "'") (pretty-print-lisp-form-1 (cadr form) (+ 1 start-col) single-lining?)) ((quasiquote-form? form) ; (quasiquote x) - backquote
(add-to-res "`") (pretty-print-lisp-form-1 (cadr form) (+ 1 start-col) single-lining?)) ((unquote-form? form) ; (unquote x) or ,x
(add-to-res ",") (pretty-print-lisp-form-1 (cadr form) (+ 1 start-col) single-lining?)) ((unquote-splicing-form? form) ; (unquote-splicing x) or , @x
(add-to-res ",@") (pretty-print-lisp-form-1 (cadr form) (+ 2 start-col) single-lining?)) ((syntactical-comment-form? form) ; (comment x)
(pretty-print-syntactical-comment form start-col single-lining?)) ((special-form? form) ; let, cond, define and others that call for special pretty priting
(pretty-print-special-form form start-col)) ((list? form) (cond ((null? form) (add-to-res "()")) ((single-liner-form? form start-col prefered-maximum-width) (add-to-res "(") (add-list-rest-to-res-single-liner form) (add-to-res ")")) (else (add-to-res "(") (pretty-print-lisp-form-1 (car form) start-col single-lining?) (add-white-space single-lining?) (if (not single-lining?) (add-to-res (indentation (+ start-col indentation-delta)))) (add-list-rest-to-res (cdr form) (+ start-col indentation-delta) single-lining?) (add-to-res ")")))) ((pair? form) (let ((prefix-list (proper-part form)) (last-el (first-improper-part form))) (cond ((single-liner-form? form start-col prefered-maximum-width) (add-to-res "(") (add-list-rest-to-res-single-liner prefix-list) (add-to-res " . ") (let ((dummy 0)) (pretty-print-lisp-form-1 last-el dummy #t)) (add-to-res ")")) (else (add-to-res "(") (add-list-rest-to-res prefix-list (+ start-col 2) single-lining?) (add-to-res " . ") (add-white-space single-lining?) (if (not single-lining?) (add-to-res (indentation (+ start-col 2)))) (pretty-print-lisp-form-1 last-el (+ start-col 2) single-lining?) (add-to-res ")"))))) ) ) (define (quote-form? x) (and (list? x) (not (null? x)) (eq? (car x) 'quote))) (define (quasiquote-form? x) (and (list? x) (not (null? x)) (eq? (car x) 'quasiquote))) (define (unquote-form? x) (and (list? x) (not (null? x)) (eq? (car x) 'unquote))) (define (unquote-splicing-form? x) (and (list? x) (not (null? x)) (eq? (car x) 'unquote-splicing))) (define (syntactical-comment-form? x) (and (list? x) (= 3 (length x)) (eq? (car x) syntactical-comment-symbol))) (define (special-form? x) (and (list? x) (not (null? x)) (memq (car x) '(define if let let* letrec cond)))) (define (named-let-form? x) (and (list? x) (>= (length x) 3) (eq? (car x) 'let ) (symbol? (cadr x)))) ; Is form x going to pretty printed on a single line. ; We are in start-col, and the preferred maximum column widht is max-width
(define (single-liner-form? x start-col max-width) (if use-single-lining (let ((width (meassure-lisp-form x))) (<= (+ width start-col) max-width)) #f)) ; Prefix string quotes within str with backslashes
(define (string-quote-protect str) (replace-string str (as-string #\") (string-append (as-string #\\) (as-string #\")))) ; return the size of form assumed that it is pretty print in single-spacing mode.
(define (meassure-lisp-form form) (cond ((symbol? form) (string-length (as-string form))) ((number? form) (string-length (as-string form))) ((string? form) (+ 2 (string-length (as-string form)))) ((char? form) 3) ; not exact meassure
((boolean? form) 2) ((vector? form) (+ 1 (meassure-lisp-form (vector->list form)))) ((quote-form? form) (+ 1 (meassure-lisp-form (cadr form)))) ((quasiquote-form? form) ; (quasiquote x) - backquote
(+ 1 (meassure-lisp-form (cadr form)))) ((unquote-form? form) ; (unquote x) or ,x
(+ 1 (meassure-lisp-form (cadr form)))) ((unquote-splicing-form? form) ; (unquote-splicing x) or , @x
(+ 2 (meassure-lisp-form (cadr form)))) ((list? form) (let ((meassure-list (map meassure-lisp-form form))) (+ (accumulate-right + 0 meassure-list) (length form) 1))) ((pair? form) (let ((prefix-list (proper-part form)) (last-el (first-improper-part form))) (+ (meassure-lisp-form prefix-list) 3 (meassure-lisp-form last-el)))) (else 0) )) ; Emit a Scheme char surface form of ch
(define (char-it ch) (cond ((eqv? ch #\space) (string-append (as-string #\#) (as-string #\\) "space")) ((eqv? ch #\newline) (string-append (as-string #\#) (as-string #\\) "newline")) (else (string-append (as-string #\#) (as-string #\\) (as-string ch))))) ; Emit a Scheme boolean surface form of b
(define (bool-it b) (if b "#t" "#f")) (define (vector-it form start-col single-lining?) (add-to-res "#") (pretty-print-lisp-form-1 (vector->list form) (+ 1 start-col) single-lining?) ) ; Process the rest of a list
(define (add-list-rest-to-res list-tail start-col single-lining?) (for-each (lambda (el) (pretty-print-lisp-form-1 el start-col single-lining?) (add-white-space single-lining?) (if (not single-lining?) (add-to-res (indentation start-col)))) list-tail) ; remove lst newline and indentation
(remove-from-res (if single-lining? 1 2))) (define (add-list-rest-to-res-single-liner lst) (let ((dummy 0)) (for-each (lambda (el) (pretty-print-lisp-form-1 el dummy #t) (add-to-res #\space)) lst) (remove-from-res 1) ; last space removed
) ) (define (indentation n) (make-string n #\space)) ; always ends i a newline to make it impossible that trailing lisp stuff ends up in a comment
(define (pretty-print-syntactical-comment form start-col single-lining?) (let* ((level (as-number (cadr form))) (comment-prefix (string-append (make-string level #\;) (as-string #\space))) (cr-comment-prefix (string-append (as-string #\newline) comment-prefix)) (comment-text (caddr form)) (comment-text-1 (replace-string comment-text (as-string #\newline) cr-comment-prefix)) ) (add-to-res comment-prefix) (add-to-res comment-text-1) (add-to-res #\newline))) (define (pretty-print-special-form form start-col) (let ((which-form (car form))) (cond ((and (eq? which-form 'define) (>= (length form) 2)) (pretty-print-define-form form start-col)) ((named-let-form? form) (pretty-print-named-let-form form start-col)) ((and (memq which-form '(let let* letrec)) (>= (length form) 2)) (pretty-print-let-form form which-form start-col)) ((and (eq? which-form 'cond) (>= (length form) 2)) (pretty-print-cond-form form start-col)) ((and (eq? which-form 'if) (>= (length form) 3)) (pretty-print-if-form form start-col)) (else (error (string-append "pretty-print-special-form: Unknown special form: " (as-string which-form))))))) (define (pretty-print-define-form form start-col) (if (single-liner-form? form start-col prefered-maximum-width) (let ((dummy 0)) (add-to-res "(") (add-to-res "define") (add-to-res #\space) (add-list-rest-to-res (cdr form) dummy #t) (add-to-res ")") ) (let ((name-or-call-form (cadr form)) (body-rest (cddr form)) (new-indent (+ start-col indentation-delta)) ) (add-to-res "(") (add-to-res "define") (add-to-res #\space) (pretty-print-lisp-form-1 name-or-call-form (+ start-col 8) #f) ; #t if we insist on calling form on a single line
(add-to-res #\newline) (add-to-res (indentation new-indent)) (add-list-rest-to-res body-rest new-indent (single-liner-form? body-rest new-indent prefered-maximum-width)) (add-to-res ")") ))) (define (pretty-print-let-form form which-let-form start-col) (let ((name-bindings (cadr form)) (which-let-form-string (as-string which-let-form)) (body-rest (cddr form)) (new-indent (+ start-col indentation-delta)) ) (add-to-res "(") (add-to-res which-let-form-string) (add-to-res #\space) ; #f: name bindings never on same line
(pretty-print-lisp-form-1 name-bindings (+ start-col (string-length which-let-form-string)) #f) (add-to-res #\newline) (add-to-res (indentation new-indent)) (add-list-rest-to-res body-rest new-indent (single-liner-form? body-rest new-indent prefered-maximum-width)) (add-to-res ")") )) (define (pretty-print-named-let-form form start-col) (let* ((name (cadr form)) (name-bindings (caddr form)) (body-rest (cdddr form)) (name-val-indent (+ start-col 6 (string-length (as-string name)))) (body-indent (+ start-col indentation-delta)) ) (add-to-res "(") (add-to-res "let") (add-to-res #\space) (add-to-res (as-string name)) (add-to-res #\space) ; #f: name bindings never on same line
(pretty-print-lisp-form-1 name-bindings name-val-indent #f) (add-to-res #\newline) (add-to-res (indentation body-indent)) (add-list-rest-to-res body-rest body-indent (single-liner-form? body-rest body-indent prefered-maximum-width)) (add-to-res ")") )) (define (pretty-print-cond-form form start-col) (let ((condition-consequence-rest (cdr form)) ) (add-to-res "(") (add-to-res "cond") (add-to-res #\space) (add-list-rest-to-res condition-consequence-rest (+ start-col 6) #f) (add-to-res ")") )) (define (pretty-print-if-form form start-col) (if (single-liner-form? form start-col prefered-maximum-width) (let ((condition (cadr form)) (body-rest (cdr form)) (dummy 0)) (add-to-res "(") (add-to-res "if") (add-to-res #\space) (add-list-rest-to-res body-rest dummy #t) (add-to-res ")") ) (let ((condition (cadr form)) (body-rest (cddr form)) (new-indent (+ start-col 4))) (add-to-res "(") (add-to-res "if") (add-to-res #\space) (pretty-print-lisp-form-1 condition new-indent (single-liner-form? condition new-indent prefered-maximum-width)) (add-to-res #\newline) (add-to-res (indentation new-indent)) (add-list-rest-to-res body-rest new-indent #f) (add-to-res ")") )))