www

commit 19920550e1682e3dcba824f024a34e9a3066d753
parent 86e824488c2a2e699933c44a4de25c8a5d808175
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Sun,  1 Oct 2006 22:38:19 +0000

Added context popup menu to syntax browser & macro stepper
Made identifier=? menus use checkable items

svn: r4461

original commit: 00b0dc8f10ce311a620aead3844af299440a0124

Diffstat:
M
collects/macro-debugger/syntax-browser/controller.ss
 | 
13
+++++++++----
M
collects/macro-debugger/syntax-browser/widget.ss
 | 
47
+++++++++++++++++++++++++++++++++++++++--------

2 files changed, 48 insertions(+), 12 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss
@@ -16,6 +16,7 @@
       (define colorers null)
       (define selection-listeners null)
       (define selected-syntax #f)
+      (define identifier=?-listeners null)
       (init-field (properties-controller
                    (new independent-properties-controller% (controller this))))
 
@@ -27,8 +28,7 @@
         (for-each (lambda (c) (send c select-syntax stx)) colorers)
         (for-each (lambda (p) (p stx)) selection-listeners))
 
-      (define/public (get-selected-syntax)
-        selected-syntax)
+      (define/public (get-selected-syntax) selected-syntax)
 
       (define/public (get-properties-controller) properties-controller)
 
@@ -41,10 +41,15 @@
       (define/public (add-selection-listener p)
         (set! selection-listeners (cons p selection-listeners)))
       
-      (define/public (on-update-identifier=? id=?)
+      (define/public (on-update-identifier=? name id=?)
         (set! -secondary-partition 
               (and id=? (new partition% (relation id=?))))
-        (for-each (lambda (c) (send c refresh)) colorers))
+        (for-each (lambda (c) (send c refresh)) colorers)
+        (for-each (lambda (f) (f name id=?)) identifier=?-listeners))
+      
+      (define/public (add-identifier=?-listener f)
+        (set! identifier=?-listeners
+              (cons f identifier=?-listeners)))
 
       (define/public (erase)
         (set! colorers null))
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -77,6 +77,36 @@
                                      "")
                                  (send e get-time-stamp)))))
           ;; FIXME: Add option for "formatted" copy/paste?
+          
+          (new menu-item%
+               (label "Clear selection")
+               (parent context-menu)
+               (callback (lambda _ (send controller select-syntax #f))))
+
+          (new separator-menu-item% (parent context-menu))
+          
+          ;; properties
+          (new menu-item% 
+               (label "Show/hide syntax properties")
+               (parent context-menu)
+               (callback (lambda _ (toggle-props))))
+          
+          ;; primary selection
+          (let ([secondary (new menu% (label "identifier=?") (parent context-menu))])
+            (for-each
+             (lambda (name func)
+               (let ([this-choice
+                      (new checkable-menu-item%
+                           (label name)
+                           (parent secondary)
+                           (callback 
+                            (lambda (i e)
+                              (send controller on-update-identifier=? name func))))])
+                 (send controller add-identifier=?-listener
+                       (lambda (new-name new-id=?) 
+                         (send this-choice check (eq? name new-name))))))
+             (map car (identifier=-choices))
+             (map cdr (identifier=-choices))))
           context-menu))
       
       ;; syntax-properties-controller<%> methods
@@ -202,15 +232,16 @@
            (callback (lambda _ (toggle-props))))
 
       (define/private (on-update-identifier=?-choice)
-        (let ([id=? (get-identifier=?)])
-          (send (get-controller) on-update-identifier=? id=?)))
-
-      (define/private (get-identifier=?)
-        (cond [(assoc (send -choice get-string-selection) 
+        (cond [(assoc (send -choice get-string-selection)
                       -identifier=-choices)
-               => cdr]
-              [else #f]))))
-
+               => (lambda (p)
+                    (send (get-controller)
+                          on-update-identifier=? (car p) (cdr p)))]
+              [else #f]))
+      (send (get-controller) add-identifier=?-listener
+            (lambda (name func)
+              (send -choice set-selection
+                    (or (send -choice find-string name) 0))))))
 
   ;; syntax-browser-frame%
   (define syntax-browser-frame%