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

Added context popup menu to syntax browser & macro stepper

Browse Source 
Made identifier=? menus use checkable items

svn: r4461
This commit is contained in:
Ryan Culpepper 2006-10-01 22:38:19 +00:00
parent 029659c1d5
commit 00b0dc8f10
4 changed files with 87 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/macro-debugger/syntax-browser/controller.ss
View File

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

47
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -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%

9
collects/macro-debugger/tool.ss
View File

@ -131,7 +131,14 @@
(current-module-name-resolver mnr)))))
(define/private (make-handlers original-eval-handler original-module-name-resolver)
(let ([stepper (delay (make-macro-stepper (new-standard-hiding-policy)))]
(let ([stepper
(delay
(let ([frame (new macro-stepper-frame%
(policy (new-standard-hiding-policy))
(macro-hiding? #t)
(identifier=? "bound-identifier=?"))])
(send frame show #t)
(send frame get-widget)))]
[debugging? debugging?])
(values
(lambda (expr)

58
collects/macro-debugger/view/gui.ss
View File

@ -62,7 +62,7 @@
(init policy
macro-hiding?)
(init (show-hiding-panel? #t)
(identifier=? #f)
(identifier=? "<nothing>")
(width (sb:pref:width))
(height (sb:pref:height)))
(inherit get-menu%
@ -114,40 +114,49 @@
(label label) (parent menu) (callback (lambda _ (callback))))
(new separator-menu-item% (parent menu)))))
(begin
(new (get-menu-item%) (label "Show properties") (parent syntax-menu)
(callback (lambda _ (send (send widget get-view) show-props))))
(new (get-menu-item%) (label "Hide properties") (parent syntax-menu)
(callback (lambda _ (send (send widget get-view) hide-props))))
(define id-menu
(new (get-menu%) (label "Identifier=?") (parent syntax-menu)))
(for-each (lambda (p)
(new (get-menu-item%) (label (car p)) (parent id-menu)
(callback (lambda _
(send (send widget get-controller)
on-update-identifier=?
(cdr p))))))
(sb:identifier=-choices))
(new (get-menu-item%) (label "Clear selection") (parent syntax-menu)
(callback
(lambda _ (send (send widget get-controller) select-syntax #f)))))
(define widget
(new macro-stepper-widget%
(register-syntax-action (mk-register-action syntax-menu))
(register-stepper-action (mk-register-action stepper-menu))
(parent (send this get-area-container))
(policy policy)
(macro-hiding? macro-hiding?)
(show-hiding-panel? show-hiding-panel?)))
(define/public (get-widget) widget)
(begin
(new (get-menu-item%) (label "Show/hide syntax properties") (parent syntax-menu)
(callback (lambda _ (send (send widget get-view) toggle-props))))
(define id-menu
(new (get-menu%) (label "Identifier=?") (parent syntax-menu)))
(for-each (lambda (p)
(let ([this-choice
(new checkable-menu-item%
(label (car p))
(parent id-menu)
(callback (lambda _
(send (send widget get-controller)
on-update-identifier=?
(car p)
(cdr p)))))])
(send (send widget get-controller)
add-identifier=?-listener
(lambda (new-name new-func)
(send this-choice check (eq? new-name (car p)))))))
(sb:identifier=-choices))
(new (get-menu-item%) (label "Clear selection") (parent syntax-menu)
(callback
(lambda _ (send (send widget get-controller) select-syntax #f))))
(new (get-menu-item%)
(label "Show/hide macro hiding configuration")
(parent stepper-menu)
(callback (lambda _ (send widget show/hide-macro-hiding-prefs)))))
(begin
(when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))])
(when p
(send (send widget get-controller)
on-update-identifier=?
(car p)
(cdr p))))))
(frame:reorder-menus this)
@ -157,8 +166,6 @@
(define macro-stepper-widget%
(class* object% ()
(init-field parent)
(init-field register-syntax-action)
(init-field register-stepper-action)
(init policy)
(init macro-hiding?)
(init show-hiding-panel?)
@ -243,10 +250,7 @@
(new button% (label "Next term") (parent updown-navigator)
(callback (lambda (b e) (navigate-down)))))
(register-stepper-action "Show/hide macro hiding configuration"
(lambda () (show/hide-macro-hiding-prefs)))
(define/private (show/hide-macro-hiding-prefs)
(define/public (show/hide-macro-hiding-prefs)
(send area change-children
(lambda (children)
(if (memq control-pane children)