From 1df81534e7dff2dcc30be3d187dd76cfc99fd319 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 8 Oct 2007 13:08:33 +0000 Subject: [PATCH] fix to transpose-sexp so that it now works with snips. Thanks to Danny Yoo svn: r7449 --- collects/framework/private/frame.ss | 190 +++++++++++++++++---------- collects/framework/private/scheme.ss | 29 +++- 2 files changed, 147 insertions(+), 72 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 4fa8915ee2..a2062c6263 100644 --- a/collects/framework/private/frame.ss +++ b/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? - 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))) + (when show-memory-text? + (for-each + (λ (memory-canvas) + (send memory-canvas set-str (format-number (current-memory-use)))) + memory-canvases))) (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% - [label (string-constant collect-button-label)] - [parent panel] - [callback - (λ x - (collect-garbage) - (update-memory-text))])] - [ec (new editor-canvas% + [ec (new position-canvas% [parent panel] - [editor memory-text] - [line-count 1] - [style '(no-hscroll no-vscroll)])]) - (set! memory-canvas ec) - (determine-width "99.99" ec memory-text) + [button-up + (λ () + (collect-garbage) + (update-memory-text))] + [init-width "99.99 MB"])]) + (set! memory-canvases (cons ec memory-canvases)) (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) - (let* ([line (send edit position-paragraph pos)] - [col (find-col edit line pos)]) - (if line-numbers? + (if line-numbers? + (let* ([line (send edit position-paragraph pos)] + [col (find-col edit line pos)]) (format "~a:~a" (add1 line) (if offset? (add1 col) - col)) - (format "~a" pos))))]) + col))) + (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% - [parent position-parent] - [style '(no-hscroll no-vscroll)])) - - (define position-edit (new text%)) - + (define position-canvas (new position-canvas% [parent position-parent] [init-width "000:00-000:00"])) (define/private (change-position-edit-contents 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 position-canvas set-str str)) (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 - (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))) + (editor-position-changed))) (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-text (make-object memory-text%)) - (define memory-canvas #f) - (send memory-text hide-caret #t) + (define memory-canvases '()) (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%)) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index cba5d7b1b1..54add80c5c 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1031,6 +1031,23 @@ (change-style matching-parenthesis-style pos (+ pos 1)) (change-style matching-parenthesis-style (- end 1) end)]))))))) + ;; get-snips/rev: start end -> (listof snip) + ;; Returns a list of the snips in reverse order between + ;; start and end. + (define/private (get-snips/rev start end) + (split-snip start) + (split-snip end) + (let loop ([snips/rev '()] + [a-snip (find-snip start 'after-or-none)]) + (cond + [(or (not a-snip) + (>= (get-snip-position a-snip) + end)) + snips/rev] + [else + (loop (cons (send a-snip copy) snips/rev) + (send a-snip next))]))) + (define/public (transpose-sexp pos) (let ([start-1 (get-backward-sexp pos)]) (if (not start-1) @@ -1045,13 +1062,13 @@ (if (or (not start-2) (< start-2 end-1)) (bell) - (let ([text-1 - (get-text start-1 end-1)] - [text-2 - (get-text start-2 end-2)]) + (let ([snips-1/rev (get-snips/rev start-1 end-1)] + [snips-2/rev (get-snips/rev start-2 end-2)]) (begin-edit-sequence) - (insert text-1 start-2 end-2) - (insert text-2 start-1 end-1) + (delete start-2 end-2) + (for-each (λ (s) (insert s start-2)) snips-1/rev) + (delete start-1 end-1) + (for-each (λ (s) (insert s start-1)) snips-2/rev) (set-position end-2) (end-edit-sequence))))))))))) [define tab-size 8]