commit 0cad27438deab291f02f2e4e3b88705b00114f95
parent fcd4cc32c4b0ca68d388ddc5eb31ef8c3d46bcb9
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 8 Nov 2010 21:37:33 -0700
macro-stepper: gui improvements
- give "?" of ?-arrows a white background
- improved clickback replacement
- fixed tack/untack
original commit: 75079ec421d46fed52a16afedf1f3272c5915565
Diffstat:
1 file changed, 64 insertions(+), 33 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt
@@ -19,7 +19,7 @@
text:region-data-mixin
text:clickregion-mixin)
-(define err (current-error-port))
+(define arrow-cursor (make-object cursor% 'arrow))
(define arrow-brush
(send the-brush-list find-or-create-brush "white" 'solid))
@@ -161,17 +161,17 @@
(define tacked-table (make-hasheq))
- (define/override (on-event ev)
+ (define/override (on-local-event ev)
(case (send ev get-event-type)
((right-down)
(if (pair? (get-position-drawings hover-position))
(send (get-canvas) popup-menu
- (make-tack/untack-menu)
+ (make-tack/untack-menu (get-position-drawings hover-position))
(send ev get-x)
(send ev get-y))
- (super on-event ev)))
+ (super on-local-event ev)))
(else
- (super on-event ev))))
+ (super on-local-event ev))))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(super on-paint before? dc left top right bottom dx dy draw-caret)
@@ -179,26 +179,32 @@
(for ([draw (in-hash-keys tacked-table)])
(draw this dc left top right bottom dx dy))))
- (define/private (make-tack/untack-menu)
+ (define/private (make-tack/untack-menu drawings)
(define menu (new popup-menu%))
(define keymap (get-keymap))
- (new menu-item% (label "Tack")
- (parent menu)
- (callback (lambda _ (tack))))
- (new menu-item% (label "Untack")
- (parent menu)
- (callback (lambda _ (untack))))
+ (define tack-item
+ (new menu-item% (label "Tack")
+ (parent menu)
+ (callback (lambda _ (tack drawings)))))
+ (define untack-item
+ (new menu-item% (label "Untack")
+ (parent menu)
+ (callback (lambda _ (untack drawings)))))
+ (send tack-item enable
+ (for/or ([d (in-list drawings)]) (not (unbox (drawing-tacked? d)))))
+ (send untack-item enable
+ (for/or ([d (in-list drawings)]) (unbox (drawing-tacked? d))))
(when (is-a? keymap keymap/popup<%>)
(new separator-menu-item% (parent menu))
(send keymap add-context-menu-items menu))
menu)
- (define/private (tack)
- (for ([d (get-position-drawings hover-position)])
+ (define/private (tack drawings)
+ (for ([d (in-list drawings)])
(hash-set! tacked-table (drawing-draw d) #t)
(set-box! (drawing-tacked? d) #t)))
- (define/private (untack)
- (for ([d (get-position-drawings hover-position)])
+ (define/private (untack drawings)
+ (for ([d (in-list drawings)])
(hash-remove! tacked-table (drawing-draw d))
(set-box! (drawing-tacked? d) #f)))))
@@ -261,13 +267,16 @@
endx
(+ endy (/ fh 2))
dx dy)
- (send dc set-text-mode 'transparent)
(when question?
- (send dc set-font (?-font dc))
- (send dc set-text-foreground color)
- (send dc draw-text "?"
- (+ endx dx fw)
- (- (+ endy dy) fh)))))))])
+ (let* ([?x (+ endx dx fw)]
+ [?y (- (+ endy dy) fh)])
+ (send* dc
+ (set-brush billboard-brush)
+ (set-font (?-font dc))
+ (set-text-foreground color)
+ (draw-rounded-rectangle (- ?x _d) (- ?y _d)
+ (+ fw _d _d) (+ fh _d _d))
+ (draw-text "?" ?x ?y))))))))])
(add-hover-drawing from1 from2 draw tack-box)
(add-hover-drawing to1 to2 draw tack-box))))
@@ -324,34 +333,56 @@ Like clickbacks, but:
(major problem w/ macro stepper and large expansions!)
- callback takes position of click, not (start, end)
- different rules for removal
- - TODO: change cursor on mouse-over
- - TODO: invoke callback on mouse-up
- TODO: extend to double-click
|#
(define text:clickregion-mixin
(mixin (text:region-data<%>) ()
- (inherit get-region-mapping
+ (inherit get-admin
+ get-region-mapping
dc-location-to-editor-location
find-position)
(super-new)
(define clickbacks (get-region-mapping clickregion-key))
+ (define tracking #f)
(define/public (set-clickregion start end callback)
(if callback
(interval-map-set! clickbacks start end callback)
(interval-map-remove! clickbacks start end)))
+ (define/private (get-event-position ev)
+ (define gx (send ev get-x))
+ (define gy (send ev get-y))
+ (define-values (x y) (dc-location-to-editor-location gx gy))
+ (find-position x y))
+
(define/override (on-default-event ev)
- (when (send ev button-down?)
- (define gx (send ev get-x))
- (define gy (send ev get-y))
- (define-values (x y) (dc-location-to-editor-location gx gy))
- (define pos (find-position x y))
- (define cb (interval-map-ref clickbacks pos #f))
- (when cb (cb pos)))
- (super on-default-event ev))))
+ (define admin (get-admin))
+ (when admin
+ (define pos (get-event-position ev))
+ (case (send ev get-event-type)
+ ((left-down)
+ (set! tracking (interval-map-ref clickbacks pos #f))
+ (send admin update-cursor))
+ ((left-up)
+ (when tracking
+ (let ([cb (interval-map-ref clickbacks pos #f)]
+ [tracking* tracking])
+ (set! tracking #f)
+ (when (eq? tracking* cb)
+ (cb pos)))
+ (send admin update-cursor)))))
+ (super on-default-event ev))
+
+ (define/override (adjust-cursor ev)
+ (define pos (get-event-position ev))
+ (define cb (interval-map-ref clickbacks pos #f))
+ (if cb
+ arrow-cursor
+ (super adjust-cursor ev)))))
+
#|
(define text:hover-identifier<%>
