suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix to transpose-sexp so that it now works with snips. Thanks to Danny Yoo

Browse Source 
svn: r7449
This commit is contained in:
Robby Findler 2007-10-08 13:08:33 +00:00
parent b712773aa7
commit 1df81534e7
2 changed files with 147 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

190
collects/framework/private/frame.ss
View File

@ -259,6 +259,63 @@
(define unlocked-message-line1 (string-constant read/write-line1)) (define unlocked-message-line1 (string-constant read/write-line1))
(define unlocked-message-line2 (string-constant read/write-line2)) (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% (define lock-canvas%
(class canvas% (class canvas%
(field [locked? #f]) (field [locked? #f])
@ -480,7 +537,7 @@
;; need high priority callbacks to ensure ordering wrt other callbacks ;; need high priority callbacks to ensure ordering wrt other callbacks
(queue-callback t #t)))) (queue-callback t #t))))
(super-instantiate ()))) (super-new)))
(define info<%> (interface (basic<%>) (define info<%> (interface (basic<%>)
determine-width determine-width
@ -608,15 +665,11 @@
(define/public (get-info-panel) info-panel) (define/public (get-info-panel) info-panel)
(define/public (update-memory-text) (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) (define/private (format-number n)
(let* ([mbytes (/ n 1024 1024)] (let* ([mbytes (/ n 1024 1024)]
@ -627,7 +680,8 @@
"." "."
(cond (cond
[(<= after-decimal 9) (format "0~a" after-decimal)] [(<= 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) (define/private (pad-to-3 n)
(cond (cond
@ -639,27 +693,21 @@
(when show-memory-text? (when show-memory-text?
(let* ([panel (new horizontal-panel% (let* ([panel (new horizontal-panel%
[parent (get-info-panel)] [parent (get-info-panel)]
[style '(border)] ;[style '(border)]
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #f])] [stretchable-height #f])]
[button (new button% [ec (new position-canvas%
[label (string-constant collect-button-label)]
[parent panel]
[callback
(λ x
(collect-garbage)
(update-memory-text))])]
[ec (new editor-canvas%
[parent panel] [parent panel]
[editor memory-text] [button-up
[line-count 1] (λ ()
[style '(no-hscroll no-vscroll)])]) (collect-garbage)
(set! memory-canvas ec) (update-memory-text))]
(determine-width "99.99" ec memory-text) [init-width "99.99 MB"])])
(set! memory-canvases (cons ec memory-canvases))
(update-memory-text) (update-memory-text)
(set! memory-cleanup (set! memory-cleanup
(λ () (λ ()
(send ec set-editor #f))) (remq ec memory-canvases)))
(send panel stretchable-width #f))) (send panel stretchable-width #f)))
[define lock-canvas (make-object lock-canvas% (get-info-panel))] [define lock-canvas (make-object lock-canvas% (get-info-panel))]
@ -722,6 +770,40 @@
(let-values ([(cw ch) (send position-canvas get-client-size)]) (let-values ([(cw ch) (send position-canvas get-client-size)])
(inexact->exact (floor (- cw (unbox wb))))))) (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<%>) (define text-info<%> (interface (info<%>)
set-macro-recording set-macro-recording
overwrite-status-changed overwrite-status-changed
@ -757,15 +839,15 @@
(let* ([edit (get-info-editor)] (let* ([edit (get-info-editor)]
[make-one [make-one
(λ (pos) (λ (pos)
(let* ([line (send edit position-paragraph pos)] (if line-numbers?
[col (find-col edit line pos)]) (let* ([line (send edit position-paragraph pos)]
(if line-numbers? [col (find-col edit line pos)])
(format "~a:~a" (format "~a:~a"
(add1 line) (add1 line)
(if offset? (if offset?
(add1 col) (add1 col)
col)) col)))
(format "~a" pos))))]) (format "~a" pos)))])
(cond (cond
[(not (object? position-canvas)) [(not (object? position-canvas))
(void)] (void)]
@ -781,7 +863,7 @@
(set! last-params (list offset? line-numbers?)) (set! last-params (list offset? line-numbers?))
(set! last-start start) (set! last-start start)
(set! last-end end) (set! last-end end)
(when (object? position-edit) (when (object? position-canvas)
(change-position-edit-contents (change-position-edit-contents
(if (= start end) (if (= start end)
(make-one start) (make-one start)
@ -893,20 +975,9 @@
[parent (get-info-panel)] [parent (get-info-panel)]
[stretchable-width #f] [stretchable-width #f]
[stretchable-height #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) (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 (send (get-info-panel) change-children
(λ (l) (λ (l)
@ -952,17 +1023,7 @@
(send macro-recording-message show #f) (send macro-recording-message show #f)
(send anchor-message show #f) (send anchor-message show #f)
(send overwrite-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% (define click-pref-panel%
(class horizontal-panel% (class horizontal-panel%
@ -993,7 +1054,7 @@
(define pasteboard-info<%> (interface (info<%>))) (define pasteboard-info<%> (interface (info<%>)))
(define pasteboard-info-mixin (define pasteboard-info-mixin
(mixin (basic<%>) (pasteboard-info<%>) (mixin (basic<%>) (pasteboard-info<%>)
(super-instantiate ()))) (super-new)))
(include "standard-menus.ss") (include "standard-menus.ss")
@ -1654,7 +1715,7 @@
(define/public (get-delegatee) delegatee) (define/public (get-delegatee) delegatee)
(super-instantiate ()) (super-new)
(define delegatee (instantiate delegatee-text% ())) (define delegatee (instantiate delegatee-text% ()))
(define delegate-ec (instantiate delegatee-editor-canvas% () (define delegate-ec (instantiate delegatee-editor-canvas% ()
@ -2049,7 +2110,7 @@
(define replace-text% (define replace-text%
(class text:keymap% (class text:keymap%
(inherit set-styles-fixed) (inherit set-styles-fixed)
(super-instantiate ()) (super-new)
(set-styles-fixed #t))) (set-styles-fixed #t)))
(define find-edit #f) (define find-edit #f)
@ -2408,7 +2469,7 @@
(send replace-canvas set-editor replace-edit)) (send replace-canvas set-editor replace-edit))
(end-container-sequence))) (end-container-sequence)))
(super-instantiate ()) (super-new)
(hide-search #t))) (hide-search #t)))
@ -2421,12 +2482,9 @@
(get-editor)) (get-editor))
(define/override (get-editor<%>) text:searching<%>) (define/override (get-editor<%>) text:searching<%>)
(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? (define show-memory-text?
(or (with-handlers ([exn:fail:filesystem? (or (with-handlers ([exn:fail:filesystem?
(λ (x) #f)]) (λ (x) #f)])
@ -2446,7 +2504,7 @@
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant happy-birthday-matthew))] (string-constant happy-birthday-matthew))]
[else (super on-event evt)])) [else (super on-event evt)]))
(super-instantiate ()))) (super-new)))
(define basic% (register-group-mixin (basic-mixin frame%))) (define basic% (register-group-mixin (basic-mixin frame%)))
(define size-pref% (size-pref-mixin basic%)) (define size-pref% (size-pref-mixin basic%))

29
collects/framework/private/scheme.ss
View File

@ -1031,6 +1031,23 @@
(change-style matching-parenthesis-style pos (+ pos 1)) (change-style matching-parenthesis-style pos (+ pos 1))
(change-style matching-parenthesis-style (- end 1) end)]))))))) (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) (define/public (transpose-sexp pos)
(let ([start-1 (get-backward-sexp pos)]) (let ([start-1 (get-backward-sexp pos)])
(if (not start-1) (if (not start-1)
@ -1045,13 +1062,13 @@
(if (or (not start-2) (if (or (not start-2)
(< start-2 end-1)) (< start-2 end-1))
(bell) (bell)
(let ([text-1 (let ([snips-1/rev (get-snips/rev start-1 end-1)]
(get-text start-1 end-1)] [snips-2/rev (get-snips/rev start-2 end-2)])
[text-2
(get-text start-2 end-2)])
(begin-edit-sequence) (begin-edit-sequence)
(insert text-1 start-2 end-2) (delete start-2 end-2)
(insert text-2 start-1 end-1) (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) (set-position end-2)
(end-edit-sequence))))))))))) (end-edit-sequence)))))))))))
[define tab-size 8] [define tab-size 8]