From 43eb4df4c75a4516a7b355ea034023b6ae77c852 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 13 Sep 2009 13:56:22 +0000 Subject: [PATCH] move pretty-print implementation from mzlib to scheme svn: r15990 original commit: 374a70d9f1c3aa14d78836c75fe64e3bc0c2365f --- collects/mzlib/pretty.ss | 1280 +------------------------------------- 1 file changed, 3 insertions(+), 1277 deletions(-) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index ee8f8db..3dcd8ee 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1,1277 +1,3 @@ -;; Originally: -;; "genwrite.scm" generic write used by pp.scm -;; copyright (c) 1991, marc feeley - -;; Pretty-printer for MzScheme -;; Handles structures, cycles, and graphs - -;; TO INSTALL this pretty-printer into a MzScheme's read-eval-print loop, -;; require this module and evaluate: -;; (current-print pretty-print-handler) - -(module pretty mzscheme - (require mzlib/private/port) - - (provide pretty-print - pretty-display - pretty-print-columns - pretty-print-depth - pretty-print-handler - pretty-print-size-hook - pretty-print-print-hook - pretty-print-pre-print-hook - pretty-print-post-print-hook - pretty-print-print-line - pretty-print-show-inexactness - pretty-print-exact-as-decimal - pretty-print-.-symbol-without-bars - pretty-print-abbreviate-read-macros - - pretty-print-style-table? - pretty-print-current-style-table - pretty-print-extend-style-table - pretty-print-remap-stylable - - pretty-format - pretty-printing - pretty-print-newline - make-tentative-pretty-print-output-port - tentative-pretty-print-port-transfer - tentative-pretty-print-port-cancel) - - (define-struct pretty-print-style-table (hash)) - - (define pretty-print-extend-style-table - (lambda (table symbols like-symbols) - (let ([terr (lambda (kind which) - (raise-type-error - 'pretty-print-extend-style-table - kind - which - table symbols like-symbols))]) - (unless (or (not table) (pretty-print-style-table? table)) - (terr "pretty-print style table or #f" 0)) - (unless (and (list? symbols) - (andmap symbol? symbols)) - (terr "list of symbols" 1)) - (unless (and (list? like-symbols) - (andmap symbol? like-symbols)) - (terr "list of symbols" 1)) - (unless (= (length symbols) (length like-symbols)) - (raise-mismatch-error - 'pretty-print-extend-style-table - (format "length of first list (~a) doesn't match the length of the second list (~a): " - (length symbols) (length like-symbols)) - like-symbols))) - (let ([ht (if table (pretty-print-style-table-hash table) (make-hash-table))] - [new-ht (make-hash-table)]) - (hash-table-for-each - ht - (lambda (key val) - (hash-table-put! new-ht key val))) - (for-each - (lambda (symbol like-symbol) - (let ((s (hash-table-get ht - like-symbol - (lambda () #f)))) - (hash-table-put! new-ht symbol (or s like-symbol)))) - symbols like-symbols) - (make-pretty-print-style-table new-ht)))) - - (define pretty-print-abbreviate-read-macros (make-parameter #t)) - - (define pretty-print-current-style-table - (make-parameter - (pretty-print-extend-style-table #f null null) - (lambda (s) - (unless (pretty-print-style-table? s) - (raise-type-error - 'pretty-print-current-style-table - "pretty-print style table" - s)) - s))) - - (define pretty-print-.-symbol-without-bars - (make-parameter #f (lambda (x) (and x #t)))) - - (define pretty-print-show-inexactness - (make-parameter #f - (lambda (x) (and x #t)))) - - (define pretty-print-exact-as-decimal - (make-parameter #f - (lambda (x) (and x #t)))) - - (define pretty-print-columns - (make-parameter 79 - (lambda (x) - (unless (or (eq? x 'infinity) - (integer? x)) - (raise-type-error - 'pretty-print-columns - "integer or 'infinity" - x)) - x))) - - (define pretty-print-depth - (make-parameter #f - (lambda (x) - (unless (or (not x) (number? x)) - (raise-type-error - 'pretty-print-depth - "number or #f" - x)) - x))) - - (define can-accept-n? - (lambda (n x) - (procedure-arity-includes? x n))) - - (define pretty-print-size-hook - (make-parameter (lambda (x display? port) #f) - (lambda (x) - (unless (can-accept-n? 3 x) - (raise-type-error - 'pretty-print-size-hook - "procedure of 3 arguments" - x)) - x))) - - (define pretty-print-print-hook - (make-parameter void - (lambda (x) - (unless (can-accept-n? 3 x) - (raise-type-error - 'pretty-print-print-hook - "procedure of 3 arguments" - x)) - x))) - - (define pretty-print-print-line - (make-parameter (lambda (line port offset width) - (when (and (number? width) - (not (eq? 0 line))) - (newline port)) - 0) - (lambda (x) - (unless (can-accept-n? 4 x) - (raise-type-error - 'pretty-print-print-line - "procedure of 4 arguments" - x)) - x))) - - (define pretty-print-pre-print-hook - (make-parameter void - (lambda (x) - (unless (can-accept-n? 2 x) - (raise-type-error - 'pretty-print-pre-print-hook - "procedure of 2 arguments" - x)) - x))) - - (define pretty-print-post-print-hook - (make-parameter void - (lambda (x) - (unless (can-accept-n? 2 x) - (raise-type-error - 'pretty-print-post-print-hook - "procedure of 2 arguments" - x)) - x))) - - (define pretty-printing - (make-parameter #f (lambda (x) (and x #t)))) - - (define pretty-print-remap-stylable - (make-parameter (λ (x) #f) - (λ (f) - (unless (can-accept-n? 1 f) - (raise-type-error - 'pretty-print-remap-stylable - "procedure of 1 argument" - f)) - (λ (x) - (let ([res (f x)]) - (unless (or (not res) (symbol? res)) - (raise-type-error - 'pretty-print-remap-stylable - "result of parameter function to be a symbol or #f" - res)) - res))))) - - (define make-pretty-print - (lambda (display?) - (letrec ([pretty-print - (case-lambda - [(obj port) - (let ([width (pretty-print-columns)] - [size-hook (pretty-print-size-hook)] - [print-hook (pretty-print-print-hook)] - [pre-hook (pretty-print-pre-print-hook)] - [post-hook (pretty-print-post-print-hook)]) - (generic-write obj display? - width - (make-printing-port port - pre-hook - post-hook - print-hook - (pretty-print-print-line)) - (print-graph) (print-struct) (print-hash-table) - (and (not display?) (print-vector-length)) (print-box) - (pretty-print-depth) - (lambda (o display?) - (size-hook o display? port))) - (void))] - [(obj) (pretty-print obj (current-output-port))])]) - pretty-print))) - - (define pretty-print (make-pretty-print #f)) - (define pretty-display (make-pretty-print #t)) - - (define-struct mark (str def)) - (define-struct hide (val)) - - (define (make-tentative-output-port pport width esc) - (let* ([content null] - [special-ok? (port-writes-special? pport)] - ;; The null device counts for us: - [/dev/null (let-values ([(line col pos) (port-next-location pport)]) - (relocate-output-port - (let ([p (open-output-nowhere special-ok?)]) - (port-count-lines! p) - p) - (or line 1) (or col 0) (or pos 1)))] - [check-esc (lambda () - (let-values ([(l c p) (port-next-location /dev/null)]) - (when (c . > . width) - (esc))))] - [p (make-output-port - 'tentative - always-evt - (lambda (s start end block? break?) - (write-bytes s /dev/null start end) - (check-esc) - (set! content (cons (subbytes s start end) content)) - (- end start)) - void - (and special-ok? - (lambda (special block break?) - (write-special special /dev/null) - (check-esc) - (set! content (cons (cons 'special special) content)) - #t)) - #f #f - (lambda () - (port-next-location /dev/null)))] - [first-line? #t]) - (port-count-lines! /dev/null) - (port-count-lines! p) - (register-printing-port p - (make-print-port-info - (lambda () (reverse content)) - (box #t) - (lambda (v) - (set! content (cons (cons 'pre v) content))) - (lambda (v) - (set! content (cons (cons 'post v) content))) - (lambda (v len display?) - (display (make-string len #\.) /dev/null) - (set! content (cons (list* 'hooked v len display?) - content))) - (lambda (use-line? offset width) - (when (and (number? width) - (not first-line?)) - (newline p)) - (set! first-line? #f) - 0) - esc)) - p)) - - (define (make-tentative-pretty-print-output-port pport width esc) - (let ([p (make-tentative-output-port pport width esc)]) - (port-write-handler p (port-write-handler pport)) - (port-display-handler p (port-display-handler pport)) - (port-print-handler p (port-print-handler pport)) - p)) - - (define (make-printing-port port pre-print post-print output-hooked print-line) - (let-values ([(line col pos) (port-next-location port)]) - (let* ([orig-counts? (and line col pos)] - [p (if orig-counts? - (relocate-output-port port line col pos #f) - (transplant-output-port port #f 1 #f))] - [line -1]) - (port-count-lines! p) - (register-printing-port p - (make-print-port-info - (lambda () null) - (box #t) - (lambda (v) - (pre-print v port)) - (lambda (v) - (post-print v port)) - (lambda (v len display?) - (output-hooked v display? p)) - (lambda (use-line? offset width) - (set! line (add1 line)) - (print-line (and use-line? line) p offset width)) - void)) - p))) - - (define printing-ports (make-hash-table 'weak)) - - (define-struct print-port-info (get-content - def-box - pre-print - post-print - output-hooked - print-line - esc)) - - (define (register-printing-port p info) - (hash-table-put! printing-ports p (make-ephemeron p info))) - - (define (register-printing-port-like p pport) - (hash-table-put! printing-ports p - (make-ephemeron p - (ephemeron-value (hash-table-get printing-ports pport))))) - - (define (get pport selector) - (let ([e (hash-table-get printing-ports pport (lambda () #f))]) - (selector (if e - (ephemeron-value e) - (make-print-port-info - (lambda () null) - (box #t) - void void void void void))))) - - (define (printing-port-pre-print pport) - (get pport print-port-info-pre-print)) - (define (printing-port-post-print pport) - (get pport print-port-info-post-print)) - (define (printing-port-def-box pport) - (get pport print-port-info-def-box)) - (define (printing-port-output-hooked pport) - (get pport print-port-info-output-hooked)) - (define (printing-port-print-line pport) - (get pport print-port-info-print-line)) - (define (printing-port-esc pport) - (get pport print-port-info-esc)) - - (define orig-display (port-display-handler (open-output-string))) - (define orig-write (port-write-handler (open-output-string))) - - (define (pretty-print-newline pport width) - (let-values ([(l col p) (port-next-location pport)]) - ((printing-port-print-line pport) #t (or col 0) width))) - - (define (tentative-pretty-print-port-transfer a-pport pport) - (let ([content ((get a-pport print-port-info-get-content))]) - (for-each (lambda (elem) - (if (bytes? elem) - (write-bytes elem pport) - (case (car elem) - [(special) (write-special (cdr elem) pport)] - [(pre) ((printing-port-pre-print pport) (cdr elem))] - [(post) ((printing-port-post-print pport) (cdr elem))] - [(hooked) ((printing-port-output-hooked pport) - (cadr elem) (caddr elem) (cdddr elem))]))) - content))) - - (define (tentative-pretty-print-port-cancel pport) - (set-box! (get pport print-port-info-def-box) #f)) - - (define (add-spaces n port) - (if (> n 0) - (if (> n 7) - (begin - (write-string " " port) - (add-spaces (- n 8) port)) - (write-string " " port 0 n)))) - - (define (prefab?! obj v) - (let ([d (prefab-struct-key obj)]) - (and d - (begin - (vector-set! v 0 d) - #t)))) - - (define (generic-write obj display? width pport - print-graph? print-struct? print-hash-table? print-vec-length? print-box? - depth size-hook) - - (define pair-open (if (print-pair-curly-braces) "{" "(")) - (define pair-close (if (print-pair-curly-braces) "}" ")")) - (define mpair-open (if (print-mpair-curly-braces) "{" "(")) - (define mpair-close (if (print-mpair-curly-braces) "}" ")")) - - (define table (make-hash-table)) ; Hash table for looking for loops - - (define show-inexactness? (pretty-print-show-inexactness)) - (define exact-as-decimal? (pretty-print-exact-as-decimal)) - - (define vector->repeatless-list - (if print-vec-length? - (lambda (v) - (let ([len (vector-length v)]) - (if (zero? len) - null - (let ([last (vector-ref v (sub1 len))]) - (let loop ([i (- len 2)]) - (if (i . < . 0) - (list last) - (let ([e (vector-ref v i)]) - (if (eq? e last) - (loop (sub1 i)) - (let loop ([i (sub1 i)][r (list e last)]) - (if (i . < . 0) - r - (loop (sub1 i) (cons (vector-ref v i) r)))))))))))) - vector->list)) - - (define (extract-sub-objects obj pport) - (let ([p (open-output-nowhere 'null (port-writes-special? pport))] - [l null]) - (let ([record (lambda (o p) (set! l (cons o l)))]) - (port-write-handler p record) - (port-display-handler p record) - (port-print-handler p record)) - (parameterize ([pretty-printing #f]) - ((custom-write-accessor obj) obj p #f)) - l)) - - (define found-cycle - (or print-graph? - (let loop ([obj obj]) - (and (or (vector? obj) - (pair? obj) - (mpair? obj) - (and (box? obj) - print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash-table? obj) print-hash-table?)) - (or (hash-table-get table obj (lambda () #f)) - (begin - (hash-table-put! table obj #t) - (let ([cycle - (cond - [(vector? obj) - (let ([len (vector-length obj)]) - (let vloop ([i 0]) - (if (= i len) - #f - (or (loop (vector-ref obj i)) - (vloop (add1 i))))))] - [(pair? obj) - (or (loop (car obj)) - (loop (cdr obj)))] - [(mpair? obj) - (or (loop (mcar obj)) - (loop (mcdr obj)))] - [(and (box? obj) print-box?) (loop (unbox obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (loop (extract-sub-objects obj pport))] - [(struct? obj) - (ormap loop - (vector->list (struct->vector obj)))] - [(hash-table? obj) - (let/ec esc - (hash-table-for-each - obj - (lambda (v k) - (when (or (loop v) - (loop k)) - (esc #t)))) - #f)])]) - (hash-table-remove! table obj) - cycle))))))) - - (define __dummy__ - (when found-cycle - (let loop ([obj obj]) - (if (or (vector? obj) - (pair? obj) - (mpair? obj) - (and (box? obj) - print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash-table? obj) print-hash-table?)) - ;; A little confusing: use #t for not-found - (let ([p (hash-table-get table obj (lambda () #t))]) - (when (not (mark? p)) - (if p - (begin - (hash-table-put! table obj #f) - (cond - [(vector? obj) - (let ([len (vector-length obj)]) - (let vloop ([i 0]) - (unless (= i len) - (loop (vector-ref obj i)) - (vloop (add1 i)))))] - [(pair? obj) - (loop (car obj)) - (loop (cdr obj))] - [(mpair? obj) - (loop (mcar obj)) - (loop (mcdr obj))] - [(and (box? obj) print-box?) (loop (unbox obj))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (loop (extract-sub-objects obj pport))] - [(struct? obj) - (for-each loop - (vector->list (struct->vector obj)))] - [(hash-table? obj) - (hash-table-for-each - obj - (lambda (k v) - (loop k) - (loop v)))])) - (begin - (hash-table-put! table obj - (make-mark #f (box #f))))))))))) - - (define cycle-counter 0) - - (define found (if found-cycle - table - #f)) - - (define dsub1 (lambda (d) - (if d - (sub1 d) - #f))) - - (define (pre-print pport obj) - ((printing-port-pre-print pport) obj)) - (define (post-print pport obj) - ((printing-port-post-print pport) - obj)) - (define (output-hooked pport obj len display?) - ((printing-port-output-hooked pport) - obj len display?)) - - (define expr-found - (lambda (pport ref) - (let ([n cycle-counter]) - (set! cycle-counter (add1 cycle-counter)) - (set-mark-str! ref - (string-append "#" - (number->string n) - "#")) - (set-mark-def! ref (printing-port-def-box pport)) - (display (string-append "#" - (number->string n) - "=") - pport)))) - - (define check-expr-found - (lambda (obj pport check? c-k d-k n-k) - (let ([ref (and check? - found - (hash-table-get found obj (lambda () #f)))]) - (if (and ref (unbox (mark-def ref))) - (if c-k - (c-k (mark-str ref)) - (display (mark-str ref) pport)) - (if (and ref d-k) - (d-k) - (begin - (when ref - (expr-found pport ref)) - (n-k))))))) - - (define (write-custom recur obj pport depth display? width) - (let-values ([(l c p) (port-next-location pport)]) - (let ([p (relocate-output-port pport l c p)]) - (port-count-lines! p) - (let ([writer (lambda (v port) - (recur port v (dsub1 depth) #f))] - [displayer (lambda (v port) - (recur port v (dsub1 depth) #t))]) - (port-write-handler p writer) - (port-display-handler p displayer) - (port-print-handler p writer)) - (register-printing-port-like p pport) - (parameterize ([pretty-printing #t] - [pretty-print-columns (or width 'infinity)]) - ((custom-write-accessor obj) obj p (not display?)))))) - - ;; ------------------------------------------------------------ - ;; wr: write on a single line - (define (wr* pport obj depth display?) - - (define (out str) - (write-string str pport)) - - (define (wr obj depth) - (wr* pport obj depth display?)) - - (define (wr-expr expr depth pair? car cdr open close) - (if (and (read-macro? expr pair? car cdr) - (equal? open "(")) - (begin - (out (read-macro-prefix expr car)) - (wr (read-macro-body expr car cdr) depth)) - (wr-lst expr #t depth pair? car cdr open close))) - - (define (wr-lst l check? depth pair? car cdr open close) - (if (pair? l) - (check-expr-found - l pport check? - #f #f - (lambda () - (if (and depth (zero? depth)) - (begin - (out open) - (out "...") - (out close)) - (begin - (out open) - (wr (car l) (dsub1 depth)) - (let loop ([l (cdr l)]) - (check-expr-found - l pport (and check? (pair? l)) - (lambda (s) (out " . ") (out s) (out close)) - (lambda () - (out " . ") - (wr-lst l check? (dsub1 depth) pair? car cdr open close) - (out close)) - (lambda () - (cond - [(pair? l) - (if (and (eq? (car l) 'unquote) - (pair? (cdr l)) - (null? (cdr (cdr l)))) - (begin - (out " . ,") - (wr (car (cdr l)) (dsub1 depth)) - (out close)) - (begin - (out " ") - (wr (car l) (dsub1 depth)) - (loop (cdr l))))] - [(null? l) (out close)] - [else - (out " . ") - (wr l (dsub1 depth)) - (out close)])))))))) - (begin - (out open) - (out close)))) - - (unless (hide? obj) - (pre-print pport obj)) - (if (and depth - (negative? depth) - (not (hide? obj))) - (out "...") - - (cond - [(size-hook obj display?) - => (lambda (len) - (output-hooked pport obj len display?))] - - [(pair? obj) - (wr-expr obj depth pair? car cdr pair-open pair-close)] - [(mpair? obj) - (wr-expr obj depth mpair? mcar mcdr mpair-open mpair-close)] - [(null? obj) - (wr-lst obj #f depth pair? car cdr "(" ")")] - [(vector? obj) - (check-expr-found - obj pport #t - #f #f - (lambda () - (out "#") - (when print-vec-length? - (out (number->string (vector-length obj)))) - (wr-lst (vector->repeatless-list obj) #f depth pair? car cdr "(" ")")))] - [(and (box? obj) - print-box?) - (check-expr-found - obj pport #t - #f #f - (lambda () - (out "#&") - (wr (unbox obj) (dsub1 depth))))] - [(and (custom-write? obj) - (not (struct-type? obj))) - (check-expr-found - obj pport #t - #f #f - (lambda () - (parameterize ([pretty-print-columns 'infinity]) - (write-custom wr* obj pport depth display? width))))] - [(struct? obj) - (if (and print-struct? - (not (and depth - (zero? depth)))) - (check-expr-found - obj pport #t - #f #f - (lambda () - (out "#") - (let ([v (struct->vector obj)]) - (when (prefab?! obj v) - (out "s")) - (wr-lst (vector->list v) #f (dsub1 depth) pair? car cdr "(" ")")))) - (parameterize ([print-struct #f]) - ((if display? orig-display orig-write) obj pport)))] - [(hash-table? obj) - (if (and print-hash-table? - (not (and depth - (zero? depth)))) - (check-expr-found - obj pport #t - #f #f - (lambda () - (out (if (hash-table? obj 'equal) - "#hash" - (if (hash-table? obj 'eqv) - "#hasheqv" - "#hasheq"))) - (wr-lst (hash-table-map obj (lambda (k v) - (cons k (make-hide v)))) - #f depth - pair? car cdr "(" ")"))) - (parameterize ([print-hash-table #f]) - ((if display? orig-display orig-write) obj pport)))] - [(hide? obj) - (wr* pport (hide-val obj) depth display?)] - [(boolean? obj) - (out (if obj "#t" "#f"))] - [(number? obj) - (when (and show-inexactness? - (inexact? obj)) - (out "#i")) - (out ((if exact-as-decimal? - number->decimal-string - number->string) - obj))] - [(and (pretty-print-.-symbol-without-bars) - (eq? obj '|.|)) - (out ".")] - [else - ((if display? orig-display orig-write) obj pport)])) - (unless (hide? obj) - (post-print pport obj))) - - ;; ------------------------------------------------------------ - ;; pp: write on (potentially) multiple lines - (define (pp* pport obj depth display?) - - (define (pp obj depth) - (pp* pport obj depth display?)) - - (define (out str) - (write-string str pport)) - - (define (spaces n) - (add-spaces n pport)) - - (define (ccol) - (let-values ([(l col p) (port-next-location pport)]) - col)) - - (define (indent to) - (let ([col (ccol)]) - (if (< to col) - (begin - (let ([col ((printing-port-print-line pport) #t col width)]) - (spaces (- to col)))) - (spaces (max 0 (- to col)))))) - - (define (pr obj extra pp-pair depth) - ;; may have to split on multiple lines - (let* ([can-multi (and width - (not (size-hook obj display?)) - (or (pair? obj) - (mpair? obj) - (vector? obj) - (and (box? obj) print-box?) - (and (custom-write? obj) - (not (struct-type? obj))) - (and (struct? obj) print-struct?) - (and (hash-table? obj) print-hash-table?)))] - [graph-ref (if can-multi - (and found (hash-table-get found obj (lambda () #f))) - #f)] - [old-counter cycle-counter]) - (if (and can-multi - (or (not graph-ref) - (not (unbox (mark-def graph-ref))))) - ;; It might be possible to split obj across lines. - ;; Try writing the obj, but accumulate the info that goes out - ;; into a-pport - (let ([a-pport - (let/ec esc - (letrec ([a-pport (make-tentative-output-port - pport - (- width extra) - (lambda () (esc a-pport)))]) - ;; Here's the attempt to write on one line: - (wr* a-pport obj depth display?) - a-pport))]) - (let-values ([(l c p) (port-next-location a-pport)]) - (if (<= c (- width extra)) - ;; All can be printed on one line, so just dump the - ;; accumulated text - (tentative-pretty-print-port-transfer a-pport pport) - ;; Doesn't fit on one line, so start over - (begin - (tentative-pretty-print-port-cancel a-pport) - (set! cycle-counter old-counter) - (when graph-ref - (expr-found pport graph-ref)) - (pre-print pport obj) - (cond - [(pair? obj) (pp-pair obj extra depth - pair? car cdr pair-open pair-close)] - [(mpair? obj) (pp-pair obj extra depth - mpair? mcar mcdr mpair-open mpair-close)] - [(vector? obj) - (out "#") - (when print-vec-length? - (out (number->string (vector-length obj)))) - (pp-list (vector->repeatless-list obj) extra pp-expr #f depth - pair? car cdr pair-open pair-close)] - [(and (custom-write? obj) - (not (struct-type? obj))) - (write-custom pp* obj pport depth display? width)] - [(struct? obj) ; print-struct is on if we got here - (out "#") - (let ([v (struct->vector obj)]) - (when (prefab?! obj v) - (out "s")) - (pp-list (vector->list v) extra pp-expr #f depth - pair? car cdr pair-open pair-close))] - [(hash-table? obj) - (out (if (hash-table? obj 'equal) - "#hash" - (if (hash-table? obj 'eqv) - "#hasheqv" - "#hasheq"))) - (pp-list (hash-table-map obj cons) extra pp-expr #f depth - pair? car cdr pair-open pair-close)] - [(and (box? obj) print-box?) - (out "#&") - (pr (unbox obj) extra pp-pair depth)]) - (post-print pport obj))))) - ;; Not possible to split obj across lines; so just write directly - (wr* pport obj depth display?)))) - - (define (pp-expr expr extra depth - apair? acar acdr open close) - (if (and (read-macro? expr apair? acar acdr) - (equal? open "(") - (not (and found (hash-table-get found (acdr expr) #f)))) - (begin - (out (read-macro-prefix expr acar)) - (pr (read-macro-body expr acar acdr) - extra - pp-expr - depth)) - (let ((head (acar expr))) - (if (or (and (symbol? head) - (not (size-hook head display?))) - ((pretty-print-remap-stylable) head)) - (let ((proc (style head expr apair? acar acdr))) - (if proc - (proc expr extra depth - apair? acar acdr open close) - (if (and #f - ;; Why this special case? Currently disabled. - (> (string-length - (symbol->string - (if (symbol? head) - head - ((pretty-print-remap-stylable) head)))) - max-call-head-width)) - (pp-general expr extra #f #f #f pp-expr depth - apair? acar acdr open close) - (pp-list expr extra pp-expr #t depth - apair? acar acdr open close)))) - (pp-list expr extra pp-expr #t depth - apair? acar acdr open close))))) - - (define (wr obj depth) - (wr* pport obj depth display?)) - - ;; (head item1 - ;; item2 - ;; item3) - (define (pp-call expr extra pp-item depth - apair? acar acdr open close) - (out open) - (wr (acar expr) (dsub1 depth)) - (let ([col (+ (ccol) 1)]) - (pp-down close (acdr expr) col col extra pp-item #t #t depth - apair? acar acdr open close))) - - ;; (head item1 item2 - ;; item3 - ;; item4) - (define (pp-two-up expr extra pp-item depth - apair? acar acdr open close) - (out open) - (let ([col (ccol)]) - (wr (acar expr) (dsub1 depth)) - (out " ") - (wr (acar (acdr expr)) (dsub1 depth)) - (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth - apair? acar acdr open close))) - - ;; (head item1 - ;; item2 - ;; item3) - (define (pp-one-up expr extra pp-item depth - apair? acar acdr open close) - (out open) - (let ([col (ccol)]) - (wr (acar expr) (dsub1 depth)) - (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth - apair? acar acdr open close))) - - ;; (item1 - ;; item2 - ;; item3) - (define (pp-list l extra pp-item check? depth - apair? acar acdr open close) - (out open) - (let ([col (ccol)]) - (pp-down close l col col extra pp-item #f check? depth - apair? acar acdr open close))) - - (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth - apair? acar acdr open close) - (let loop ([l l] [icol col1] [check? check-first?]) - (check-expr-found - l pport (and check? (apair? l)) - (lambda (s) - (indent col2) - (out ".") - (indent col2) - (out s) - (out closer)) - (lambda () - (indent col2) - (out ".") - (indent col2) - (pr l extra pp-item depth) - (out closer)) - (lambda () - (cond - [(apair? l) - (let ([rest (acdr l)]) - (let ([extra (if (null? rest) (+ extra 1) 0)]) - (indent icol) - (pr (acar l) extra pp-item (dsub1 depth)) - (loop rest col2 check-rest?)))] - [(null? l) - (out closer)] - [else - (indent col2) - (out ".") - (indent col2) - (pr l (+ extra 1) pp-item (dsub1 depth)) - (out closer)]))))) - - (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth - apair? acar acdr open close) - - (define (tail1 rest col1 col3) - (if (and pp-1 (apair? rest)) - (let* ((val1 (acar rest)) - (rest (acdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (indent col3) - (pr val1 extra pp-1 depth) - (tail2 rest col1 col3)) - (tail2 rest col1 col3))) - - (define (tail2 rest col1 col3) - (if (and pp-2 (apair? rest)) - (let* ((val1 (acar rest)) - (rest (acdr rest)) - (extra (if (null? rest) (+ extra 1) 0))) - (indent col3) - (pr val1 extra pp-2 depth) - (tail3 rest col1)) - (tail3 rest col1))) - - (define (tail3 rest col1) - (pp-down close rest col1 col1 extra pp-3 #f #t depth - apair? acar acdr open close)) - - (let* ([head (acar expr)] - [rest (acdr expr)] - [col (ccol)]) - (out open) - (wr head (dsub1 depth)) - (if (and named? (apair? rest)) - (let* ((name (acar rest)) - (rest (acdr rest))) - (out " ") - (wr name (dsub1 depth)) - (tail1 rest (+ col indent-general) (+ (ccol) 1))) - (tail1 rest (+ col indent-general) (+ (ccol) 1))))) - - (define (pp-expr-list l extra depth - apair? acar acdr open close) - (pp-list l extra pp-expr #t depth - apair? acar acdr open close)) - - (define (pp-lambda expr extra depth - apair? acar acdr open close) - (pp-general expr extra #f pp-expr-list #f pp-expr depth - apair? acar acdr open close)) - - (define (pp-if expr extra depth - apair? acar acdr open close) - (pp-general expr extra #f pp-expr #f pp-expr depth - apair? acar acdr open close)) - - (define (pp-cond expr extra depth - apair? acar acdr open close) - (pp-list expr extra pp-expr-list #t depth - apair? acar acdr open close)) - - (define (pp-syntax-case expr extra depth - apair? acar acdr open close) - (pp-two-up expr extra pp-expr-list depth - apair? acar acdr open close)) - - (define (pp-module expr extra depth - apair? acar acdr open close) - (pp-two-up expr extra pp-expr depth - apair? acar acdr open close)) - - (define (pp-make-object expr extra depth - apair? acar acdr open close) - (pp-one-up expr extra pp-expr-list depth - apair? acar acdr open close)) - - (define (pp-case expr extra depth - apair? acar acdr open close) - (pp-general expr extra #f pp-expr #f pp-expr-list depth - apair? acar acdr open close)) - - (define (pp-and expr extra depth - apair? acar acdr open close) - (pp-call expr extra pp-expr depth - apair? acar acdr open close)) - - (define (pp-let expr extra depth - apair? acar acdr open close) - (let* ((rest (acdr expr)) - (named? (and (apair? rest) (symbol? (do-remap (acar rest)))))) - (pp-general expr extra named? pp-expr-list #f pp-expr depth - apair? acar acdr open close))) - - (define (pp-begin expr extra depth - apair? acar acdr open close) - (pp-general expr extra #f #f #f pp-expr depth - apair? acar acdr open close)) - - (define (pp-do expr extra depth - apair? acar acdr open close) - (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth - apair? acar acdr open close)) - - ;; define formatting style (change these to suit your style) - - (define indent-general 2) - - (define max-call-head-width 5) - - (define (no-sharing? expr count apair? acdr) - (if (apair? expr) - (if (and found - (hash-table-get found (acdr expr) #f)) - #f - (or (zero? count) - (no-sharing? (acdr expr) (sub1 count) apair? acdr))) - #f)) - - (define (style head expr apair? acar acdr) - (case (look-in-style-table head) - ((lambda λ define define-macro define-syntax - syntax-rules - shared - unless when) - (and (no-sharing? expr 1 apair? acdr) - pp-lambda)) - ((if set! set!-values) - (and (no-sharing? expr 1 apair? acdr) - pp-if)) - ((cond case-lambda) - (and (no-sharing? expr 0 apair? acdr) - pp-cond)) - ((case class) - (and (no-sharing? expr 1 apair? acdr) - pp-case)) - ((and or import export - require require-for-syntax require-for-template - provide link - public private override rename inherit field init) - (and (no-sharing? expr 0 apair? acdr) - pp-and)) - ((let letrec let* - let-values letrec-values let*-values - let-syntax letrec-syntax - let-syntaxes letrec-syntaxes) - (and (no-sharing? expr - (if (and (apair? (acdr expr)) - (symbol? (acar (acdr expr)))) - 2 - 1) - apair? - acdr) - pp-let)) - ((begin begin0) - (and (no-sharing? expr 0 apair? acdr) - pp-begin)) - ((do letrec-syntaxes+values) - (and (no-sharing? expr 2 apair? acdr) - pp-do)) - ((module) - (and (no-sharing? expr 2 apair? acdr) - pp-module)) - ((send syntax-case instantiate) - (and (no-sharing? expr 2 apair? acdr) - pp-syntax-case)) - ((make-object) - (and (no-sharing? expr 1 apair? acdr) - pp-make-object)) - - (else #f))) - - (pr obj 0 pp-expr depth)) - - ;; ------------------------------------------------------------ - ;; This is where generic-write's body expressions start - - ((printing-port-print-line pport) #t 0 width) - (let-values ([(l col p) (port-next-location pport)]) - (if (and width (not (eq? width 'infinity))) - (pp* pport obj depth display?) - (wr* pport obj depth display?))) - (let-values ([(l col p) (port-next-location pport)]) - ((printing-port-print-line pport) #f col width))) - - (define (look-in-style-table raw-head) - (let ([head (do-remap raw-head)]) - (or (hash-table-get (pretty-print-style-table-hash - (pretty-print-current-style-table)) - head - #f) - head))) - - (define (do-remap raw-head) - (cond - [((pretty-print-remap-stylable) raw-head) - => - values] - [else raw-head])) - - (define (read-macro? l pair? car cdr) - (define (length1? l) (and (pair? l) (null? (cdr l)))) - (and (pretty-print-abbreviate-read-macros) - (let ((head (do-remap (car l))) (tail (cdr l))) - (case head - ((quote quasiquote unquote unquote-splicing syntax unsyntax unsyntax-splicing) - (length1? tail)) - (else #f))))) - - (define (read-macro-body l car cdr) - (car (cdr l))) - - (define (read-macro-prefix l car) - (let ((head (do-remap (car l)))) - (case head - ((quote) "'") - ((quasiquote) "`") - ((unquote) ",") - ((unquote-splicing) ",@") - ((syntax) "#'") - ((unsyntax) "#,") - ((unsyntax-splicing) "#,@")))) - - (define pretty-print-handler - (lambda (v) - (unless (void? v) - (pretty-print v)))) - - (define (number->decimal-string x) - (cond - [(or (inexact? x) - (integer? x)) - (number->string x)] - [(not (real? x)) - (let ([r (real-part x)] - [i (imag-part x)]) - (format "~a~a~ai" - (number->decimal-string r) - (if (negative? i) - "" - "+") - (number->decimal-string i)))] - [else - (let ([n (numerator x)] - [d (denominator x)]) - ;; Count powers of 2 in denomintor - (let loop ([v d][2-power 0]) - (if (and (positive? v) - (even? v)) - (loop (arithmetic-shift v -1) (add1 2-power)) - ;; Count powers of 5 in denominator - (let loop ([v v][5-power 0]) - (if (zero? (remainder v 5)) - (loop (quotient v 5) (add1 5-power)) - ;; No more 2s or 5s. Anything left? - (if (= v 1) - ;; Denominator = (* (expt 2 2-power) (expt 5 5-power)). - ;; Print number as decimal. - (let* ([10-power (max 2-power 5-power)] - [scale (* (expt 2 (- 10-power 2-power)) - (expt 5 (- 10-power 5-power)))] - [s (number->string (* (abs n) scale))] - [orig-len (string-length s)] - [len (max (add1 10-power) orig-len)] - [padded-s (if (< orig-len len) - (string-append - (make-string (- len orig-len) #\0) - s) - s)]) - (format "~a~a.~a" - (if (negative? n) "-" "") - (substring padded-s 0 (- len 10-power)) - (substring padded-s (- len 10-power) len))) - ;; d has factor(s) other than 2 and 5. - ;; Print as a fraction. - (number->string x)))))))])) - - (define pretty-format - (case-lambda - [(t) (pretty-format t (pretty-print-columns))] - [(t w) - (parameterize ([pretty-print-columns w]) - (let ([op (open-output-string)]) - (pretty-print t op) - (let ([s (get-output-string op)]) - (if (eq? w 'infinity) - s - (substring s 0 (- (string-length s) 1))))))])) - - - ) - +(module pretty scheme/base + (require scheme/pretty) + (provide (all-from-out scheme/pretty)))