From 9c8ad7bb7fb232927ba0f1c6a21e81fabacd97ac Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 18 Dec 2009 03:33:15 +0000 Subject: [PATCH] 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 --- .../syntax-browser/interfaces.ss | 5 + .../macro-debugger/syntax-browser/keymap.ss | 132 ++++++------------ .../macro-debugger/syntax-browser/text.ss | 24 ++-- collects/macro-debugger/view/extensions.ss | 41 +++--- collects/unstable/interval-map.ss | 23 ++- 5 files changed, 88 insertions(+), 137 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index d6bc811761..411f922945 100644 --- 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 index 10dad67c8f..5c43929a51 100644 --- 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 (add-context-menu-items menu) + (void)) - (define/public (get-context-menu%) - smart-context-menu%) - - (field (the-context-menu #f)) - (set! the-context-menu (new (get-context-menu%))) - - (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 menu (new popup-menu%)) + (add-context-menu-items menu) + (send admin popup-menu 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/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) + (define/private (selected-syntax) + (send controller get-selected-syntax)) + ;; Functionality - (define/public (get-controller) controller) - - (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/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))))) - (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 - - (add-menu-items) - )) diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss index 7de682d5e5..8ab05c867c 100644 --- 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 index 1894f8074a..88cd1133ef 100644 --- 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% diff --git a/collects/unstable/interval-map.ss b/collects/unstable/interval-map.ss index 995bfa5c5a..ea62078b8b 100644 --- a/collects/unstable/interval-map.ss +++ b/collects/unstable/interval-map.ss @@ -59,21 +59,20 @@ ;; (Also need to insert missing intervals) ;; Main loop: (let loop ([start start] [ix (skip-list-iterate-least/>=? s start)]) - (cond [ix - ;; First do leading gap, [ start, key(ix) ) - (let ([ixstart (and ix (skip-list-iterate-key s ix))]) + (let ([ixstart (and ix (skip-list-iterate-key s ix))]) + (cond [(and ix (