fixed PR 8925

svn: r7470

collects/framework/private/frame.ss

@@ -259,6 +259,63 @@
   (define unlocked-message-line1 (string-constant read/write-line1))
   (define unlocked-message-line2 (string-constant read/write-line2))
   
+  (define lock-canvas%
+    (class canvas%
+      (field [locked? #f])
+      (inherit refresh)
+      (define/public (set-locked l)
+        (unless (eq? locked? l)
+          (set! locked? l)
+          (setup-sizes)
+          (refresh)))
+      (inherit get-client-size get-dc)
+      (define/override (on-paint)
+        (let* ([dc (get-dc)]
+               [draw
+                (λ (str1 str2 bg-color bg-style line-color line-style)
+                  (send dc set-font small-control-font)
+                  (let-values ([(w h) (get-client-size)]
+                               [(tw1 th1 _1 _2) (send dc get-text-extent str1)]
+                               [(tw2 th2 _3 _4) (send dc get-text-extent str2)])
+                    (send dc set-pen (send the-pen-list find-or-create-pen line-color 1 line-style))
+                    (send dc set-brush (send the-brush-list find-or-create-brush bg-color bg-style))
+                    (send dc draw-rectangle 0 0 w h)
+                    (cond
+                      [(string=? str2 "")
+                       (send dc draw-text str1
+                             (- (/ w 2) (/ tw1 2))
+                             (- (* h 1/2) (/ th1 2)))]
+                      [else
+                       (send dc draw-text str1
+                             (- (/ w 2) (/ tw1 2))
+                             (- (* h 1/2) th1))
+                       (send dc draw-text str2
+                             (- (/ w 2) (/ tw2 2))
+                             (* h 1/2))])))])
+          (when locked?
+            (draw locked-message-line1 locked-message-line2
+                  "yellow" 'solid "black" 'solid))))
+      
+      (inherit get-parent min-width min-height stretchable-width stretchable-height)
+      (define/private (setup-sizes)
+        (let ([dc (get-dc)])
+          (if locked?
+              (let-values ([(wl1 hl1 _1 _2) (send dc get-text-extent locked-message-line1)]
+                           [(wl2 hl2 _3 _4) (send dc get-text-extent locked-message-line2)])
+                (min-width (inexact->exact (floor (+ 2 (max (+ wl1 2) (+ wl2 2))))))
+                (min-height (inexact->exact (floor (+ 2 hl1 hl2)))))
+              (begin
+                (min-width 0)
+                (min-height 0)))))
+      
+      (super-new [style '(transparent)])
+      
+      (send (get-dc) set-font small-control-font)
+      (setup-sizes)
+      (stretchable-width #f)
+      (stretchable-height #t)))
+  
+  #;
   (define lock-canvas%
     (class canvas%
       (field [locked? #f])
@@ -480,7 +537,7 @@
               ;; need high priority callbacks to ensure ordering wrt other callbacks
               (queue-callback t #t))))
       
-      (super-instantiate ())))
+      (super-new)))
   
   (define info<%> (interface (basic<%>)
                     determine-width
@@ -608,15 +665,11 @@
       
       (define/public (get-info-panel) info-panel)
       (define/public (update-memory-text)
-        (when (and show-memory-text?
+        (when show-memory-text?
-                   memory-canvas)
+          (for-each
-          (send memory-text begin-edit-sequence)
+           (λ (memory-canvas)
-          (send memory-text lock #f)
+             (send memory-canvas set-str (format-number (current-memory-use))))
-          (send memory-text erase)
+           memory-canvases)))
-          (send memory-text insert (format-number (current-memory-use)))
-          (ensure-enough-width memory-canvas memory-text)
-          (send memory-text lock #t)
-          (send memory-text end-edit-sequence)))
       
       (define/private (format-number n)
         (let* ([mbytes (/ n 1024 1024)]
@@ -627,7 +680,8 @@
            "."
            (cond
              [(<= after-decimal 9) (format "0~a" after-decimal)]
-             [else (number->string after-decimal)]))))
+             [else (number->string after-decimal)])
+           " MB")))
       
       (define/private (pad-to-3 n)
         (cond
@@ -639,27 +693,21 @@
       (when show-memory-text?
         (let* ([panel (new horizontal-panel%
                            [parent (get-info-panel)]
-                           [style '(border)]
+                           ;[style '(border)]
                            [stretchable-width #f]
                            [stretchable-height #f])]
-               [button (new button%
+               [ec (new position-canvas%
-                            [label (string-constant collect-button-label)]
                         [parent panel]
-                            [callback
+                        [button-up
-                             (λ x
+                         (λ ()
                            (collect-garbage)
-                               (update-memory-text))])]
+                           (update-memory-text))]
-               [ec (new editor-canvas%
+                        [init-width "99.99 MB"])])
-                        [parent panel]
+          (set! memory-canvases (cons ec memory-canvases))
-                        [editor memory-text]
-                        [line-count 1]
-                        [style '(no-hscroll no-vscroll)])])
-          (set! memory-canvas ec)
-          (determine-width "99.99" ec memory-text)
           (update-memory-text)
           (set! memory-cleanup
                 (λ ()
-                  (send ec set-editor #f)))
+                  (remq ec memory-canvases)))
           (send panel stretchable-width #f)))
       
       [define lock-canvas (make-object lock-canvas% (get-info-panel))]
@@ -722,6 +770,40 @@
       (let-values ([(cw ch) (send position-canvas get-client-size)])
         (inexact->exact (floor (- cw (unbox wb)))))))
   
+  (define position-canvas%
+    (class canvas%
+      (inherit min-client-height min-client-width get-dc get-client-size refresh)
+      (init init-width)
+      (init-field [button-up #f])
+      (define str "")
+      (define/public (set-str _str)
+        (set! str _str)
+        (update-client-width str)
+        (refresh))
+      (define/private (update-client-width str)
+        (let ([dc (get-dc)])
+          (let-values ([(cw _4) (get-client-size)]
+                       [(tw _1 _2 _3) (send dc get-text-extent str)])
+            (when (< cw tw)
+              (min-client-width (inexact->exact (floor tw)))))))
+      (define/override (on-paint)
+        (let ([dc (get-dc)])
+          (let-values ([(cw ch) (get-client-size)]
+                       [(tw th _1 _2) (send dc get-text-extent str)])
+            (send dc draw-text str 0 (/ (- ch th) 2)))))
+      (define/override (on-event evt)
+        (when button-up
+          (when (send evt button-up?)
+            (let-values ([(cw ch) (get-client-size)])
+              (when (and (<= (send evt get-x) cw)
+                         (<= (send evt get-y) ch))
+                (button-up))))))
+      (super-new (style '(transparent)))
+      (let ([dc (get-dc)])
+        (let-values ([(_1 th _2 _3) (send dc get-text-extent str)])
+          (min-client-height (inexact->exact (floor th)))))
+      (update-client-width init-width)))
+  
   (define text-info<%> (interface (info<%>)
                          set-macro-recording
                          overwrite-status-changed
@@ -757,15 +839,15 @@
         (let* ([edit (get-info-editor)]
                [make-one
                 (λ (pos)
+                  (if line-numbers?
                       (let* ([line (send edit position-paragraph pos)]
                              [col (find-col edit line pos)])
-                    (if line-numbers?
                         (format "~a:~a"
                                 (add1 line)
                                 (if offset?
                                     (add1 col)
-                                    col))
+                                    col)))
-                        (format "~a" pos))))])
+                      (format "~a" pos)))])
           (cond
             [(not (object? position-canvas))
              (void)]
@@ -781,7 +863,7 @@
                  (set! last-params (list offset? line-numbers?))
                  (set! last-start start)
                  (set! last-end end)
-                 (when (object? position-edit)
+                 (when (object? position-canvas)
                    (change-position-edit-contents
                     (if (= start end)
                         (make-one start)
@@ -893,20 +975,9 @@
                                    [parent (get-info-panel)]
                                    [stretchable-width #f]
                                    [stretchable-height #f]))
-      (define position-canvas (new editor-canvas% 
+      (define position-canvas (new position-canvas% [parent position-parent] [init-width "000:00-000:00"]))
-                                   [parent position-parent]
-                                   [style '(no-hscroll no-vscroll)]))
-      
-      (define position-edit (new text%))
-      
       (define/private (change-position-edit-contents str)
-        (send position-edit begin-edit-sequence)
+        (send position-canvas set-str str))
-        (send position-edit lock #f)
-        (send position-edit erase)
-        (send position-edit insert str)
-        (ensure-enough-width position-canvas position-edit)
-        (send position-edit lock #t)
-        (send position-edit end-edit-sequence))
       
       (send (get-info-panel) change-children
             (λ (l)
@@ -952,17 +1023,7 @@
       (send macro-recording-message show #f)
       (send anchor-message show #f)
       (send overwrite-message show #f)
-      (send* position-canvas
+      (editor-position-changed)))
-        (set-line-count 1)
-        (set-editor position-edit)
-        (stretchable-width #f)
-        (stretchable-height #f))
-      (determine-width "000:00-000:00"
-                       position-canvas
-                       position-edit)
-      (editor-position-changed)
-      (send position-edit hide-caret #t)
-      (send position-edit lock #t)))
   
   (define click-pref-panel%
     (class horizontal-panel%
@@ -993,7 +1054,7 @@
   (define pasteboard-info<%> (interface (info<%>)))
   (define pasteboard-info-mixin
     (mixin (basic<%>) (pasteboard-info<%>)
-      (super-instantiate ())))
+      (super-new)))
   
   (include "standard-menus.ss")
   
@@ -1654,7 +1715,7 @@
       
       (define/public (get-delegatee) delegatee)
       
-      (super-instantiate ())
+      (super-new)
       
       (define delegatee (instantiate delegatee-text% ()))
       (define delegate-ec (instantiate delegatee-editor-canvas% ()
@@ -2049,7 +2110,7 @@
   (define replace-text%
     (class text:keymap%
       (inherit set-styles-fixed)
-      (super-instantiate ())
+      (super-new)
       (set-styles-fixed #t)))
   
   (define find-edit #f)
@@ -2408,7 +2469,7 @@
             (send replace-canvas set-editor replace-edit))
           (end-container-sequence)))
       
-      (super-instantiate ())
+      (super-new)
       
       (hide-search #t)))
   
@@ -2421,12 +2482,9 @@
         (get-editor))
       (define/override (get-editor<%>) text:searching<%>)
       (define/override (get-editor%) text:searching%)
-      (super-instantiate ())))
+      (super-new)))
   
-  (define memory-text% (class text% (super-new)))
+  (define memory-canvases '())
-  (define memory-text (make-object memory-text%))
-  (define memory-canvas #f)
-  (send memory-text hide-caret #t)
   (define show-memory-text?
     (or (with-handlers ([exn:fail:filesystem?
                          (λ (x) #f)])
@@ -2446,7 +2504,7 @@
            (message-box (string-constant drscheme)
                         (string-constant happy-birthday-matthew))]
           [else (super on-event evt)]))
-      (super-instantiate ())))
+      (super-new)))
   
   (define basic% (register-group-mixin (basic-mixin frame%)))
   (define size-pref% (size-pref-mixin basic%))

collects/framework/private/scheme.ss

@@ -394,7 +394,7 @@
       (send style-list find-named-style "Matching Parenthesis Style")))
   
   (define text-mixin
-    (mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>)
+    (mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>) (-text<%>)
       (inherit begin-edit-sequence
                delete
                end-edit-sequence
@@ -433,12 +433,34 @@
       (inherit has-focus? find-snip split-snip
                position-location get-dc)
       
+      (define/override (get-word-at current-pos)
+        (let ([no-word ""])
+          (cond
+            [(or (is-stopped?) (is-frozen?))
+             no-word]
+            [else
+             (let ([type (classify-position current-pos)])
+               (cond
+                 [(eq? 'symbol type) 
+                  (get-text (look-for-non-symbol current-pos)
+                            current-pos)]
+                 [else no-word]))])))
+      
+      (define/private (look-for-non-symbol start)
+        (let loop ([i start])
+          (cond
+            [(< i 0) 0]
+            [(eq? (classify-position i) 'symbol)
+             (loop (- i 1))]
+            [else (+ i 1)])))
+
       (public tabify-on-return? tabify
               tabify-all insert-return calc-last-para 
               box-comment-out-selection comment-out-selection uncomment-selection
               flash-forward-sexp 
               flash-backward-sexp backward-sexp find-up-sexp up-sexp find-down-sexp down-sexp
               remove-parens-forward)
+      
       (define/public (get-limit pos) 0)
       
       (define/public (balance-parens key-event)
@@ -1165,8 +1187,9 @@
   
   (define -text% (set-mode-mixin
                   (text-mixin
+                   (text:autocomplete-mixin
                     (mode:host-text-mixin
-                    color:text%))))
+                     color:text%)))))
   
   (define text-mode% (text-mode-mixin color:text-mode%))