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

Merged 4023:4047 from /branches/ryanc/md1

Browse Source 
- Fixed macro hiding for letrec-syntaxes+values
  - Fixed module tracing (prevented required modules from being traced)
  - Better auto-scroll in gui
  - Fixed reductions bug in letrec-syntaxes+values
  - Added hide library syntax option

svn: r4048
This commit is contained in:
Ryan Culpepper 2006-08-13 03:28:43 +00:00
parent da35684a84
commit adb230f3c3
8 changed files with 154 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -347,8 +347,6 @@
[(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
(make-p:letrec-values e1 e2 rs $3 $4 $6)])
;; Might have to deal with let*-values
(PrimLetrecSyntaxes+Values
(#:args e1 e2 rs)
[(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes

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

@ -191,11 +191,11 @@
(letrec-syntaxes+values ([SVARS SRHS] ...) ([VVARS VRHS] ...) . BODY)
([for-derivs (SRHS ...) srhss]
[for-derivs (VRHS ...) vrhss]
[for-bderiv BODY body])
#:with (lambda (new-e2)
(syntax-case #'BODY ()
[(e) #'e]
[(e ...) #'(begin e ...)])))]
[for-bderiv BODY body]))]
; #:with (lambda (new-e2)
; (syntax-case #'BODY ()
; [(e) #'e]
; [(e ...) #'(begin e ...)])))]
[(AnyQ p:#%datum (e1 e2 rs tagged-stx))
(cond [(or (eq? tagged-stx e1) (show-macro? #'#%datum))
@ -448,7 +448,7 @@
(let ([new-table (table-restrict/lsv1 e1 srenames)])
(parameterize ((subterms-table new-table))
(append (apply append (map for-deriv srhss))
(let ([new-table (table-restrict/lsv2 e1 srenames)])
(let ([new-table (table-restrict/lsv2 e1 vrenames)])
(parameterize ((subterms-table new-table))
(append (apply append (map for-deriv vrhss))
(for-bderiv body)))))))]
@ -1099,9 +1099,12 @@
(table-restrict/rename (cons #'?formals #'?body) rename)))
(define (table-restrict/lsv1 stx rename)
(with-syntax ([(?lsv ?sbindings ?vbindings ?body) stx])
(with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
(table-restrict/rename (cons #'?sbindings (cons #'?vbindings #'?body)) rename)))
(define (table-restrict/lsv2 stx rename)
(error 'unimplemented))
(if rename
(with-syntax ([(?lsv ?sbindings ?vbindings . ?body) stx])
(table-restrict/rename (cons #'?vbindings #'?body) rename))
(subterms-table)))
)

22
collects/macro-debugger/model/hiding-policies.ss
View File

@ -5,17 +5,23 @@
(provide (all-defined))
(define-struct hiding-policy
(opaque-modules opaque-ids opaque-kernel transparent-ids))
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids))
(define (policy-hide-module p m)
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
(define (policy-unhide-module p m)
(hash-table-remove! (hiding-policy-opaque-modules p) m))
(define (policy-hide-kernel p)
(set-hiding-policy-opaque-kernel! p #t))
(define (policy-unhide-kernel p)
(set-hiding-policy-opaque-kernel! p #f))
(define (policy-hide-libs p)
(set-hiding-policy-opaque-libs! p #t))
(define (policy-unhide-libs p)
(set-hiding-policy-opaque-libs! p #f))
(define (policy-hide-id p id)
(policy-unshow-id p id)
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
@ -32,11 +38,13 @@
(make-hiding-policy (make-hash-table)
(make-module-identifier-mapping)
#f
#f
(make-module-identifier-mapping)))
(define (new-standard-hiding-policy)
(let ([p (new-hiding-policy)])
(policy-hide-kernel p)
(policy-hide-libs p)
p))
;; ---
@ -57,6 +65,7 @@
[(struct hiding-policy (opaque-modules
opaque-identifiers
opaque-kernel
opaque-libs
transparent-identifiers))
(let ([binding (identifier-binding id)])
(if (list? binding)
@ -67,7 +76,9 @@
[in-kernel?
(and (symbol? srcmod)
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
[not-opaque-id
[in-lib-module?
(lib-module? srcmod)]
[not-opaque-id
(not (module-identifier-mapping-get opaque-identifiers id /false))]
[transparent-id
(module-identifier-mapping-get transparent-identifiers id /false)])
@ -75,7 +86,14 @@
(and (not opaque-srcmod)
(not opaque-nommod)
(not (and in-kernel? opaque-kernel))
(not (and in-lib-module? opaque-libs))
not-opaque-id))))
#f))]))
(define (lib-module? mpi)
(and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(pair? path) (memq (car path) '(lib planet))]
[(string? path) (lib-module? rel)]
[else #f]))))
)

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

@ -207,11 +207,13 @@
(syntax->list #'(?svars* ...))
"Rename bound variables"]
[Expr (?srhs ...) srhss]
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
[#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
(syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...))
"Rename bound variables"]
;; If vrenames is #f, no var bindings to rename
[#:if vrenames
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
[#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
(syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...))
"Rename bound variables"]]
[Expr (?vrhs ...) vrhss]
[Block ?body body]
=> (lambda (mid)

1
collects/macro-debugger/model/trace.ss
View File

@ -13,6 +13,7 @@
trace
trace/result
trace+reductions
current-expand-observe
(all-from "reductions.ss"))
(define current-expand-observe

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

@ -12,7 +12,7 @@
(lib "string-constant.ss" "string-constants"))
(provide tool@)
(define tool@
(unit/sig drscheme:tool-exports^
(import drscheme:tool^)
@ -95,21 +95,34 @@
(super reset-console)
(run-in-evaluation-thread
(lambda ()
(current-eval (make-eval-handler (current-eval))))))
(define/private (make-eval-handler original-eval-handler)
(if debugging?
(let ([stepper (delay (view:make-macro-stepper))])
(lambda (expr)
(if (compiled-expression?
(if (syntax? expr) (syntax-e expr) expr))
(original-eval-handler expr)
(let-values ([(e-expr deriv) (trace/result expr)])
(show-deriv deriv stepper)
(if (syntax? e-expr)
(original-eval-handler e-expr)
(raise e-expr))))))
original-eval-handler))
(let-values ([(e mnr) (make-handlers (current-eval) (current-module-name-resolver))])
(current-eval e)
(current-module-name-resolver mnr)))))
(define/private (make-handlers original-eval-handler original-module-name-resolver)
(let ([stepper (delay (view:make-macro-stepper))]
[debugging? debugging?])
(values
(lambda (expr)
(if debugging?
(let-values ([(e-expr deriv) (trace/result expr)])
(show-deriv deriv stepper)
(if (syntax? e-expr)
(original-eval-handler e-expr)
(raise e-expr)))
(original-eval-handler expr)))
(lambda args
(let ([eo (current-expand-observe)]
[saved-debugging? debugging?])
(dynamic-wind
(lambda ()
(set! debugging? #f)
(when eo (current-expand-observe void)))
(lambda ()
(apply original-module-name-resolver args))
(lambda ()
(set! debugging? saved-debugging?)
(when eo (current-expand-observe eo)))))))))
(define/private (show-deriv deriv stepper-promise)
(parameterize ([current-eventspace drscheme-eventspace])

36
collects/macro-debugger/view/browse-deriv.ss
View File

@ -1,7 +1,7 @@
(module browse-deriv mzscheme
(require (lib "class.ss")
(lib "match.ss")
(lib "plt-match.ss")
(lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
@ -28,22 +28,34 @@
(unit/sig node^
(import)
;; Node = (union Derivation MRule PRule)
;; Node = (union Derivation Transformation)
;; node-children
(define (node-children node)
(match node
[($ pderiv e1 e2 prule)
(node-children prule)]
[($ mderiv e1 e2 mrule next)
(list mrule next)]
[($ mrule e1 e2 rs me1 me2 locals)
;; FIXME
[(AnyQ mrule (e1 e2 tx next))
(list tx next)]
[(AnyQ transformation (e1 e2 rs me1 me2 locals))
null]
[($ prule e1 e2 rs)
;; FIXME
null]))
[(AnyQ p:define-syntaxes (e1 e2 rs rhs))
(list rhs)]
[(AnyQ p:define-values (e1 e2 rs rhs))
(list rhs)]
[(AnyQ p:if (e1 e2 rs full? test then else))
(if full?
(list test then else)
(list test then))]
[(AnyQ p:wcm (e1 e2 rs key value body))
(list key value body)]
[(AnyQ p:set! (e1 e2 rs id-rs rhs))
(list rhs)]
[(AnyQ p:set!-macro (e1 e2 rs deriv))
(list deriv)]
[(AnyQ p:begin (e1 e2 rs (AnyQ lderiv (es1 es2 derivs))))
derivs]
[(AnyQ p:begin0 (e1 e2 rs first (AnyQ lderiv (es1 es2 derivs))))
(cons first derivs)]))
;; node-summary-string
(define (node-summary-string node)

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

@ -233,6 +233,7 @@
;; 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)
@ -244,6 +245,7 @@
(send sbview add-text "Error\n"))))
(reverse derivs-prefix))
(send sbview add-separator))
(set! position-of-interest (send text last-position))
(when steps
(let ([step (cursor:current steps)])
(unless step
@ -282,7 +284,11 @@
(send sbview add-syntax (lift/deriv-e1 suffix-deriv)))
(cdr derivs)))
(send text end-edit-sequence)
(send text scroll-to-position 0)
(send text scroll-to-position
position-of-interest
#f
(send text last-position)
'start)
(enable/disable-buttons))
(define/private (enable/disable-buttons)
@ -309,8 +315,8 @@
(send sbview erase-all))])
(let ([ds (map car derivs-prefix)])
(let ([sds (map (lambda (d) (synthesize d)) ds)])
(set! derivs-prefix (map cons ds sds))))
(refresh)))
(set! derivs-prefix (map cons ds sds)))))
(refresh))
;; refresh : -> void
;; Resynth current derivation,
@ -318,21 +324,29 @@
;; Show first step
(define/private (refresh)
(if (pair? derivs)
(let ([deriv (car derivs)])
(with-handlers ([(lambda (e) (catch-errors?))
(lambda (e)
(message-box
"Error"
"Internal error in macro stepper (reductions)")
(send sbview erase-all))])
(let ([d (synthesize deriv)])
(set! synth-deriv d)
(set! steps (cursor:new (reductions d)))))
(navigate-to-start))
(refresh/nontrivial)
(begin (set! synth-deriv #f)
(set! steps #f)
(update))))
;; refresh/nontrivial : -> void
(define/private (refresh/nontrivial)
(let ([deriv (car derivs)])
(with-handlers ([(lambda (e) (catch-errors?))
(lambda (e)
(message-box
"Error"
"Internal error in macro stepper (reductions)")
(set! synth-deriv #f)
(set! steps (cursor:new null)))])
(let ([d (synthesize deriv)])
(let ([s (cursor:new (reductions d))])
(set! synth-deriv d)
(set! steps s)))))
#;(navigate-to-start)
(update))
;; synthesize : Derivation -> Derivation
(define/private (synthesize deriv)
(let ([show-macro? (get-show-macro?)])
(if show-macro?
@ -377,16 +391,23 @@
(define stx-name #f)
(define stx-module #f)
(define pane
(new vertical-pane%
(define super-pane
(new horizontal-pane%
(parent parent)
(stretchable-height #f)
(stretchable-height #f)))
(define left-pane
(new vertical-pane%
(parent super-pane)
(stretchable-width #f)
(alignment '(left top))))
(define right-pane
(new vertical-pane%
(parent super-pane)))
(define enable-ctl
(new check-box%
(label "Enable macro hiding?")
(parent pane)
(parent left-pane)
(value enabled?)
(callback
(lambda _
@ -395,17 +416,27 @@
(define kernel-ctl
(new check-box%
(label "Hide mzscheme primitives")
(parent pane)
(label "Hide mzscheme syntax")
(parent left-pane)
(value (hiding-policy-opaque-kernel policy))
(callback (lambda _
(if (send kernel-ctl get-value)
(policy-hide-kernel policy)
(policy-unhide-kernel policy))
(refresh)))))
(define libs-ctl
(new check-box%
(label "Hide library syntax")
(parent left-pane)
(value (hiding-policy-opaque-libs policy))
(callback (lambda _
(if (send libs-ctl get-value)
(policy-hide-libs policy)
(policy-unhide-libs policy))
(refresh)))))
(define look-pane
(new horizontal-pane% (parent pane) (stretchable-height #f)))
(new horizontal-pane% (parent right-pane) (stretchable-height #f)))
(define look-ctl
(new list-box% (parent look-pane) (label "") (choices null)))
(define delete-ctl
@ -416,12 +447,12 @@
(refresh)))))
(define add-pane
(new horizontal-pane% (parent pane) (stretchable-height #f)))
(new horizontal-pane% (parent right-pane) (stretchable-height #f)))
(define add-text
(new text-field%
(label "")
(parent add-pane)
(enabled #f)
#;(enabled #f)
(stretchable-width #t)))
(define add-editor (send add-text get-editor))
(define add-hide-module-button
@ -434,6 +465,8 @@
(new button% (parent add-pane) (label "Show macro") (enabled #f)
(callback (lambda _ (add-show-identifier) (refresh)))))
(send add-editor lock #t)
;; Methods
;; enable-hiding : boolean -> void
@ -456,6 +489,7 @@
;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx)
(set! stx lstx)
(send add-editor lock #f)
(send add-editor erase)
(unless (identifier? stx)
(send add-hide-module-button enable #f))
@ -470,10 +504,12 @@
(set! stx-name (syntax-e stx))
(set! stx-module #f)))
(update-add-text)))
(send add-editor lock #t)
(send add-show-id-button enable (identifier? lstx))
(send add-hide-id-button enable (identifier? lstx)))
(define/private (update-add-text)
(send add-editor lock #f)
(if stx-module
(send add-editor insert
(format "'~s' from module ~a"
@ -481,7 +517,8 @@
(mpi->string stx-module)))
(send add-editor insert
(format "lexically-bound ~s"
stx-name))))
stx-name)))
(send add-editor lock #t))
(define/private (add-hide-module)
(when stx-module