commit f07531a360d2874e85da9b4ac6f1ca01abc1d51a
parent 2ef398f6bb26cdc5a2cfe235db5db3707e702222
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 18 Dec 2009 03:33:15 +0000
macro-debugger:
add tack/untack to normal context menu
fix arrows bug, caused by bug in interval-map
unstable/interval-map: fixed stupid update*! bug
svn: r17346
original commit: 9c8ad7bb7fb232927ba0f1c6a21e81fabacd97ac
Diffstat:
4 files changed, 77 insertions(+), 125 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss
@@ -84,6 +84,11 @@
;; add-keymap : text snip
add-keymap))
+;; keymap/popup<%>
+(define-interface keymap/popup<%> ()
+ (;; add-context-menu-items : popup-menu -> void
+ add-context-menu-items))
+
;; display<%>
(define-interface display<%> ()
(;; refresh : -> void
diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss
@@ -4,75 +4,54 @@
unstable/gui/notify
"interfaces.ss"
"partition.ss")
-(provide smart-keymap%
- syntax-keymap%)
+(provide syntax-keymap%)
-(define smart-keymap%
- (class keymap%
+(define keymap/popup%
+ (class* keymap% (keymap/popup<%>)
(init editor)
-
+ (super-new)
(inherit add-function
map-function
chain-to-keymap)
- (super-new)
-
- (define/public (get-context-menu%)
- smart-context-menu%)
-
- (field (the-context-menu #f))
- (set! the-context-menu (new (get-context-menu%)))
+ (define/public (add-context-menu-items menu)
+ (void))
- (map-function "rightbutton" "popup-context-window")
- (add-function "popup-context-window"
+ (map-function "rightbutton" "popup-context-menu")
+ (add-function "popup-context-menu"
(lambda (editor event)
- (do-popup-context-window editor event)))
+ (popup-context-menu editor event)))
- (chain-to-keymap (send editor get-keymap) #t)
- (send editor set-keymap this)
-
- (define/private (do-popup-context-window editor event)
+ (define/private (popup-context-menu editor event)
(define-values (x y)
(send editor dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(define admin (send editor get-admin))
- (send admin popup-menu the-context-menu x y))
-
- ))
-
-(define smart-context-menu%
- (class popup-menu%
- (define on-demand-actions null)
- (define/public (add-on-demand p)
- (set! on-demand-actions (cons p on-demand-actions)))
+ (define menu (new popup-menu%))
+ (add-context-menu-items menu)
+ (send admin popup-menu menu x y))
- (define/override (on-demand)
- (super on-demand)
- (for-each (lambda (p) (p)) on-demand-actions))
-
- (super-new)))
+ ;; FIXME: move out of constructor to use sites
+ (chain-to-keymap (send editor get-keymap) #t)
+ (send editor set-keymap this)))
(define syntax-keymap%
- (class smart-keymap%
+ (class keymap/popup%
(init-field controller
config)
-
(inherit add-function
map-function
call-function
chain-to-keymap)
- (inherit-field the-context-menu)
- (field [copy-menu #f]
- [clear-menu #f]
- [props-menu #f])
(super-new)
- ;; Functionality
+ (define/private (selected-syntax)
+ (send controller get-selected-syntax))
- (define/public (get-controller) controller)
+ ;; Functionality
- (add-function "copy-text"
+ (add-function "copy-syntax-as-text"
(lambda (_ event)
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
@@ -93,53 +72,24 @@
(lambda (i e)
(send config set-props-shown? #f)))
- (define/private (selected-syntax)
- (send controller get-selected-syntax))
-
- (define/public (add-menu-items)
- (set! copy-menu
- (new menu-item% (label "Copy") (parent the-context-menu)
- (demand-callback
- (lambda (i)
- (send i enable (and (selected-syntax) #t))))
- (callback
- (lambda (i e)
- (call-function "copy-text" i e)))))
- (add-separator)
- (set! clear-menu
- (new menu-item%
- (label "Clear selection")
- (parent the-context-menu)
- (demand-callback
- (lambda (i)
- (send i enable (and (selected-syntax) #t))))
- (callback
- (lambda (i e)
- (call-function "clear-syntax-selection" i e)))))
- (set! props-menu
- (menu-option/notify-box the-context-menu
- "View syntax properties"
- (get-field props-shown? config))
- #;
- (new menu-item%
- (label "Show syntax properties")
- (parent the-context-menu)
- (demand-callback
- (lambda (i)
- (if (send config get-props-shown?)
- (send i set-label "Hide syntax properties")
- (send i set-label "Show syntax properties"))))
- (callback
- (lambda (i e)
- (if (send config get-props-shown?)
- (call-function "hide-syntax-properties" i e)
- (call-function "show-syntax-properties" i e))))))
- (void))
-
- (define/public (add-separator)
- (new separator-menu-item% (parent the-context-menu)))
-
- ;; Initialize menu
+ (define/override (add-context-menu-items menu)
+ (new menu-item% (label "Copy") (parent menu)
+ (demand-callback
+ (lambda (i)
+ (send i enable (and (selected-syntax) #t))))
+ (callback
+ (lambda (i e)
+ (call-function "copy-syntax-as-text" i e))))
+ (new separator-menu-item% (parent menu))
+ (new menu-item%
+ (label "Clear selection")
+ (parent menu)
+ (demand-callback
+ (lambda (i)
+ (send i enable (and (selected-syntax) #t))))
+ (callback
+ (lambda (i e)
+ (call-function "clear-syntax-selection" i e))))
+ (menu-option/notify-box menu "View syntax properties"
+ (get-field props-shown? config)))))
- (add-menu-items)
- ))
diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss
@@ -1,4 +1,3 @@
-
#lang scheme/base
(require scheme/list
scheme/class
@@ -6,7 +5,8 @@
drscheme/arrow
framework/framework
unstable/interval-map
- unstable/gui/notify)
+ unstable/gui/notify
+ "interfaces.ss")
(provide text:hover<%>
text:hover-drawings<%>
@@ -118,10 +118,11 @@
(invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0)))
(define/public (add-hover-drawing start end draw [tack-box (box #f)])
- (interval-map-cons*! drawings-list
- start (add1 end)
- (make-drawing start end draw tack-box)
- null))
+ (let ([drawing (make-drawing start end draw tack-box)])
+ (interval-map-cons*! drawings-list
+ start (add1 end)
+ drawing
+ null)))
(define/public (delete-all-drawings)
(interval-map-remove! drawings-list -inf.0 +inf.0))
@@ -145,6 +146,7 @@
(define text:tacking-mixin
(mixin (text:basic<%> text:hover-drawings<%>) ()
(inherit get-canvas
+ get-keymap
get-position-drawings)
(inherit-field hover-position)
(super-new)
@@ -171,14 +173,16 @@
(define/private (make-tack/untack-menu)
(define menu (new popup-menu%))
+ (define keymap (get-keymap))
(new menu-item% (label "Tack")
(parent menu)
- (callback
- (lambda _ (tack))))
+ (callback (lambda _ (tack))))
(new menu-item% (label "Untack")
(parent menu)
- (callback
- (lambda _ (untack))))
+ (callback (lambda _ (untack))))
+ (when (is-a? keymap keymap/popup<%>)
+ (new separator-menu-item% (parent menu))
+ (send keymap add-context-menu-items menu))
menu)
(define/private (tack)
diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.ss
@@ -32,8 +32,7 @@
(class s:syntax-keymap%
(init-field: (macro-stepper widget<%>))
(inherit-field config
- controller
- the-context-menu)
+ controller)
(inherit add-function
call-function)
@@ -59,29 +58,23 @@
;; Menu
- (inherit add-separator)
+ (define/override (add-context-menu-items menu)
+ (super add-context-menu-items menu)
+ (new separator-menu-item% (parent menu))
+ (new menu-item% (label "Show selected identifier") (parent menu)
+ (demand-callback
+ (lambda (i)
+ (send i enable (identifier? (send controller get-selected-syntax)))))
+ (callback
+ (lambda (i e)
+ (call-function "hiding:show-macro" i e))))
+ (new menu-item% (label "Hide selected identifier") (parent menu)
+ (demand-callback
+ (lambda (i)
+ (send i enable (identifier? (send controller get-selected-syntax)))))
+ (callback
+ (lambda (i e) (call-function "hiding:hide-macro" i e)))))))
- (define/override (add-menu-items)
- (super add-menu-items)
- (add-separator)
- (set! show-macro
- (new menu-item% (label "Show selected identifier") (parent the-context-menu)
- (callback (lambda (i e)
- (call-function "hiding:show-macro" i e)))))
- (set! hide-macro
- (new menu-item% (label "Hide selected identifier") (parent the-context-menu)
- (callback (lambda (i e)
- (call-function "hiding:hide-macro" i e)))))
- (enable/disable-hide/show #f)
- (void))
-
- (define/private (enable/disable-hide/show ?)
- (send show-macro enable ?)
- (send hide-macro enable ?))
-
- (send: controller s:controller<%> listen-selected-syntax
- (lambda (stx)
- (enable/disable-hide/show (identifier? stx))))))
(define stepper-syntax-widget%
(class s:widget%
