suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

reformat pretty.rkt a bit

Browse Source 
#lang instead of module, spaces instead of tabs, other whitespace and
indentation
This commit is contained in:
AlexKnauth 2016-08-13 09:17:47 -05:00 committed by Robby Findler
parent 1478f64c14
commit 1af7ec7088
1 changed files with 1607 additions and 1607 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
racket/collects/racket/pretty.rkt
View File

@ -9,12 +9,12 @@
;; require this module and evaluate: ;; require this module and evaluate:
;; (current-print pretty-print-handler) ;; (current-print pretty-print-handler)
(module pretty racket/base #lang racket/base
(require racket/private/port (require racket/private/port
racket/flonum racket/flonum
racket/fixnum) racket/fixnum)
(provide pretty-print (provide pretty-print
pretty-write pretty-write
pretty-display pretty-display
pretty-print-columns pretty-print-columns
@ -42,9 +42,9 @@
tentative-pretty-print-port-transfer tentative-pretty-print-port-transfer
tentative-pretty-print-port-cancel) tentative-pretty-print-port-cancel)
(define-struct pretty-print-style-table (hash)) (define-struct pretty-print-style-table (hash))
(define pretty-print-extend-style-table (define pretty-print-extend-style-table
(lambda (table symbols like-symbols) (lambda (table symbols like-symbols)
(let ([terr (lambda (kind which) (let ([terr (lambda (kind which)
(raise-argument-error (raise-argument-error
@ -83,9 +83,9 @@
symbols like-symbols) symbols like-symbols)
(make-pretty-print-style-table new-ht)))) (make-pretty-print-style-table new-ht))))
(define pretty-print-abbreviate-read-macros (make-parameter #t)) (define pretty-print-abbreviate-read-macros (make-parameter #t))
(define pretty-print-current-style-table (define pretty-print-current-style-table
(make-parameter (make-parameter
(pretty-print-extend-style-table #f null null) (pretty-print-extend-style-table #f null null)
(lambda (s) (lambda (s)
@ -96,18 +96,18 @@
s)) s))
s))) s)))
(define pretty-print-.-symbol-without-bars (define pretty-print-.-symbol-without-bars
(make-parameter #f (lambda (x) (and x #t)))) (make-parameter #f (lambda (x) (and x #t))))
(define pretty-print-show-inexactness (define pretty-print-show-inexactness
(make-parameter #f (make-parameter #f
(lambda (x) (and x #t)))) (lambda (x) (and x #t))))
(define pretty-print-exact-as-decimal (define pretty-print-exact-as-decimal
(make-parameter #f (make-parameter #f
(lambda (x) (and x #t)))) (lambda (x) (and x #t))))
(define pretty-print-columns (define pretty-print-columns
(make-parameter 79 (make-parameter 79
(lambda (x) (lambda (x)
(unless (or (eq? x 'infinity) (unless (or (eq? x 'infinity)
@ -118,7 +118,7 @@
x)) x))
x))) x)))
(define pretty-print-depth (define pretty-print-depth
(make-parameter #f (make-parameter #f
(lambda (x) (lambda (x)
(unless (or (not x) (number? x)) (unless (or (not x) (number? x))
@ -128,11 +128,11 @@
x)) x))
x))) x)))
(define can-accept-n? (define can-accept-n?
(lambda (n x) (lambda (n x)
(procedure-arity-includes? x n))) (procedure-arity-includes? x n)))
(define pretty-print-size-hook (define pretty-print-size-hook
(make-parameter (lambda (x display? port) #f) (make-parameter (lambda (x display? port) #f)
(lambda (x) (lambda (x)
(unless (can-accept-n? 3 x) (unless (can-accept-n? 3 x)
@ -142,7 +142,7 @@
x)) x))
x))) x)))
(define pretty-print-print-hook (define pretty-print-print-hook
(make-parameter void (make-parameter void
(lambda (x) (lambda (x)
(unless (can-accept-n? 3 x) (unless (can-accept-n? 3 x)
@ -152,7 +152,7 @@
x)) x))
x))) x)))
(define pretty-print-print-line (define pretty-print-print-line
(make-parameter (lambda (line port offset width) (make-parameter (lambda (line port offset width)
(when (and (number? width) (when (and (number? width)
(not (eq? 0 line))) (not (eq? 0 line)))
@ -166,7 +166,7 @@
x)) x))
x))) x)))
(define pretty-print-pre-print-hook (define pretty-print-pre-print-hook
(make-parameter void (make-parameter void
(lambda (x) (lambda (x)
(unless (can-accept-n? 2 x) (unless (can-accept-n? 2 x)
@ -176,7 +176,7 @@
x)) x))
x))) x)))
(define pretty-print-post-print-hook (define pretty-print-post-print-hook
(make-parameter void (make-parameter void
(lambda (x) (lambda (x)
(unless (can-accept-n? 2 x) (unless (can-accept-n? 2 x)
@ -186,10 +186,10 @@
x)) x))
x))) x)))
(define pretty-printing (define pretty-printing
(make-parameter #f (lambda (x) (and x #t)))) (make-parameter #f (lambda (x) (and x #t))))
(define pretty-print-remap-stylable (define pretty-print-remap-stylable
(make-parameter (λ (x) #f) (make-parameter (λ (x) #f)
(λ (f) (λ (f)
(unless (can-accept-n? 1 f) (unless (can-accept-n? 1 f)
@ -206,7 +206,7 @@
res)) res))
res))))) res)))))
(define make-pretty-print (define make-pretty-print
(lambda (name display? as-qq?) (lambda (name display? as-qq?)
(letrec ([pretty-print (letrec ([pretty-print
(case-lambda (case-lambda
@ -239,20 +239,20 @@
[(obj) (pretty-print obj (current-output-port))])]) [(obj) (pretty-print obj (current-output-port))])])
pretty-print))) pretty-print)))
(define pretty-print (make-pretty-print 'pretty-print #f #t)) (define pretty-print (make-pretty-print 'pretty-print #f #t))
(define pretty-display (let ([pp (make-pretty-print 'pretty-display #t #f)]) (define pretty-display (let ([pp (make-pretty-print 'pretty-display #t #f)])
(case-lambda (case-lambda
[(v) (pp v)] [(v) (pp v)]
[(v o) (pp v o)]))) [(v o) (pp v o)])))
(define pretty-write (let ([pp (make-pretty-print 'pretty-write #f #f)]) (define pretty-write (let ([pp (make-pretty-print 'pretty-write #f #f)])
(case-lambda (case-lambda
[(v) (pp v)] [(v) (pp v)]
[(v o) (pp v o)]))) [(v o) (pp v o)])))
(define-struct mark (str def) #:mutable) (define-struct mark (str def) #:mutable)
(define-struct hide (val)) (define-struct hide (val))
(define (make-tentative-output-port pport width esc) (define (make-tentative-output-port pport width esc)
(let* ([content null] (let* ([content null]
[special-ok? (port-writes-special? pport)] [special-ok? (port-writes-special? pport)]
;; The null device counts for us: ;; The null device counts for us:
@ -309,14 +309,14 @@
0) 0)
esc)))) esc))))
(define (make-tentative-pretty-print-output-port pport width esc) (define (make-tentative-pretty-print-output-port pport width esc)
(let ([p (make-tentative-output-port pport width esc)]) (let ([p (make-tentative-output-port pport width esc)])
(port-write-handler p (port-write-handler pport)) (port-write-handler p (port-write-handler pport))
(port-display-handler p (port-display-handler pport)) (port-display-handler p (port-display-handler pport))
(port-print-handler p (port-print-handler pport)) (port-print-handler p (port-print-handler pport))
p)) p))
(define (make-printing-port port pre-print post-print output-hooked print-line) (define (make-printing-port port pre-print post-print output-hooked print-line)
(let-values ([(line col pos) (port-next-location port)]) (let-values ([(line col pos) (port-next-location port)])
(let* ([orig-counts? (and line col pos)] (let* ([orig-counts? (and line col pos)]
[p (if orig-counts? [p (if orig-counts?
@ -339,10 +339,10 @@
(print-line (and use-line? line) p offset width)) (print-line (and use-line? line) p offset width))
void))))) void)))))
(struct printing-port (port info) (struct printing-port (port info)
#:property prop:output-port 0) #:property prop:output-port 0)
(define-struct print-port-info (get-content (define-struct print-port-info (get-content
def-box def-box
pre-print pre-print
post-print post-print
@ -350,36 +350,36 @@
print-line print-line
esc)) esc))
(define (register-printing-port p info) (define (register-printing-port p info)
(printing-port p info)) (printing-port p info))
(define (register-printing-port-like p pport) (define (register-printing-port-like p pport)
(printing-port p (printing-port-info pport))) (printing-port p (printing-port-info pport)))
(define (get pport selector) (define (get pport selector)
(selector (printing-port-info pport))) (selector (printing-port-info pport)))
(define (printing-port-pre-print pport) (define (printing-port-pre-print pport)
(get pport print-port-info-pre-print)) (get pport print-port-info-pre-print))
(define (printing-port-post-print pport) (define (printing-port-post-print pport)
(get pport print-port-info-post-print)) (get pport print-port-info-post-print))
(define (printing-port-def-box pport) (define (printing-port-def-box pport)
(get pport print-port-info-def-box)) (get pport print-port-info-def-box))
(define (printing-port-output-hooked pport) (define (printing-port-output-hooked pport)
(get pport print-port-info-output-hooked)) (get pport print-port-info-output-hooked))
(define (printing-port-print-line pport) (define (printing-port-print-line pport)
(get pport print-port-info-print-line)) (get pport print-port-info-print-line))
(define (printing-port-esc pport) (define (printing-port-esc pport)
(get pport print-port-info-esc)) (get pport print-port-info-esc))
(define orig-display (port-display-handler (open-output-string))) (define orig-display (port-display-handler (open-output-string)))
(define orig-write (port-write-handler (open-output-string))) (define orig-write (port-write-handler (open-output-string)))
(define (pretty-print-newline pport width) (define (pretty-print-newline pport width)
(let-values ([(l col p) (port-next-location pport)]) (let-values ([(l col p) (port-next-location pport)])
((printing-port-print-line pport) #t (or col 0) width))) ((printing-port-print-line pport) #t (or col 0) width)))
(define (tentative-pretty-print-port-transfer a-pport pport) (define (tentative-pretty-print-port-transfer a-pport pport)
(let ([content ((get a-pport print-port-info-get-content))]) (let ([content ((get a-pport print-port-info-get-content))])
(for-each (lambda (elem) (for-each (lambda (elem)
(if (bytes? elem) (if (bytes? elem)
@ -392,10 +392,10 @@
(cadr elem) (caddr elem) (cdddr elem))]))) (cadr elem) (caddr elem) (cdddr elem))])))
content))) content)))
(define (tentative-pretty-print-port-cancel pport) (define (tentative-pretty-print-port-cancel pport)
(set-box! (get pport print-port-info-def-box) #f)) (set-box! (get pport print-port-info-def-box) #f))
(define (add-spaces n port) (define (add-spaces n port)
(if (> n 0) (if (> n 0)
(if (> n 7) (if (> n 7)
(begin (begin
@ -404,17 +404,17 @@
(write-string " " port 0 n)) (write-string " " port 0 n))
(void))) (void)))
(define (prefab?! obj v) (define (prefab?! obj v)
(let ([d (prefab-struct-key obj)]) (let ([d (prefab-struct-key obj)])
(and d (and d
(begin (begin
(vector-set! v 0 d) (vector-set! v 0 d)
#t)))) #t))))
(define-struct unquoted (val)) (define-struct unquoted (val))
(define struct-ellipses (string->uninterned-symbol "...")) (define struct-ellipses (string->uninterned-symbol "..."))
(define (generic-write obj display? width pport (define (generic-write obj display? width pport
print-graph? print-struct? print-hash-table? print-vec-length? print-graph? print-struct? print-hash-table? print-vec-length?
print-box? print-as-qq? qq-depth print-box? print-as-qq? qq-depth
depth size-hook) depth size-hook)
@ -1527,7 +1527,7 @@
(let-values ([(l col p) (port-next-location pport)]) (let-values ([(l col p) (port-next-location pport)])
((printing-port-print-line pport) #f col width))) ((printing-port-print-line pport) #f col width)))
(define (look-in-style-table raw-head) (define (look-in-style-table raw-head)
(let ([head (do-remap raw-head)]) (let ([head (do-remap raw-head)])
(or (hash-ref (pretty-print-style-table-hash (or (hash-ref (pretty-print-style-table-hash
(pretty-print-current-style-table)) (pretty-print-current-style-table))
@ -1535,14 +1535,14 @@
#f) #f)
head))) head)))
(define (do-remap raw-head) (define (do-remap raw-head)
(cond (cond
[((pretty-print-remap-stylable) raw-head) [((pretty-print-remap-stylable) raw-head)
=> =>
values] values]
[else raw-head])) [else raw-head]))
(define (read-macro? l pair? car cdr qd) (define (read-macro? l pair? car cdr qd)
(define (length1? l) (and (pair? l) (null? (cdr l)))) (define (length1? l) (and (pair? l) (null? (cdr l))))
(and (pretty-print-abbreviate-read-macros) (and (pretty-print-abbreviate-read-macros)
(let ((head (do-remap (car l))) (tail (cdr l))) (let ((head (do-remap (car l))) (tail (cdr l)))
@ -1553,10 +1553,10 @@
(length1? tail)) (length1? tail))
(else #f))))) (else #f)))))
(define (read-macro-body l car cdr) (define (read-macro-body l car cdr)
(car (cdr l))) (car (cdr l)))
(define (read-macro-prefix l car) (define (read-macro-prefix l car)
(let ((head (do-remap (car l)))) (let ((head (do-remap (car l))))
(case head (case head
((quote) "'") ((quote) "'")
@ -1568,12 +1568,12 @@
((unsyntax) "#,") ((unsyntax) "#,")
((unsyntax-splicing) "#,@")))) ((unsyntax-splicing) "#,@"))))
(define pretty-print-handler (define pretty-print-handler
(lambda (v) (lambda (v)
(unless (void? v) (unless (void? v)
(pretty-print v)))) (pretty-print v))))
(define (number->decimal-string x) (define (number->decimal-string x)
(cond (cond
[(or (inexact? x) [(or (inexact? x)
(integer? x)) (integer? x))
@ -1622,7 +1622,7 @@
;; Print as a fraction. ;; Print as a fraction.
(number->string x)))))))])) (number->string x)))))))]))
(define (pretty-format t [w (pretty-print-columns)] #:mode [mode 'print]) (define (pretty-format t [w (pretty-print-columns)] #:mode [mode 'print])
(parameterize ([pretty-print-columns w]) (parameterize ([pretty-print-columns w])
(let ([op (open-output-string)]) (let ([op (open-output-string)])
((case mode ((case mode
@ -1637,5 +1637,5 @@
(substring s 0 (- (string-length s) 1))))))) (substring s 0 (- (string-length s) 1)))))))
)