diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index a2062c62..4fa8915e 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -259,63 +259,6 @@ (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]) @@ -537,7 +480,7 @@ ;; need high priority callbacks to ensure ordering wrt other callbacks (queue-callback t #t)))) - (super-new))) + (super-instantiate ()))) (define info<%> (interface (basic<%>) determine-width @@ -665,11 +608,15 @@ (define/public (get-info-panel) info-panel) (define/public (update-memory-text) - (when show-memory-text? - (for-each - (λ (memory-canvas) - (send memory-canvas set-str (format-number (current-memory-use)))) - memory-canvases))) + (when (and show-memory-text? + memory-canvas) + (send memory-text begin-edit-sequence) + (send memory-text lock #f) + (send memory-text erase) + (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)] @@ -680,8 +627,7 @@ "." (cond [(<= after-decimal 9) (format "0~a" after-decimal)] - [else (number->string after-decimal)]) - " MB"))) + [else (number->string after-decimal)])))) (define/private (pad-to-3 n) (cond @@ -693,21 +639,27 @@ (when show-memory-text? (let* ([panel (new horizontal-panel% [parent (get-info-panel)] - ;[style '(border)] + [style '(border)] [stretchable-width #f] [stretchable-height #f])] - [ec (new position-canvas% + [button (new button% + [label (string-constant collect-button-label)] + [parent panel] + [callback + (λ x + (collect-garbage) + (update-memory-text))])] + [ec (new editor-canvas% [parent panel] - [button-up - (λ () - (collect-garbage) - (update-memory-text))] - [init-width "99.99 MB"])]) - (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 (λ () - (remq ec memory-canvases))) + (send ec set-editor #f))) (send panel stretchable-width #f))) [define lock-canvas (make-object lock-canvas% (get-info-panel))] @@ -770,40 +722,6 @@ (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 @@ -839,15 +757,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)]) + (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))) - (format "~a" pos)))]) + col)) + (format "~a" pos))))]) (cond [(not (object? position-canvas)) (void)] @@ -863,7 +781,7 @@ (set! last-params (list offset? line-numbers?)) (set! last-start start) (set! last-end end) - (when (object? position-canvas) + (when (object? position-edit) (change-position-edit-contents (if (= start end) (make-one start) @@ -975,9 +893,20 @@ [parent (get-info-panel)] [stretchable-width #f] [stretchable-height #f])) - (define position-canvas (new position-canvas% [parent position-parent] [init-width "000:00-000:00"])) + (define position-canvas (new editor-canvas% + [parent position-parent] + [style '(no-hscroll no-vscroll)])) + + (define position-edit (new text%)) + (define/private (change-position-edit-contents str) - (send position-canvas set-str str)) + (send position-edit begin-edit-sequence) + (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) @@ -1023,7 +952,17 @@ (send macro-recording-message show #f) (send anchor-message show #f) (send overwrite-message show #f) - (editor-position-changed))) + (send* position-canvas + (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% @@ -1054,7 +993,7 @@ (define pasteboard-info<%> (interface (info<%>))) (define pasteboard-info-mixin (mixin (basic<%>) (pasteboard-info<%>) - (super-new))) + (super-instantiate ()))) (include "standard-menus.ss") @@ -1715,7 +1654,7 @@ (define/public (get-delegatee) delegatee) - (super-new) + (super-instantiate ()) (define delegatee (instantiate delegatee-text% ())) (define delegate-ec (instantiate delegatee-editor-canvas% () @@ -2110,7 +2049,7 @@ (define replace-text% (class text:keymap% (inherit set-styles-fixed) - (super-new) + (super-instantiate ()) (set-styles-fixed #t))) (define find-edit #f) @@ -2469,7 +2408,7 @@ (send replace-canvas set-editor replace-edit)) (end-container-sequence))) - (super-new) + (super-instantiate ()) (hide-search #t))) @@ -2482,9 +2421,12 @@ (get-editor)) (define/override (get-editor<%>) text:searching<%>) (define/override (get-editor%) text:searching%) - (super-new))) + (super-instantiate ()))) - (define memory-canvases '()) + (define memory-text% (class text% (super-new))) + (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)]) @@ -2504,7 +2446,7 @@ (message-box (string-constant drscheme) (string-constant happy-birthday-matthew))] [else (super on-event evt)])) - (super-new))) + (super-instantiate ()))) (define basic% (register-group-mixin (basic-mixin frame%))) (define size-pref% (size-pref-mixin basic%))