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

Fixed eol properties

Browse Source 
Reorganized macro stepper gui
Added macro stepper actions to popup menu

svn: r4505
This commit is contained in:
Ryan Culpepper 2006-10-06 04:48:14 +00:00
parent 2bf78b3308
commit 39145f9c71
13 changed files with 597 additions and 382 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/macro-debugger/syntax-browser/embed.ss
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))

50
collects/macro-debugger/syntax-browser/frame.ss
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))))))
))
)

12
collects/macro-debugger/syntax-browser/interfaces.ss
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<%>

60
collects/macro-debugger/syntax-browser/keymap.ss
View File

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

8
collects/macro-debugger/syntax-browser/syntax-snip.ss
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)))
))
@ -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")

65
collects/macro-debugger/syntax-browser/widget.ss
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)
(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%))

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

@ -9,8 +9,9 @@
(lib "bitmap-label.ss" "mrlib")
(lib "string-constant.ss" "string-constants")
"model/trace.ss"
"model/hiding-policies.ss"
(prefix view: "view/interfaces.ss")
(prefix view: "view/gui.ss")
(prefix view: "view/prefs.ss")
(prefix sb: "syntax-browser/embed.ss"))
(define view-base/tool@
@ -19,15 +20,32 @@
(define base-frame%
(frame:standard-menus-mixin frame:basic%))))
(define-values/invoke-unit/sig view:view^
(define stepper@
(compound-unit/sig
(import)
(link (PREFS : sb:prefs^ (sb:global-prefs@))
(SB : sb:implementation^ (sb:implementation@))
(BASE : view:view-base^ (view-base/tool@))
(VIEW : view:view^ (view:view@ BASE PREFS SB)))
(link [PREFS : view:prefs^ (view:prefs@)]
[SBKEYMAP : sb:keymap^ (sb:keymap@)]
[SBMENU : sb:context-menu^ (sb:context-menu@ SBSNIP)]
[SBSNIP : sb:snip^ (sb:global-snip@)]
[SBWMENU : sb:context-menu^ (sb:widget-context-menu-extension@ SBMENU)]
[VMENU : sb:context-menu^ (view:context-menu-extension@ SBMENU)]
[SBWIDGET : sb:widget^ (sb:widget@ SBKEYMAP SBWMENU)]
[VWIDGET : sb:widget^ (view:browser-extension@ SBWIDGET VMENU)]
[BASE : view:view-base^ (view-base/tool@)]
[VIEW : view:view^ (view:view@ PREFS BASE VWIDGET)])
(export (open VIEW))))
#;(define stepper@
(compound-unit/sig
(import)
(link (PREFS : view:prefs^ (view:prefs@))
(SB : sb:implementation^ (sb:implementation@))
(BASE : view:view-base^ (view-base/tool@))
(VIEW : view:view^ (view:view@ PREFS BASE SB)))
(export (open VIEW))))
(define-values/invoke-unit/sig view:view^ stepper@)
(provide tool@)
(define tool@
@ -135,10 +153,7 @@
(define/private (make-handlers original-eval-handler original-module-name-resolver)
(let ([stepper
(delay
(let ([frame (new macro-stepper-frame%
(policy (new-standard-hiding-policy))
(macro-hiding? #t)
(identifier=? "bound-identifier=?"))])
(let ([frame (new macro-stepper-frame%)])
(send frame show #t)
(send frame get-widget)))]
[debugging? debugging?])

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

@ -6,9 +6,11 @@
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "boundmap.ss" "syntax")
"interfaces.ss"
"warning.ss"
"hiding-panel.ss"
(prefix sb: "../syntax-browser/embed.ss")
"../syntax-browser/util.ss"
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/hide.ss"
@ -17,23 +19,10 @@
"cursor.ss"
"util.ss")
(provide view^
view-base^
catch-errors?
view-base@
view@)
;; Signatures
(define-signature view^
(macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
(define-signature view-base^
(base-frame%))
(provide catch-errors?
view@
context-menu-extension@
browser-extension@)
;; Configuration
@ -42,27 +31,26 @@
;; Macro Stepper
(define view-base@
(unit/sig view-base^
(import)
(define base-frame%
(frame:standard-menus-mixin (frame:basic-mixin frame%)))))
(define view@
(unit/sig view^
(import view-base^
(sb : sb:prefs^)
(sb : sb:implementation^))
(import prefs^
view-base^
(sb : sb:widget^))
(define (default-policy)
(let ([p (new-hiding-policy)])
(set-hiding-policy-opaque-kernel! p (pref:hide-primitives?))
(set-hiding-policy-opaque-libs! p (pref:hide-libs?))
p))
(define macro-stepper-frame%
(class base-frame%
(init policy
macro-hiding?)
(init (show-hiding-panel? #t)
(identifier=? "<nothing>")
(width 700 #;(sb:pref:width))
(height 500 #;(sb:pref:height)))
(init (policy (default-policy))
(macro-hiding? (pref:macro-hiding?))
(show-hiding-panel? (pref:show-hiding-panel?))
(identifier=? (pref:identifier=?))
(width (pref:width))
(height (pref:height)))
(inherit get-menu%
get-menu-item%
get-menu-bar
@ -78,7 +66,10 @@
(send widget update/preserve-view))
(define/augment (on-close)
(pref:width (send this get-width))
(pref:height (send this get-height))
(send widget shutdown)
(preferences:save)
(inner (void) on-close))
(override/return-false file-menu:create-new?
@ -194,6 +185,7 @@
(define/public (get-controller) sbc)
(define/public (get-view) sbview)
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define area (new vertical-panel% (parent parent)))
(define super-navigator
@ -213,9 +205,10 @@
(stretchable-height #f)
(alignment '(center center))))
(define sbview (new sb:widget:syntax-widget%
(define sbview (new sb:syntax-widget%
(parent area)
(pref:props-percentage sb:pref:props-percentage)))
(macro-stepper this)
(pref:props-percentage pref:props-percentage)))
(define sbc (send sbview get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
@ -455,13 +448,22 @@
;; Hiding policy
(define/private (get-policy)
(and (send macro-hiding-prefs get-enabled?)
(send macro-hiding-prefs get-policy)))
(define/private (get-show-macro?)
(let ([policy (send macro-hiding-prefs get-policy)])
(let ([policy (get-policy)])
(and policy (lambda (id) (policy-show-macro? policy id)))))
;; --
(define/public (shutdown)
(let ([policy (get-policy)])
(pref:macro-hiding? (and policy #t))
(pref:hide-primitives? (and policy (hiding-policy-opaque-kernel policy)))
(pref:hide-libs? (and policy (hiding-policy-opaque-libs policy))))
(pref:show-hiding-panel? (send control-pane is-shown?))
(when warnings-frame (send warnings-frame show #f)))
;; Initialization
@ -469,255 +471,6 @@
(super-new)
(refresh)))
;; 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 ?)
(set! enabled? ?))
;; get-policy
(define/public (get-policy) (and enabled? 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/private (add-hide-module)
(when stx-module
(policy-hide-module policy stx-module)
(update-list-view)))
(define/private (add-hide-identifier)
(when (identifier? stx)
(policy-hide-id policy stx)
(update-list-view)))
(define/private (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)))
;; warnings-frame%
(define warnings-frame%
(class frame%
(super-new (label "Macro stepper warnings") (width 400) (height 300))
(define text (new text% (auto-wrap #t)))
(define ec (new editor-canvas% (parent this) (editor text)))
(send text lock #t)
(define -nonlinearity-text #f)
(define -localactions-text #f)
(define/private (add-nonlinearity-text)
(unless -nonlinearity-text
(set! -nonlinearity-text #t)
(add-text "An opaque macro duplicated one of its subterms. "
"Macro hiding requires opaque macros to use their subterms linearly. "
"The macro stepper is showing the expansion of that macro use.")))
(define/private (add-localactions-text)
(unless -localactions-text
(set! -localactions-text #t)
(add-text "An opaque macro called local-expand, syntax-local-lift-expression, "
"etc. Macro hiding cannot currently handle local actions. "
"The macro stepper is showing the expansion of that macro use.")))
(define/private (add-text . strs)
(send text lock #f)
(for-each (lambda (s) (send text insert s)) strs)
(send text insert "\n\n")
(send text lock #t))
(define/public (add-warning tag)
(case tag
((nonlinearity)
(add-nonlinearity-text))
((localactions)
(add-localactions-text))))
(send this show #t)))
;; Main entry points
(define make-macro-stepper
@ -745,4 +498,74 @@
w))
))
(define context-menu-extension@
(unit/sig sb:context-menu^
(import (pre : sb:context-menu^))
(define context-menu%
(class pre:context-menu%
(init-field macro-stepper)
(inherit-field controller)
(inherit add-separator)
(define/private (get-prefs-panel)
(send macro-stepper get-macro-hiding-prefs))
(define show-macro #f)
(define hide-macro #f)
(define remove-macro #f)
(define/override (after-selection-items)
(super after-selection-items)
(add-separator)
(set! show-macro
(new menu-item% (label "Show this macro") (parent this)
(callback (lambda _ (do-show)))))
(set! hide-macro
(new menu-item% (label "Hide this macro") (parent this)
(callback (lambda _ (do-hide)))))
#;(set! remove-macro
(new menu-item% (label "Remove macro from policy") (parent this)
(callback (lambda _ (do-remove)))))
(void))
(define/private (do-show)
(send (get-prefs-panel) add-show-identifier))
(define/private (do-hide)
(send (get-prefs-panel) add-hide-identifier))
(define/override (on-demand)
(define-values (opaque transparent)
(let ([policy (send (get-prefs-panel) get-policy)])
(values (hiding-policy-opaque-ids policy)
(hiding-policy-transparent-ids policy))))
(define stx (send controller get-selected-syntax))
(define id? (identifier? stx))
(define transparent?
(and id? (module-identifier-mapping-get transparent stx (lambda () #f))))
(define opaque?
(and id? (module-identifier-mapping-get opaque stx (lambda () #f))))
(send show-macro enable (and id? (not transparent?)))
(send hide-macro enable (and id? (not opaque?)))
#;(send remove-macro enable (and id? (or opaque? transparent?)))
(super on-demand))
(super-new)))))
(define browser-extension@
(unit/sig sb:widget^
(import (pre : sb:widget^)
sb:context-menu^)
(define syntax-widget%
(class pre:syntax-widget%
(init-field macro-stepper)
(inherit get-controller)
(define/override (make-context-menu)
(new context-menu%
(controller (get-controller))
(macro-stepper macro-stepper)))
(super-new)))))
)

223
collects/macro-debugger/view/hiding-panel.ss Normal file
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)))
)

28
collects/macro-debugger/view/interfaces.ss Normal file
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=?))
)

37
collects/macro-debugger/view/prefs.ss
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)
))
)

15
collects/macro-debugger/view/view.ss
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))))
)

47
collects/macro-debugger/view/warning.ss Normal file
View File

@ -0,0 +1,47 @@
(module warning mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(provide warnings-frame%)
;; warnings-frame%
(define warnings-frame%
(class frame%
(super-new (label "Macro stepper warnings") (width 400) (height 300))
(define text (new text% (auto-wrap #t)))
(define ec (new editor-canvas% (parent this) (editor text)))
(send text lock #t)
(define -nonlinearity-text #f)
(define -localactions-text #f)
(define/private (add-nonlinearity-text)
(unless -nonlinearity-text
(set! -nonlinearity-text #t)
(add-text "An opaque macro duplicated one of its subterms. "
"Macro hiding requires opaque macros to use their subterms linearly. "
"The macro stepper is showing the expansion of that macro use.")))
(define/private (add-localactions-text)
(unless -localactions-text
(set! -localactions-text #t)
(add-text "An opaque macro called local-expand, syntax-local-lift-expression, "
"etc. Macro hiding cannot currently handle local actions. "
"The macro stepper is showing the expansion of that macro use.")))
(define/private (add-text . strs)
(send text lock #f)
(for-each (lambda (s) (send text insert s)) strs)
(send text insert "\n\n")
(send text lock #t))
(define/public (add-warning tag)
(case tag
((nonlinearity)
(add-nonlinearity-text))
((localactions)
(add-localactions-text))))
(send this show #t)))
)