commit df01af09b9027f282038d580e6a5001b1ebf3fec
parent 9599b2253b733881fcd7da95e12a01c43eb7ac72
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 6 Oct 2006 04:48:14 +0000
Fixed eol properties
Reorganized macro stepper gui
Added macro stepper actions to popup menu
svn: r4505
original commit: 39145f9c71807baf1e97d66db63f135fbf7e2999
Diffstat:
10 files changed, 417 insertions(+), 86 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/embed.ss b/collects/macro-debugger/syntax-browser/embed.ss
@@ -1,11 +1,15 @@
(module embed mzscheme
(require "interfaces.ss"
+ "widget.ss"
+ "keymap.ss"
"implementation.ss"
"params.ss"
"partition.ss")
(provide (all-from "interfaces.ss")
+ (all-from "widget.ss")
+ (all-from "keymap.ss")
(all-from "implementation.ss")
(all-from "params.ss")
identifier=-choices))
diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.ss
@@ -4,7 +4,9 @@
(lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
- "interfaces.ss")
+ (lib "list.ss")
+ "interfaces.ss"
+ "partition.ss")
(provide frame@)
(define frame@
@@ -47,5 +49,49 @@
(send widget save-prefs)
(preferences:save)
(inner (void) on-close))
- ))))
+ ))
+
+ ;; syntax-widget/controls%
+ (define syntax-widget/controls%
+ (class* syntax-widget% ()
+ (inherit get-main-panel
+ get-controller
+ toggle-props)
+ (super-new)
+
+ (define -control-panel
+ (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
+
+ ;; Put the control panel up front
+ (send (get-main-panel) change-children
+ (lambda (children)
+ (cons -control-panel (remq -control-panel children))))
+
+ (define -identifier=-choices (identifier=-choices))
+ (define -choice
+ (new choice% (label "identifer=?") (parent -control-panel)
+ (choices (map car -identifier=-choices))
+ (callback (lambda _ (on-update-identifier=?-choice)))))
+ (new button%
+ (label "Clear")
+ (parent -control-panel)
+ (callback (lambda _ (send (get-controller) select-syntax #f))))
+ (new button%
+ (label "Properties")
+ (parent -control-panel)
+ (callback (lambda _ (toggle-props))))
+
+ (define/private (on-update-identifier=?-choice)
+ (cond [(assoc (send -choice get-string-selection)
+ -identifier=-choices)
+ => (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))))))
+
+ ))
)
diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss
@@ -16,6 +16,9 @@
;; make-syntax-browser : -> syntax-browser<%>
make-syntax-browser
+ ;; syntax-widget/controls%
+ syntax-widget/controls%
+
;; syntax-browser-frame%
syntax-browser-frame%))
@@ -50,10 +53,7 @@
(define-signature widget^
(;; syntax-widget%
- syntax-widget%
-
- ;; syntax-widget/controls%
- syntax-widget/controls%))
+ syntax-widget%))
(define-signature implementation^
([unit widget : widget^]
@@ -97,8 +97,8 @@
;; show : boolean -> void
#;show
- ;; is-shown? : -> boolean
- #;is-shown?))
+ ;; props-shown? : -> boolean
+ props-shown?))
;; syntax-configuration<%>
(define syntax-configuration<%>
diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss
@@ -49,35 +49,42 @@
(init-field controller)
(super-new)
+ (define copy-menu #f)
+ (define copy-syntax-menu #f)
+ (define clear-menu #f)
+
(define/public (add-edit-items)
- (new menu-item% (label "Copy") (parent this)
- (callback (lambda (i e)
- (define stx (send controller get-selected-syntax))
- (send the-clipboard set-clipboard-string
- (if stx
- (format "~s" (syntax-object->datum stx))
- "")
- (send e get-time-stamp)))))
- (new menu-item% (label "Copy syntax") (parent this)
- (callback (lambda (i e)
- (define stx (send controller get-selected-syntax))
- (define t (new text%))
- (send t insert
- (new syntax-snip%
- (syntax stx)
- #;(controller controller)))
- (send t select-all)
- (send t copy))))
+ (set! copy-menu
+ (new menu-item% (label "Copy") (parent this)
+ (callback (lambda (i e)
+ (define stx (send controller get-selected-syntax))
+ (send the-clipboard set-clipboard-string
+ (if stx
+ (format "~s" (syntax-object->datum stx))
+ "")
+ (send e get-time-stamp))))))
+ (set! copy-syntax-menu
+ (new menu-item% (label "Copy syntax") (parent this)
+ (callback (lambda (i e)
+ (define stx (send controller get-selected-syntax))
+ (define t (new text%))
+ (send t insert
+ (new syntax-snip%
+ (syntax stx)
+ #;(controller controller)))
+ (send t select-all)
+ (send t copy)))))
(void))
(define/public (after-edit-items)
(void))
(define/public (add-selection-items)
- (new menu-item%
- (label "Clear selection")
- (parent this)
- (callback (lambda _ (send controller select-syntax #f))))
+ (set! clear-menu
+ (new menu-item%
+ (label "Clear selection")
+ (parent this)
+ (callback (lambda _ (send controller select-syntax #f)))))
(void))
(define/public (after-selection-items)
@@ -106,7 +113,14 @@
(define/public (add-separator)
(new separator-menu-item% (parent this)))
-
+
+ (define/override (on-demand)
+ (define stx (send controller get-selected-syntax))
+ (send copy-menu enable (and stx #t))
+ (send copy-syntax-menu enable (and stx #t))
+ (send clear-menu enable (and stx #t))
+ (super on-demand))
+
;; Initialization
(add-edit-items)
(after-edit-items)
diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss
@@ -105,8 +105,8 @@
(define -outer (new text%))
(super-new (editor -outer) (with-border? #f))
- (set-margin 2 0 0 0)
- (set-inset 3 0 0 0)
+ (set-margin 0 0 0 0)
+ (set-inset 0 0 0 0)
(set-snipclass snip-class)
(send -outer select-all)
(send -outer change-style (make-object style-delta% 'change-alignment 'top)
@@ -195,7 +195,7 @@
(send pv set-syntax stx))
(define/public (show ?)
(send parent show ?))
- (define/public (is-shown?)
+ (define/public (props-shown?)
(send parent is-shown?))
(super-new)))
))
@@ -207,7 +207,7 @@
(define context-menu%
(class pre:context-menu%
(init-field snip)
-
+
(define/override (after-selection-items)
(super after-selection-items)
(new menu-item% (label "Show syntax properties")
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -11,7 +11,6 @@
"typesetter.ss"
"hrule-snip.ss"
"properties.ss"
- "partition.ss"
"util.ss")
(provide widget@
widget-context-menu-extension@)
@@ -40,9 +39,12 @@
(new syntax-controller%
(properties-controller this)))
+ (define/public (make-context-menu)
+ (new context-menu% (widget this)))
+
(new syntax-keymap%
(editor -text)
- (context-menu (new context-menu% (widget this))))
+ (context-menu (make-context-menu)))
;; FIXME: Why doesn't this work?
#;
@@ -68,7 +70,7 @@
(define/public (show ?)
(if ? (show-props) (hide-props)))
- (define/public (is-shown?)
+ (define/public (props-shown?)
(send -props-panel is-shown?))
(define/public (toggle-props)
@@ -152,47 +154,6 @@
(super-new)))
- ;; syntax-widget/controls%
- (define syntax-widget/controls%
- (class* syntax-widget% ()
- (inherit get-main-panel
- get-controller
- toggle-props)
- (super-new)
-
- (define -control-panel
- (new horizontal-pane% (parent (get-main-panel)) (stretchable-height #f)))
-
- ;; Put the control panel up front
- (send (get-main-panel) change-children
- (lambda (children)
- (cons -control-panel (remq -control-panel children))))
-
- (define -identifier=-choices (identifier=-choices))
- (define -choice
- (new choice% (label "identifer=?") (parent -control-panel)
- (choices (map car -identifier=-choices))
- (callback (lambda _ (on-update-identifier=?-choice)))))
- (new button%
- (label "Clear")
- (parent -control-panel)
- (callback (lambda _ (send (get-controller) select-syntax #f))))
- (new button%
- (label "Properties")
- (parent -control-panel)
- (callback (lambda _ (toggle-props))))
-
- (define/private (on-update-identifier=?-choice)
- (cond [(assoc (send -choice get-string-selection)
- -identifier=-choices)
- => (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))))))
))
(define widget-context-menu-extension@
@@ -203,13 +164,23 @@
(class pre:context-menu%
(init-field widget)
+ (define props-menu #f)
+
(define/override (after-selection-items)
(super after-selection-items)
- (new menu-item% (label "Show/hide syntax properties")
- (parent this)
- (callback (lambda _ (send widget toggle-props))))
+ (set! props-menu
+ (new menu-item% (label "Show/hide syntax properties")
+ (parent this)
+ (callback (lambda _ (send widget toggle-props)))))
(void))
+ (define/override (on-demand)
+ (send props-menu set-label
+ (if (send widget props-shown?)
+ "Hide syntax properties"
+ "Show syntax properties"))
+ (super on-demand))
+
(super-new (controller (send widget get-controller)))))))
(define browser-text% (editor:standard-style-list-mixin text:basic%))
diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss
@@ -0,0 +1,223 @@
+
+(module hiding-panel mzscheme
+ (require (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "list.ss")
+ (lib "boundmap.ss" "syntax")
+ "../model/hiding-policies.ss"
+ "../syntax-browser/util.ss")
+ (provide macro-hiding-prefs-widget%)
+
+ ;; macro-hiding-prefs-widget%
+ (define macro-hiding-prefs-widget%
+ (class object%
+ (init parent)
+ (init-field stepper)
+ (init-field policy)
+ (init-field (enabled? #f))
+
+ (define stx #f)
+ (define stx-name #f)
+ (define stx-module #f)
+
+ (define super-pane
+ (new horizontal-pane%
+ (parent parent)
+ (stretchable-height #f)))
+ (define left-pane
+ (new vertical-pane%
+ (parent super-pane)
+ (stretchable-width #f)
+ (alignment '(left top))))
+ (define right-pane
+ (new vertical-pane%
+ (parent super-pane)))
+
+ (define enable-ctl
+ (new check-box%
+ (label "Enable macro hiding?")
+ (parent left-pane)
+ (value enabled?)
+ (callback
+ (lambda _
+ (set! enabled? (send enable-ctl get-value))
+ (force-refresh)))))
+
+ (define kernel-ctl
+ (new check-box%
+ (label "Hide mzscheme syntax")
+ (parent left-pane)
+ (value (hiding-policy-opaque-kernel policy))
+ (callback (lambda _
+ (if (send kernel-ctl get-value)
+ (policy-hide-kernel policy)
+ (policy-unhide-kernel policy))
+ (refresh)))))
+ (define libs-ctl
+ (new check-box%
+ (label "Hide library syntax")
+ (parent left-pane)
+ (value (hiding-policy-opaque-libs policy))
+ (callback (lambda _
+ (if (send libs-ctl get-value)
+ (policy-hide-libs policy)
+ (policy-unhide-libs policy))
+ (refresh)))))
+
+ (define look-pane
+ (new horizontal-pane% (parent right-pane) (stretchable-height #f)))
+ (define look-ctl
+ (new list-box% (parent look-pane) (label "") (choices null)))
+ (define delete-ctl
+ (new button% (parent look-pane) (label "Delete")
+ (callback
+ (lambda _
+ (delete-selected)
+ (refresh)))))
+
+ (define add-pane
+ (new horizontal-pane% (parent right-pane) (stretchable-height #f)))
+ (define add-text
+ (new text-field%
+ (label "")
+ (parent add-pane)
+ (stretchable-width #t)))
+ (define add-editor (send add-text get-editor))
+ (define add-hide-module-button
+ (new button% (parent add-pane) (label "Hide module") (enabled #f)
+ (callback (lambda _ (add-hide-module) (refresh)))))
+ (define add-hide-id-button
+ (new button% (parent add-pane) (label "Hide macro") (enabled #f)
+ (callback (lambda _ (add-hide-identifier) (refresh)))))
+ (define add-show-id-button
+ (new button% (parent add-pane) (label "Show macro") (enabled #f)
+ (callback (lambda _ (add-show-identifier) (refresh)))))
+
+ (send add-editor lock #t)
+
+ ;; Methods
+
+ ;; enable-hiding : boolean -> void
+ ;; Called only by stepper, which does it's own refresh
+ (define/public (enable-hiding ok?)
+ (set! enabled? ok?))
+
+ ;; get-enabled?
+ (define/public (get-enabled?) enabled?)
+
+ ;; get-policy
+ (define/public (get-policy) policy)
+
+ ;; refresh
+ (define/private (refresh)
+ (when enabled?
+ (send stepper refresh/resynth)))
+
+ ;; force-refresh
+ (define/private (force-refresh)
+ (send stepper refresh/resynth))
+
+ ;; set-syntax : syntax/#f -> void
+ (define/public (set-syntax lstx)
+ (set! stx lstx)
+ (send add-editor lock #f)
+ (send add-editor erase)
+ (unless (identifier? stx)
+ (send add-hide-module-button enable #f))
+ (when (identifier? stx)
+ (let ([binding (identifier-binding stx)])
+ (send add-hide-module-button enable (pair? binding))
+ (if (pair? binding)
+ (begin
+ (set! stx-name (cadr binding))
+ (set! stx-module (car binding)))
+ (begin
+ (set! stx-name (syntax-e stx))
+ (set! stx-module #f)))
+ (update-add-text)))
+ (send add-editor lock #t)
+ (send add-show-id-button enable (identifier? lstx))
+ (send add-hide-id-button enable (identifier? lstx)))
+
+ (define/private (update-add-text)
+ (send add-editor lock #f)
+ (when (identifier? stx)
+ (send add-editor insert (identifier-text "" stx)))
+ (send add-editor lock #t))
+
+ (define/public (add-hide-module)
+ (when stx-module
+ (policy-hide-module policy stx-module)
+ (update-list-view)))
+
+ (define/public (add-hide-identifier)
+ (when (identifier? stx)
+ (policy-hide-id policy stx)
+ (update-list-view)))
+
+ (define/public (add-show-identifier)
+ (when (identifier? stx)
+ (policy-show-id policy stx)
+ (update-list-view)))
+
+ (define/private (delete-selected)
+ (for-each (lambda (n)
+ (let ([d (send look-ctl get-data n)])
+ (case (car d)
+ ((identifier) (policy-unhide-id policy (cdr d)))
+ ((show-identifier) (policy-unshow-id policy (cdr d)))
+ ((module) (policy-unhide-module policy (cdr d))))))
+ (send look-ctl get-selections))
+ (update-list-view))
+
+ (define/private (identifier-text prefix id)
+ (let ([b (identifier-binding id)])
+ (cond [(pair? b)
+ (let ([name (cadr b)]
+ [mod (car b)])
+ (format "~a'~s' from module ~a"
+ prefix
+ name
+ (mpi->string mod)))]
+ [(eq? b 'lexical)
+ (format "~alexically bound '~s'"
+ prefix
+ (syntax-e id))]
+ [(not b)
+ (format "~aglobal or unbound '~s'" prefix (syntax-e id))])))
+
+ (define/private (update-list-view)
+ (let ([opaque-modules
+ (hash-table-map (hiding-policy-opaque-modules policy)
+ (lambda (k v) k))]
+ [opaque-ids
+ (filter values
+ (module-identifier-mapping-map
+ (hiding-policy-opaque-ids policy)
+ (lambda (k v) (and v k))))]
+ [transparent-ids
+ (filter values
+ (module-identifier-mapping-map
+ (hiding-policy-transparent-ids policy)
+ (lambda (k v) (and v k))))])
+ (define (om s)
+ (cons (format "hide from module ~a" (mpi->string s))
+ (cons 'module s)))
+ (define (*i prefix tag id)
+ (cons (identifier-text prefix id)
+ (cons tag id)))
+ (define (oid id) (*i "hide " 'identifier id))
+ (define (tid id) (*i "show " 'show-identifier id))
+ (let ([choices
+ (sort (append (map om opaque-modules)
+ (map oid opaque-ids)
+ (map tid transparent-ids))
+ (lambda (a b)
+ (string<=? (car a) (car b))))])
+ (send look-ctl clear)
+ (for-each (lambda (c) (send look-ctl append (car c) (cdr c)))
+ choices))))
+
+ (super-new)))
+
+ )
+\ No newline at end of file
diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss
@@ -0,0 +1,28 @@
+
+(module interfaces mzscheme
+ (require (lib "unitsig.ss"))
+ (provide (all-defined))
+
+ ;; Signatures
+
+ (define-signature view^
+ (macro-stepper-frame%
+ macro-stepper-widget%
+ make-macro-stepper
+ go
+ go/deriv))
+
+ (define-signature view-base^
+ (base-frame%))
+
+ (define-signature prefs^
+ (pref:width
+ pref:height
+ pref:props-percentage
+ pref:macro-hiding?
+ pref:show-hiding-panel?
+ pref:hide-primitives?
+ pref:hide-libs?
+ pref:identifier=?))
+
+ )
diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss
@@ -1,5 +1,38 @@
(module prefs mzscheme
- (require (lib "framework.ss" "framework"))
+ (require (lib "unitsig.ss")
+ (lib "framework.ss" "framework")
+ "interfaces.ss")
+ (provide prefs@)
- '...)
+ (define-syntax pref:get/set
+ (syntax-rules ()
+ [(_ get/set prop)
+ (define get/set
+ (case-lambda
+ [() (preferences:get 'prop)]
+ [(newval) (preferences:set 'prop newval)]))]))
+
+ (define prefs@
+ (unit/sig prefs^
+ (import)
+
+ (preferences:set-default 'MacroStepper:Frame:Width 700 number?)
+ (preferences:set-default 'MacroStepper:Frame:Height 600 number?)
+ (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
+ (preferences:set-default 'MacroStepper:MacroHiding? #t boolean?)
+ (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
+ (preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?)
+ (preferences:set-default 'MacroStepper:HideLibs? #t boolean?)
+ (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
+
+ (pref:get/set pref:width MacroStepper:Frame:Width)
+ (pref:get/set pref:height MacroStepper:Frame:Height)
+ (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
+ (pref:get/set pref:macro-hiding? MacroStepper:MacroHiding?)
+ (pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
+ (pref:get/set pref:hide-primitives? MacroStepper:HidePrimitives?)
+ (pref:get/set pref:hide-libs? MacroStepper:HideLibs?)
+ (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
+ ))
+ )
diff --git a/collects/macro-debugger/view/view.ss b/collects/macro-debugger/view/view.ss
@@ -1,16 +1,27 @@
(module view mzscheme
(require (lib "unitsig.ss")
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "framework.ss" "framework")
(prefix sb: "../syntax-browser/embed.ss")
+ "interfaces.ss"
+ "prefs.ss"
"gui.ss")
(provide (all-defined))
+ (define view-base@
+ (unit/sig view-base^
+ (import)
+ (define base-frame%
+ (frame:standard-menus-mixin (frame:basic-mixin frame%)))))
+
(define-values/invoke-unit/sig view^
(compound-unit/sig
(import)
- (link (PREFS : sb:prefs^ (sb:global-prefs@))
+ (link (PREFS : prefs^ (prefs@))
(SB : sb:implementation^ (sb:implementation@))
(BASE : view-base^ (view-base@))
- (VIEW : view^ (view@ BASE PREFS SB)))
+ (VIEW : view^ (view@ BASE SB)))
(export (open VIEW))))
)
