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

add racket/private/custom-write

Browse Source
This commit is contained in:
Ryan Culpepper 2015-08-11 19:32:29 -04:00
parent 02574d2501
commit 59300afbef
2 changed files with 75 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
racket/collects/racket/private/custom-write.rkt Normal file
View File

@ -0,0 +1,75 @@
#lang racket/base
(require racket/pretty)
(provide make-constructor-style-printer)
;; make-constructor-style-printer : (Any -> (U String Symbol))
;; (Any -> (Sequenceof Any))
;; -> (Any OutputPort (U #t #f 0 1)) -> Void
(define (make-constructor-style-printer get-constructor get-contents)
(lambda (obj port mode)
(define (recur x p)
(case mode
((#t) (write x p))
((#f) (display x p))
((0 1) (print x p mode))))
;; Only two cases: 0 vs everything else
(define (print-prefix p)
(let ([prefix
(case mode
((0) "(")
(else "#<"))]
[constructor
(get-constructor obj)]
[post-constr
(case mode
((0) "")
(else ":"))])
(write-string prefix p)
(display constructor p)
(write-string post-constr p)))
(define (print-suffix p)
(let ([suffix
(case mode
((0) ")")
(else ">"))])
(write-string suffix p)))
(define (print-contents p leading-space)
(let ([lead (if leading-space (make-string (add1 leading-space) #\space) " ")])
(for ([elt (get-contents obj)]) ;; note: generic sequence
(when leading-space
(pretty-print-newline p (pretty-print-columns)))
(write-string lead p)
(recur elt p))))
(define (print/one-line p)
(print-prefix p)
(print-contents p #f)
(print-suffix p))
(define (print/multi-line p)
(let-values ([(line col pos) (port-next-location p)])
(print-prefix p)
(print-contents p col)
(print-suffix p)))
(cond [(and (pretty-printing)
(integer? (pretty-print-columns)))
((let/ec esc
(letrec ([tport
(make-tentative-pretty-print-output-port
port
(- (pretty-print-columns) 1)
(lambda ()
(esc
(lambda ()
(tentative-pretty-print-port-cancel tport)
(print/multi-line port)))))])
(print/one-line tport)
(tentative-pretty-print-port-transfer tport port))
void))]
[else
(print/one-line port)])
(void)))

71
racket/collects/unstable/custom-write.rkt
View File

@ -70,74 +70,3 @@ Constructor-style printer
(sequence-append (get-super-contents obj)
(get-new-contents obj)))
get-new-contents)))]))
;; ----
(define (make-constructor-style-printer get-constructor get-contents)
(lambda (obj port mode)
(define (recur x p)
(case mode
((#t) (write x p))
((#f) (display x p))
((0 1) (print x p mode))))
;; Only two cases: 0 vs everything else
(define (print-prefix p)
(let ([prefix
(case mode
((0) "(")
(else "#<"))]
[constructor
(get-constructor obj)]
[post-constr
(case mode
((0) "")
(else ":"))])
(write-string prefix p)
(display constructor p)
(write-string post-constr p)))
(define (print-suffix p)
(let ([suffix
(case mode
((0) ")")
(else ">"))])
(write-string suffix p)))
(define (print-contents p leading-space)
(let ([lead (if leading-space (make-string (add1 leading-space) #\space) " ")])
(for ([elt (get-contents obj)])
(when leading-space
(pretty-print-newline p (pretty-print-columns)))
(write-string lead p)
(recur elt p))))
(define (print/one-line p)
(print-prefix p)
(print-contents p #f)
(print-suffix p))
(define (print/multi-line p)
(let-values ([(line col pos) (port-next-location p)])
(print-prefix p)
(print-contents p col)
(print-suffix p)))
(cond [(and (pretty-printing)
(integer? (pretty-print-columns)))
((let/ec esc
(letrec ([tport
(make-tentative-pretty-print-output-port
port
(- (pretty-print-columns) 1)
(lambda ()
(esc
(lambda ()
(tentative-pretty-print-port-cancel tport)
(print/multi-line port)))))])
(print/one-line tport)
(tentative-pretty-print-port-transfer tport port))
void))]
[else
(print/one-line port)])
(void)))