/usr/share/racket/collects/unstable/custom-write.rkt is in racket-common 6.1-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | #lang racket/base
(require racket/pretty
racket/match
racket/sequence
racket/contract/base)
(provide (contract-out
[make-constructor-style-printer
(-> (-> any/c (or/c symbol? string?))
(-> any/c sequence?)
(-> any/c output-port? (or/c #t #f 0 1) void?))]
[prop:auto-custom-write
(struct-type-property/c 'constructor)]))
;; TODO: deal with super struct types better
;; - see "Problem" below
#|
Constructor-style printer
- eg 'set' printer
- in mode 0, "(" + constructor + { " " + elem }* + ")"
- else, "#<" + constructor + ":" + ... + ">"
- print elems w/ same mode
- never quotable
|#
(define-values (prop:auto-custom-write auto-custom-write? auto-custom-write-proc)
(make-struct-type-property
'auto-custom-write
(lambda (val info)
(case val
((constructor)
(struct-info->get-constructor+get-contents info))))
(list (cons prop:custom-print-quotable
(lambda (auto-write-val) 'never))
(cons prop:custom-write
(lambda (auto-write-val)
(make-constructor-style-printer
(car auto-write-val)
(cdr auto-write-val)))))))
(define (struct-info->get-constructor+get-contents info)
(match info
[(list name init-ct auto-ct accessor mutator imms super skipped?)
(let ([get-super-contents
;; Problem: if super type was not transparent (to current
;; inspector), then we don't get it (ie, skipped? is #t), and so we
;; can't tell if super type also has prop:auto-custom-write
;; property.
(cond [skipped?
(error 'prop:auto-custom-write
"struct super type is inaccessible")]
[(not super)
#f]
[(auto-custom-write? super)
(cdr (auto-custom-write-proc super))]
[else
(let ([super-getters
(struct-info->get-constructor+get-contents
(call-with-values (lambda () (struct-type-info super))
list))])
(cdr super-getters))])])
(define (get-constructor obj)
name)
(define (get-new-contents obj)
(for/list ([i (in-range (+ init-ct auto-ct))])
(accessor obj i)))
(cons get-constructor
(if get-super-contents
(lambda (obj)
(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)))
|