From 64f062f5a5292333b79669b4e2dfcc4928e98b0e Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 8 Mar 2007 03:20:15 +0000 Subject: [PATCH] Macro stepper: improved interaction of hiding and lifting (outside of modules, mostly) only mzscheme's top-interaction is stripped off automatically now svn: r5754 --- collects/macro-debugger/model/deriv-parser.ss | 2 +- collects/macro-debugger/model/deriv-util.ss | 4 +- collects/macro-debugger/model/hide.ss | 272 ++++++++++-------- collects/macro-debugger/model/reductions.ss | 37 ++- collects/macro-debugger/tool.ss | 44 ++- 5 files changed, 222 insertions(+), 137 deletions(-) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 9ea259c171..826eaccd6d 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -157,7 +157,7 @@ [(enter-local local-pre (? EE) local-post exit-local) (make-local-expansion $1 $5 $2 $4 $3)] [(lift) - (make-local-lift (car $1) (cdr $1))] + (make-local-lift (cdr $1) (car $1))] [(lift-statement) (make-local-lift-end $1)] [(phase-up (? EE/LetLifts)) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index 7b20fcea14..d8bfbc2c89 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -173,7 +173,7 @@ [(AnyQ mrule (_ _ tx next)) (join (loop tx) (loop next))] [(AnyQ lift-deriv (_ _ first lift second)) - (join (loop first) (loop lift) (loop second))] + (join (loop first) (loop second))] [(AnyQ transformation (_ _ _ _ _ locals _)) (loops locals)] [(struct local-expansion (_ _ _ _ deriv)) @@ -259,8 +259,8 @@ (pred e1)] [_ #f]) (match-lambda + ;; FIXME: Why? [(AnyQ p:module (_ _ _ _ _)) #t] - [(AnyQ lift-deriv (_ _ _ _ _)) #t] [_ #f]) d)) diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index 80d9e4ec4b..2dc1c46e27 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -29,6 +29,55 @@ (define (warn tag message) ((current-hiding-warning-handler) tag message)) + ;; current-unvisited-lifts : (paramter-of Derivation) + ;; The derivs for the lifts yet to be seen in the processing + ;; of the first part of the current lift-deriv. + (define current-unvisited-lifts (make-parameter null)) + + ;; current-unhidden-lifts : (parameter-of Derivation) + ;; The derivs for those lifts that occur within unhidden macros. + ;; Derivs are moved from the current-unvisited-lifts to this list. + (define current-unhidden-lifts (make-parameter null)) + + ;; add-unhidden-lift : Derivation -> void + (define (add-unhidden-lift d) + (current-unhidden-lifts (cons d (current-unhidden-lifts)))) + + ;; extract/remove-unvisted-lift : identifier -> Derivation + (define (extract/remove-unvisited-lift id) + (define (get-defined-id d) + (match d + [(AnyQ deriv (e1 e2)) + (with-syntax ([(?define-values (?id) ?expr) e1]) + #'?id)])) + ;; The Wrong Way + (let ([unvisited (current-unvisited-lifts)]) + (unless (pair? unvisited) + (error 'hide:extract/remove-unvisited-lift + "out of lifts!")) + (let ([lift (car unvisited)]) + (current-unvisited-lifts (cdr unvisited)) + lift)) + ;; The Right Way + ;; FIXME: Doesn't work inside of modules. Why not? + #; + (let loop ([lifts (current-unvisited-lifts)] + [prefix null]) + (cond [(null? lifts) + #;(fprintf (current-error-port) + "hide:extract/remove-unvisited-lift: couldn't find lift for ~s~n" + id) + (raise (make-localactions))] + [(bound-identifier=? id (get-defined-id (car lifts))) + (let ([lift (car lifts)]) + (current-unvisited-lifts + (let loop ([prefix prefix] [lifts (cdr lifts)]) + (if (null? prefix) + lifts + (loop (cdr prefix) (cons (car prefix) lifts))))) + lift)] + [else + (loop (cdr lifts) (cons (car lifts) prefix))]))) ; ; @@ -67,6 +116,7 @@ ;; Benefits of 1: ;; Preserves order of expansion, even if macro reorders (so effects happen right) ;; May be easier to deal with marking/renaming + ;; Easier to deal with lifting (lifts get seen in correct order) ;; Gives finer control over handling of blocks (joining pass1 and pass2 expansions) ;; Drawbacks of 1: ;; Need to process results more to find final syntax & nonlinear subterms @@ -274,7 +324,7 @@ [(AnyQ mrule (e1 e2 tx next)) (let ([show-k (lambda () - (recv #;[(tx) (for-transformation tx)] + (recv [(tx) (for-transformation tx)] [(next e2) (for-deriv next)] (values (rewrap d (make-mrule e1 e2 tx next)) e2)))]) @@ -296,113 +346,88 @@ ;; Lift ;; Shaky invariant: - ;; Only normal lifts occur in first... no end-module-decl lifts. + ;; Only lift-exprs occur in first... no lift-end-module-decls ;; They occur in reverse order. + ;; PROBLEM: Hiding process may disturb order lifts are seen. [(IntQ lift-deriv (e1 e2 first lifted-stx second) tag) - ;; Option 1: Give up on first, hide on second - #; - (begin (warn 'lifts "lifts are unimplemented") - (let-values ([(second e2) (for-deriv second)]) - (values (rewrap d (make-lift-deriv e1 e2 first lifted-stx second)) - e2))) ;; Option 2: Hide first, show *all* lifted expressions, ;; and hide second (lifted defs only; replace last expr with first-e2) (let* ([second-derivs (match second [(IntQ p:begin (_ _ _ (IntQ lderiv (_ _ inners)))) (reverse inners)])] - [lift-stxs - (with-syntax ([(?begin form ...) lifted-stx]) - (cdr (reverse (syntax->list #'(form ...)))))] - [lift-derivs + [lift-derivs/0 ;; If interrupted, then main-expr deriv will not be in list + ;; second-derivs are already reversed (if tag second-derivs (cdr second-derivs))] [begin-stx (stx-car lifted-stx)]) - (let-values ([(first-d first-e2) (for-deriv first)]) - (define lifted-stx* - (datum->syntax-object lifted-stx - `(,begin-stx ,@(reverse lift-stxs) ,first-e2) - lifted-stx - lifted-stx)) - (define main-deriv (make-p:stop first-e2 first-e2 null)) - (define inner-derivs - (reverse - ;; If interrupted, then main-expr deriv will not be in list - (if tag lift-derivs (cons main-deriv lift-derivs)))) - (define lderiv* - (rewrap second - (make-lderiv (map lift/deriv-e1 inner-derivs) - (and (not tag) - (map lift/deriv-e2 inner-derivs)) - inner-derivs))) - (define-values (lderiv** es2**) (for-lderiv lderiv*)) - (define e2* - (and es2** - (datum->syntax-object e2 `(,begin-stx ,@es2**) e2 e2))) - (define second* - (rewrap second (make-p:begin lifted-stx* e2* null lderiv**))) - (values (rewrap d (make-lift-deriv e1 e2* first-d lifted-stx* second*)) - e2*))) - #; - ;; Option3: Hide first, retaining transparent lifts and inlining opaque lifts - ;; Hide second, only on retained lifts - ;; Problem: lift order may be damaged by other hiding processes - (let* ([second-derivs - (match second - [(IntQ p:begin (_ _ _ (IntQ lderiv (_ _ inners)))) - (reverse inners)])] - [lift-stxs - (with-syntax ([(?begin form ...) lifted-stx]) - (cdr (reverse (syntax->list #'(form ...)))))] - [lift-derivs (cdr second-derivs)] - [begin-stx (stx-car lifted-stx)]) - (let-values ([(first-d first-e2 retained-lifts) - (parameterize ((lifts-available (map cons lift-stxs lift-derivs)) - (lifts-retained null)) - (let-values ([(first-d first-e2) (for-deriv first)]) - (unless (null? (lifts-available)) - (printf "hide: lift-deriv: unused lift derivs!~n")) - (values first-d first-e2 (lifts-retained))))]) - ;; If all the lifts were hidden, then remove lift-deriv node - ;; Otherwise, recreate with the retained lifts - (if (null? retained-lifts) - (values first-d first-e2) - (let () - (define retained-stxs (map car retained-lifts)) - (define retained-derivs (map cdr retained-lifts)) - (define lifted-stx* - (datum->syntax-object lifted-stx - `(,begin-stx ,@retained-stxs ,first-e2) - lifted-stx - lifted-stx)) - (define main-deriv (make-p:stop first-e2 first-e2 null)) - (define inner-derivs - (if tag retained-derivs (append retained-derivs main-deriv))) - (define lderiv* - (rewrap second - (make-lderiv (map lift/deriv-e1 inner-derivs) - (map lift/deriv-e2 inner-derivs) - inner-derivs))) - (define-values (ld*-d ld*-es2) (for-lderiv lderiv*)) - (define e2* - (and ld*-es2 - (datum->syntax-object e2 `(,begin-stx ,@ld*-es2) e2 e2))) - (define second* - (rewrap second (make-p:begin lifted-stx* e2* null ld*-d))) - (values (make-lift-deriv e1 e2* first-d lifted-stx* second*) - e2*)))))] - + (define-values (first-d first-e2 lift-derivs) + ;; Note: lift-derivs are back in reverse order from current-unvisited-lifts + (parameterize ((current-unvisited-lifts lift-derivs/0) + (current-unhidden-lifts null)) + #;(printf "setting current-unvisited-lifts: ~s~n" (length lift-derivs/0)) + (let-values ([(d e2) (for-deriv first)]) + (when (pair? (current-unvisited-lifts)) + (error 'hide:lift-deriv "missed ~s lift-expressions: ~s" + (length (current-unvisited-lifts)) + (current-unvisited-lifts))) + (values d e2 (current-unhidden-lifts))))) + (define lift-stxs (map lift/deriv-e1 lift-derivs)) + (define main-deriv (make-p:stop first-e2 first-e2 null)) + ;; If no lifted syntaxes remain, then simplify: + (if (null? lift-derivs) + (values first-d first-e2) + (let () + (define lifted-stx* + (datum->syntax-object lifted-stx + `(,begin-stx ,@lift-stxs ,first-e2) + lifted-stx + lifted-stx)) + (define inner-derivs + ;; If interrupted, then main-expr deriv will not be in list + (if tag lift-derivs (append lift-derivs (list main-deriv)))) + (define lderiv* + (rewrap second + (make-lderiv (map lift/deriv-e1 inner-derivs) + (and (not tag) + (map lift/deriv-e2 inner-derivs)) + inner-derivs))) + (define-values (lderiv** es2**) (for-lderiv lderiv*)) + (define e2* + (and es2** + (datum->syntax-object e2 `(,begin-stx ,@es2**) e2 e2))) + (define second* + (rewrap second (make-p:begin lifted-stx* e2* null lderiv**))) + (values (rewrap d (make-lift-deriv e1 e2* first-d lifted-stx* second*)) + e2*))))] + ;; Errors [#f (values #f #f)])) ;; for-transformation : Transformation -> Transformation??? - #; (define (for-transformation tx) (match tx - [(IntQ transformation (e1 e2 rs me1 me2 locals _seq)) - (error 'unimplemented "hide: for-transformation")])) + [(AnyQ transformation (e1 e2 rs me1 me2 locals _seq)) + (let ([locals (map for-local-action (or locals null))]) + (rewrap tx (make-transformation e1 e2 rs me1 me2 locals _seq)))])) + ;; for-local-action : LocalAction -> LocalAction + (define (for-local-action la) + (match la + [(struct local-expansion (e1 e2 me1 me2 deriv)) + (let-values ([(deriv e2) (for-deriv deriv)]) + (make-local-expansion e1 e2 me1 me2 deriv))] + [(struct local-lift (expr id)) + (add-unhidden-lift (extract/remove-unvisited-lift id)) + la] + [(struct local-lift-end (decl)) + ;;(printf "hide:for-local-action: local-lift-end unimplemented~n") + la] + [(struct local-bind (deriv)) + (let-values ([(deriv e2) (for-deriv deriv)]) + (make-local-bind deriv))])) + ;; for-rename : Rename -> (values Rename syntax) (define (for-rename rename) (values rename rename)) @@ -504,7 +529,8 @@ (define (create-synth-deriv e1 subterm-derivs) (define (error? x) (and (s:subterm? x) - (or (interrupted-wrap? (s:subterm-deriv x)) (error-wrap? (s:subterm-deriv x))))) + (or (interrupted-wrap? (s:subterm-deriv x)) + (error-wrap? (s:subterm-deriv x))))) (let ([errors (map s:subterm-deriv (filter error? subterm-derivs))] [subterms (filter (lambda (x) (not (error? x))) subterm-derivs)]) @@ -520,23 +546,30 @@ (define (subterm-derivations d) ;; for-deriv : Derivation -> (list-of Subterm) - ;; FIXME: finish (define (for-deriv d) + (let ([path (check-visible d)]) + (if path + (let-values ([(d _) (hide d)]) + (list (make-s:subterm path d))) + (for-unlucky-deriv/record-error d)))) + + ;; check-visible : Derivation -> Path/#f + (define (check-visible d) (match d [(AnyQ deriv (e1 e2)) (let ([paths (table-get (subterms-table) e1)]) - (cond [(null? paths) - (for-unlucky-deriv/record-error d)] + (cond [(null? paths) #f] [(null? (cdr paths)) - (let-values ([(d _) (hide d)]) - (list (make-s:subterm (car paths) d)))] + (car paths)] [else ;; More than one path to the same(eq?) syntax object ;; Not good. ;; FIXME: Better to delay check to here, or check whole table first? ;; FIXME - (raise (make-nonlinearity "nonlinearity in original term" paths))]))] - [#f null])) + (raise + (make-nonlinearity + "nonlinearity in original term" paths))]))] + [#f #f])) ;; for-unluck-deriv/record-error -> (list-of Subterm) ;; Guarantee: (deriv-e1 deriv) is not in subterms table @@ -643,27 +676,25 @@ [(AnyQ mrule (e1 e2 (and ew (struct error-wrap (_ _ _))) next)) (list (make-s:subterm #f ew))] - + [(AnyQ lift-deriv (e1 e2 first lifted-stx next)) + #;(printf "encountered lift-deriv in seek mode!~n") + (raise (make-localactions)) (>>Seek (for-deriv first) (for-deriv next))] - + ;; Errors -; [(struct error-wrap (exn tag (? deriv? inner))) -; (append (for-deriv inner) -; (list (make-s:subterm #f (make-error-wrap exn tag #f))))] [#f null] )) ;; for-transformation : Transformation -> (values (list-of Subterm) Table) (define (for-transformation tx) (match tx - [(struct transformation (e1 e2 rs me1 me2 locals _seq)) + [(IntQ transformation (e1 e2 rs me1 me2 locals _seq)) ;; FIXME: We'll need to use e1/e2/me1/me2 to synth locals, perhaps ;; FIXME: and we'll also need to account for *that* marking, too... - (unless (null? locals) - (raise (make-localactions))) + (for-each for-local-action (or locals null)) ;(let* ([table-at-end #f] ; [subterms ; (>>Seek [#:rename (do-rename e1 me1)] @@ -674,25 +705,30 @@ ; (values subterms table-at-end)) (let-values ([(rename-subterms1 table1) (do-rename e1 me1)]) (parameterize ((subterms-table table1)) - (let (#;[sss (map for-local locals)]) + (let () ;; [sss (map for-local locals)] (let-values ([(rename-subterms2 table2) (do-rename me2 e2)]) ;; FIXME: Including these seems to produce evil results ;; ie, parts of the hidden macro use appear as marked ;; when they shouldn't - (values (append #;rename-subterms1 - #;(apply append sss) - #;rename-subterms2) - table2)))))])) + (values null ;; (append rename-subterms1 (apply append sss) rename-subterms2) + table2)))))] + [(ErrW transformation (e1 e2 rs me1 me2 locals _seq)) + (for-each for-local-action (or locals null)) + (values null #f)])) - ;; for-local : LocalAction -> (list-of Subterm) - #; - (define (for-local local) + ;; for-local-action : LocalAction -> (list-of Subterm) + (define (for-local-action local) (match local - [(IntQ local-expansion (e1 e2 me1 me2 deriv)) - (error 'unimplemented "seek: for-local")] - ;; Also need to handle local-bind - ;; ... - [else null])) + [(struct local-expansion (e1 e2 me1 me2 deriv)) + (raise (make-localactions))] + [(struct local-lift (expr id)) + ;; FIXME: seek in the lifted deriv, transplant subterm expansions *here* + (extract/remove-unvisited-lift id)] + [(struct local-lift-end (decl)) + ;; FIXME!!! + (void)] + [(struct local-bind (deriv)) + (raise (make-localactions))])) ;; for-lderiv : ListDerivation -> (list-of Subterm) (define (for-lderiv ld) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index aa32422dea..11c9c76d90 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -37,13 +37,13 @@ (define (reductions d) (parameterize ((current-definites null) (current-frontier null)) - (add-frontier (list (lift/deriv-e1 d))) + (when d (add-frontier (list (lift/deriv-e1 d)))) (reductions* d))) (define (reductions+definites d) (parameterize ((current-definites null) (current-frontier null)) - (add-frontier (list (lift/deriv-e1 d))) + (when d (add-frontier (list (lift/deriv-e1 d)))) (let ([rs (reductions* d)]) (values rs (current-definites))))) @@ -129,13 +129,13 @@ (R e1 [! exni] [#:pattern (?begin . LDERIV)] - [#:frontier (stx->list #'LDERIV)] + [#:frontier (stx->list* #'LDERIV)] [List LDERIV lderiv])] [(AnyQ p:begin0 (e1 e2 rs first lderiv) exni) (R e1 [! exni] [#:pattern (?begin0 FIRST . LDERIV)] - [#:frontier (cons #'FIRST (stx->list #'LDERIV))] + [#:frontier (cons #'FIRST (stx->list* #'LDERIV))] [Expr FIRST first] [List LDERIV lderiv])] [(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni) @@ -143,7 +143,7 @@ (R tagged-stx [! exni] [#:pattern (?#%app . LDERIV)] - [#:frontier (stx->list #'LDERIV)] + [#:frontier (stx->list* #'LDERIV)] [List LDERIV lderiv])]) (if (eq? tagged-stx e1) tail @@ -153,7 +153,7 @@ [! exni] [#:bind (?formals* . ?body*) renames] [#:pattern (?lambda ?formals . ?body)] - [#:frontier (stx->list #'?body)] + [#:frontier (stx->list* #'?body)] [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) #'?formals #'?formals* 'rename-lambda] @@ -173,7 +173,7 @@ [Block (?body ...) (map cdr renames+bodies)]) (with-syntax ([(?case-lambda [?formals . ?body] ...) e1] [((?formals* . ?body*) ...) (map car renames+bodies)]) - (add-frontier (apply append (map stx->list (syntax->list #'(?body ...))))) + (add-frontier (apply append (map stx->list* (syntax->list #'(?body ...))))) (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) (rename-frontier #'(?formals ...) #'(?formals* ...)) (cons (walk/foci (syntax->list #'(?formals ...)) @@ -187,7 +187,7 @@ (R e1 [! exni] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] - [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))] + [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:rename (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) @@ -200,7 +200,7 @@ (R e1 [! exni] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] - [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))] + [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:rename (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) @@ -216,7 +216,7 @@ [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] [#:frontier (append (syntax->list #'(?srhs ...)) (syntax->list #'(?vrhs ...)) - (stx->list #'?body))] + (stx->list* #'?body))] [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames] [#:rename (syntax/skeleton e1 @@ -338,7 +338,7 @@ (blaze-frontier e1) ;;(printf "frontier for mrule: ~s~n" (current-frontier)) (append (reductions-transformation transformation) - (begin (add-frontier (list (lift/deriv-e1 next))) + (begin (when next (add-frontier (list (lift/deriv-e1 next)))) (reductions* next)))] ;; Lifts @@ -427,7 +427,7 @@ [(AnyQ lderiv (pass2-es1 _ _)) (list (walk stxs1 pass2-es1 'block->letrec))]) null) - (begin (add-frontier (stx->list (lift/lderiv-es1 pass2))) + (begin (add-frontier (stx->list* (lift/lderiv-es1 pass2))) (list-reductions pass2))))] [#f null])) @@ -590,5 +590,16 @@ (set! final-stxs (reverse prefix)) null]))]) (values reductions final-stxs))) - + + (define (stx->list* stx) + (cond [(pair? stx) + (cons (car stx) (stx->list* (cdr stx)))] + [(null? stx) + null] + [(syntax? stx) + (let ([x (syntax-e stx)]) + (if (pair? x) + (cons (car x) (stx->list* (cdr x))) + (list stx)))] + [else null])) ) diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index a169eb01e9..2c24243eab 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -3,12 +3,14 @@ (require (lib "class.ss") (lib "list.ss") (lib "unit.ss") + (lib "plt-match.ss") (lib "mred.ss" "mred") (lib "framework.ss" "framework") (lib "tool.ss" "drscheme") (lib "bitmap-label.ss" "mrlib") (lib "string-constant.ss" "string-constants") "model/trace.ss" + "model/deriv-c.ss" "model/deriv-util.ss" (prefix view: "view/interfaces.ss") (prefix view: "view/gui.ss") @@ -180,10 +182,46 @@ (set! debugging? saved-debugging?) (when eo (current-expand-observe eo))))))))) + ;; show-deriv/orig-parts + ;; Strip off mzscheme's #%top-interaction + ;; Careful: the #%top-interaction node may be inside of a lift-deriv (define/private (show-deriv/orig-parts deriv stepper-promise) - (for-each (lambda (d) (show-deriv d stepper-promise)) - (find-derivs/syntax (lambda (stx) (and (syntax? stx) (syntax-source stx))) - deriv))) + ;; adjust-deriv/lift : Derivation -> (list-of Derivation) + (define (adjust-deriv/lift deriv) + (match deriv + [(IntQ lift-deriv (e1 e2 first lifted-stx second)) + (let ([first (adjust-deriv/top first)]) + (and first + (let ([e1 (lift/deriv-e1 first)]) + (rewrap deriv + (make-lift-deriv e1 e2 first lifted-stx second)))))] + [else (adjust-deriv/top deriv)])) + ;; adjust-deriv/top : Derivation -> Derivation + (define (adjust-deriv/top deriv) + (if (syntax-source (lift/deriv-e1 deriv)) + deriv + ;; It's not original... + ;; Strip out mzscheme's top-interactions + ;; Keep anything that is a non-mzscheme top-interaction + ;; Drop everything else (not original program) + (match deriv + [(IntQ mrule (e1 e2 tx next)) + (match tx + [(AnyQ transformation (e1 e2 rs me1 me2 locals seq)) + (cond [(ormap (lambda (x) + (module-identifier=? x #'#%top-interaction)) + rs) + ;; Just mzscheme's top-interaction; strip it out + (adjust-deriv/top next)] + [(equal? (map syntax-e rs) '(#%top-interaction)) + ;; A *different* top interaction; keep it + deriv] + [else + ;; Not original and not tagged with top-interaction + #f])])] + [else #f]))) + (let ([deriv* (adjust-deriv/lift deriv)]) + (when deriv* (show-deriv deriv* stepper-promise)))) (define/private (show-deriv deriv stepper-promise) (parameterize ([current-eventspace drscheme-eventspace])