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

Add Optimization Coach right-click menu entry to existing menu.

Browse Source
This commit is contained in:
Vincent St-Amour 2012-07-24 12:30:27 -04:00
parent 73942fcfa8
commit f2ff88be4a
1 changed files with 23 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/typed-racket/optimizer/tool/tool.rkt
View File

@ -43,7 +43,8 @@
hide-optimization-coach-panel hide-optimization-coach-panel
get-filters get-filters
set-filters! set-filters!
optimization-coach-visible?) optimization-coach-visible?
build-optimization-coach-popup-menu)
(define optimization-coach-drracket-button (define optimization-coach-drracket-button
(list (list
@ -143,34 +144,20 @@
(define/augment (on-delete start len) (define/augment (on-delete start len)
(clear-highlights)) (clear-highlights))
(define/override (on-event event) (define/public (build-optimization-coach-popup-menu menu pos text)
(if (send event button-down? 'right)
(let-values ([(pos text) (get-pos/text event)])
(define menu (build-optimization-coach-popup-menu pos text))
(if menu
(send (get-canvas) popup-menu menu
(+ 1 (inexact->exact (floor (send event get-x))))
(+ 1 (inexact->exact (floor (send event get-y)))))
;; not for us, pass it on
(super on-event event)))
;; not a right click, pass it on
(super on-event event)))
(define (build-optimization-coach-popup-menu pos text)
(and pos (and pos
(is-a? text text%) (is-a? text text%)
;; pos is in a highlight ;; pos is in a highlight
(for/fold ([menu #f]) (for/fold ([new-item #f])
([h (in-list highlights)]) ([h (in-list highlights)])
(match-define `(,start ,end ,popup-fun) h) (match-define `(,start ,end ,popup-fun) h)
(or menu (or new-item
(and (<= start pos end) (and (<= start pos end)
(let ([menu (make-object popup-menu% #f)]) (new menu-item%
(new menu-item% [label "Show Optimization Info"]
[label "Show Optimization Info"] [parent menu]
[parent menu] [callback (lambda _
[callback (lambda _ (popup-fun text start end))]) (popup-fun text start end))]))))))
menu))))))
(super-new))) (super-new)))
@ -233,7 +220,8 @@
(define tab-switch-mixin (define tab-switch-mixin
(mixin (drracket:unit:frame<%>) () (mixin (drracket:unit:frame<%>) ()
(inherit set-show-menu-sort-key get-current-tab) (inherit set-show-menu-sort-key get-current-tab
get-definitions-text)
(define/public (get-optimization-coach-menu-item) (define/public (get-optimization-coach-menu-item)
optimization-coach-menu-item) optimization-coach-menu-item)
@ -267,6 +255,17 @@
(define optimization-coach-menu-item #f) (define optimization-coach-menu-item #f)
;; right-click menu
(keymap:add-to-right-button-menu
(let ([old (keymap:add-to-right-button-menu)])
(lambda (menu editor event)
(define definitions (get-definitions-text))
(let-values ([(pos text) (send definitions get-pos/text event)])
(send definitions build-optimization-coach-popup-menu
menu pos text))
(old menu editor event))))
(super-new))) (super-new)))
(drracket:get/extend:extend-unit-frame tab-switch-mixin)) (drracket:get/extend:extend-unit-frame tab-switch-mixin))