Fixed eol properties

Reorganized macro stepper gui
Added macro stepper actions to popup menu

svn: r4505

original commit: 39145f9c71807baf1e97d66db63f135fbf7e2999
This commit is contained in:
Ryan Culpepper 2006-10-06 04:48:14 +00:00
parent 9599b2253b
commit df01af09b9
10 changed files with 416 additions and 86 deletions

View File

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

View File

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

View File

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

View File

@ -49,7 +49,12 @@
(init-field controller)
(super-new)
(define copy-menu #f)
(define copy-syntax-menu #f)
(define clear-menu #f)
(define/public (add-edit-items)
(set! copy-menu
(new menu-item% (label "Copy") (parent this)
(callback (lambda (i e)
(define stx (send controller get-selected-syntax))
@ -57,7 +62,8 @@
(if stx
(format "~s" (syntax-object->datum stx))
"")
(send e get-time-stamp)))))
(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))
@ -67,17 +73,18 @@
(syntax stx)
#;(controller controller)))
(send t select-all)
(send t copy))))
(send t copy)))))
(void))
(define/public (after-edit-items)
(void))
(define/public (add-selection-items)
(set! clear-menu
(new menu-item%
(label "Clear selection")
(parent this)
(callback (lambda _ (send controller select-syntax #f))))
(callback (lambda _ (send controller select-syntax #f)))))
(void))
(define/public (after-selection-items)
@ -107,6 +114,13 @@
(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)

View File

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

View File

@ -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)
(set! props-menu
(new menu-item% (label "Show/hide syntax properties")
(parent this)
(callback (lambda _ (send widget toggle-props))))
(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%))

View File

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

View File

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

View File

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

View File

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