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

macro-stepper: gui improvements

Browse Source 
- give "?" of ?-arrows a white background
  - improved clickback replacement
  - fixed tack/untack

original commit: 75079ec421d46fed52a16afedf1f3272c5915565
This commit is contained in:
Ryan Culpepper 2010-11-08 21:37:33 -07:00
parent fcd4cc32c4
commit 0cad27438d
1 changed files with 64 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
collects/macro-debugger/syntax-browser/text.rkt
View File

@ -19,7 +19,7 @@
text:region-data-mixin text:region-data-mixin
text:clickregion-mixin) text:clickregion-mixin)
(define err (current-error-port)) (define arrow-cursor (make-object cursor% 'arrow))
(define arrow-brush (define arrow-brush
(send the-brush-list find-or-create-brush "white" 'solid)) (send the-brush-list find-or-create-brush "white" 'solid))
@ -161,17 +161,17 @@
(define tacked-table (make-hasheq)) (define tacked-table (make-hasheq))
(define/override (on-event ev) (define/override (on-local-event ev)
(case (send ev get-event-type) (case (send ev get-event-type)
((right-down) ((right-down)
(if (pair? (get-position-drawings hover-position)) (if (pair? (get-position-drawings hover-position))
(send (get-canvas) popup-menu (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-x)
(send ev get-y)) (send ev get-y))
(super on-event ev))) (super on-local-event ev)))
(else (else
(super on-event ev)))) (super on-local-event ev))))
(define/override (on-paint before? dc left top right bottom dx dy draw-caret) (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) (super on-paint before? dc left top right bottom dx dy draw-caret)
@ -179,26 +179,32 @@
(for ([draw (in-hash-keys tacked-table)]) (for ([draw (in-hash-keys tacked-table)])
(draw this dc left top right bottom dx dy)))) (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 menu (new popup-menu%))
(define keymap (get-keymap)) (define keymap (get-keymap))
(new menu-item% (label "Tack") (define tack-item
(parent menu) (new menu-item% (label "Tack")
(callback (lambda _ (tack)))) (parent menu)
(new menu-item% (label "Untack") (callback (lambda _ (tack drawings)))))
(parent menu) (define untack-item
(callback (lambda _ (untack)))) (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<%>) (when (is-a? keymap keymap/popup<%>)
(new separator-menu-item% (parent menu)) (new separator-menu-item% (parent menu))
(send keymap add-context-menu-items menu)) (send keymap add-context-menu-items menu))
menu) menu)
(define/private (tack) (define/private (tack drawings)
(for ([d (get-position-drawings hover-position)]) (for ([d (in-list drawings)])
(hash-set! tacked-table (drawing-draw d) #t) (hash-set! tacked-table (drawing-draw d) #t)
(set-box! (drawing-tacked? d) #t))) (set-box! (drawing-tacked? d) #t)))
(define/private (untack) (define/private (untack drawings)
(for ([d (get-position-drawings hover-position)]) (for ([d (in-list drawings)])
(hash-remove! tacked-table (drawing-draw d)) (hash-remove! tacked-table (drawing-draw d))
(set-box! (drawing-tacked? d) #f))))) (set-box! (drawing-tacked? d) #f)))))
@ -261,13 +267,16 @@
endx endx
(+ endy (/ fh 2)) (+ endy (/ fh 2))
dx dy) dx dy)
(send dc set-text-mode 'transparent)
(when question? (when question?
(send dc set-font (?-font dc)) (let* ([?x (+ endx dx fw)]
(send dc set-text-foreground color) [?y (- (+ endy dy) fh)])
(send dc draw-text "?" (send* dc
(+ endx dx fw) (set-brush billboard-brush)
(- (+ endy dy) fh)))))))]) (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 from1 from2 draw tack-box)
(add-hover-drawing to1 to2 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!) (major problem w/ macro stepper and large expansions!)
- callback takes position of click, not (start, end) - callback takes position of click, not (start, end)
- different rules for removal - different rules for removal
- TODO: change cursor on mouse-over
- TODO: invoke callback on mouse-up
- TODO: extend to double-click - TODO: extend to double-click
|# |#
(define text:clickregion-mixin (define text:clickregion-mixin
(mixin (text:region-data<%>) () (mixin (text:region-data<%>) ()
(inherit get-region-mapping (inherit get-admin
get-region-mapping
dc-location-to-editor-location dc-location-to-editor-location
find-position) find-position)
(super-new) (super-new)
(define clickbacks (get-region-mapping clickregion-key)) (define clickbacks (get-region-mapping clickregion-key))
(define tracking #f)
(define/public (set-clickregion start end callback) (define/public (set-clickregion start end callback)
(if callback (if callback
(interval-map-set! clickbacks start end callback) (interval-map-set! clickbacks start end callback)
(interval-map-remove! clickbacks start end))) (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) (define/override (on-default-event ev)
(when (send ev button-down?) (define admin (get-admin))
(define gx (send ev get-x)) (when admin
(define gy (send ev get-y)) (define pos (get-event-position ev))
(define-values (x y) (dc-location-to-editor-location gx gy)) (case (send ev get-event-type)
(define pos (find-position x y)) ((left-down)
(define cb (interval-map-ref clickbacks pos #f)) (set! tracking (interval-map-ref clickbacks pos #f))
(when cb (cb pos))) (send admin update-cursor))
(super on-default-event ev)))) ((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<%> (define text:hover-identifier<%>