-
-
Notifications
You must be signed in to change notification settings - Fork 63
/
runtime.rkt
222 lines (201 loc) · 8.38 KB
/
runtime.rkt
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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
#lang racket/base
(provide configure configure/settings
options->sl-runtime-settings
(struct-out sl-runtime-settings)
sl-render-value/format)
(require mzlib/pconvert
racket/pretty
lang/private/set-result
lang/private/rewrite-error-message
(prefix-in image-core: mrlib/image-core)
mrlib/cache-image-snip
(only-in racket/draw bitmap%)
racket/snip
racket/class
(only-in test-engine/test-markup get-rewritten-error-message-parameter render-value-parameter)
(only-in test-engine/syntax report-signature-violation! test)
(only-in test-engine/test-engine test-object-copy current-test-object test-object=?)
(only-in deinprogramm/signature/signature
signature? signature-name
signature-violation-proc)
(only-in simple-tree-text-markup/construct number)
simple-tree-text-markup/text
"print-width.rkt")
(struct sl-runtime-settings
(printing-style ; write, trad-write, print, quasiquote
fraction-style ; mixed-fraction, mixed-fraction-e, repeating-decimal, repeating-decimal-e
show-sharing?
insert-newlines?
tracing? ; unclear if this should be here
true/false/empty-as-ids?
abbreviate-cons-as-list?
use-function-output-syntax?
output-function-instead-of-lambda?))
(define insert-newlines (make-parameter #t))
(define (options->sl-runtime-settings options)
(sl-runtime-settings 'print
'repeating-decimal
(and (memq 'show-sharing options) #t)
#t ; insert-newlines?
#f ; tracing?
#f ; true/false/empty-as-ids?
(and (memq 'abbreviate-cons-as-list options) #t)
(and (memq 'use-function-output-syntax options) #t)
(and (memq 'output-function-instead-of-lambda options) #t)))
(define (configure options)
(configure/settings (options->sl-runtime-settings options)))
(define (configure/settings settings)
(read-decimal-as-inexact #f)
;; Set print-convert options:
(booleans-as-true/false (sl-runtime-settings-true/false/empty-as-ids? settings))
(print-boolean-long-form #t)
[constructor-style-printing
(case (sl-runtime-settings-printing-style settings)
[(quasiquote) #f]
[else #t])]
(print-as-expression #f)
(add-make-prefix-to-constructor #t)
(abbreviate-cons-as-list (sl-runtime-settings-abbreviate-cons-as-list? settings))
(insert-newlines (sl-runtime-settings-insert-newlines? settings))
(current-print-convert-hook
(let ([ph (current-print-convert-hook)])
(lambda (val basic sub)
(cond
[(and (sl-runtime-settings-output-function-instead-of-lambda? settings)
(procedure? val))
(cond
((object-name val)
=> (lambda (name)
(string->symbol (format "function:~a" name))))
(else 'function))]
[(and (not (sl-runtime-settings-true/false/empty-as-ids? settings)) (equal? val '())) ''()]
[(equal? val set!-result) '(void)]
[(signature? val)
(or (signature-name val)
'<signature>)]
[(is-image? val) val]
[else (ph val basic sub)]))))
(use-named/undefined-handler
(lambda (x)
(and (sl-runtime-settings-use-function-output-syntax? settings)
(procedure? x)
(object-name x))))
(named/undefined-handler
(lambda (x)
(string->symbol
(format "function:~a" (object-name x)))))
; sharing done by print-convert
(show-sharing (sl-runtime-settings-show-sharing? settings))
; sharing done by write
(print-graph (and (sl-runtime-settings-show-sharing? settings)
;; print-convert takes care of this also, so only do it when that doesn't happen
(case (sl-runtime-settings-printing-style settings)
([trad-write write] #t)
(else #f))))
(define img-str "#<image>")
(define (is-image? val)
(or (is-a? val image-core:image%) ; 2htdp/image
(is-a? val cache-image-snip%) ; htdp/image
(is-a? val image-snip%) ; literal image constant
(is-a? val bitmap%))) ; works in other places, so include it here too
;; exact fractions - slight hack as we know for what numbers DrRacket generates special snips
(define (use-number-markup? x)
(and (number? x)
(exact? x)
(real? x)
(not (integer? x))))
(define fraction-view
(case (sl-runtime-settings-fraction-style settings)
[(mixed-fraction mixed-fraction-e) 'mixed]
[(repeating-decimal repeating-decimal-e) 'decimal]))
(pretty-print-show-inexactness #t)
(pretty-print-exact-as-decimal (eq? fraction-view 'decimal))
(pretty-print-print-hook
(let ([oh (pretty-print-print-hook)])
(λ (val display? port)
(cond
[(and (not (port-writes-special? port))
(is-image? val))
(display img-str port)]
[(and (use-number-markup? val)
(port-writes-special? port))
(write-special (number val #:exact-prefix 'never #:inexact-prefix 'always #:fraction-view fraction-view) port)]
[(number? val)
(display (number-markup->string val #:exact-prefix 'never #:inexact-prefix 'always #:fraction-view fraction-view) port)]
[else
(oh val display? port)]))))
(pretty-print-size-hook
(let ([oh (pretty-print-size-hook)])
(λ (val display? port)
(cond
[(and (not (port-writes-special? port))
(is-image? val))
(string-length img-str)]
[(and (use-number-markup? val)
(port-writes-special? port))
1]
[(number? val)
(string-length (number-markup->string val #:exact-prefix 'never #:inexact-prefix 'always #:fraction-view fraction-view))]
[else
(oh val display? port)]))))
; test-engine
(get-rewritten-error-message-parameter get-rewriten-error-message)
; test-engine
(render-value-parameter
(lambda (value port)
(parameterize ([print-value-columns 40])
(print value port))))
(error-display-handler
(let ([o-d-h (error-display-handler)])
(λ (msg exn)
(define x (get-rewriten-error-message exn))
(o-d-h x exn))))
(global-port-print-handler
(lambda (val port [depth 0])
(define printing-style (sl-runtime-settings-printing-style settings))
(define cols
(if (exact-integer? (print-value-columns)) ;; print-value-columns takes precedence
(print-value-columns)
(htdp-print-columns)))
(parameterize ([print-value-columns (if (eqv? cols 'infinity)
+inf.0
cols)]
[pretty-print-columns
(if (sl-runtime-settings-insert-newlines? settings)
cols
'infinity)])
(let [(val (case printing-style
[(write trad-write) val]
[else (print-convert val)]))]
(case printing-style
[(print) (pretty-print val port depth)]
[(write trad-write constructor) (pretty-write val port)]
[(quasiquote) (pretty-write val port)])))))
(signature-violation-proc
(lambda (obj signature message blame-srcloc)
(report-signature-violation! obj signature message blame-srcloc)))
(let ((interaction? #f))
(current-read-interaction
(let ((old-read-interaction (current-read-interaction)))
(lambda args
; we've entered the REPL, so test once
(set! interaction? #t)
(apply old-read-interaction args))))
; in the repl, re-run tests / display results if anything has changed
(current-eval
(let ((old-eval (current-eval)))
(lambda args
(let ((test-object (test-object-copy (current-test-object))))
(dynamic-wind
void
(lambda () (apply old-eval args))
(lambda ()
(when (and interaction? (not (test-object=? test-object (current-test-object))))
(test))))))))))
(define (sl-render-value/format value port width)
(parameterize ([print-value-columns (if (eq? width 'infinity)
+inf.0
width)])
(print value port)
(unless (insert-newlines)
(newline port))))