diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index d9d0ff5c0c..6cc9ed9880 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -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 diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index f314fa1439..8f35028b18 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -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))) ) diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss index 68e81fa9fc..5529cc99ae 100644 --- a/collects/macro-debugger/model/hiding-policies.ss +++ b/collects/macro-debugger/model/hiding-policies.ss @@ -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])))) ) \ No newline at end of file diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index f4ff65d2dd..aa05de6d75 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -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) diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss index c66ca4358b..3d12d620a7 100644 --- a/collects/macro-debugger/model/trace.ss +++ b/collects/macro-debugger/model/trace.ss @@ -13,6 +13,7 @@ trace trace/result trace+reductions + current-expand-observe (all-from "reductions.ss")) (define current-expand-observe diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index 0d57dc6ec9..88d8a73e6e 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -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]) diff --git a/collects/macro-debugger/view/browse-deriv.ss b/collects/macro-debugger/view/browse-deriv.ss index 63a6e4c369..85a1582851 100644 --- a/collects/macro-debugger/view/browse-deriv.ss +++ b/collects/macro-debugger/view/browse-deriv.ss @@ -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) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index e5b3ddf5f0..3d911b9d4b 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -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