80 lines
2.8 KiB
Racket
80 lines
2.8 KiB
Racket
#lang racket/base
|
|
(require mzlib/pconvert
|
|
racket/pretty
|
|
lang/private/set-result
|
|
lang/private/rewrite-error-message
|
|
mrlib/image-core
|
|
racket/snip
|
|
racket/class)
|
|
|
|
(provide configure)
|
|
|
|
(define (configure options)
|
|
;; Set print-convert options:
|
|
(booleans-as-true/false #t)
|
|
(constructor-style-printing #t)
|
|
(add-make-prefix-to-constructor #f)
|
|
(abbreviate-cons-as-list (memq 'abbreviate-cons-as-list options))
|
|
(current-print-convert-hook
|
|
(let ([ph (current-print-convert-hook)])
|
|
(lambda (val basic sub)
|
|
(cond
|
|
[(equal? val set!-result) '(void)]
|
|
[(is-image? val) val]
|
|
[else (ph val basic sub)]))))
|
|
(use-named/undefined-handler
|
|
(lambda (x)
|
|
(and (memq 'use-function-output-syntax options)
|
|
(procedure? x)
|
|
(object-name x))))
|
|
(named/undefined-handler
|
|
(lambda (x)
|
|
(string->symbol
|
|
(format "function:~a" (object-name x)))))
|
|
;; Set pretty-print options:
|
|
(pretty-print-show-inexactness #t)
|
|
(pretty-print-exact-as-decimal #t)
|
|
(define img-str "#<image>")
|
|
(define (is-image? val)
|
|
(or (is-a? val image%) ;; 2htdp/image
|
|
(is-a? val image-snip%))) ;; literal image constant
|
|
(show-sharing (memq 'show-sharing options))
|
|
|
|
;; Set print handlers to use print-convert and pretty-write:
|
|
(define (set-handlers thunk)
|
|
(parameterize ([pretty-print-print-hook
|
|
(let ([oh (pretty-print-print-hook)])
|
|
(λ (val display? port)
|
|
(if (and (not (port-writes-special? port))
|
|
(is-image? val))
|
|
(begin (display img-str port)
|
|
(string-length img-str))
|
|
(oh val display? port))))]
|
|
[pretty-print-size-hook
|
|
(let ([oh (pretty-print-size-hook)])
|
|
(λ (val display? port)
|
|
(if (and (not (port-writes-special? port))
|
|
(is-image? val))
|
|
(string-length img-str)
|
|
(oh val display? port))))])
|
|
(thunk)))
|
|
(current-print
|
|
(lambda (v)
|
|
(unless (void? v)
|
|
(define converted (print-convert v))
|
|
(set-handlers
|
|
(λ () (pretty-write converted))))))
|
|
(error-display-handler
|
|
(let ([o-d-h (error-display-handler)])
|
|
(lambda (msg exn)
|
|
(define x (get-rewriten-error-message exn))
|
|
(o-d-h x exn))))
|
|
(let ([orig (global-port-print-handler)])
|
|
(global-port-print-handler
|
|
(lambda (val port [depth 0])
|
|
(parameterize ([global-port-print-handler orig])
|
|
(let ([val (print-convert val)])
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
(set-handlers
|
|
(λ () (pretty-write val port))))))))))
|