stk/Lib/pp.stk

569 lines
21 KiB
Plaintext

;; pretty-printer by mf
;*************************************************************
(define *pp:port* #t) ; default value = current output
(define *pp:lgth* 80) ; default value = max length of a line
(define (pp obj . options)
; obj = file name in a string or
; expression to be pretty printed
; options = toutes facultatives
; destination = file name in a string
; #t ==> current output (default value)
; #f ==> a string
; line-length = integer >= 0 = max length of a line on output
; (default value = 80)
(let ((dest 'output))
(set! *pp:port* #t)
(set! *pp:lgth* 80)
(let loop ((L options))
(when (not (null? L))
; there is options....
(cond ((string? (car L)) ; output in a file
(set! *pp:port* (open-output-file (car L)))
(set! dest 'file))
((integer? (car L))
(set! *pp:lgth* (car L)))
((boolean? (car L)) ; current output or a string
(when (not (car L))
(set! *pp:port* (open-output-string))
(set! dest 'string))))
(loop (cdr L))))
(if (string? obj) ; file name
(let* ((p (open-input-file obj))
(to-pp (read p)))
(while (not (eof-object? to-pp))
(*pp:pp-one-exp* to-pp)
(format *pp:port* "~%")
(set! to-pp (read p))))
(*pp:pp-one-exp* obj))
(cond ((eq? dest 'file) (close-output-port *pp:port*))
((eq? dest 'string) (get-output-string *pp:port*)))))
;*************************************************************
; pretty-print an expression
;*************************************************************
(define *pp:cur-pos* 0) ; current position in line
(define *pp:line* 1) ; current line
(define *pp:lgth-symb* 0) ; lgth of symb to write
(define *printer-list* '(()))
(define *pp:last-symb-is-new-line* #t)
(define *pp:to-substitute* #t)
(define *pp:last* 0) ; for *pp:fit?*
(define (*pp:pp-one-exp* expr)
(set! *pp:cur-pos* 0) ; current position in line
(set! *pp:line* 1) ; current line
(set! *pp:lgth-symb* 0) ; lgth of symb to write
(set! *pp:last-symb-is-new-line* #t)
(set! *pp:to-substitute* #t)
(set! *pp:last* 0) ; for *pp:fit?*
(let ((expr (if (procedure? expr) (procedure-body expr)
expr)))
(*pp:print-expr* expr *pp:cur-pos*)
(format *pp:port* "~%")
#t))
(define (*pp:out-char* c) ; output the char c NOT at end of line
; c = left parenthesis|quote|quasiquote|unquote|unquote-splicing
(format *pp:port* "~A" c)
(set! *pp:last-symb-is-new-line* #t)
(set! *pp:cur-pos* (+ *pp:cur-pos* 1)))
(define (*pp:left-par*) ; output a left parenthesis
(*pp:out-char* #\( ))
(define (*pp:out-char-eol* c) ; output the char c perhaps at end of line
; c = right parenthesis|space|period
(format *pp:port* "~A" c)
(set! *pp:last-symb-is-new-line* #f)
(set! *pp:cur-pos* (+ *pp:cur-pos* 1)))
(define (*pp:right-par*) ; output a right parenthesis
(*pp:out-char-eol* #\)))
(define (*pp:space*) ; output a space
(*pp:out-char-eol* #\space))
(define (*pp:period*) ; output " . "
(*pp:space*)
(*pp:out-char-eol* #\.)
(*pp:space*))
(define (*pp:output-symb* symb) ; output the symbol symb
(format *pp:port* "~S" symb)
(set! *pp:last-symb-is-new-line* #f)
(set! *pp:cur-pos* (+ *pp:cur-pos* *pp:lgth-symb*)))
(define (*pp:newline-indent* x) ; output a newline and x spaces
(when (not *pp:last-symb-is-new-line*)
(format *pp:port* "~%")
(cond ((<= x 0) #t)
((>= x *pp:lgth*) (set! x 0))
(else
(format *pp:port* "~A" (make-string x #\space))))
(set! *pp:last-symb-is-new-line* #t)
(set! *pp:line* (+ *pp:line* 1))
(set! *pp:cur-pos* x)))
; #t if expr will fit between *pp:last* and *pp:lgth*
(define (*pp:fit?* expr)
(define (inc-pos? val)
(if (<= (+ *pp:last* val) *pp:lgth*)
(begin (set! *pp:last* (+ *pp:last* val)) #t)
#f))
(cond ((keyword? expr)
(set! *pp:lgth-symb* (string-length (keyword->string expr)))
(inc-pos? *pp:lgth-symb*))
((symbol? expr)
(set! *pp:lgth-symb* (string-length (symbol->string expr)))
(inc-pos? *pp:lgth-symb*))
((string? expr) ; don't forget " "
(set! *pp:lgth-symb* (+ 2 (string-length expr)))
(inc-pos? *pp:lgth-symb*))
((boolean? expr) ; #t or #f
(set! *pp:lgth-symb* 2)
(inc-pos? *pp:lgth-symb*))
((number? expr)
(set! *pp:lgth-symb* (string-length (number->string expr)))
(inc-pos? *pp:lgth-symb*))
((eof-object? expr) (inc-pos? 5)) ;??????????????????
((char? expr) ; #\...
(inc-pos? (case expr
(#\null 6)
(#\bell 6)
(#\space 7)
(#\delete 8)
(#\backspace 11)
(#\tab 5)
(#\newline 9)
(#\page 6)
(#\return 8)
(#\escape 8)
(else 3))))
((pair? expr) ; ( a b ...)
(let ((head (car expr))
(tail (cdr expr))
(subst (*pp:abbrev* expr)))
(cond (subst ; to substitute
(set! *pp:lgth-symb*
(if (or (eq? subst 'unquote-splicing)
(eq? subst 'quote-unquote))
2
1))
(and (inc-pos? *pp:lgth-symb*)
(*pp:fit?* tail)))
((null? tail) ; (a)
(and (inc-pos? 2) (*pp:fit?* head)))
((and (pair? tail)
(null? (cdr tail))) ; (a b)
(and (inc-pos? 1) (*pp:fit?* head) (*pp:fit?* tail)))
(else ; (a b ...)
(and (inc-pos? 2) (*pp:fit?* head) (*pp:fit?* tail))))))
((vector? expr)
(letrec ((vlen (- (vector-length expr) 1))
(vloop
(lambda (n)
(if (< n vlen)
(and (inc-pos? 1)
(*pp:fit?* (vector-ref expr n))
(vloop (+ n 1)))
(and (inc-pos? 1)
(*pp:fit?* (vector-ref expr vlen)))))))
(and (inc-pos? 2) (vloop 0))))
(else ; null list
#t)))
;******************************************************************
; output an expression
;******************************************************************
(define (*pp:print-expr* expr pos)
(let ((special
(if (and *pp:to-substitute* (pair? expr))
(assoc (car expr) *printer-list*)
#f)))
(if (pair? special)
((cdr special) expr pos)
(begin (set! *pp:last* *pp:cur-pos*)
(if (not (*pp:fit?* expr))
(*pp:newline-indent* pos))
(cond ((vector? expr) (*pp:print-vector* expr pos))
((not (pair? expr))
; *pp:lgth-symb* = lgth of the last symb
(*pp:output-symb* expr))
((and (not (pair? (car expr)))
(list? expr)) ; (operator args)
(*pp:print-op* expr pos))
(else (*pp:print-list* expr pos)))))))
;******************************************************************
; output a vector
;******************************************************************
(define (*pp:print-vector* vect pos)
(*pp:out-char* "#")
; en attendant de pouvoir mettre :
; (*pp:out-char* #\#)
(*pp:left-par*)
(let ((vect-lgth (- (vector-length vect) 1))
(n 0))
(set! pos (+ pos 2))
(*pp:print-expr* (vector-ref vect n) pos) ; first element
(while (< n vect-lgth)
(*pp:space*)
(set! n (+ n 1))
(*pp:print-expr* (vector-ref vect n) pos)))
(*pp:right-par*))
;******************************************************************
; output (operator args)
;******************************************************************
(define (*pp:print-op* expr pos)
(*pp:left-par*)
(*pp:print-expr* (car expr) (+ pos 1))
(let ((first-line *pp:line*))
(unless (null? (cdr expr))
(set! *pp:last* *pp:cur-pos*)
(if (or (and (pair? (cadr expr)) (not (*pp:fit?* (caadr expr))))
(and (not (pair? (cadr expr)))
(not (*pp:fit?* (cadr expr)))))
(*pp:newline-indent* (+ pos 1))
(*pp:space*))
(set! pos *pp:cur-pos*)
(set! *pp:last-symb-is-new-line* #t)
(*pp:print-expr* (cadr expr) pos) ; 1st arg on the same line
(for-each (lambda (arg)
(set! *pp:last* *pp:cur-pos*)
; (if (or (not (*pp:fit?* arg)) (< first-line *pp:line*))
(if (not (*pp:fit?* arg))
(*pp:newline-indent* pos)
(*pp:space*))
(*pp:print-expr* arg pos))
(cddr expr))))
(*pp:right-par*))
;******************************************************************
; output (if cond then else)
;******************************************************************
(define (*pp:print-if* expr pos)
(let ((on-new-line #f) (first-line *pp:line*))
(*pp:left-par*)
(*pp:print-expr* (car expr) pos) ; if
(*pp:space*)
(set! pos *pp:cur-pos*)
(set! *pp:last-symb-is-new-line* #t) ; to stay on the same line
(*pp:print-expr* (cadr expr) pos) ; cond
(set! *pp:last* *pp:cur-pos*)
(set! on-new-line (or (not (*pp:fit?* (cddr expr))) ; (then else)
(< first-line *pp:line*)))
(if on-new-line (*pp:newline-indent* pos) (*pp:space*))
(*pp:print-expr* (caddr expr) pos) ; then
(when (not (null? (cdddr expr)))
(if on-new-line (*pp:newline-indent* pos) (*pp:space*))
(*pp:print-expr* (cadddr expr) pos))
(*pp:right-par*)))
;******************************************************************
; output clause
;******************************************************************
(define (*pp:print-clause* clause pos)
(*pp:left-par*)
(unless (null? clause)
(*pp:print-expr* (car clause) pos)
(set! *pp:last* *pp:cur-pos*)
(if (not (*pp:fit?* (cdr clause)))
(*pp:newline-indent* pos)
(*pp:space*))
(set! clause (cdr clause))
(while (not (null? clause))
(*pp:print-expr* (car clause) pos)
(unless (null? (cdr clause))
(set! *pp:last* *pp:cur-pos*)
(if (not (*pp:fit?* (cadr clause)))
(*pp:newline-indent* pos)
(*pp:space*)))
(set! clause (cdr clause))))
(*pp:right-par*))
;******************************************************************
; output (cond clauses)
;******************************************************************
(define (*pp:print-cond* expr pos)
(*pp:left-par*)
(*pp:print-expr* (car expr) (+ pos 1)) ; output "cond"
(*pp:space*)
(set! pos (+ pos 6))
(*pp:print-clause* (cadr expr) (+ pos 1)) ; the first clause
(for-each (lambda (clause)
(*pp:newline-indent* pos)
(*pp:print-clause* clause (+ pos 1)))
(cddr expr))
(*pp:right-par*))
;******************************************************************
; output (case clauses)
;******************************************************************
(define (*pp:print-case* expr pos)
(*pp:left-par*)
(*pp:print-expr* (car expr) (+ pos 1))
(*pp:space*)
(set! pos (+ pos 2))
(*pp:print-expr* (cadr expr) pos)
(for-each (lambda (clause)
(*pp:newline-indent* pos)
(*pp:print-clause* clause pos))
(cddr expr))
(*pp:right-par*))
;******************************************************************
; output (do inits exit body)
;******************************************************************
(define (*pp:print-do* expr pos)
(*pp:left-par*)
(*pp:print-expr* (car expr) (+ pos 1)) ; do
(*pp:space*)
(let ((inits (cadr expr))
(exit (caddr expr))
(body (cdddr expr))
(pos-ie (+ pos 4))
(pos-body (+ pos 2)))
(*pp:print-clause* inits pos-ie)
(*pp:newline-indent* pos-ie)
(*pp:print-clause* exit pos-ie)
(for-each (lambda (expr)
(*pp:newline-indent* pos-body)
(*pp:print-expr* expr pos-body))
body))
(*pp:right-par*))
;******************************************************************
; output (let|let*|letrec|let-syntax|letrec-syntax bindings body)
;******************************************************************
(define (*pp:print-let* expr pos)
(define (print-binding bind pos)
(*pp:left-par*)
(*pp:print-expr* (car bind) pos)
(*pp:space*)
(set! *pp:last-symb-is-new-line* #t) ; to stay on the same line
(*pp:print-expr* (cadr bind) pos)
(*pp:right-par*))
(*pp:newline-indent* pos)
(*pp:left-par*)
(*pp:print-expr* (car expr) (+ pos 1))
(*pp:space*)
(set! pos (+ pos 2))
(let ((pos-bind (+ pos *pp:lgth-symb* 1))
(bindings (cadr expr))
(body (cddr expr)))
(if (symbol? bindings) ; named let
(begin (*pp:print-expr* bindings pos-bind)
(*pp:space*)
(set! pos-bind (+ pos-bind *pp:lgth-symb* 1))
(set! bindings (caddr expr))
(set! body (cdr body))))
(*pp:left-par*)
(when (not (null? bindings))
(print-binding (car bindings) pos-bind) ; the first binding
(for-each (lambda (clause)
(*pp:newline-indent* pos-bind)
(print-binding clause pos-bind))
(cdr bindings)))
(*pp:right-par*)
(for-each (lambda (expr)
(*pp:newline-indent* pos)
(*pp:print-expr* expr pos))
body))
(*pp:right-par*))
;******************************************************************
; output (define|define-macro|extend-syntax|when|unless|while arg body)
; on a new line
;******************************************************************
(define (*pp:print-sform* expr pos)
(*pp:newline-indent* pos)
(*pp:left-par*)
(*pp:print-expr* (car expr) (+ pos 1))
(*pp:space*)
(set! pos (+ pos 2))
(set! *pp:last* *pp:cur-pos*)
(if (not (*pp:fit?* (cadr expr))) (*pp:newline-indent* pos))
(*pp:print-expr* (cadr expr) pos)
(let ((next-on-new-line (pair? (cadr expr))))
(for-each (lambda (arg)
(set! *pp:last* *pp:cur-pos*)
(if (or next-on-new-line (not (*pp:fit?* arg)))
(*pp:newline-indent* pos)
(*pp:space*))
(*pp:print-expr* arg pos))
(cddr expr)))
(*pp:right-par*))
;******************************************************************
; output (lambda arg body)
;******************************************************************
(define (*pp:print-lambda* expr pos)
(let ((next-line #f))
(*pp:left-par*)
(*pp:print-expr* (car expr) (+ pos 1))
(*pp:space*)
(set! pos (+ pos 2))
(set! *pp:last* *pp:cur-pos*)
(unless (*pp:fit?* (cadr expr))
(set! next-line #t)
(*pp:newline-indent* pos))
(*pp:print-expr* (cadr expr) pos)
(set! next-line (or next-line (not (*pp:fit?* (cddr expr)))))
(for-each (lambda (arg)
(if next-line (*pp:newline-indent* pos))
(*pp:print-expr* arg pos))
(cddr expr))
(*pp:right-par*)))
;******************************************************************
; check for substitution of quote, quasiquote, unquote, unquote-splicing
; general rules :
; After a quote, symbols don't have to be substitued except for unquote
;******************************************************************
(define (*pp:abbrev* expr)
(if (and *pp:to-substitute* (pair? expr))
(cond ((and (pair? (cdr expr))
(null? (cddr expr))
(eq? (car expr) 'quote)) ; (quote x)
(if (and (pair? (cadr expr))
(eq? (caadr expr) 'unquote))
'quote-unquote
'quote))
(else
(if (memq (car expr)
'(quasiquote unquote unquote-splicing))
(car expr)
#f)))
#f))
;******************************************************************
; output (quote arg) ==> 'arg
; (quote ( arg1 arg2 ...)) ==> '(arg1 ag2 ...)
; (quote (unquote arg)) ==> ',arg
; (quote (unquote arg1 arg2 ...)) ==> ',(arg1 arg2 ...)
; (quasiquote arg) ==> `arg
; (quasiquote (arg1 arg2 ...)) ==> `(arg1 arg2 ...)
; (unquote arg) ==> , arg
; (unquote (arg1 arg2 ...)) ==> ,(arg1 arg2 ...)
; (unquote-splicing arg) ==> ,@ arg
; (unquote-splicing (arg1 arg2 ...)) ==> ,@(arg1 arg2 ...)
;******************************************************************
(define (*pp:print-quote* expr pos)
(let ((which (*pp:abbrev* expr)))
(cond ((not which)
(set! *pp:to-substitute* #f)
(*pp:print-expr* expr pos)
(set! *pp:to-substitute* #t))
((eq? which 'quote)
(set! *pp:to-substitute* #f)
(set! *pp:last* (+ *pp:cur-pos* 1))
(if (not (*pp:fit?* (cdr expr))) (*pp:newline-indent* pos))
(*pp:out-char* #\')
(*pp:print-expr* (cadr expr) (+ pos 1))
(set! *pp:to-substitute* #t))
((eq? which 'quote-unquote)
(*pp:out-char* #\') (*pp:out-char* #\,)
(*pp:print-expr* (car (cdadr expr)) (+ pos 2)))
(else
(case which
(quasiquote (*pp:out-char* #\`))
(unquote (*pp:out-char* #\,))
(unquote-splicing (*pp:out-char* #\,) (*pp:out-char* #\@)))
(*pp:print-expr* (cadr expr)
(+ pos (if (eq? which 'unquote-splicing)
2
1)))))))
;******************************************************************
; output (call/cc|call-with-current-continuation body)
;******************************************************************
(define (*pp:print-sform0* expr pos)
(*pp:left-par*)
(*pp:print-expr* (car expr) pos)
(set! pos (+ pos 2))
(for-each (lambda (arg)
(*pp:newline-indent* pos)
(*pp:print-expr* arg pos))
(cdr expr))
(*pp:right-par*))
;******************************************************************
; output a list
;******************************************************************
(define (*pp:print-list* lst pos)
(*pp:left-par*)
(set! pos (+ pos 1))
(*pp:print-expr* (car lst) pos) ; 1st element
(let ((last #f) (lst (cdr lst)))
(while (and (not (null? lst)) (not last))
(cond ((not (pair? lst))
(*pp:period*)
(*pp:print-expr* lst pos)
(set! last #t))
(else
(*pp:space*)
(*pp:print-expr* (car lst) pos)))
(if (not last) (set! lst (cdr lst)))))
(*pp:right-par*))
;******************************************************************
; define special forms
;******************************************************************
(define (printer-add form printer) ; add special pretty printers
(set! *printer-list*
(cons '()
(cons (cons form printer)
(cdr *printer-list*)))))
(printer-add 'quote *pp:print-quote*)
(printer-add 'quasiquote *pp:print-quote*)
(printer-add 'unquote *pp:print-quote*)
(printer-add 'unquote-splicing *pp:print-quote*)
(printer-add 'lambda *pp:print-lambda*)
(printer-add 'define *pp:print-sform*)
(printer-add 'define-macro *pp:print-sform*)
(printer-add 'extend-syntax *pp:print-sform*)
(printer-add 'when *pp:print-sform*)
(printer-add 'unless *pp:print-sform*)
(printer-add 'while *pp:print-sform*)
(printer-add 'let *pp:print-let*)
(printer-add 'letrec *pp:print-let*)
(printer-add 'let* *pp:print-let*)
(printer-add 'let-syntax *pp:print-let*)
(printer-add 'letrec-syntax *pp:print-let*)
(printer-add 'do *pp:print-do*)
(printer-add 'if *pp:print-if*)
(printer-add 'cond *pp:print-cond*)
(printer-add 'case *pp:print-case*)
(printer-add 'record-case *pp:print-case*)
(printer-add 'call-with-current-continuation *pp:print-sform0*)
(printer-add 'call/cc *pp:print-sform0*)