From df01af09b9027f282038d580e6a5001b1ebf3fec Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 6 Oct 2006 04:48:14 +0000 Subject: [PATCH] Fixed eol properties Reorganized macro stepper gui Added macro stepper actions to popup menu svn: r4505 original commit: 39145f9c71807baf1e97d66db63f135fbf7e2999 --- .../macro-debugger/syntax-browser/embed.ss | 4 + .../macro-debugger/syntax-browser/frame.ss | 50 +++- .../syntax-browser/interfaces.ss | 12 +- .../macro-debugger/syntax-browser/keymap.ss | 60 +++-- .../syntax-browser/syntax-snip.ss | 8 +- .../macro-debugger/syntax-browser/widget.ss | 65 ++--- collects/macro-debugger/view/hiding-panel.ss | 223 ++++++++++++++++++ collects/macro-debugger/view/interfaces.ss | 28 +++ collects/macro-debugger/view/prefs.ss | 37 ++- collects/macro-debugger/view/view.ss | 15 +- 10 files changed, 416 insertions(+), 86 deletions(-) create mode 100644 collects/macro-debugger/view/hiding-panel.ss create mode 100644 collects/macro-debugger/view/interfaces.ss diff --git a/collects/macro-debugger/syntax-browser/embed.ss b/collects/macro-debugger/syntax-browser/embed.ss index 176120b..1a77f20 100644 --- 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 index 1257840..f729d03 100644 --- 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 index add1a86..2b41baa 100644 --- 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 index 14e6201..503c056 100644 --- 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 index 750f3f0..2ca4373 100644 --- 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 index 02ff0fd..7c3a365 100644 --- 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 new file mode 100644 index 0000000..a2f466e --- /dev/null +++ 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 new file mode 100644 index 0000000..d68591b --- /dev/null +++ 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 index bf3f4bd..5f95742 100644 --- 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 index ee854d3..502a2bc 100644 --- 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)))) )