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

Merged changes to macro-debugger from /branches/ryanc/md5 4899:5119

Browse Source 
updated to change in expansion of lexical variables
  many UI updates and tweaks
  improved syntax properties panel
  added expand-only and expand/hide
  added rudimentary textual stepper
  fixed PR 8395 by adding snipclass for hrule-snip
  fixed PR 8431: reductions and block splicing
  fixed PR 8433: handling unquote and macro hiding w/ errors in hidden terms

svn: r5120

original commit: 056683743d998145deb4b2e82fa8fc73507ed7e3
This commit is contained in:
Ryan Culpepper 2006-12-14 21:25:21 +00:00
parent b50b6f5a73
commit 9ce9194139
18 changed files with 599 additions and 262 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/macro-debugger/expand.ss
View File

@ -1,9 +1,32 @@
(module expand mzscheme (module expand mzscheme
(require (lib "unitsig.ss")) (require "model/trace.ss"
(require "view/view.ss") "model/hide.ss")
(provide expand/step) (provide expand-only
expand/hide)
(provide expand/step)
(define (expand/step . args)
(apply (dynamic-require '(lib "stepper.ss" "macro-debugger") 'expand/step)
args))
(define (expand-only stx show-list)
(define (show? id)
(ormap (lambda (x) (module-identifier=? id x))
show-list))
(expand/hiding stx show?))
(define (expand/hide stx hide-list)
(define (show? id)
(andmap (lambda (x) (not (module-identifier=? id x)))
hide-list))
(expand/hiding stx show?))
(define (expand/hiding stx show?)
(let-values ([(result deriv) (trace/result stx)])
(when (exn? result)
(raise result))
(let-values ([(_d estx) (hide/policy deriv show?)])
estx)))
(define (expand/step stx)
(go stx))
) )

20
collects/macro-debugger/model/deriv-parser.ss
View File

@ -60,6 +60,8 @@
$2] $2]
[(visit (? TaggedPrimStep 'prim) return) [(visit (? TaggedPrimStep 'prim) return)
($2 $1)] ($2 $1)]
[(visit VariableStep return)
($2 $1 $3)]
[((? EE/Macro)) [((? EE/Macro))
$1]) $1])
(EE/Macro (EE/Macro
@ -127,9 +129,10 @@
;; MacroStep Answer = Transformation (I,E) ;; MacroStep Answer = Transformation (I,E)
(MacroStep (MacroStep
[(Resolves enter-macro [(Resolves enter-macro
(! 'bad-transformer)
macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform
exit-macro) exit-macro)
(make-transformation $2 $7 $1 $3 $6 $4)]) (make-transformation $2 $8 $1 $4 $7 $5)])
;; Local actions taken by macro ;; Local actions taken by macro
;; LocalAction Answer = (list-of LocalAction) ;; LocalAction Answer = (list-of LocalAction)
@ -163,9 +166,13 @@
(PrimStep (PrimStep
(#:no-wrap) (#:no-wrap)
[(Resolves NoError enter-prim (? Prim) exit-prim) [(Resolves NoError enter-prim (? Prim) exit-prim)
($4 $3 $5 $1)] ($4 $3 $5 $1)])
(VariableStep
(#:no-wrap)
(#:args e1 e2)
[(Resolves variable) [(Resolves variable)
(make-p:variable (car $2) (cdr $2) $1)]) (make-p:variable e1 e2 $1)])
;; Tagged Primitive syntax ;; Tagged Primitive syntax
;; TaggedPrimStep Answer = syntax -> PRule ;; TaggedPrimStep Answer = syntax -> PRule
@ -174,6 +181,8 @@
(#:args orig-stx) (#:args orig-stx)
[(Resolves ! IMPOSSIBLE) [(Resolves ! IMPOSSIBLE)
(make-p:unknown orig-stx #f $1)] (make-p:unknown orig-stx #f $1)]
[(Resolves NoError enter-prim ! IMPOSSIBLE)
(make-p:unknown orig-stx #f $1)]
[(Resolves NoError enter-prim (? TaggedPrim) exit-prim) [(Resolves NoError enter-prim (? TaggedPrim) exit-prim)
($4 orig-stx $5 $1 $3)]) ($4 orig-stx $5 $1 $3)])
@ -234,7 +243,10 @@
(Prim#%ModuleBegin (Prim#%ModuleBegin
(#:args e1 e2 rs) (#:args e1 e2 rs)
[(prim-#%module-begin ! (? ModulePass1 'pass1) next-group (? ModulePass2 'pass2)) [(prim-#%module-begin (! 'malformed)
(? ModulePass1 'pass1) next-group
(? ModulePass2 'pass2)
(! 'provides))
(make-p:#%module-begin e1 e2 rs $3 $5)]) (make-p:#%module-begin e1 e2 rs $3 $5)])
(ModulePass1 (ModulePass1

31
collects/macro-debugger/model/reductions.ss
View File

@ -29,7 +29,9 @@
;; Primitives ;; Primitives
[(struct p:variable (e1 e2 rs)) [(struct p:variable (e1 e2 rs))
null] (if (bound-identifier=? e1 e2)
null
(list (walk e1 e2 "Resolve variable (remove extra marks)")))]
[(IntQ p:module (e1 e2 rs #f body)) [(IntQ p:module (e1 e2 rs #f body))
(with-syntax ([(?module name language . BODY) e1]) (with-syntax ([(?module name language . BODY) e1])
(let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))] (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]
@ -42,21 +44,19 @@
(let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]) (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))])
(with-context ctx (with-context ctx
(reductions body))))] (reductions body))))]
[(IntQ p:#%module-begin (e1 e2 rs pass1 pass2)) [(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2))
#;(R e1 (?module-begin . MBODY)
[! exni 'blah]
[ModulePass1 MBODY pass1]
=> (lambda (e1prime)
(R e1prime (?module-begin2 . MBODY2)
[ModulePass2 MBODY2 pass2])))
(with-syntax ([(?#%module-begin form ...) e1]) (with-syntax ([(?#%module-begin form ...) e1])
(let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))])
(let-values ([(reductions1 final-stxs1) (let-values ([(reductions1 final-stxs1)
(with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x))) (with-context frame
(mbrules-reductions pass1 (syntax->list #'(form ...)) #t))]) (mbrules-reductions pass1 (syntax->list #'(form ...)) #t))])
(let-values ([(reductions2 final-stxs2) (let-values ([(reductions2 final-stxs2)
(with-context (lambda (x) (d->so e1 (cons #'?#%module-begin x))) (with-context frame
(mbrules-reductions pass2 final-stxs1 #f))]) (mbrules-reductions pass2 final-stxs1 #f))])
(append reductions1 reductions2))))] (if (error-wrap? d)
(append reductions1 reductions2
(list (stumble (frame final-stxs2) (error-wrap-exn d))))
(append reductions1 reductions2))))))]
[(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni) [(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni)
(R e1 _ (R e1 _
[! exni] [! exni]
@ -269,7 +269,8 @@
[#f null] [#f null]
#;[else (error 'reductions "unmatched case: ~s" d)])) #;
[else (error 'reductions "unmatched case: ~s" d)]))
;; reductions-transformation : Transformation -> ReductionSequence ;; reductions-transformation : Transformation -> ReductionSequence
(define (reductions-transformation tx) (define (reductions-transformation tx)
@ -279,6 +280,8 @@
(list (walk e1 e2 "Macro transformation")))] (list (walk e1 e2 "Macro transformation")))]
[(IntW transformation (e1 e2 rs me1 me2 locals) 'locals) [(IntW transformation (e1 e2 rs me1 me2 locals) 'locals)
(reductions-locals e1 locals)] (reductions-locals e1 locals)]
[(ErrW transformation (e1 e2 rs me1 me2 locals) 'bad-transformer exn)
(list (stumble e1 exn))]
[(ErrW transformation (e1 e2 rs me1 me2 locals) 'transform exn) [(ErrW transformation (e1 e2 rs me1 me2 locals) 'transform exn)
(append (reductions-locals e1 locals) (append (reductions-locals e1 locals)
(list (stumble e1 exn)))])) (list (stumble e1 exn)))]))
@ -374,7 +377,9 @@
[(cons (struct b:splice (renames head tail)) next) [(cons (struct b:splice (renames head tail)) next)
(loop next tail prefix (loop next tail prefix
(cons (list (walk/foci (deriv-e2 head) (cons (list (walk/foci (deriv-e2 head)
(take-until tail (stx-cdr suffix)) (stx-take tail
(- (stx-improper-length tail)
(stx-improper-length (stx-cdr suffix))))
(E (revappend prefix (E (revappend prefix
(cons (deriv-e2 head) (stx-cdr suffix)))) (cons (deriv-e2 head) (stx-cdr suffix))))
(E (revappend prefix tail)) (E (revappend prefix tail))

9
collects/macro-debugger/model/stx-util.ss
View File

@ -80,15 +80,6 @@
(cond [(zero? n) null] (cond [(zero? n) null]
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))])) [else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))]))
(define *args* #f)
(define (take-until stxs tail)
(set! *args* (list stxs tail))
(let loop ([stxs stxs])
(if (eq? stxs tail)
null
(cons (stx-car stxs) (loop (stx-cdr stxs))))))
(define (stx-improper-length stx) (define (stx-improper-length stx)
(if (stx-pair? stx) (if (stx-pair? stx)
(add1 (stx-improper-length (stx-cdr stx))) (add1 (stx-improper-length (stx-cdr stx)))

139
collects/macro-debugger/stepper-text.ss Normal file
View File

@ -0,0 +1,139 @@
(module stepper-text mzscheme
(require (lib "list.ss")
(lib "pretty.ss")
"model/trace.ss"
"model/steps.ss"
"model/hide.ss"
"model/hiding-policies.ss"
"syntax-browser/partition.ss"
"syntax-browser/pretty-helper.ss")
(provide expand/step-text
stepper-text)
(define expand/step-text
(case-lambda
[(stx) (expand/step-text stx #f)]
[(stx show)
(define s (stepper-text stx (->show-function show)))
(s 'all)]))
(define stepper-text
(case-lambda
[(stx) (internal-stepper stx #f)]
[(stx show) (internal-stepper stx (->show-function show))]))
;; internal procedures
(define (internal-stepper stx show?)
(define steps (get-steps stx show?))
(define used-steps null)
(define partition (new-bound-partition))
(define dispatch
(case-lambda
[() (dispatch 'next)]
[(sym)
(case sym
((next)
(if (pair? steps)
(begin (show-step (car steps) partition)
(set! used-steps (cons (car steps) used-steps))
(set! steps (cdr steps)))
#f))
((prev)
(if (pair? used-steps)
(begin (show-step (car used-steps) partition)
(set! steps (cons (car used-steps) steps))
(set! used-steps (cdr used-steps)))
#f))
((all)
(when (pair? steps)
(dispatch 'next)
(dispatch 'all))))]))
dispatch)
(define (get-steps stx show?)
(define deriv (trace stx))
(define hderiv
(if show? (hide/policy deriv show?) deriv))
(define (ok? x)
(or (rewrite-step? x) (misstep? x)))
(filter ok? (reductions hderiv)))
(define (show-step step partition)
(cond [(step? step)
(display (step-note step))
(newline)
(show-term (step-e1 step) partition)
(display " ==>")
(newline)
(show-term (step-e2 step) partition)
(newline)]
[(misstep? step)
(display (exn-message (misstep-exn step)))
(newline)
(show-term (misstep-e1 step) partition)]))
(define (show-term stx partition)
(define-values (datum flat=>stx stx=>flat)
(table stx partition 0 'always))
(define identifier-list
(filter identifier? (hash-table-map stx=>flat (lambda (k v) k))))
(define (pp-size-hook obj display-like? port)
(cond [(syntax-dummy? obj)
(let ((ostring (open-output-string)))
((if display-like? display write)
(syntax-dummy-val obj)
ostring)
(string-length (get-output-string ostring)))]
[else #f]))
(define (pp-print-hook obj display-like? port)
(cond [(syntax-dummy? obj)
((if display-like? display write) (syntax-dummy-val obj) port)]
[else
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
(define (pp-extend-style-table)
(let* ([ids identifier-list]
[syms (map (lambda (x) (hash-table-get stx=>flat x)) ids)]
[like-syms (map syntax-e ids)])
(pretty-print-extend-style-table (pp-better-style-table)
syms
like-syms)))
(define (pp-better-style-table)
(pretty-print-extend-style-table (pretty-print-current-style-table)
(map car extended-style-list)
(map cdr extended-style-list)))
(parameterize
([pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table)]
;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t]
[print-graph #f]
[print-struct #f]
[print-box #t]
[print-vector-length #t]
[print-hash-table #f]
[print-honu #f])
(pretty-print datum)))
(define (->show-function show)
(cond [(procedure? show)
show]
[(list? show)
(lambda (id)
(ormap (lambda (x) (module-identifier=? x id))
show))]
[(hiding-policy? show)
(lambda (x) (policy-show-macro? show x))]
[(eq? show #f)
#f]
[else
(error 'expand/trace-text
"expected procedure or list of identifiers for macros to show; got: ~e"
show)]))
(define extended-style-list
'((define-values . define)
(define-syntaxes . define-syntax)))
)

9
collects/macro-debugger/stepper.ss Normal file
View File

@ -0,0 +1,9 @@
(module stepper mzscheme
(require "view/view.ss")
(provide expand/step)
(define (expand/step stx)
(go stx))
)

25
collects/macro-debugger/syntax-browser/hrule-snip.ss
View File

@ -16,7 +16,7 @@
[ad-y (box 0)]) [ad-y (box 0)])
(send (get-admin) get-view-size ad-x ad-y) (send (get-admin) get-view-size ad-x ad-y)
#;(set-box?! bw fw) #;(set-box?! bw fw)
(set-box?! bw (unbox ad-x)) (set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc))))
(set-box?! bh h)))) (set-box?! bh h))))
(define/override (draw dc x y left top right bottom dx dy draw-caret) (define/override (draw dc x y left top right bottom dx dy draw-caret)
(let* [(xh (get-xheight dc)) (let* [(xh (get-xheight dc))
@ -30,5 +30,28 @@
(set! cached-xheight h) (set! cached-xheight h)
h))) h)))
(define cached-xheight #f) (define cached-xheight #f)
;; Snip methods
(define/override (copy)
(new hrule-snip%))
(define/override (write stream)
(void))
(inherit set-snipclass)
(super-new)
(set-snipclass snip-class)))
(define hrule-snipclass%
(class snip-class%
(define/override (read stream)
(let ([str (send stream get-bytes)])
(new hrule-snip%)))
(super-new))) (super-new)))
(define snip-class (new hrule-snipclass%))
(send snip-class set-version 1)
(send snip-class set-classname
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser")))
(send (get-the-snip-class-list) add snip-class)
) )

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

@ -8,72 +8,30 @@
(provide keymap@ (provide keymap@
context-menu@) context-menu@)
(define keymap@
(unit/sig keymap^
(import)
(define syntax-keymap%
(class keymap%
(init editor)
(init-field context-menu)
(inherit add-function
map-function
chain-to-keymap)
(super-new)
;; Initialization
(map-function "rightbutton" "popup-context-window")
(add-function "popup-context-window"
(lambda (editor event)
(do-popup-context-window editor event)))
;; Attach to editor
(chain-to-keymap (send editor get-keymap) #t)
(send editor set-keymap this)
(define/private (do-popup-context-window editor event)
(define-values (x y)
(send editor dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(define admin (send editor get-admin))
(send admin popup-menu context-menu x y))))))
(define context-menu@ (define context-menu@
(unit/sig context-menu^ (unit/sig context-menu^
(import snip^) (import)
(define context-menu% (define context-menu%
(class popup-menu% (class popup-menu%
(init-field keymap)
(init-field controller) (init-field controller)
(super-new) (super-new)
(define copy-menu #f) (field [copy-menu #f]
(define copy-syntax-menu #f) [copy-syntax-menu #f]
(define clear-menu #f) [clear-menu #f]
[props-menu #f])
(define/public (add-edit-items) (define/public (add-edit-items)
(set! copy-menu (set! copy-menu
(new menu-item% (label "Copy") (parent this) (new menu-item% (label "Copy") (parent this)
(callback (lambda (i e) (callback (lambda (i e)
(define stx (send controller get-selected-syntax)) (send keymap call-function "copy-text" i e)))))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
"")
(send e get-time-stamp))))))
(set! copy-syntax-menu (set! copy-syntax-menu
(new menu-item% (label "Copy syntax") (parent this) (new menu-item% (label "Copy syntax") (parent this)
(callback (lambda (i e) (callback (lambda (i e)
(define stx (send controller get-selected-syntax)) (send keymap call-function "copy-syntax" i e)))))
(define t (new text%))
(send t insert
(new syntax-snip%
(syntax stx)
#;(controller controller)))
(send t select-all)
(send t copy)))))
(void)) (void))
(define/public (after-edit-items) (define/public (after-edit-items)
@ -84,7 +42,16 @@
(new menu-item% (new menu-item%
(label "Clear selection") (label "Clear selection")
(parent this) (parent this)
(callback (lambda _ (send controller select-syntax #f))))) (callback
(lambda (i e)
(send keymap call-function "clear-syntax-selection" i e)))))
(set! props-menu
(new menu-item%
(label "Show syntax properties")
(parent this)
(callback
(lambda (i e)
(send keymap call-function "show-syntax-properties" i e)))))
(void)) (void))
(define/public (after-selection-items) (define/public (after-selection-items)
@ -134,4 +101,75 @@
(after-partition-items) (after-partition-items)
)))) ))))
(define keymap@
(unit/sig keymap^
(import context-menu^ snip^)
(define syntax-keymap%
(class keymap%
(init editor)
(init-field controller)
(inherit add-function
map-function
chain-to-keymap)
(super-new)
(define context-menu (make-context-menu))
(define/public (make-context-menu)
(new context-menu% (controller controller) (keymap this)))
;; Key mappings
(map-function "rightbutton" "popup-context-window")
;; Functionality
(add-function "popup-context-window"
(lambda (editor event)
(do-popup-context-window editor event)))
(add-function "copy-text"
(lambda (_ event)
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
"")
(send event get-time-stamp))))
(add-function "copy-syntax"
(lambda (_ event)
(define stx (send controller get-selected-syntax))
(define t (new text%))
(send t insert
(new syntax-snip%
(syntax stx)))
(send t select-all)
(send t copy)))
(add-function "clear-syntax-selection"
(lambda (i e)
(send controller select-syntax #f)))
(add-function "show-syntax-properties"
(lambda (i e)
(error 'show-syntax-properties "not provided by this keymap")))
;; Attach to editor
(chain-to-keymap (send editor get-keymap) #t)
(send editor set-keymap this)
(define/public (get-controller) controller)
(define/private (do-popup-context-window editor event)
(define-values (x y)
(send editor dc-location-to-editor-location
(send event get-x)
(send event get-y)))
(define admin (send editor get-admin))
(send admin popup-menu context-menu x y))))))
) )

8
collects/macro-debugger/syntax-browser/partition.ss
View File

@ -9,10 +9,7 @@
identifier=-choices) identifier=-choices)
(define (new-bound-partition) (define (new-bound-partition)
#;(define p (new partition% (relation id:same-marks?))) (new bound-partition%))
(define p (new bound-partition%))
(send p get-partition (datum->syntax-object #f 'no-marks))
p)
;; representative-symbol : symbol ;; representative-symbol : symbol
;; Must be fresh---otherwise, using it could detect rename wraps ;; Must be fresh---otherwise, using it could detect rename wraps
@ -75,6 +72,7 @@
(lambda (k v) (lambda (k v)
(printf "~s => ~s~n" k v)))) (printf "~s => ~s~n" k v))))
(get-partition unmarked-syntax)
(super-new) (super-new)
)) ))
@ -91,6 +89,7 @@
(or n (or n
(begin0 next-number (begin0 next-number
(bound-identifier-mapping-put! numbers r next-number) (bound-identifier-mapping-put! numbers r next-number)
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax-object->datum stx))
(set! next-number (add1 next-number)))))) (set! next-number (add1 next-number))))))
(define/public (same-partition? a b) (define/public (same-partition? a b)
@ -102,6 +101,7 @@
(define/private (representative stx) (define/private (representative stx)
(datum->syntax-object stx representative-symbol)) (datum->syntax-object stx representative-symbol))
(get-partition unmarked-syntax)
(super-new))) (super-new)))
;; Different identifier relations for highlighting. ;; Different identifier relations for highlighting.

49
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -19,11 +19,16 @@
(define-struct syntax-dummy (val)) (define-struct syntax-dummy (val))
;; syntax->datum/tables : stx [partition% num boolean] ;; A SuffixOption is one of
;; - 'never -- never
;; - 'always -- suffix > 0
;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit
;; syntax->datum/tables : stx [partition% num SuffixOption]
;; -> (values s-expr hashtable hashtable) ;; -> (values s-expr hashtable hashtable)
;; When partition is not false, tracks the partititions that subterms belong to ;; When partition is not false, tracks the partititions that subterms belong to
;; When limit is a number, restarts processing with numbering? set to true ;; When limit is a number, restarts processing with numbering? set to true
;; When numbering? is true, suffixes identifiers with partition numbers.
;; ;;
;; Returns three values: ;; Returns three values:
;; - an S-expression ;; - an S-expression
@ -32,18 +37,23 @@
;; Syntax objects which are eq? will map to same flat values ;; Syntax objects which are eq? will map to same flat values
(define syntax->datum/tables (define syntax->datum/tables
(case-lambda (case-lambda
[(stx) (table stx #f #f #f)] [(stx) (table stx #f #f 'never)]
[(stx partition limit numbering?) (table stx partition limit numbering?)])) [(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
;; table : syntax partition%-or-#f num-or-#f -> (values s-expr hashtable hashtable) ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit numbering?) (define (table stx partition limit suffixopt)
(define (make-identifier-proxy id) (define (make-identifier-proxy id)
(case suffixopt
((never) (unintern (syntax-e id)))
((always)
(let ([n (send partition get-partition id)]) (let ([n (send partition get-partition id)])
(cond [(or (zero? n) (not numbering?)) (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
(string->uninterned-symbol (symbol->string (syntax-e id)))] ((over-limit)
[else (let ([n (send partition get-partition id)])
(string->uninterned-symbol (if (<= n limit)
(format "~a:~a" (syntax-e id) n))]))) (unintern (syntax-e id))
(suffix (syntax-e id) n))))))
(let/ec escape (let/ec escape
(let ([flat=>stx (make-hash-table)] (let ([flat=>stx (make-hash-table)]
[stx=>flat (make-hash-table)]) [stx=>flat (make-hash-table)])
@ -51,10 +61,11 @@
(cond [(hash-table-get stx=>flat obj (lambda _ #f)) (cond [(hash-table-get stx=>flat obj (lambda _ #f))
=> (lambda (datum) datum)] => (lambda (datum) datum)]
[(and partition (identifier? obj)) [(and partition (identifier? obj))
(let ([lp-datum (make-identifier-proxy obj)]) (when (and (eq? suffixopt 'all-if-over-limit)
(when (and limit (> (send partition count) limit)) (> (send partition count) limit))
(call-with-values (lambda () (table stx partition #f #t)) (call-with-values (lambda () (table stx partition #f 'always))
escape)) escape))
(let ([lp-datum (make-identifier-proxy obj)])
(hash-table-put! flat=>stx lp-datum obj) (hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum) (hash-table-put! stx=>flat obj lp-datum)
lp-datum)] lp-datum)]
@ -69,8 +80,7 @@
[(vector? obj) [(vector? obj)
(list->vector (map loop (vector->list obj)))] (list->vector (map loop (vector->list obj)))]
[(symbol? obj) [(symbol? obj)
;(make-syntax-dummy obj) (unintern obj)]
(string->uninterned-symbol (symbol->string obj))]
[(number? obj) [(number? obj)
(make-syntax-dummy obj)] (make-syntax-dummy obj)]
[(box? obj) [(box? obj)
@ -90,4 +100,11 @@
(values (loop stx) (values (loop stx)
flat=>stx flat=>stx
stx=>flat)))) stx=>flat))))
(define (unintern sym)
(string->uninterned-symbol (symbol->string sym)))
(define (suffix sym n)
(string->uninterned-symbol (format "~a:~a" sym n)))
) )

4
collects/macro-debugger/syntax-browser/pretty-printer.ss
View File

@ -97,7 +97,9 @@
;; recompute-tables : -> void ;; recompute-tables : -> void
(define/private (recompute-tables) (define/private (recompute-tables)
(set!-values (datum ht:flat=>stx ht:stx=>flat) (set!-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables main-stx primary-partition 12 #f)) (syntax->datum/tables main-stx primary-partition
(length (current-colors))
(current-suffix-option)))
(set! identifier-list (set! identifier-list
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))) (filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k)))))

133
collects/macro-debugger/syntax-browser/properties.ss
View File

@ -12,10 +12,12 @@
(init parent) (init parent)
(define selected-syntax #f) (define selected-syntax #f)
(define tab-choices (get-tab-choices))
(define tab-panel (new tab-panel% (define tab-panel (new tab-panel%
(choices (list "Binding" "Source" "Properties")) (choices (map car tab-choices))
(parent parent) (parent parent)
(callback (lambda _ (refresh))))) (callback (lambda _ (refresh)))))
(define text (new text%)) (define text (new text%))
(send text set-styles-sticky #f) (send text set-styles-sticky #f)
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel))) (define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))
@ -24,64 +26,107 @@
(set! selected-syntax stx) (set! selected-syntax stx)
(refresh)) (refresh))
;; get-tab-choices : (listof (cons string thunk))
;; Override to add or remove panels
(define/public (get-tab-choices)
(list (cons "Term" (lambda () (display-meaning-info)))
(cons "Syntax Object" (lambda () (display-stxobj-info)))))
(define/private (refresh) (define/private (refresh)
(send* text (send* text
(lock #f) (lock #f)
(begin-edit-sequence) (begin-edit-sequence)
(erase)) (erase))
(when (syntax? selected-syntax) (when (syntax? selected-syntax)
(let ([s (send tab-panel get-item-label (send tab-panel get-selection))]) (let ([tab (send tab-panel get-item-label (send tab-panel get-selection))])
(cond [(equal? s "Binding") (cond [(assoc tab tab-choices) => (lambda (p) ((cdr p)))]
(display-binding-info)] [else (error 'properties-view%:refresh "internal error: no such tab: ~s" tab)])))
[(equal? s "Source")
(display-source-info)]
[(equal? s "Properties")
(display-properties)])))
(send* text (send* text
(end-edit-sequence) (end-edit-sequence)
(lock #t) (lock #t)
(scroll-to-position 0))) (scroll-to-position 0)))
(define/pubment (display-meaning-info)
(when (and (identifier? selected-syntax)
(uninterned? (syntax-e selected-syntax)))
(display "Uninterned symbol!\n\n" key-sd))
(display-binding-info)
(inner (void) display-meaning-info))
(define/private (display-binding-info) (define/private (display-binding-info)
(for-each (lambda (p) (display-binding-kv (car p) ((cdr p) selected-syntax))) (display "Apparent identifier binding\n" key-sd)
(unless (identifier? selected-syntax)
(display "Not applicable\n\n" n/a-sd))
(when (identifier? selected-syntax)
(if (eq? (identifier-binding selected-syntax) 'lexical)
(display "lexical (all phases)\n" #f)
(for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) selected-syntax)))
binding-properties)) binding-properties))
(display "\n" #f)))
(define/private (display-binding-kv k v) (define/private (display-binding-kvs k v)
(display (format "~a~n" k) key-sd) (display k sub-key-sd)
(cond [(eq? v 'lexical) (display "\n" #f)
(display "lexical\n" #f)] (cond [(eq? v #f)
[(eq? v #f) (display " top-level or unbound\n" #f)]
(display "#f (top-level or unbound)\n" #f)]
[(list? v) [(list? v)
(display-subkv "source module" (mpi->string (list-ref v 0))) (display-subkv " defined in" (mpi->string (list-ref v 0)))
(display-subkv "source id" (list-ref v 1)) (display-subkv " as" (list-ref v 1))
(display-subkv "nom. module" (mpi->string (list-ref v 2))) (display-subkv " imported from" (mpi->string (list-ref v 2)))
(display-subkv "nom. id" (list-ref v 3)) (display-subkv " as" (list-ref v 3))
(if (list-ref v 4) (if (list-ref v 4)
(display-subkv "phase" "via define-for-syntax"))] (display " via define-for-syntax" sub-key-sd))]))
[(void? v)
(display "Not applicable\n" n/a-sd)])
(display "\n" #f))
(define/private (display-subkv k v) (define/pubment (display-stxobj-info)
(display (format "~a: " k) sub-key-sd) (display-source-info)
(display (format "~a~n" v) #f)) (display-extra-source-info)
(inner (void) display-stxobj-info)
(display-symbol-property-info))
(define/private (display-source-info) (define/private (display-source-info)
(for-each (lambda (p) (display-subkv (car p) ((cdr p) selected-syntax))) (define s-source (syntax-source selected-syntax))
source-properties)) (define s-line (syntax-line selected-syntax))
(define s-column (syntax-column selected-syntax))
(define s-position (syntax-position selected-syntax))
(define s-span0 (syntax-span selected-syntax))
(define s-span (if (zero? s-span0) #f s-span0))
(display "Source location\n" key-sd)
(if (or s-source s-line s-column s-position s-span)
(begin
(display-subkv "source" (prettify-source s-source))
(display-subkv "line" s-line)
(display-subkv "column" s-column)
(display-subkv "position" s-position)
(display-subkv "span" s-span0))
(display "No source location available\n" n/a-sd))
(display "\n" #f))
(define/private (display-properties) (define/private (display-extra-source-info)
(display "Built-in properties\n" key-sd)
(display-subkv "source module"
(let ([mod (syntax-source-module selected-syntax)])
(and mod (mpi->string mod))))
(display-subkv "original?" (syntax-original? selected-syntax))
(display "\n" #f))
(define/private (display-symbol-property-info)
(let ([keys (syntax-property-symbol-keys selected-syntax)]) (let ([keys (syntax-property-symbol-keys selected-syntax)])
(if (null? keys) (display "Additional properties\n" key-sd)
(display "No properties available" n/a-sd) (when (null? keys)
(for-each (lambda (k) (display-kv k (syntax-property selected-syntax k))) (display "No additional properties available.\n" n/a-sd))
(when (pair? keys)
(for-each (lambda (k) (display-subkv k (syntax-property selected-syntax k)))
keys)))) keys))))
(define/private (display-kv key value) (define/private (display-kv key value)
(display (format "~a~n" key) key-sd) (display (format "~a~n" key) key-sd)
(display (format "~s~n~n" value) #f)) (display (format "~s~n~n" value) #f))
(define/public (display-subkv k v)
(display (format "~a: " k) sub-key-sd)
(display (format "~a~n" v) #f))
(define/private (display item sd) (define/private (display item sd)
(let ([p0 (send text last-position)]) (let ([p0 (send text last-position)])
(send text insert item) (send text insert item)
@ -97,22 +142,22 @@
;; binding-properties : (listof (cons string (syntax -> any))) ;; binding-properties : (listof (cons string (syntax -> any)))
(define binding-properties (define binding-properties
(list (cons "identifier-binding" (list (cons "in the standard phase"
(lift/id identifier-binding)) (lift/id identifier-binding))
(cons "identifier-transformer-binding" (cons "in the transformer phase (\"for-syntax\")"
(lift/id identifier-transformer-binding)) (lift/id identifier-transformer-binding))
(cons "identifier-template-binding" (cons "in the template phase (\"for-template\")"
(lift/id identifier-template-binding)))) (lift/id identifier-template-binding))))
;; source-properties : (listof (cons string (syntax -> any))) (define (uninterned? s)
(define source-properties (not (eq? s (string->symbol (symbol->string s)))))
(list (cons "syntax-source" syntax-source)
(cons "syntax-source-module" (define (prettify-source s)
(lambda (stx) (mpi->string (syntax-source-module stx)))) (cond [(is-a? s editor<%>)
(cons "syntax-line" syntax-line) 'editor]
(cons "syntax-position" syntax-position) [else s]))
(cons "syntax-span" syntax-span)
(cons "syntax-original?" syntax-original?))) ;; Styles
(define key-sd (define key-sd
(let ([sd (new style-delta%)]) (let ([sd (new style-delta%)])

19
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -9,7 +9,7 @@
"properties.ss" "properties.ss"
"typesetter.ss") "typesetter.ss")
(provide snip@ (provide snip@
snip-context-menu-extension@) snip-keymap-extension@)
(define snip@ (define snip@
(unit/sig snip^ (unit/sig snip^
@ -48,7 +48,7 @@
(send -outer change-style (make-object style-delta% 'change-alignment 'top)) (send -outer change-style (make-object style-delta% 'change-alignment 'top))
(new syntax-keymap% (new syntax-keymap%
(editor -outer) (editor -outer)
(context-menu (new context-menu% (snip this)))) (snip this))
(refresh) (refresh)
(define/public (get-controller) controller) (define/public (get-controller) controller)
@ -200,6 +200,21 @@
(super-new))) (super-new)))
)) ))
(define snip-keymap-extension@
(unit/sig keymap^
(import (pre : keymap^))
(define syntax-keymap%
(class pre:syntax-keymap%
(init-field snip)
(inherit add-function)
(super-new (controller (send snip get-controller)))
(add-function "show-syntax-properties"
(lambda (i e)
(send snip show-props)))))))
#;
(define snip-context-menu-extension@ (define snip-context-menu-extension@
(unit/sig context-menu^ (unit/sig context-menu^
(import (pre : context-menu^)) (import (pre : context-menu^))

75
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -13,12 +13,12 @@
"properties.ss" "properties.ss"
"util.ss") "util.ss")
(provide widget@ (provide widget@
widget-keymap-extension@
widget-context-menu-extension@) widget-context-menu-extension@)
(define widget@ (define widget@
(unit/sig widget^ (unit/sig widget^
(import keymap^ (import keymap^)
context-menu^)
;; syntax-widget% ;; syntax-widget%
;; A syntax-widget creates its own syntax-controller. ;; A syntax-widget creates its own syntax-controller.
@ -39,12 +39,11 @@
(new syntax-controller% (new syntax-controller%
(properties-controller this))) (properties-controller this)))
(define/public (make-context-menu) (define/public (make-keymap text)
(new context-menu% (widget this)))
(new syntax-keymap% (new syntax-keymap%
(editor -text) (editor text)
(context-menu (make-context-menu))) (widget this)))
(make-keymap -text)
(send -text lock #t) (send -text lock #t)
(send -split-panel set-percentages (send -split-panel set-percentages
@ -56,29 +55,24 @@
(define/public (set-syntax stx) (define/public (set-syntax stx)
(send props set-syntax stx)) (send props set-syntax stx))
(define/public (show ?)
(if ? (show-props) (hide-props)))
(define/public (props-shown?) (define/public (props-shown?)
(send -props-panel is-shown?)) (send -props-panel is-shown?))
(define/public (toggle-props) (define/public (toggle-props)
(if (send -props-panel is-shown?) (show-props (not (send -props-panel is-shown?))))
(hide-props)
(show-props)))
(define/public (hide-props) (define/public (show-props show?)
(when (send -props-panel is-shown?) (if show?
(set! props-percentage (cadr (send -split-panel get-percentages)))
(send -split-panel delete-child -props-panel)
(send -props-panel show #f)))
(define/public (show-props)
(unless (send -props-panel is-shown?) (unless (send -props-panel is-shown?)
(send -split-panel add-child -props-panel) (send -split-panel add-child -props-panel)
(send -split-panel set-percentages (send -split-panel set-percentages
(list (- 1 props-percentage) props-percentage)) (list (- 1 props-percentage) props-percentage))
(send -props-panel show #t))) (send -props-panel show #t))
(when (send -props-panel is-shown?)
(set! props-percentage
(cadr (send -split-panel get-percentages)))
(send -split-panel delete-child -props-panel)
(send -props-panel show #f))))
;; ;;
@ -145,32 +139,41 @@
)) ))
(define widget-keymap-extension@
(unit/sig keymap^
(import (pre : keymap^))
(define syntax-keymap%
(class pre:syntax-keymap%
(init-field widget)
(super-new (controller (send widget get-controller)))
(inherit add-function)
(add-function "show-syntax-properties"
(lambda (i e)
(send widget toggle-props)))
(define/public (get-widget) widget)
))))
(define widget-context-menu-extension@ (define widget-context-menu-extension@
(unit/sig context-menu^ (unit/sig context-menu^
(import (pre : context-menu^)) (import (pre : context-menu^))
(define context-menu% (define context-menu%
(class pre:context-menu% (class pre:context-menu%
(init-field widget) (inherit-field keymap)
(inherit-field props-menu)
(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)))))
(void))
(define/override (on-demand) (define/override (on-demand)
(send props-menu set-label (send props-menu set-label
(if (send widget props-shown?) (if (send (send keymap get-widget) props-shown?)
"Hide syntax properties" "Hide syntax properties"
"Show syntax properties")) "Show syntax properties"))
(super on-demand)) (super on-demand))
(super-new)))))
(super-new (controller (send widget get-controller))))))) (define browser-text%
(text:hide-caret/selection-mixin
(define browser-text% (editor:standard-style-list-mixin text:basic%)) (editor:standard-style-list-mixin text:basic%)))
) )

69
collects/macro-debugger/view/hiding-panel.ss
View File

@ -4,6 +4,7 @@
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "list.ss") (lib "list.ss")
(lib "boundmap.ss" "syntax") (lib "boundmap.ss" "syntax")
"util.ss"
"../model/hiding-policies.ss" "../model/hiding-policies.ss"
"../syntax-browser/util.ss") "../syntax-browser/util.ss")
(provide macro-hiding-prefs-widget%) (provide macro-hiding-prefs-widget%)
@ -13,8 +14,19 @@
(class object% (class object%
(init parent) (init parent)
(init-field stepper) (init-field stepper)
(init-field policy) (init-field config)
(init-field (enabled? #f))
(define policy (new-hiding-policy))
(set-hiding-policy-opaque-kernel! policy (send config get-hide-primitives?))
(set-hiding-policy-opaque-libs! policy (send config get-hide-libs?))
(send config listen-hide-primitives?
(lambda (value)
(set-hiding-policy-opaque-kernel! policy value)
(refresh)))
(send config listen-hide-libs?
(lambda (value)
(set-hiding-policy-opaque-libs! policy value)
(refresh)))
(define stx #f) (define stx #f)
(define stx-name #f) (define stx-name #f)
@ -34,35 +46,21 @@
(parent super-pane))) (parent super-pane)))
(define enable-ctl (define enable-ctl
(new check-box% (check-box/notify-box left-pane
(label "Enable macro hiding?") "Enable macro hiding?"
(parent left-pane) (get-field macro-hiding? config)))
(value enabled?) (send config listen-macro-hiding?
(callback (lambda (value) (force-refresh)))
(lambda _
(set! enabled? (send enable-ctl get-value))
(force-refresh)))))
(define kernel-ctl (define kernel-ctl
(new check-box% (check-box/notify-box left-pane
(label "Hide mzscheme syntax") "Hide mzscheme syntax"
(parent left-pane) (get-field hide-primitives? config)))
(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 (define libs-ctl
(new check-box% (check-box/notify-box left-pane
(label "Hide library syntax") "Hide library syntax"
(parent left-pane) (get-field hide-libs? config)))
(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 (define look-pane
(new horizontal-pane% (parent right-pane) (stretchable-height #f))) (new horizontal-pane% (parent right-pane) (stretchable-height #f)))
@ -97,21 +95,12 @@
;; Methods ;; Methods
;; enable-hiding : boolean -> void (define/public (get-show-macro?)
;; Called only by stepper, which does it's own refresh (lambda (id) (policy-show-macro? policy id)))
(define/public (enable-hiding ok?)
(send enable-ctl set-value ok?)
(set! enabled? ok?))
;; get-enabled?
(define/public (get-enabled?) enabled?)
;; get-policy
(define/public (get-policy) policy)
;; refresh ;; refresh
(define/public (refresh) (define/public (refresh)
(when enabled? (when (send config get-macro-hiding?)
(send stepper refresh/resynth))) (send stepper refresh/resynth)))
;; force-refresh ;; force-refresh

19
collects/macro-debugger/view/interfaces.ss
View File

@ -20,9 +20,26 @@
pref:height pref:height
pref:props-percentage pref:props-percentage
pref:macro-hiding? pref:macro-hiding?
pref:show-syntax-properties?
pref:show-hiding-panel? pref:show-hiding-panel?
pref:hide-primitives? pref:hide-primitives?
pref:hide-libs? pref:hide-libs?
pref:identifier=?)) pref:identifier=?
pref:show-rename-steps?
pref:highlight-foci?
pref:suppress-warnings?
))
;; macro-stepper-config%
;; all fields are notify-box% objects
;; width
;; height
;; macro-hiding?
;; hide-primitives?
;; hide-libs?
;; show-syntax-properties?
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?
) )

9
collects/macro-debugger/view/prefs.ss
View File

@ -21,18 +21,27 @@
(preferences:set-default 'MacroStepper:Frame:Height 600 number?) (preferences:set-default 'MacroStepper:Frame:Height 600 number?)
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?) (preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
(preferences:set-default 'MacroStepper:MacroHiding? #t boolean?) (preferences:set-default 'MacroStepper:MacroHiding? #t boolean?)
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
(preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?) (preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
(preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?) (preferences:set-default 'MacroStepper:HidePrimitives? #t boolean?)
(preferences:set-default 'MacroStepper:HideLibs? #t boolean?) (preferences:set-default 'MacroStepper:HideLibs? #t boolean?)
(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?) (preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
(preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?)
(preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?)
(preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
(pref:get/set pref:width MacroStepper:Frame:Width) (pref:get/set pref:width MacroStepper:Frame:Width)
(pref:get/set pref:height MacroStepper:Frame:Height) (pref:get/set pref:height MacroStepper:Frame:Height)
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage) (pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding? MacroStepper:MacroHiding?) (pref:get/set pref:macro-hiding? MacroStepper:MacroHiding?)
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?) (pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
(pref:get/set pref:hide-primitives? MacroStepper:HidePrimitives?) (pref:get/set pref:hide-primitives? MacroStepper:HidePrimitives?)
(pref:get/set pref:hide-libs? MacroStepper:HideLibs?) (pref:get/set pref:hide-libs? MacroStepper:HideLibs?)
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison) (pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
)) ))
) )