1#lang racket/base
2(provide configure configure/settings
3         options->sl-runtime-settings
4         (struct-out sl-runtime-settings)
5         sl-render-value/format)
6
7(require mzlib/pconvert
8         racket/pretty
9         lang/private/set-result
10         lang/private/rewrite-error-message
11         (prefix-in image-core: mrlib/image-core)
12         mrlib/cache-image-snip
13         (only-in racket/draw bitmap%)
14         racket/snip
15         racket/class
16         (only-in test-engine/test-markup get-rewritten-error-message-parameter render-value-parameter)
17         (only-in test-engine/syntax report-signature-violation!)
18         (only-in deinprogramm/signature/signature
19                  signature? signature-name
20                  signature-violation-proc)
21         (only-in simple-tree-text-markup/construct number)
22         simple-tree-text-markup/text
23         "print-width.rkt")
24
25(struct sl-runtime-settings
26  (printing-style ; write, trad-write, print, quasiquote
27   fraction-style ; mixed-fraction, mixed-fraction-e, repeating-decimal, repeating-decimal-e
28   show-sharing?
29   insert-newlines?
30   tracing? ; unclear if this should be here
31   true/false/empty-as-ids?
32   abbreviate-cons-as-list?
33   use-function-output-syntax?))
34
35(define insert-newlines (make-parameter #t))
36
37(define (options->sl-runtime-settings options)
38  (sl-runtime-settings 'print
39                       'repeating-decimal
40                       (and (memq 'show-sharing options) #t)
41                       #t ; insert-newlines?
42                       #f ; tracing?
43                       #f ; true/false/empty-as-ids?
44                       (and (memq 'abbreviate-cons-as-list options) #t)
45                       (and (memq 'use-function-output-syntax options) #t)))
46
47(define (configure options)
48  (configure/settings (options->sl-runtime-settings options)))
49
50(define (configure/settings settings)
51  ;; Set print-convert options:
52  (booleans-as-true/false (sl-runtime-settings-true/false/empty-as-ids? settings))
53  (print-boolean-long-form #t)
54  [constructor-style-printing
55   (case (sl-runtime-settings-printing-style settings)
56     [(quasiquote) #f]
57     [else #t])]
58  (print-as-expression #f)
59  (add-make-prefix-to-constructor #t)
60  (abbreviate-cons-as-list (sl-runtime-settings-abbreviate-cons-as-list? settings))
61  (insert-newlines (sl-runtime-settings-insert-newlines? settings))
62  (current-print-convert-hook
63   (let ([ph (current-print-convert-hook)])
64     (lambda (val basic sub)
65       (cond
66         [(and (not (sl-runtime-settings-true/false/empty-as-ids? settings)) (equal? val '())) ''()]
67         [(equal? val set!-result) '(void)]
68         [(signature? val)
69          (or (signature-name val)
70              '<signature>)]
71         [(is-image? val) val]
72         [else (ph val basic sub)]))))
73  (use-named/undefined-handler
74   (lambda (x)
75     (and (sl-runtime-settings-use-function-output-syntax? settings)
76          (procedure? x)
77          (object-name x))))
78  (named/undefined-handler
79   (lambda (x)
80     (string->symbol
81      (format "function:~a" (object-name x)))))
82
83  ; sharing done by print-convert
84  (show-sharing (sl-runtime-settings-show-sharing? settings))
85  ; sharing done by write
86  (print-graph (and (sl-runtime-settings-show-sharing? settings)
87                    ;; print-convert takes care of this also, so only do it when that doesn't happen
88                    (case (sl-runtime-settings-printing-style settings)
89                      ([trad-write write] #t)
90                      (else #f))))
91
92  (define img-str "#<image>")
93  (define (is-image? val)
94    (or (is-a? val image-core:image%) ; 2htdp/image
95        (is-a? val cache-image-snip%) ; htdp/image
96        (is-a? val image-snip%) ; literal image constant
97        (is-a? val bitmap%))) ; works in other places, so include it here too
98
99  ;; exact fractions - slight hack as we know for what numbers DrRacket generates special snips
100  (define (use-number-markup? x)
101    (and (number? x)
102         (exact? x)
103         (real? x)
104         (not (integer? x))))
105
106  (define fraction-view
107    (case (sl-runtime-settings-fraction-style settings)
108      [(mixed-fraction mixed-fraction-e) 'mixed]
109      [(repeating-decimal repeating-decimal-e) 'decimal]))
110
111  (pretty-print-show-inexactness #t)
112  (pretty-print-exact-as-decimal (eq? fraction-view 'decimal))
113
114  (pretty-print-print-hook
115   (let ([oh (pretty-print-print-hook)])
116     (λ (val display? port)
117       (cond
118        [(and (not (port-writes-special? port))
119              (is-image? val))
120         (display img-str port)]
121        [(and (use-number-markup? val)
122              (port-writes-special? port))
123         (write-special (number val #:exact-prefix 'never #:inexact-prefix 'always #:fraction-view fraction-view) port)]
124        [(number? val)
125         (display (number-markup->string val #:exact-prefix 'never #:inexact-prefix 'always #:fraction-view fraction-view) port)]
126        [else
127         (oh val display? port)]))))
128
129  (pretty-print-size-hook
130   (let ([oh (pretty-print-size-hook)])
131     (λ (val display? port)
132       (cond
133         [(and (not (port-writes-special? port))
134               (is-image? val))
135          (string-length img-str)]
136        [(and (use-number-markup? val)
137              (port-writes-special? port))
138         1]
139        [(number? val)
140         (string-length (number-markup->string val #:exact-prefix 'never #:inexact-prefix 'always #:fraction-view fraction-view))]
141        [else
142         (oh val display? port)]))))
143
144  ; test-engine
145  (get-rewritten-error-message-parameter get-rewriten-error-message)
146  ; test-engine
147  (render-value-parameter
148   (lambda (value port)
149     (parameterize ([print-value-columns 40])
150       (print value port))))
151
152  (error-display-handler
153   (let ([o-d-h (error-display-handler)])
154     (λ (msg exn)
155       (define x (get-rewriten-error-message exn))
156       (o-d-h x exn))))
157
158  (global-port-print-handler
159   (lambda (val port [depth 0])
160     (define printing-style (sl-runtime-settings-printing-style settings))
161     (define cols
162       (if (exact-integer? (print-value-columns)) ;; print-value-columns takes precedence
163           (print-value-columns)
164           (htdp-print-columns)))
165
166     (parameterize ([print-value-columns (if (eqv? cols 'infinity)
167                                             +inf.0
168                                             cols)]
169                    [pretty-print-columns
170                     (if (sl-runtime-settings-insert-newlines? settings)
171                         cols
172                         'infinity)])
173       (let [(val (case printing-style
174                    [(write trad-write) val]
175                    [else (print-convert val)]))]
176         (case printing-style
177           [(print) (pretty-print val port depth)]
178           [(write trad-write constructor) (pretty-write val port)]
179           [(quasiquote) (pretty-write val port)])))))
180
181  (signature-violation-proc
182   (lambda (obj signature message blame)
183     (report-signature-violation! obj signature message blame))))
184
185(define (sl-render-value/format value port width)
186  (parameterize ([print-value-columns (if (eq? width 'infinity)
187                                          +inf.0
188                                          width)])
189    (print value port)
190    (unless (insert-newlines)
191      (newline port))))
192