.

original commit: eca8bf7cc52a128657d2f227bcbf82ce9e966849

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)

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?
+        (or (with-handlers ([not-break-exn?
-			 (lambda (x) #f)])
+                             (lambda (x) #f)])
-	  (directory-exists? (build-path (collection-path "framework") "CVS"))))
+              (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%

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?)

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^

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?])
+;          (rename [super-tabify-on-return? tabify-on-return?])
-          (define/override (tabify-on-return?)
+;          (define/override (tabify-on-return?)
-            (and (super-tabify-on-return?)
+;            (and (super-tabify-on-return?)
-                 allow-tabify?))
+;                 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! in-port (make-custom-input-port read-string-proc
-            (set! out-port (make-custom-output-port #f (make-write-string-proc out-sd) flush-proc out-close-proc))
+                                                  #f
-            (set! err-port (make-custom-output-port #f (make-write-string-proc err-sd) flush-proc out-close-proc))
+                                                  in-close-proc))
-            (set! value-port (make-custom-output-port #f (make-write-string-proc value-sd) flush-proc out-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