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