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

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

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)
-    ))

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)

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%

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 (<? ixstart end))
+               ;; First do leading gap, [ start, key(ix) )
                (when (<? start ixstart)
                  (skip-list-set! s start (cons ixstart (force updated-defaultp))))
                ;; Then interval, [ ixstart, end(ix) )
-               (when (<? ixstart end)
-                 (let ([ixvalue (skip-list-iterate-value s ix)])
-                   (skip-list-iterate-set-value! s ix
-                     (cons (car ixvalue) (updater (cdr ixvalue))))
-                   (loop (car ixvalue) (skip-list-iterate-next s ix)))))]
-            [else
-             ;; Do gap, [ start, end )
-             (when (<? start end)
-               (skip-list-set! s start (cons end (force updated-defaultp))))]))))
+               (let ([ixvalue (skip-list-iterate-value s ix)])
+                 (skip-list-iterate-set-value! s ix
+                   (cons (car ixvalue) (updater (cdr ixvalue))))
+                 (loop (car ixvalue) (skip-list-iterate-next s ix)))]
+              [else
+               ;; Do gap, [ start, end )
+               (when (<? start end)
+                 (skip-list-set! s start (cons end (force updated-defaultp))))])))))
 
 
 (define (interval-map-cons*! im start end obj [default null])