diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index a990dd54..d15bfde9 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -37,6 +37,29 @@ mred^) (provide/contract/docs + + (number-snip:make-repeating-decimal-snip + (number? boolean? . -> . (is-a?/c snip%)) + (num show-prefix?) + + "Makes a number snip that shows the decimal expansion for \\var{number}" + "The boolean indicates if a {\\tt \\#e} prefix appears" + "on the number." + "" + "See also" + "@flink number-snip:number-snip:make-fraction-snip %" + ".") + (number-snip:make-fraction-snip + (number? boolean? . -> . (is-a?/c snip%)) + (num show-prefix-in-decimal-view?) + + "Makes a number snip that shows a fractional view of \\var{number}." + "The boolean indicates if a {\\tt \\#e} prefix appears" + "on the number, when shown in the decimal state." + "" + "See also" + "@flink drscheme:number-snip:make-repeating-decimal-snip %" + ".") (version:add-spec (any? any? . -> . void?) (spec revision) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 3fe51c18..0f82a260 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -554,7 +554,7 @@ 'framework:show-status-line (lambda (p v) (update-info-visibility v)))] - [define memory-cleanup void] ;; only for CVSers; used with memory-text + [define memory-cleanup void] ;; only for CVSers and nightly build users; used with memory-text (rename [super-on-close on-close]) [define/override on-close @@ -626,7 +626,7 @@ [(<= n 99) (format "0~a" n)] [else (number->string n)])) - ; only for CVSers + ; only for CVSers and nightly build users (when show-memory-text? (let* ([panel (make-object horizontal-panel% (get-info-panel) '(border))] [button (make-object button% (string-constant collect-button-label) panel @@ -2310,14 +2310,16 @@ (define (get-editor%) text:searching%) (super-instantiate ()))) - ; to see printouts in memory debugging better. (define memory-text% (class text% (super-new))) (define memory-text (make-object memory-text%)) (send memory-text hide-caret #t) (define show-memory-text? - (with-handlers ([not-break-exn? - (lambda (x) #f)]) - (directory-exists? (build-path (collection-path "framework") "CVS")))) + (or (with-handlers ([not-break-exn? + (lambda (x) #f)]) + (directory-exists? (collection-path "cvs-time-stamp"))) + (with-handlers ([not-break-exn? + (lambda (x) #f)]) + (directory-exists? (build-path (collection-path "framework") "CVS"))))) (define bday-click-canvas% (class canvas% diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index 8e8e5dc6..2e265777 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -22,6 +22,8 @@ (application-preferences-handler (lambda () (preferences:show-dialog))) + (preferences:set-default 'framework:fraction-snip-style 'mixed (lambda (x) (memq x '(mixed improper)))) + (preferences:set-default 'framework:standard-style-list:font-name (get-family-builtin-face 'modern) string?) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 9392d8ba..f1868ed7 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -79,8 +79,20 @@ framework:color-model-fun^ framework:comment-box-fun^ framework:comment-box-class^ - framework:comment-box^) + framework:comment-box^ + framework:number-snip^ + framework:number-snip-fun^ + framework:number-snip-class^) + (define-signature framework:number-snip-fun^ + (make-repeating-decimal-snip + make-fraction-snip)) + (define-signature framework:number-snip-class^ + (snip-class%)) + (define-signature framework:number-snip^ + ((open framework:number-snip-fun^) + (open framework:number-snip-class^))) + (define-signature framework:comment-box-fun^ ()) (define-signature framework:comment-box-class^ diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 3c2924e1..4c1e0a9f 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -20,7 +20,8 @@ [keymap : framework:keymap^] [color-model : framework:color-model^] [frame : framework:frame^] - [scheme : framework:scheme^]) + [scheme : framework:scheme^] + [number-snip : framework:number-snip^]) (rename [-keymap% keymap%]) @@ -943,10 +944,10 @@ (super-on-local-char key)]))) (define allow-tabify? #t) - (rename [super-tabify-on-return? tabify-on-return?]) - (define/override (tabify-on-return?) - (and (super-tabify-on-return?) - allow-tabify?)) +; (rename [super-tabify-on-return? tabify-on-return?]) +; (define/override (tabify-on-return?) +; (and (super-tabify-on-return?) +; allow-tabify?)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -1163,7 +1164,6 @@ (define (out-close-proc) (void)) - ;; disable set-styles-sticky? (define out-sd (make-object style-delta% 'change-normal)) (define err-sd (make-object style-delta% 'change-italic)) (define value-sd (make-object style-delta% 'change-normal)) @@ -1171,10 +1171,21 @@ (send err-sd set-delta-foreground (make-object color% 255 0 0)) (send value-sd set-delta-foreground (make-object color% 0 0 175)) - (set! in-port (make-custom-input-port read-string-proc #f in-close-proc)) - (set! out-port (make-custom-output-port #f (make-write-string-proc out-sd) flush-proc out-close-proc)) - (set! err-port (make-custom-output-port #f (make-write-string-proc err-sd) flush-proc out-close-proc)) - (set! value-port (make-custom-output-port #f (make-write-string-proc value-sd) flush-proc out-close-proc))) + (set! in-port (make-custom-input-port read-string-proc + #f + in-close-proc)) + (set! out-port (make-custom-output-port #f + (make-write-string-proc out-sd) + flush-proc + out-close-proc)) + (set! err-port (make-custom-output-port #f + (make-write-string-proc err-sd) + flush-proc + out-close-proc)) + (set! value-port (make-custom-output-port #f + (make-write-string-proc value-sd) + flush-proc + out-close-proc))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1264,7 +1275,105 @@ (values fst (cdr lst)))]))]))) (super-new))) - + #| + (define (drscheme-pretty-print-size-hook x _ port) + (and (or (eq? port this-out) + (eq? port this-err) + (eq? port this-result)) + (cond + [(is-a? x sized-snip<%>) (send x get-character-width)] + [(is-a? x snip%) + (let ([dc (get-dc)] + [wbox (box 0)]) + (send x get-extent dc 0 0 wbox #f #f #f #f #f) + (let-values ([(xw xh xa xd) (send dc get-text-extent "x")]) + (max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))] + [(syntax? x) + ;; two spaces is about how big the turn down triangle + ;; and the extra space accounts for. Of course, when + ;; it is opened, this will be all wrong. + (+ 2 (string-length (format "~s" x)))] + [((use-number-snip) x) + (let ([number-snip-type ((which-number-snip) x)]) + (cond + [(memq number-snip-type '(repeating-decimal + repeating-decimal-e + mixed-fraction + mixed-fraction-e)) + 1] ;; no idea of size yet + [else + (error 'which-number-snip + "unexpected result from parameter: ~e" + number-snip-type)]))] + [else #f]))) + + (define (drscheme-pretty-print-print-hook x _ port) + (let ([port-out-write + (cond + [(eq? port this-out) (lambda (x) (this-out-write x))] + [(eq? port this-err) (lambda (x) (this-err-write x))] + [(eq? port this-result) (lambda (x) (this-result-write x))] + ;; this case should only happen if the user's program overrides the pretty-print-size-hook + ;; and doesnt' override the pretty-print-print-hook to match. + [else #f])]) + (if port-out-write + (let ([snip/str + (cond + [(syntax? x) (render-syntax/snip x)] + [((use-number-snip) x) + (let ([number-snip-type ((which-number-snip) x)]) + (cond + [(eq? number-snip-type 'repeating-decimal) + (drscheme:number-snip:make-repeating-decimal-snip x #f)] + [(eq? number-snip-type 'repeating-decimal-e) + (drscheme:number-snip:make-repeating-decimal-snip x #t)] + [(eq? number-snip-type 'mixed-fraction) + (drscheme:number-snip:make-fraction-snip x #f)] + [(eq? number-snip-type 'mixed-fraction-e) + (drscheme:number-snip:make-fraction-snip x #t)] + [else + (error 'which-number-snip + "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e" + number-snip-type)]))] + [else x])]) + (port-out-write snip/str)) + (display x)))) + + ;; setup-display/write-handlers : -> void + ;; sets the port-display-handler and the port-write-handler + ;; for the initial output port, initial error port and the + ;; value port. + (define (setup-display/write-handlers) + (let* ([make-setup-handler + (lambda (port port-out-write) + (lambda (port-handler pretty) + (let ([original-handler (port-handler port)]) + (port-handler + port + (rec drscheme-port-handler + (lambda (v p) + ;; avoid looping by calling original-handler + ;; for strings, since `pretty' calls write/display with + ;; strings + (if (string? v) + (original-handler v p) + (parameterize ([pretty-print-columns 'infinity]) + (pretty v p)))))))))] + + [setup-handlers + (lambda (setup-handler) + (setup-handler port-display-handler pretty-display) + (setup-handler port-write-handler pretty-print))] + + [setup-out-handler (make-setup-handler this-out (lambda (x) (this-out-write x)))] + [setup-err-handler (make-setup-handler this-err (lambda (x) (this-err-write x)))] + [setup-value-handler (make-setup-handler this-result (lambda (x) (this-result-write x)))]) + (setup-handlers setup-out-handler) + (setup-handlers setup-err-handler) + (setup-handlers setup-value-handler))) + + |# + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; queues