suzanne.soy/racket
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
This commit is contained in:
Ryan Culpepper 2006-12-14 21:25:21 +00:00
parent 9cf47eea85
commit 056683743d
25 changed files with 1205 additions and 526 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
collects/macro-debugger/doc.txt
View File

@ -26,10 +26,10 @@ syntax browser uses colors and a properties panel to show the term's
syntax properties, such as lexical binding information and source
location.
_expand.ss_
===========
_stepper.ss_
============
> (require (lib "expand.ss" "macro-debugger"))
> (require (lib "stepper.ss" "macro-debugger"))
This module provides a single procedure:
@ -38,6 +38,59 @@ This module provides a single procedure:
Expands the syntax (or S-expression) and opens a macro stepper frame
for stepping through the expansion.
_expand.ss_
===========
> (require (lib "expand.ss" "macro-debugger"))
This module provides the following procedures:
> expand/step
This export will disappear in a future version of the collection.
Require from stepper.ss instead.
> (expand-only syntax list-of-identifiers)
Expands the given syntax, but only shows the expansion of macros in
the given identifier list.
Warning: because of limitations in syntax, expansion, and hiding, the
resulting syntax may not evaluate to the same thing as the original
syntax.
> (expand/hide syntax list-of-identifier)
Expands the given syntax, but hides the expansion of macros in the
given identifier list (conceptually, the complement of expand-only).
Warning: because of limitations in syntax, expansion, and hiding, the
resulting syntax may not evaluate to the same thing as the original
syntax.
_stepper-text.ss_
=================
> (require (lib "stepper-text.ss" "macro-debugger"))
This module provides two procedures for stepping through macro
expansion in text-only environments.
> (expand/step-text syntax [identifier-predicate])
Expands the syntax and prints the macro expansion steps. If the
identifier predicate is given, it determines which macros are shown
(if absent, no macros are hidden). A list of identifiers is also
accepted.
> (stepper-text syntax [identifier-predicate])
Returns a procedure P that:
- when called with no arguments (or on the symbol 'next),
prints out individual steps until macro expansion finishes
- when called on the symbol 'all,
prints out all of the remaining steps
_syntax-browser.ss_
===================

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

@ -1,9 +1,32 @@
(module expand mzscheme
(require (lib "unitsig.ss"))
(require "view/view.ss")
(provide expand/step)
(require "model/trace.ss"
"model/hide.ss")
(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]
[(visit (? TaggedPrimStep 'prim) return)
($2 $1)]
[(visit VariableStep return)
($2 $1 $3)]
[((? EE/Macro))
$1])
(EE/Macro
@ -127,9 +129,10 @@
;; MacroStep Answer = Transformation (I,E)
(MacroStep
[(Resolves enter-macro
(! 'bad-transformer)
macro-pre-transform (? LocalActions 'locals) (! 'transform) macro-post-transform
exit-macro)
(make-transformation $2 $7 $1 $3 $6 $4)])
(make-transformation $2 $8 $1 $4 $7 $5)])
;; Local actions taken by macro
;; LocalAction Answer = (list-of LocalAction)
@ -163,9 +166,13 @@
(PrimStep
(#:no-wrap)
[(Resolves NoError enter-prim (? Prim) exit-prim)
($4 $3 $5 $1)]
($4 $3 $5 $1)])
(VariableStep
(#:no-wrap)
(#:args e1 e2)
[(Resolves variable)
(make-p:variable (car $2) (cdr $2) $1)])
(make-p:variable e1 e2 $1)])
;; Tagged Primitive syntax
;; TaggedPrimStep Answer = syntax -> PRule
@ -174,6 +181,8 @@
(#:args orig-stx)
[(Resolves ! IMPOSSIBLE)
(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)
($4 orig-stx $5 $1 $3)])
@ -234,7 +243,10 @@
(Prim#%ModuleBegin
(#: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)])
(ModulePass1

15
collects/macro-debugger/model/hide.ss
View File

@ -489,7 +489,8 @@
(parameterize ((subterms-table subterms))
(match (seek d)
[(and (struct error-wrap (exn tag inner)) ew)
(values ew (deriv-e2 inner))]
(values ew #f)
#;(values ew (deriv-e2 inner))]
[deriv
(values (rewrap d deriv) (lift/deriv-e2 deriv))])))]))
@ -513,7 +514,7 @@
[subterms (filter (lambda (x) (not (error? x))) subterm-derivs)])
;(printf "subterm paths:~n~s~n" (map s:subterm-path subterm-derivs))
;(printf "subterms:~n~s~n" subterm-derivs)
(let ([e2 (substitute-subterms e1 subterms)])
(let ([e2 (and (null? errors) (substitute-subterms e1 subterms))])
(let ([d (make-p:synth e1 e2 null subterms)])
(if (pair? errors)
(rewrap (car errors) d)
@ -529,7 +530,7 @@
[(AnyQ deriv (e1 e2))
(let ([paths (table-get (subterms-table) e1)])
(cond [(null? paths)
(for-unlucky-deriv d)]
(for-unlucky-deriv/record-error d)]
[(null? (cdr paths))
(let-values ([(d _) (hide d)])
(list (make-s:subterm (car paths) d)))]
@ -541,6 +542,14 @@
(raise (make-nonlinearity "nonlinearity in original term" paths))]))]
[#f null]))
;; for-unluck-deriv/record-error -> (list-of Subterm)
;; Guarantee: (deriv-e1 deriv) is not in subterms table
(define (for-unlucky-deriv/record-error d)
(if (error-wrap? d)
(append (for-unlucky-deriv d)
(list (make-s:subterm #f d)))
(for-unlucky-deriv d)))
;; for-unlucky-deriv : Derivation -> (list-of Subterm)
;; Guarantee: (deriv-e1 deriv) is not in subterms table
(define (for-unlucky-deriv d)

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

@ -29,7 +29,9 @@
;; Primitives
[(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))
(with-syntax ([(?module name language . BODY) e1])
(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)))])
(with-context ctx
(reductions body))))]
[(IntQ 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])))
[(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2))
(with-syntax ([(?#%module-begin form ...) e1])
(let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))])
(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))])
(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))])
(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)
(R e1 _
[! exni]
@ -269,7 +269,8 @@
[#f null]
#;[else (error 'reductions "unmatched case: ~s" d)]))
#;
[else (error 'reductions "unmatched case: ~s" d)]))
;; reductions-transformation : Transformation -> ReductionSequence
(define (reductions-transformation tx)
@ -279,6 +280,8 @@
(list (walk e1 e2 "Macro transformation")))]
[(IntW transformation (e1 e2 rs me1 me2 locals) '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)
(append (reductions-locals e1 locals)
(list (stumble e1 exn)))]))
@ -374,7 +377,9 @@
[(cons (struct b:splice (renames head tail)) next)
(loop next tail prefix
(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
(cons (deriv-e2 head) (stx-cdr suffix))))
(E (revappend prefix tail))

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

@ -80,15 +80,6 @@
(cond [(zero? n) null]
[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)
(if (stx-pair? 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)])
(send (get-admin) get-view-size ad-x ad-y)
#;(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))))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let* [(xh (get-xheight dc))
@ -30,5 +30,28 @@
(set! cached-xheight h)
h)))
(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)))
(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)
)

43
collects/macro-debugger/syntax-browser/implementation.ss
View File

@ -9,6 +9,8 @@
"prefs.ss")
(provide global-prefs@
global-snip@
widget-keymap@
widget-context-menu@
implementation@)
(provide-signature-elements snip^)
(provide-signature-elements snipclass^)
@ -16,15 +18,22 @@
;; prefs@ and snip@ should only be invoked once
;; We create a new unit/sig out of their invocation
(define snip-keymap@
(compound-unit/sig
(import [MENU : context-menu^]
[SNIP : snip^])
(link [KEYMAP : keymap^ (keymap@ MENU SNIP)]
[SNIP-KEYMAP : keymap^ (snip-keymap-extension@ KEYMAP)])
(export (open SNIP-KEYMAP))))
(define snip-implementation@
(compound-unit/sig
(import)
(link [PREFS : prefs^ (prefs@)]
[KEYMAP : keymap^ (keymap@)]
[MENU : context-menu^ (context-menu@ SNIP)]
[MENU : context-menu^ (context-menu@)]
[KEYMAP : keymap^ (snip-keymap@ MENU SNIP)]
[SNIP-CLASS : snipclass^ (snipclass@ SNIP)]
[SNIP-MENU : context-menu^ (snip-context-menu-extension@ MENU)]
[SNIP : snip^ (snip@ PREFS KEYMAP SNIP-MENU SNIP-CLASS)])
[SNIP : snip^ (snip@ PREFS KEYMAP MENU SNIP-CLASS)])
(export (open PREFS) (open SNIP) (open SNIP-CLASS))))
(define-values/invoke-unit/sig ((open snip^) (open prefs^) (open snipclass^))
snip-implementation@)
@ -49,15 +58,29 @@
;; Everyone else re-uses the global-snip@ unit
;; implementation@ : prefs^ -> implementation^
(define widget-keymap@
(compound-unit/sig
(import [MENU : context-menu^]
[SNIP : snip^])
(link [KEYMAP : keymap^ (keymap@ MENU SNIP)]
[WKEYMAP : keymap^ (widget-keymap-extension@ KEYMAP)])
(export (open WKEYMAP))))
(define widget-context-menu@
(compound-unit/sig
(import)
(link [MENU : context-menu^ (context-menu@)]
[WMENU : context-menu^ (widget-context-menu-extension@ MENU)])
(export (open WMENU))))
;; implementation@ : implementation^
(define implementation@
(compound-unit/sig
(import)
(link [KEYMAP : keymap^ (keymap@)]
[MENU : context-menu^ (context-menu@ SNIP)]
[SNIP : snip^ (global-snip@)]
[WIDGET-MENU : context-menu^ (widget-context-menu-extension@ MENU)]
[WIDGET : widget^ (widget@ KEYMAP WIDGET-MENU)])
(link [SNIP : snip^ (global-snip@)]
[MENU : context-menu^ (widget-context-menu@)]
[KEYMAP : keymap^ (widget-keymap@ MENU SNIP)]
[WIDGET : widget^ (widget@ KEYMAP)])
(export (unit SNIP snip)
(unit WIDGET widget))))

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

@ -8,72 +8,30 @@
(provide keymap@
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@
(unit/sig context-menu^
(import snip^)
(import)
(define context-menu%
(class popup-menu%
(init-field keymap)
(init-field controller)
(super-new)
(define copy-menu #f)
(define copy-syntax-menu #f)
(define clear-menu #f)
(field [copy-menu #f]
[copy-syntax-menu #f]
[clear-menu #f]
[props-menu #f])
(define/public (add-edit-items)
(set! copy-menu
(new menu-item% (label "Copy") (parent this)
(callback (lambda (i e)
(define stx (send controller get-selected-syntax))
(send the-clipboard set-clipboard-string
(if stx
(format "~s" (syntax-object->datum stx))
"")
(send e get-time-stamp))))))
(send keymap call-function "copy-text" i e)))))
(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)))))
(send keymap call-function "copy-syntax" i e)))))
(void))
(define/public (after-edit-items)
@ -84,7 +42,16 @@
(new menu-item%
(label "Clear selection")
(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))
(define/public (after-selection-items)
@ -134,4 +101,75 @@
(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))))))
)

16
collects/macro-debugger/syntax-browser/params.ss
View File

@ -1,7 +1,9 @@
(module params mzscheme
(provide current-syntax-font-size
current-default-columns)
current-default-columns
current-colors
current-suffix-option)
;; current-syntax-font-size : parameter of number/#f
;; When non-false, overrides the default font size
@ -10,4 +12,16 @@
;; current-default-columns : parameter of number
(define current-default-columns (make-parameter 60))
;; current-suffix-option : parameter of SuffixOption
(define current-suffix-option (make-parameter 'over-limit))
(define current-colors
(make-parameter
(list "black" "red" "blue"
"mediumforestgreen" "darkgreen"
"darkred"
"cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
"indigo" "purple"
"orange" "salmon" "darkgoldenrod" "olive")))
)

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

@ -9,10 +9,7 @@
identifier=-choices)
(define (new-bound-partition)
#;(define p (new partition% (relation id:same-marks?)))
(define p (new bound-partition%))
(send p get-partition (datum->syntax-object #f 'no-marks))
p)
(new bound-partition%))
;; representative-symbol : symbol
;; Must be fresh---otherwise, using it could detect rename wraps
@ -75,6 +72,7 @@
(lambda (k v)
(printf "~s => ~s~n" k v))))
(get-partition unmarked-syntax)
(super-new)
))
@ -91,6 +89,7 @@
(or n
(begin0 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))))))
(define/public (same-partition? a b)
@ -102,6 +101,7 @@
(define/private (representative stx)
(datum->syntax-object stx representative-symbol))
(get-partition unmarked-syntax)
(super-new)))
;; 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))
;; 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)
;; 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 numbering? is true, suffixes identifiers with partition numbers.
;;
;; Returns three values:
;; - an S-expression
@ -32,18 +37,23 @@
;; Syntax objects which are eq? will map to same flat values
(define syntax->datum/tables
(case-lambda
[(stx) (table stx #f #f #f)]
[(stx partition limit numbering?) (table stx partition limit numbering?)]))
[(stx) (table stx #f #f 'never)]
[(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
;; table : syntax partition%-or-#f num-or-#f -> (values s-expr hashtable hashtable)
(define (table stx partition limit numbering?)
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt)
(define (make-identifier-proxy id)
(case suffixopt
((never) (unintern (syntax-e id)))
((always)
(let ([n (send partition get-partition id)])
(cond [(or (zero? n) (not numbering?))
(string->uninterned-symbol (symbol->string (syntax-e id)))]
[else
(string->uninterned-symbol
(format "~a:~a" (syntax-e id) n))])))
(if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
((over-limit)
(let ([n (send partition get-partition id)])
(if (<= n limit)
(unintern (syntax-e id))
(suffix (syntax-e id) n))))))
(let/ec escape
(let ([flat=>stx (make-hash-table)]
[stx=>flat (make-hash-table)])
@ -51,10 +61,11 @@
(cond [(hash-table-get stx=>flat obj (lambda _ #f))
=> (lambda (datum) datum)]
[(and partition (identifier? obj))
(let ([lp-datum (make-identifier-proxy obj)])
(when (and limit (> (send partition count) limit))
(call-with-values (lambda () (table stx partition #f #t))
(when (and (eq? suffixopt 'all-if-over-limit)
(> (send partition count) limit))
(call-with-values (lambda () (table stx partition #f 'always))
escape))
(let ([lp-datum (make-identifier-proxy obj)])
(hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum)
lp-datum)]
@ -69,8 +80,7 @@
[(vector? obj)
(list->vector (map loop (vector->list obj)))]
[(symbol? obj)
;(make-syntax-dummy obj)
(string->uninterned-symbol (symbol->string obj))]
(unintern obj)]
[(number? obj)
(make-syntax-dummy obj)]
[(box? obj)
@ -90,4 +100,11 @@
(values (loop stx)
flat=>stx
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
(define/private (recompute-tables)
(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
(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)
(define selected-syntax #f)
(define tab-choices (get-tab-choices))
(define tab-panel (new tab-panel%
(choices (list "Binding" "Source" "Properties"))
(choices (map car tab-choices))
(parent parent)
(callback (lambda _ (refresh)))))
(define text (new text%))
(send text set-styles-sticky #f)
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))
@ -24,64 +26,107 @@
(set! selected-syntax stx)
(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)
(send* text
(lock #f)
(begin-edit-sequence)
(erase))
(when (syntax? selected-syntax)
(let ([s (send tab-panel get-item-label (send tab-panel get-selection))])
(cond [(equal? s "Binding")
(display-binding-info)]
[(equal? s "Source")
(display-source-info)]
[(equal? s "Properties")
(display-properties)])))
(let ([tab (send tab-panel get-item-label (send tab-panel get-selection))])
(cond [(assoc tab tab-choices) => (lambda (p) ((cdr p)))]
[else (error 'properties-view%:refresh "internal error: no such tab: ~s" tab)])))
(send* text
(end-edit-sequence)
(lock #t)
(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)
(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))
(display "\n" #f)))
(define/private (display-binding-kv k v)
(display (format "~a~n" k) key-sd)
(cond [(eq? v 'lexical)
(display "lexical\n" #f)]
[(eq? v #f)
(display "#f (top-level or unbound)\n" #f)]
(define/private (display-binding-kvs k v)
(display k sub-key-sd)
(display "\n" #f)
(cond [(eq? v #f)
(display " top-level or unbound\n" #f)]
[(list? v)
(display-subkv "source module" (mpi->string (list-ref v 0)))
(display-subkv "source id" (list-ref v 1))
(display-subkv "nom. module" (mpi->string (list-ref v 2)))
(display-subkv "nom. id" (list-ref v 3))
(display-subkv " defined in" (mpi->string (list-ref v 0)))
(display-subkv " as" (list-ref v 1))
(display-subkv " imported from" (mpi->string (list-ref v 2)))
(display-subkv " as" (list-ref v 3))
(if (list-ref v 4)
(display-subkv "phase" "via define-for-syntax"))]
[(void? v)
(display "Not applicable\n" n/a-sd)])
(display "\n" #f))
(display " via define-for-syntax" sub-key-sd))]))
(define/private (display-subkv k v)
(display (format "~a: " k) sub-key-sd)
(display (format "~a~n" v) #f))
(define/pubment (display-stxobj-info)
(display-source-info)
(display-extra-source-info)
(inner (void) display-stxobj-info)
(display-symbol-property-info))
(define/private (display-source-info)
(for-each (lambda (p) (display-subkv (car p) ((cdr p) selected-syntax)))
source-properties))
(define s-source (syntax-source selected-syntax))
(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)])
(if (null? keys)
(display "No properties available" n/a-sd)
(for-each (lambda (k) (display-kv k (syntax-property selected-syntax k)))
(display "Additional properties\n" key-sd)
(when (null? keys)
(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))))
(define/private (display-kv key value)
(display (format "~a~n" key) key-sd)
(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)
(let ([p0 (send text last-position)])
(send text insert item)
@ -97,22 +142,22 @@
;; binding-properties : (listof (cons string (syntax -> any)))
(define binding-properties
(list (cons "identifier-binding"
(list (cons "in the standard phase"
(lift/id identifier-binding))
(cons "identifier-transformer-binding"
(cons "in the transformer phase (\"for-syntax\")"
(lift/id identifier-transformer-binding))
(cons "identifier-template-binding"
(cons "in the template phase (\"for-template\")"
(lift/id identifier-template-binding))))
;; source-properties : (listof (cons string (syntax -> any)))
(define source-properties
(list (cons "syntax-source" syntax-source)
(cons "syntax-source-module"
(lambda (stx) (mpi->string (syntax-source-module stx))))
(cons "syntax-line" syntax-line)
(cons "syntax-position" syntax-position)
(cons "syntax-span" syntax-span)
(cons "syntax-original?" syntax-original?)))
(define (uninterned? s)
(not (eq? s (string->symbol (symbol->string s)))))
(define (prettify-source s)
(cond [(is-a? s editor<%>)
'editor]
[else s]))
;; Styles
(define key-sd
(let ([sd (new style-delta%)])

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

@ -9,7 +9,7 @@
"properties.ss"
"typesetter.ss")
(provide snip@
snip-context-menu-extension@)
snip-keymap-extension@)
(define snip@
(unit/sig snip^
@ -48,7 +48,7 @@
(send -outer change-style (make-object style-delta% 'change-alignment 'top))
(new syntax-keymap%
(editor -outer)
(context-menu (new context-menu% (snip this))))
(snip this))
(refresh)
(define/public (get-controller) controller)
@ -200,6 +200,21 @@
(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@
(unit/sig context-menu^
(import (pre : context-menu^))

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

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

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

@ -14,21 +14,20 @@
"../model/deriv-util.ss"
"../model/trace.ss"
"../model/hide.ss"
"../model/hiding-policies.ss"
"../model/steps.ss"
"cursor.ss"
"util.ss")
(provide catch-errors?
pre-stepper@
(provide pre-stepper@
view@
context-menu-extension@
browser-extension@)
browser-extension@
;; Configuration
catch-errors?)
;; Debugging parameters / Not user configurable
(define catch-errors? (make-parameter #t))
(define show-rename-steps? (make-parameter #f))
;; Macro Stepper
@ -38,20 +37,32 @@
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-config%
(class object%
(field/notify width (notify-box/pref pref:width))
(field/notify height (notify-box/pref pref:height))
(field/notify macro-hiding? (notify-box/pref pref:macro-hiding?))
(field/notify show-syntax-properties?
(notify-box/pref pref:show-syntax-properties?))
(field/notify show-hiding-panel?
(notify-box/pref pref:show-hiding-panel?))
(field/notify hide-primitives?
(notify-box/pref pref:hide-primitives?))
(field/notify hide-libs?
(notify-box/pref pref:hide-libs?))
(field/notify highlight-foci?
(notify-box/pref pref:highlight-foci?))
(field/notify show-rename-steps?
(notify-box/pref pref:show-rename-steps?))
(field/notify suppress-warnings?
(notify-box/pref pref:suppress-warnings?))
(super-new)))
(define macro-stepper-frame%
(class base-frame%
(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)))
(init (identifier=? (pref:identifier=?)))
(init-field (config (new macro-stepper-config%)))
(inherit get-menu%
get-menu-item%
get-menu-bar
@ -60,15 +71,15 @@
get-help-menu)
(super-new (label "Macro stepper")
(width width)
(height height))
(width (send config get-width))
(height (send config get-height)))
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
(send widget update/preserve-view))
(define/augment (on-close)
(pref:width (send this get-width))
(pref:height (send this get-height))
(send widget shutdown)
(inner (void) on-close))
@ -90,38 +101,35 @@
(define file-menu (get-file-menu))
(define edit-menu (get-edit-menu))
(define syntax-menu
(new (get-menu%) (parent (get-menu-bar)) (label "Syntax")))
(define stepper-menu
(new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
(define help-menu (get-help-menu))
(define (mk-register-action menu)
(lambda (label callback)
(if label
(new (get-menu-item%)
(label label) (parent menu) (callback (lambda _ (callback))))
(new separator-menu-item% (parent menu)))))
(define widget
(new macro-stepper-widget%
(parent (send this get-area-container))
(policy policy)
(macro-hiding? macro-hiding?)
(show-hiding-panel? show-hiding-panel?)))
(config config)))
(define/public (get-widget) widget)
(begin
(new (get-menu-item%) (label "Show/hide syntax properties") (parent syntax-menu)
(callback (lambda _ (send (send widget get-view) toggle-props))))
(define id-menu
(new (get-menu%) (label "Identifier=?") (parent syntax-menu)))
;; Set up menus
(menu-option/notify-box stepper-menu
"Show syntax properties"
(get-field show-syntax-properties? config))
;; FIXME: rewrite with notify-box
(let ([id-menu
(new (get-menu%)
(label "Identifier=?")
(parent stepper-menu))])
(for-each (lambda (p)
(let ([this-choice
(new checkable-menu-item%
(label (car p))
(parent id-menu)
(callback (lambda _
(callback
(lambda _
(send (send widget get-controller)
on-update-identifier=?
(car p)
@ -129,24 +137,45 @@
(send (send widget get-controller)
add-identifier=?-listener
(lambda (new-name new-func)
(send this-choice check (eq? new-name (car p)))))))
(sb:identifier=-choices))
(new (get-menu-item%) (label "Clear selection") (parent syntax-menu)
(callback
(lambda _ (send (send widget get-controller) select-syntax #f))))
(new (get-menu-item%)
(label "Show/hide macro hiding configuration")
(parent stepper-menu)
(callback (lambda _ (send widget show/hide-macro-hiding-prefs)))))
(begin
(send this-choice check
(eq? new-name (car p)))))))
(sb:identifier=-choices)))
(when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))])
(when p
(send (send widget get-controller)
on-update-identifier=?
(car p)
(cdr p))))))
(cdr p)))))
(new (get-menu-item%) (label "Clear selection") (parent stepper-menu)
(callback
(lambda _
(send (send widget get-controller) select-syntax #f))))
(new separator-menu-item% (parent stepper-menu))
(menu-option/notify-box stepper-menu
"Show macro hiding panel"
(get-field show-hiding-panel? config))
(let ([extras-menu
(new (get-menu%)
(label "Extra options")
(parent stepper-menu))])
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
(get-field highlight-foci? config))
(menu-option/notify-box extras-menu
"Include renaming steps"
(get-field show-rename-steps? config))
(menu-option/notify-box extras-menu
"Suppress warnings"
(get-field suppress-warnings? config))
(new checkable-menu-item%
(label "(Debug) Catch internal errors?")
(parent extras-menu)
(checked (catch-errors?))
(callback
(lambda (c e) (catch-errors? (send c is-checked?))))))
(frame:reorder-menus this)
))
@ -155,9 +184,7 @@
(define macro-stepper-widget%
(class* object% ()
(init-field parent)
(init policy)
(init macro-hiding?)
(init show-hiding-panel?)
(init-field config)
;; derivs : (list-of Derivation)
(define derivs null)
@ -168,16 +195,26 @@
;; derivs-prefix : (list-of (cons Derivation Derivation))
(define derivs-prefix null)
;; steps : cursor
(define steps #f)
;; zoomed? : boolean
(define zoomed? #f)
(define warnings-frame #f)
(define/public (add-deriv d)
(set! derivs (append derivs (list d)))
(when (and (not (send updown-navigator is-shown?))
(when (and (not (send nav:up is-shown?))
(pair? (cdr (append derivs-prefix derivs))))
(send super-navigator add-child updown-navigator)
(send updown-navigator show #t))
(send navigator change-children
(lambda (_)
(list nav:up
nav:start
nav:previous
nav:next
nav:end
nav:down))))
(if (null? (cdr derivs))
;; There is nothing currently displayed
(refresh)
@ -188,20 +225,15 @@
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define area (new vertical-panel% (parent parent)))
(define super-navigator
(define navigator
(new horizontal-panel%
(parent area)
(stretchable-height #f)
(alignment '(center center))))
(define navigator
#;
(define advanced-navigator
(new horizontal-panel%
(parent super-navigator)
(stretchable-height #f)
(alignment '(center center))))
(define updown-navigator
(new horizontal-panel%
(parent super-navigator)
(style '(deleted))
(parent area)
(stretchable-height #f)
(alignment '(center center))))
@ -209,19 +241,34 @@
(parent area)
(macro-stepper this)
(pref:props-percentage pref:props-percentage)))
(send sbview show-props (send config get-show-syntax-properties?))
(send config listen-show-syntax-properties?
(lambda (show?) (send sbview show-props show?)))
(define sbc (send sbview get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
(define macro-hiding-prefs
(new macro-hiding-prefs-widget%
(policy policy)
(parent control-pane)
(stepper this)
(enabled? macro-hiding?)))
(config config)))
(send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-prefs show?)))
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
(send sbc add-selection-listener
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(unless show-hiding-panel?
(show/hide-macro-hiding-prefs))
(send config listen-highlight-foci?
(lambda (_) (update/preserve-view)))
(send config listen-show-rename-steps?
(lambda (_) (refresh)))
(define nav:up
(new button% (label "Previous term") (parent navigator) (style '(deleted))
(callback (lambda (b e) (navigate-up)))))
(define nav:start
(new button% (label "<-- Start") (parent navigator)
@ -236,19 +283,29 @@
(new button% (label "End -->") (parent navigator)
(callback (lambda (b e) (navigate-to-end)))))
(define nav:up
(new button% (label "Previous term") (parent updown-navigator)
(callback (lambda (b e) (navigate-up)))))
(define nav:down
(new button% (label "Next term") (parent updown-navigator)
(new button% (label "Next term") (parent navigator) (style '(deleted))
(callback (lambda (b e) (navigate-down)))))
(define/public (show/hide-macro-hiding-prefs)
#;
(define nav:zoom-in
(new button% (label "Zoom in") (parent advanced-navigator)
(callback (lambda (b e) (navigate-zoom-in)))))
#;
(define nav:zoom-out
(new button% (label "Zoom out") (parent advanced-navigator)
(callback (lambda (b e) (navigate-zoom-out)))))
#;
(define nav:jump-to
(new button% (label "Skip to") (parent advanced-navigator)
(callback (lambda (b e) (navigate-skip-to)))))
(define/public (show-macro-hiding-prefs show?)
(send area change-children
(lambda (children)
(if (memq control-pane children)
(remq control-pane children)
(append children (list control-pane))))))
(if show?
(append (remq control-pane children) (list control-pane))
(remq control-pane children)))))
;; Navigate
@ -278,6 +335,17 @@
(set! synth-deriv #f))
(refresh))
(define/private (navigate-zoom-in)
(set! zoomed? #t)
(update))
(define/private (navigate-zoom-out)
(set! zoomed? #f)
(update))
(define/private (navigate-skip-to)
'...)
(define/private (insert-step-separator text)
(send sbview add-text "\n ")
(send sbview add-text
@ -297,33 +365,27 @@
(update)
(send text scroll-to-position (unbox start-box) #f (unbox end-box)))
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send sbview get-text))
(define position-of-interest 0)
(send text begin-edit-sequence)
(send sbview erase-all)
(when (pair? derivs-prefix)
(define (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
(for-each (lambda (d+sd)
(let ([e2 (lift/deriv-e2 (cdr d+sd))])
(if e2
(send sbview add-syntax e2)
(send sbview add-text "Error\n"))))
(reverse derivs-prefix))
(send sbview add-separator))
(set! position-of-interest (send text last-position))
(reverse derivs-prefix)))
(define (update:show-current-step)
(when steps
(let ([step (cursor:current steps)])
(unless step
(let ([result (lift/deriv-e2 synth-deriv)])
(when result
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax result))
(unless result
(send sbview add-text "Error\n"))))
(when (step? step)
(cond [(step? step)
(update:show-step step)]
[(misstep? step)
(update:show-misstep step)]
[(not step)
(update:show-final)]))))
(define (update:show-step step)
(unless zoomed?
(when (pair? (step-lctx step))
(for-each (lambda (bc)
(send sbview add-text "While executing macro transformer in:\n")
@ -333,19 +395,48 @@
(insert-syntax/redex (step-e1 step) (foci (step-redex step)))
(insert-step-separator (step-note step))
(insert-syntax/contractum (step-e2 step) (foci (step-contractum step))))
(when (misstep? step)
(when zoomed?
(for-each (lambda (s) (insert-syntax s)) (foci (step-redex step)))
(insert-step-separator (step-note step))
(for-each (lambda (s) (insert-syntax s)) (foci (step-contractum step)))))
(define (update:show-misstep step)
(insert-syntax/redex (misstep-e1 step) (foci (misstep-redex step)))
(insert-step-separator "Error")
(send sbview add-text (exn-message (misstep-exn step)))
(send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e))
(exn:fail:syntax-exprs (misstep-exn step)))))))
(when (and (pair? derivs) (pair? (cdr derivs)))
(send sbview add-separator)
(exn:fail:syntax-exprs (misstep-exn step)))))
(define (update:show-final)
(let ([result (lift/deriv-e2 synth-deriv)])
(when result
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax result))
(unless result
(send sbview add-text "Error\n"))))
(define (update:show-suffix)
(when (pair? derivs)
(for-each (lambda (suffix-deriv)
(send sbview add-syntax (lift/deriv-e1 suffix-deriv)))
(cdr derivs)))
(cdr derivs))))
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send sbview get-text))
(define position-of-interest 0)
(send text begin-edit-sequence)
(send sbview erase-all)
(unless zoomed? (update:show-prefix))
(send sbview add-separator)
(set! position-of-interest (send text last-position))
(update:show-current-step)
(send sbview add-separator)
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position
position-of-interest
@ -354,13 +445,21 @@
'start)
(enable/disable-buttons))
;; insert-syntax : syntax -> void
(define/private (insert-syntax stx)
(send sbview add-syntax stx))
;; insert-syntax/redex : syntax syntaxes -> void
(define/private (insert-syntax/redex stx foci)
(send sbview add-syntax stx foci "MistyRose"))
(if (send config get-highlight-foci?)
(send sbview add-syntax stx foci "MistyRose")
(send sbview add-syntax stx)))
; insert-syntax/contractum : syntax syntaxes -> void
;; insert-syntax/contractum : syntax syntaxes -> void
(define/private (insert-syntax/contractum stx foci)
(send sbview add-syntax stx foci "LightCyan"))
(if (send config get-highlight-foci?)
(send sbview add-syntax stx foci "LightCyan")
(send sbview add-syntax stx)))
;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons)
@ -370,7 +469,15 @@
(send nav:end enable (and steps (cursor:can-move-next? steps)))
(send nav:up enable (and (pair? derivs-prefix)))
(send nav:down enable
(and (pair? derivs))))
(and (pair? derivs)))
#;
(send nav:zoom-in enable
(and (not zoomed?) steps (step? (cursor:current steps))))
#;
(send nav:zoom-out enable zoomed?)
#;
(send nav:jump-to enable #f))
;; --
;; refresh/resynth : -> void
@ -411,27 +518,24 @@
(let ([show-macro? (get-show-macro?)])
(if show-macro?
(with-handlers ([(lambda (e) (catch-errors?))
(lambda (e) (no-synthesize deriv))])
(lambda (e) (disable-hiding) deriv)])
(parameterize ((current-hiding-warning-handler
(lambda (tag message)
(unless (send config get-suppress-warnings?)
(unless warnings-frame
(set! warnings-frame (new warnings-frame%)))
(send warnings-frame add-warning tag)
#;
(send warnings-frame add-text
(format "Warning: ~a~n" message)))))
(send warnings-frame add-warning tag)))))
(let-values ([(d s) (hide/policy deriv show-macro?)])
d)))
deriv)))
(define/private (no-synthesize deriv)
(define/private (disable-hiding)
(message-box
"Macro Debugger"
(string-append
"This expansion triggers an error in the macro hiding code. "
"Trying again with macro hiding disabled."))
(send macro-hiding-prefs enable-hiding #f)
(synthesize deriv))
(queue-callback (lambda () (send config set-macro-hiding? #f))))
;; reduce : Derivation -> ReductionSequence
(define/private (reduce d)
@ -442,7 +546,7 @@
"Internal error in macro stepper (reductions)")
(set! synth-deriv #f)
(set! steps #f))])
(if (show-rename-steps?)
(if (send config get-show-rename-steps?)
(reductions d)
(filter (lambda (x) (not (rename-step? x)))
(reductions d)))))
@ -451,22 +555,13 @@
;; 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 (get-policy)])
(and policy (lambda (id) (policy-show-macro? policy id)))))
(and (send config get-macro-hiding?)
(send macro-hiding-prefs get-show-macro?)))
;; --
(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
@ -476,18 +571,10 @@
;; Main entry points
(define make-macro-stepper
(case-lambda
[(policy hiding?)
(let ([f (new macro-stepper-frame%
(policy policy)
(macro-hiding? hiding?))])
(define (make-macro-stepper)
(let ([f (new macro-stepper-frame%)])
(send f show #t)
(send f get-widget))]
[(policy)
(make-macro-stepper policy #t)]
[()
(make-macro-stepper (new-hiding-policy) #f)]))
(send f get-widget)))
(define (go stx)
(let ([stepper (make-macro-stepper)])
@ -499,8 +586,37 @@
(send w add-deriv deriv)
(send f show #t)
w))
))
;; Extensions
(define keymap-extension@
(unit/sig sb:keymap^
(import (pre : sb:keymap^))
(define syntax-keymap%
(class pre:syntax-keymap%
(init-field macro-stepper)
(inherit-field controller)
(inherit add-function)
(super-new)
(define/public (get-hiding-panel)
(send macro-stepper get-macro-hiding-prefs))
(add-function "hiding:show-macro"
(lambda (i e)
(send* (get-hiding-panel)
(add-show-identifier)
(refresh))))
(add-function "hiding:hide-macro"
(lambda (i e)
(send* (get-hiding-panel)
(add-hide-identifier)
(refresh))))))))
(define context-menu-extension@
(unit/sig sb:context-menu^
@ -508,55 +624,35 @@
(define context-menu%
(class pre:context-menu%
(init-field macro-stepper)
(inherit-field controller)
(inherit-field keymap)
(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)
(field [show-macro #f]
[hide-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)))))
(callback (lambda (i e)
(send keymap call-function "hiding:show-macro" i e)))))
(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)))))
(callback (lambda (i e)
(send keymap call-function "hiding:hide-macro" i e)))))
(void))
(define/private (do-show)
(send* (get-prefs-panel)
(add-show-identifier)
(refresh)))
(define/private (do-hide)
(send* (get-prefs-panel)
(add-hide-identifier)
(refresh)))
(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 hiding-panel (send keymap get-hiding-panel))
(define controller (send keymap get-controller))
(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))))
(define show-macro? (send hiding-panel get-show-macro?))
(define transparent? (and id? (show-macro? stx)))
(define opaque? (and id? (not (show-macro? stx))))
(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)))))
@ -564,31 +660,53 @@
(define browser-extension@
(unit/sig sb:widget^
(import (pre : sb:widget^)
sb:context-menu^)
sb:keymap^)
(define syntax-widget%
(class pre:syntax-widget%
(init-field macro-stepper)
(define/override (make-context-menu)
(new context-menu%
(define/override (make-keymap text)
(new syntax-keymap%
(editor text)
(widget this)
(macro-stepper macro-stepper)))
(super-new)))))
;; Linking
(define context-menu@
(compound-unit/sig
(import)
(link [SB:MENU : sb:context-menu^ (sb:widget-context-menu@)]
[V:MENU : sb:context-menu^ (context-menu-extension@ SB:MENU)])
(export (open V:MENU))))
(define keymap@
(compound-unit/sig
(import [MENU : sb:context-menu^]
[SNIP : sb:snip^])
(link [SB:KEYMAP : sb:keymap^ (sb:widget-keymap@ MENU SNIP)]
[V:KEYMAP : sb:keymap^ (keymap-extension@ SB:KEYMAP)])
(export (open V:KEYMAP))))
(define widget@
(compound-unit/sig
(import [KEYMAP : sb:keymap^]
[MENU : sb:context-menu^])
(link [SB:WIDGET : sb:widget^ (sb:widget@ KEYMAP)]
[V:WIDGET : sb:widget^ (browser-extension@ SB:WIDGET KEYMAP)])
(export (open V:WIDGET))))
(define pre-stepper@
(compound-unit/sig
(import [BASE : view-base^])
(link [PREFS : prefs^ (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^ (context-menu-extension@ SBWMENU)]
[SBWIDGET : sb:widget^ (sb:widget@ SBKEYMAP SBWMENU)]
[VWIDGET : sb:widget^ (browser-extension@ SBWIDGET VMENU)]
[VIEW : view^ (view@ PREFS BASE VWIDGET)])
[MENU : sb:context-menu^ (context-menu@)]
[KEYMAP : sb:keymap^ (keymap@ MENU SNIP)]
[SNIP : sb:snip^ (sb:global-snip@)]
[WIDGET : sb:widget^ (widget@ KEYMAP MENU)]
[VIEW : view^ (view@ PREFS BASE WIDGET)])
(export (open VIEW))))
)

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

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

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

@ -20,9 +20,26 @@
pref:height
pref:props-percentage
pref:macro-hiding?
pref:show-syntax-properties?
pref:show-hiding-panel?
pref:hide-primitives?
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:PropertiesPanelPercentage 1/3 number?)
(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:HidePrimitives? #t boolean?)
(preferences:set-default 'MacroStepper:HideLibs? #t boolean?)
(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: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-syntax-properties? MacroStepper:ShowSyntaxProperties?)
(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)
(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?)
))
)

128
collects/macro-debugger/view/util.ss
View File

@ -1,11 +1,135 @@
(module util mzscheme
(require (lib "class.ss"))
(provide override/return-false)
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(provide define/listen
field/notify
override/return-false
notify-box%
notify-box/pref
menu-option/notify-box
menu-group/notify-box
check-box/notify-box)
(define notification-lock (make-parameter #f))
(define-for-syntax (join . args)
(define (->string x)
(cond [(string? x) x]
[(symbol? x) (symbol->string)]
[(identifier? x) (symbol->string (syntax-e x))]
[else (error '->string)]))
(string->symbol (apply string-append (map ->string args))))
(define-syntax override/return-false
(syntax-rules ()
[(override/return-false m ...)
(begin (define/override (m) #f) ...)]))
(define-syntax (field/notify stx)
(syntax-case stx ()
[(field/notify name value)
(with-syntax ([get-name
(datum->syntax-object #'name (join "get-" #'name))]
[set-name
(datum->syntax-object #'name (join "set-" #'name))]
[listen-name
(datum->syntax-object #'name (join "listen-" #'name))])
#'(begin (field [name value])
(define/public (get-name)
(send name get))
(define/public (set-name new-value)
(send name set new-value))
(define/public (listen-name listener)
(send name listen listener))))]))
(define-syntax (define/listen stx)
(syntax-case stx ()
[(define/listen name value)
(unless (identifier? #'name)
(raise-syntax-error 'define/listen "expected identifier" #'name))
(with-syntax ([get-name
(datum->syntax-object #'name (join "get-" #'name))]
[set-name
(datum->syntax-object #'name (join "set-" #'name))]
[listen-name
(datum->syntax-object #'name (join "listen-" #'name))])
#'(begin
(define name value)
(define listeners null)
(define/public (get-name) name)
(define/public (set-name new-value)
(set! name new-value)
(for-each (lambda (listener) (listener new-value)) listeners))
(define/public (listen-name listener)
(set! listeners (cons listener listeners)))))]))
(define notify-box%
(class object%
(init value)
(define v value)
(define listeners null)
;; get : -> value
;; Fetch current value
(define/public (get)
v)
;; set : value -> void
;; Update value and notify listeners
(define/public (set nv)
(when (notification-lock)
(error 'notify-box%::set "nested mutation"))
(set! v nv)
(parameterize ((notification-lock #t))
(for-each (lambda (p) (p nv)) listeners)))
;; listen : (value -> void) -> void
;; Add a listener
(define/public (listen p)
(set! listeners (cons p listeners)))
(super-new)))
(define (notify-box/pref pref)
(define nb (new notify-box% (value (pref))))
(send nb listen pref)
nb)
(define (menu-option/notify-box parent label nb)
(define menu-item
(new checkable-menu-item%
(label label)
(parent parent)
(checked (send nb get))
(callback
(lambda _ (send nb set (not (send nb get)))))))
(send nb listen (lambda (value) (send menu-item check value)))
menu-item)
(define (check-box/notify-box parent label nb)
(define checkbox
(new check-box%
(label label)
(parent parent)
(value (send nb get))
(callback
(lambda (c e) (send nb set (send c get-value))))))
(send nb listen (lambda (value) (send checkbox set-value value)))
checkbox)
(define (menu-group/notify-box parent labels nb)
(map (lambda (option)
(define label (if (pair? option) (car option) option))
(define menu-item
(new checkable-menu-item%
(label label)
(parent parent)
(checked (eq? (send nb get) option))
(callback
(lambda _ (send nb set option)))))
(send nb listen
(lambda (value) (send menu-item check (eq? value option))))
menu-item)
labels))
)

5
collects/macro-debugger/view/warning.ss
View File

@ -1,7 +1,8 @@
(module warning mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred"))
(lib "mred.ss" "mred")
(lib "framework.ss" "framework"))
(provide warnings-frame%)
;; warnings-frame%
@ -9,7 +10,7 @@
(class frame%
(super-new (label "Macro stepper warnings") (width 400) (height 300))
(define text (new text% (auto-wrap #t)))
(define text (new text:hide-caret/selection% (auto-wrap #t)))
(define ec (new editor-canvas% (parent this) (editor text)))
(send text lock #t)