Fixed eol properties
Reorganized macro stepper gui Added macro stepper actions to popup menu svn: r4505
This commit is contained in:
Ryan Culpepper
parent
2bf78b3308
commit
39145f9c71
|
|
@ -1,11 +1,15 @@
|
||||||
|
|
||||||
(module embed mzscheme
|
(module embed mzscheme
|
||||||
(require "interfaces.ss"
|
(require "interfaces.ss"
|
||||||
|
"widget.ss"
|
||||||
|
"keymap.ss"
|
||||||
"implementation.ss"
|
"implementation.ss"
|
||||||
"params.ss"
|
"params.ss"
|
||||||
"partition.ss")
|
"partition.ss")
|
||||||
|
|
||||||
(provide (all-from "interfaces.ss")
|
(provide (all-from "interfaces.ss")
|
||||||
|
(all-from "widget.ss")
|
||||||
|
(all-from "keymap.ss")
|
||||||
(all-from "implementation.ss")
|
(all-from "implementation.ss")
|
||||||
(all-from "params.ss")
|
(all-from "params.ss")
|
||||||
identifier=-choices))
|
identifier=-choices))
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,9 @@
|
||||||
(lib "unitsig.ss")
|
(lib "unitsig.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "framework.ss" "framework")
|
(lib "framework.ss" "framework")
|
||||||
"interfaces.ss")
|
(lib "list.ss")
|
||||||
|
"interfaces.ss"
|
||||||
|
"partition.ss")
|
||||||
(provide frame@)
|
(provide frame@)
|
||||||
|
|
||||||
(define frame@
|
(define frame@
|
||||||
|
|
@ -47,5 +49,49 @@
|
||||||
(send widget save-prefs)
|
(send widget save-prefs)
|
||||||
(preferences:save)
|
(preferences:save)
|
||||||
(inner (void) on-close))
|
(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))))))
|
||||||
|
|
||||||
|
))
|
||||||
)
|
)
|
||||||
|
|
|
||||||
|
|
@ -16,6 +16,9 @@
|
||||||
;; make-syntax-browser : -> syntax-browser<%>
|
;; make-syntax-browser : -> syntax-browser<%>
|
||||||
make-syntax-browser
|
make-syntax-browser
|
||||||
|
|
||||||
|
;; syntax-widget/controls%
|
||||||
|
syntax-widget/controls%
|
||||||
|
|
||||||
;; syntax-browser-frame%
|
;; syntax-browser-frame%
|
||||||
syntax-browser-frame%))
|
syntax-browser-frame%))
|
||||||
|
|
||||||
|
|
@ -50,10 +53,7 @@
|
||||||
|
|
||||||
(define-signature widget^
|
(define-signature widget^
|
||||||
(;; syntax-widget%
|
(;; syntax-widget%
|
||||||
syntax-widget%
|
syntax-widget%))
|
||||||
|
|
||||||
;; syntax-widget/controls%
|
|
||||||
syntax-widget/controls%))
|
|
||||||
|
|
||||||
(define-signature implementation^
|
(define-signature implementation^
|
||||||
([unit widget : widget^]
|
([unit widget : widget^]
|
||||||
|
|
@ -97,8 +97,8 @@
|
||||||
;; show : boolean -> void
|
;; show : boolean -> void
|
||||||
#;show
|
#;show
|
||||||
|
|
||||||
;; is-shown? : -> boolean
|
;; props-shown? : -> boolean
|
||||||
#;is-shown?))
|
props-shown?))
|
||||||
|
|
||||||
;; syntax-configuration<%>
|
;; syntax-configuration<%>
|
||||||
(define syntax-configuration<%>
|
(define syntax-configuration<%>
|
||||||
|
|
|
||||||
|
|
@ -49,35 +49,42 @@
|
||||||
(init-field controller)
|
(init-field controller)
|
||||||
(super-new)
|
(super-new)
|
||||||
|
|
||||||
|
(define copy-menu #f)
|
||||||
|
(define copy-syntax-menu #f)
|
||||||
|
(define clear-menu #f)
|
||||||
|
|
||||||
(define/public (add-edit-items)
|
(define/public (add-edit-items)
|
||||||
(new menu-item% (label "Copy") (parent this)
|
(set! copy-menu
|
||||||
(callback (lambda (i e)
|
(new menu-item% (label "Copy") (parent this)
|
||||||
(define stx (send controller get-selected-syntax))
|
(callback (lambda (i e)
|
||||||
(send the-clipboard set-clipboard-string
|
(define stx (send controller get-selected-syntax))
|
||||||
(if stx
|
(send the-clipboard set-clipboard-string
|
||||||
(format "~s" (syntax-object->datum stx))
|
(if stx
|
||||||
"")
|
(format "~s" (syntax-object->datum stx))
|
||||||
(send e get-time-stamp)))))
|
"")
|
||||||
(new menu-item% (label "Copy syntax") (parent this)
|
(send e get-time-stamp))))))
|
||||||
(callback (lambda (i e)
|
(set! copy-syntax-menu
|
||||||
(define stx (send controller get-selected-syntax))
|
(new menu-item% (label "Copy syntax") (parent this)
|
||||||
(define t (new text%))
|
(callback (lambda (i e)
|
||||||
(send t insert
|
(define stx (send controller get-selected-syntax))
|
||||||
(new syntax-snip%
|
(define t (new text%))
|
||||||
(syntax stx)
|
(send t insert
|
||||||
#;(controller controller)))
|
(new syntax-snip%
|
||||||
(send t select-all)
|
(syntax stx)
|
||||||
(send t copy))))
|
#;(controller controller)))
|
||||||
|
(send t select-all)
|
||||||
|
(send t copy)))))
|
||||||
(void))
|
(void))
|
||||||
|
|
||||||
(define/public (after-edit-items)
|
(define/public (after-edit-items)
|
||||||
(void))
|
(void))
|
||||||
|
|
||||||
(define/public (add-selection-items)
|
(define/public (add-selection-items)
|
||||||
(new menu-item%
|
(set! clear-menu
|
||||||
(label "Clear selection")
|
(new menu-item%
|
||||||
(parent this)
|
(label "Clear selection")
|
||||||
(callback (lambda _ (send controller select-syntax #f))))
|
(parent this)
|
||||||
|
(callback (lambda _ (send controller select-syntax #f)))))
|
||||||
(void))
|
(void))
|
||||||
|
|
||||||
(define/public (after-selection-items)
|
(define/public (after-selection-items)
|
||||||
|
|
@ -107,6 +114,13 @@
|
||||||
(define/public (add-separator)
|
(define/public (add-separator)
|
||||||
(new separator-menu-item% (parent this)))
|
(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
|
;; Initialization
|
||||||
(add-edit-items)
|
(add-edit-items)
|
||||||
(after-edit-items)
|
(after-edit-items)
|
||||||
|
|
|
||||||
|
|
@ -105,8 +105,8 @@
|
||||||
|
|
||||||
(define -outer (new text%))
|
(define -outer (new text%))
|
||||||
(super-new (editor -outer) (with-border? #f))
|
(super-new (editor -outer) (with-border? #f))
|
||||||
(set-margin 2 0 0 0)
|
(set-margin 0 0 0 0)
|
||||||
(set-inset 3 0 0 0)
|
(set-inset 0 0 0 0)
|
||||||
(set-snipclass snip-class)
|
(set-snipclass snip-class)
|
||||||
(send -outer select-all)
|
(send -outer select-all)
|
||||||
(send -outer change-style (make-object style-delta% 'change-alignment 'top)
|
(send -outer change-style (make-object style-delta% 'change-alignment 'top)
|
||||||
|
|
@ -195,7 +195,7 @@
|
||||||
(send pv set-syntax stx))
|
(send pv set-syntax stx))
|
||||||
(define/public (show ?)
|
(define/public (show ?)
|
||||||
(send parent show ?))
|
(send parent show ?))
|
||||||
(define/public (is-shown?)
|
(define/public (props-shown?)
|
||||||
(send parent is-shown?))
|
(send parent is-shown?))
|
||||||
(super-new)))
|
(super-new)))
|
||||||
))
|
))
|
||||||
|
|
|
||||||
|
|
@ -11,7 +11,6 @@
|
||||||
"typesetter.ss"
|
"typesetter.ss"
|
||||||
"hrule-snip.ss"
|
"hrule-snip.ss"
|
||||||
"properties.ss"
|
"properties.ss"
|
||||||
"partition.ss"
|
|
||||||
"util.ss")
|
"util.ss")
|
||||||
(provide widget@
|
(provide widget@
|
||||||
widget-context-menu-extension@)
|
widget-context-menu-extension@)
|
||||||
|
|
@ -40,9 +39,12 @@
|
||||||
(new syntax-controller%
|
(new syntax-controller%
|
||||||
(properties-controller this)))
|
(properties-controller this)))
|
||||||
|
|
||||||
|
(define/public (make-context-menu)
|
||||||
|
(new context-menu% (widget this)))
|
||||||
|
|
||||||
(new syntax-keymap%
|
(new syntax-keymap%
|
||||||
(editor -text)
|
(editor -text)
|
||||||
(context-menu (new context-menu% (widget this))))
|
(context-menu (make-context-menu)))
|
||||||
|
|
||||||
;; FIXME: Why doesn't this work?
|
;; FIXME: Why doesn't this work?
|
||||||
#;
|
#;
|
||||||
|
|
@ -68,7 +70,7 @@
|
||||||
(define/public (show ?)
|
(define/public (show ?)
|
||||||
(if ? (show-props) (hide-props)))
|
(if ? (show-props) (hide-props)))
|
||||||
|
|
||||||
(define/public (is-shown?)
|
(define/public (props-shown?)
|
||||||
(send -props-panel is-shown?))
|
(send -props-panel is-shown?))
|
||||||
|
|
||||||
(define/public (toggle-props)
|
(define/public (toggle-props)
|
||||||
|
|
@ -152,47 +154,6 @@
|
||||||
|
|
||||||
(super-new)))
|
(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@
|
(define widget-context-menu-extension@
|
||||||
|
|
@ -203,13 +164,23 @@
|
||||||
(class pre:context-menu%
|
(class pre:context-menu%
|
||||||
(init-field widget)
|
(init-field widget)
|
||||||
|
|
||||||
|
(define props-menu #f)
|
||||||
|
|
||||||
(define/override (after-selection-items)
|
(define/override (after-selection-items)
|
||||||
(super after-selection-items)
|
(super after-selection-items)
|
||||||
(new menu-item% (label "Show/hide syntax properties")
|
(set! props-menu
|
||||||
(parent this)
|
(new menu-item% (label "Show/hide syntax properties")
|
||||||
(callback (lambda _ (send widget toggle-props))))
|
(parent this)
|
||||||
|
(callback (lambda _ (send widget toggle-props)))))
|
||||||
(void))
|
(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)))))))
|
(super-new (controller (send widget get-controller)))))))
|
||||||
|
|
||||||
(define browser-text% (editor:standard-style-list-mixin text:basic%))
|
(define browser-text% (editor:standard-style-list-mixin text:basic%))
|
||||||
|
|
|
||||||
|
|
@ -9,8 +9,9 @@
|
||||||
(lib "bitmap-label.ss" "mrlib")
|
(lib "bitmap-label.ss" "mrlib")
|
||||||
(lib "string-constant.ss" "string-constants")
|
(lib "string-constant.ss" "string-constants")
|
||||||
"model/trace.ss"
|
"model/trace.ss"
|
||||||
"model/hiding-policies.ss"
|
(prefix view: "view/interfaces.ss")
|
||||||
(prefix view: "view/gui.ss")
|
(prefix view: "view/gui.ss")
|
||||||
|
(prefix view: "view/prefs.ss")
|
||||||
(prefix sb: "syntax-browser/embed.ss"))
|
(prefix sb: "syntax-browser/embed.ss"))
|
||||||
|
|
||||||
(define view-base/tool@
|
(define view-base/tool@
|
||||||
|
|
@ -19,15 +20,32 @@
|
||||||
(define base-frame%
|
(define base-frame%
|
||||||
(frame:standard-menus-mixin frame:basic%))))
|
(frame:standard-menus-mixin frame:basic%))))
|
||||||
|
|
||||||
(define-values/invoke-unit/sig view:view^
|
(define stepper@
|
||||||
(compound-unit/sig
|
(compound-unit/sig
|
||||||
(import)
|
(import)
|
||||||
(link (PREFS : sb:prefs^ (sb:global-prefs@))
|
(link [PREFS : view:prefs^ (view:prefs@)]
|
||||||
(SB : sb:implementation^ (sb:implementation@))
|
[SBKEYMAP : sb:keymap^ (sb:keymap@)]
|
||||||
(BASE : view:view-base^ (view-base/tool@))
|
[SBMENU : sb:context-menu^ (sb:context-menu@ SBSNIP)]
|
||||||
(VIEW : view:view^ (view:view@ BASE PREFS SB)))
|
[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))))
|
(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@)
|
(provide tool@)
|
||||||
|
|
||||||
(define tool@
|
(define tool@
|
||||||
|
|
@ -135,10 +153,7 @@
|
||||||
(define/private (make-handlers original-eval-handler original-module-name-resolver)
|
(define/private (make-handlers original-eval-handler original-module-name-resolver)
|
||||||
(let ([stepper
|
(let ([stepper
|
||||||
(delay
|
(delay
|
||||||
(let ([frame (new macro-stepper-frame%
|
(let ([frame (new macro-stepper-frame%)])
|
||||||
(policy (new-standard-hiding-policy))
|
|
||||||
(macro-hiding? #t)
|
|
||||||
(identifier=? "bound-identifier=?"))])
|
|
||||||
(send frame show #t)
|
(send frame show #t)
|
||||||
(send frame get-widget)))]
|
(send frame get-widget)))]
|
||||||
[debugging? debugging?])
|
[debugging? debugging?])
|
||||||
|
|
|
||||||
|
|
@ -6,9 +6,11 @@
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "framework.ss" "framework")
|
(lib "framework.ss" "framework")
|
||||||
(lib "boundmap.ss" "syntax")
|
(lib "boundmap.ss" "syntax")
|
||||||
|
"interfaces.ss"
|
||||||
|
"warning.ss"
|
||||||
|
"hiding-panel.ss"
|
||||||
(prefix sb: "../syntax-browser/embed.ss")
|
(prefix sb: "../syntax-browser/embed.ss")
|
||||||
"../syntax-browser/util.ss"
|
"../syntax-browser/util.ss"
|
||||||
"../model/deriv.ss"
|
|
||||||
"../model/deriv-util.ss"
|
"../model/deriv-util.ss"
|
||||||
"../model/trace.ss"
|
"../model/trace.ss"
|
||||||
"../model/hide.ss"
|
"../model/hide.ss"
|
||||||
|
|
@ -17,23 +19,10 @@
|
||||||
"cursor.ss"
|
"cursor.ss"
|
||||||
"util.ss")
|
"util.ss")
|
||||||
|
|
||||||
(provide view^
|
(provide catch-errors?
|
||||||
view-base^
|
view@
|
||||||
catch-errors?
|
context-menu-extension@
|
||||||
view-base@
|
browser-extension@)
|
||||||
view@)
|
|
||||||
|
|
||||||
;; Signatures
|
|
||||||
|
|
||||||
(define-signature view^
|
|
||||||
(macro-stepper-frame%
|
|
||||||
macro-stepper-widget%
|
|
||||||
make-macro-stepper
|
|
||||||
go
|
|
||||||
go/deriv))
|
|
||||||
|
|
||||||
(define-signature view-base^
|
|
||||||
(base-frame%))
|
|
||||||
|
|
||||||
;; Configuration
|
;; Configuration
|
||||||
|
|
||||||
|
|
@ -42,27 +31,26 @@
|
||||||
|
|
||||||
;; Macro Stepper
|
;; Macro Stepper
|
||||||
|
|
||||||
(define view-base@
|
|
||||||
(unit/sig view-base^
|
|
||||||
(import)
|
|
||||||
|
|
||||||
(define base-frame%
|
|
||||||
(frame:standard-menus-mixin (frame:basic-mixin frame%)))))
|
|
||||||
|
|
||||||
(define view@
|
(define view@
|
||||||
(unit/sig view^
|
(unit/sig view^
|
||||||
(import view-base^
|
(import prefs^
|
||||||
(sb : sb:prefs^)
|
view-base^
|
||||||
(sb : sb:implementation^))
|
(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%
|
(define macro-stepper-frame%
|
||||||
(class base-frame%
|
(class base-frame%
|
||||||
(init policy
|
(init (policy (default-policy))
|
||||||
macro-hiding?)
|
(macro-hiding? (pref:macro-hiding?))
|
||||||
(init (show-hiding-panel? #t)
|
(show-hiding-panel? (pref:show-hiding-panel?))
|
||||||
(identifier=? "<nothing>")
|
(identifier=? (pref:identifier=?))
|
||||||
(width 700 #;(sb:pref:width))
|
(width (pref:width))
|
||||||
(height 500 #;(sb:pref:height)))
|
(height (pref:height)))
|
||||||
(inherit get-menu%
|
(inherit get-menu%
|
||||||
get-menu-item%
|
get-menu-item%
|
||||||
get-menu-bar
|
get-menu-bar
|
||||||
|
|
@ -78,7 +66,10 @@
|
||||||
(send widget update/preserve-view))
|
(send widget update/preserve-view))
|
||||||
|
|
||||||
(define/augment (on-close)
|
(define/augment (on-close)
|
||||||
|
(pref:width (send this get-width))
|
||||||
|
(pref:height (send this get-height))
|
||||||
(send widget shutdown)
|
(send widget shutdown)
|
||||||
|
(preferences:save)
|
||||||
(inner (void) on-close))
|
(inner (void) on-close))
|
||||||
|
|
||||||
(override/return-false file-menu:create-new?
|
(override/return-false file-menu:create-new?
|
||||||
|
|
@ -194,6 +185,7 @@
|
||||||
|
|
||||||
(define/public (get-controller) sbc)
|
(define/public (get-controller) sbc)
|
||||||
(define/public (get-view) sbview)
|
(define/public (get-view) sbview)
|
||||||
|
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
||||||
|
|
||||||
(define area (new vertical-panel% (parent parent)))
|
(define area (new vertical-panel% (parent parent)))
|
||||||
(define super-navigator
|
(define super-navigator
|
||||||
|
|
@ -213,9 +205,10 @@
|
||||||
(stretchable-height #f)
|
(stretchable-height #f)
|
||||||
(alignment '(center center))))
|
(alignment '(center center))))
|
||||||
|
|
||||||
(define sbview (new sb:widget:syntax-widget%
|
(define sbview (new sb:syntax-widget%
|
||||||
(parent area)
|
(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 sbc (send sbview get-controller))
|
||||||
(define control-pane
|
(define control-pane
|
||||||
(new vertical-panel% (parent area) (stretchable-height #f)))
|
(new vertical-panel% (parent area) (stretchable-height #f)))
|
||||||
|
|
@ -455,13 +448,22 @@
|
||||||
|
|
||||||
;; Hiding policy
|
;; Hiding policy
|
||||||
|
|
||||||
|
(define/private (get-policy)
|
||||||
|
(and (send macro-hiding-prefs get-enabled?)
|
||||||
|
(send macro-hiding-prefs get-policy)))
|
||||||
|
|
||||||
(define/private (get-show-macro?)
|
(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)))))
|
(and policy (lambda (id) (policy-show-macro? policy id)))))
|
||||||
|
|
||||||
;; --
|
;; --
|
||||||
|
|
||||||
(define/public (shutdown)
|
(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)))
|
(when warnings-frame (send warnings-frame show #f)))
|
||||||
|
|
||||||
;; Initialization
|
;; Initialization
|
||||||
|
|
@ -469,255 +471,6 @@
|
||||||
(super-new)
|
(super-new)
|
||||||
(refresh)))
|
(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
|
;; Main entry points
|
||||||
|
|
||||||
(define make-macro-stepper
|
(define make-macro-stepper
|
||||||
|
|
@ -745,4 +498,74 @@
|
||||||
w))
|
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
223
collects/macro-debugger/view/hiding-panel.ss
Normal 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
28
collects/macro-debugger/view/interfaces.ss
Normal 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=?))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
@ -1,5 +1,38 @@
|
||||||
|
|
||||||
(module prefs mzscheme
|
(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)
|
||||||
|
))
|
||||||
|
)
|
||||||
|
|
|
||||||
|
|
@ -1,16 +1,27 @@
|
||||||
|
|
||||||
(module view mzscheme
|
(module view mzscheme
|
||||||
(require (lib "unitsig.ss")
|
(require (lib "unitsig.ss")
|
||||||
|
(lib "class.ss")
|
||||||
|
(lib "mred.ss" "mred")
|
||||||
|
(lib "framework.ss" "framework")
|
||||||
(prefix sb: "../syntax-browser/embed.ss")
|
(prefix sb: "../syntax-browser/embed.ss")
|
||||||
|
"interfaces.ss"
|
||||||
|
"prefs.ss"
|
||||||
"gui.ss")
|
"gui.ss")
|
||||||
(provide (all-defined))
|
(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^
|
(define-values/invoke-unit/sig view^
|
||||||
(compound-unit/sig
|
(compound-unit/sig
|
||||||
(import)
|
(import)
|
||||||
(link (PREFS : sb:prefs^ (sb:global-prefs@))
|
(link (PREFS : prefs^ (prefs@))
|
||||||
(SB : sb:implementation^ (sb:implementation@))
|
(SB : sb:implementation^ (sb:implementation@))
|
||||||
(BASE : view-base^ (view-base@))
|
(BASE : view-base^ (view-base@))
|
||||||
(VIEW : view^ (view@ BASE PREFS SB)))
|
(VIEW : view^ (view@ BASE SB)))
|
||||||
(export (open VIEW))))
|
(export (open VIEW))))
|
||||||
)
|
)
|
||||||
|
|
|
||||||
47
collects/macro-debugger/view/warning.ss
Normal file
47
collects/macro-debugger/view/warning.ss
Normal 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)))
|
||||||
|
|
||||||
|
)
|
||||||
Loading…
Reference in New Issue
Block a user