diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index ff15471c..9a35b6ec 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -13,6 +13,7 @@ WARNING: printf is rebound in the body of the unit to always "sig.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") + (lib "interactive-value-port.ss" "mrlib") (lib "list.ss") (lib "etc.ss")) (provide text@) @@ -1043,7 +1044,7 @@ WARNING: printf is rebound in the body of the unit to always (unless err-port (error 'get-err-port "not ready")) err-port) (define/public-final (get-value-port) - (unless err-port (error 'get-value-port "not ready")) + (unless value-port (error 'get-value-port "not ready")) value-port) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1375,7 +1376,15 @@ WARNING: printf is rebound in the body of the unit to always always-evt (make-write-bytes-proc value-style) out-close-proc - (make-write-special-proc value-style))))) + (make-write-special-proc value-style))) + (let ([install-handlers + (λ (port) + (set-interactive-print-handler port) + (set-interactive-write-handler port) + (set-interactive-display-handler port))]) + (install-handlers out-port) + (install-handlers err-port) + (install-handlers value-port)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/collects/mrlib/interactive-value-port.ss b/collects/mrlib/interactive-value-port.ss new file mode 100644 index 00000000..4a385d38 --- /dev/null +++ b/collects/mrlib/interactive-value-port.ss @@ -0,0 +1,73 @@ + +(module interactive-value-port mzscheme + (require (lib "pretty.ss") + (lib "mred.ss" "mred") + (lib "class.ss") + "syntax-browser.ss") + (provide set-interactive-display-handler + set-interactive-write-handler + set-interactive-print-handler) + + (define pp-parameters + (parameterize ([pretty-print-columns 'infinity] + [pretty-print-size-hook + (λ (value display? port) + (cond + [(is-a? value snip%) 1] + ;[(use-number-snip? value) 1] + [(syntax? value) 1] + [else #f]))] + [pretty-print-print-hook + (λ (value display? port) + (cond + [(is-a? value snip%) + (write-special value port) + 1] + #; + [(use-number-snip? value) + (write-special + (number-snip:make-repeating-decimal-snip value #f) + port) + 1] + [(syntax? value) + (write-special (render-syntax/snip value))] + [else (void)]))]) + (current-parameterization))) + + (define op (current-output-port)) + (define (oprintf . x) (apply fprintf op x)) + + (define (set-interactive-display-handler port) + (let ([original-port-display-handler (port-display-handler port)]) + (port-display-handler + port + (λ (val port) + (cond + [(string? val) (original-port-display-handler val port)] + [else + (do-printing pretty-display val port)]))))) + + (define (set-interactive-write-handler port) + (port-write-handler + port + (λ (val port) + (do-printing pretty-print val port)))) + + (define (set-interactive-print-handler port) + (port-print-handler + port + (λ (val port) + (do-printing pretty-print val port)))) + + (define (use-number-snip? x) + (and #f + (number? x) + (exact? x) + (real? x) + (not (integer? x)))) + + (define (do-printing pretty value port) + (call-with-parameterization + pp-parameters + (λ () + (pretty value port))))) diff --git a/collects/drscheme/private/syntax-browser.ss b/collects/mrlib/syntax-browser.ss similarity index 98% rename from collects/drscheme/private/syntax-browser.ss rename to collects/mrlib/syntax-browser.ss index 624466f8..ac1274bc 100644 --- a/collects/drscheme/private/syntax-browser.ss +++ b/collects/mrlib/syntax-browser.ss @@ -15,7 +15,7 @@ needed to really make this work: (lib "match.ss") (lib "string.ss")) - (provide render-syntax/snip render-syntax/window) + (provide render-syntax/snip render-syntax/window snip-class) (define (render-syntax/window syntax) (let ([es (render-syntax/snip syntax)]) @@ -37,10 +37,10 @@ needed to really make this work: (make-object syntax-snip% (unmarshall-syntax (read-from-string (bytes->string/utf-8 str)))))) (super-instantiate ()))) - (define syntax-snipclass (make-object syntax-snipclass%)) - (send syntax-snipclass set-version 1) - (send syntax-snipclass set-classname "drscheme:syntax-snipclass%") - (send (get-the-snip-class-list) add syntax-snipclass) + (define snip-class (make-object syntax-snipclass%)) + (send snip-class set-version 1) + (send snip-class set-classname (format "~s" '(lib "syntax-browser.ss" "mrlib"))) + (send (get-the-snip-class-list) add snip-class) (define-struct range (obj start end)) @@ -339,7 +339,7 @@ needed to really make this work: (hide-details) (inherit set-snipclass) - (set-snipclass syntax-snipclass))) + (set-snipclass snip-class))) (define black-style-delta (make-object style-delta% 'change-normal-color)) (define green-style-delta (make-object style-delta%))