From 97d27f5e08c358ab8b905d8bf959a124f476f643 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 14 Nov 2006 07:50:21 +0000 Subject: [PATCH] Updates to macro stepper: Handle errors in BindSyntax Fixed lift-deriv hiding typo Removed same-marks from partitions When stepper autodisables hiding, update panel Refactored stepper update function Fixed internal error handling svn: r4851 --- collects/macro-debugger/model/deriv-parser.ss | 3 +- collects/macro-debugger/model/hide.ss | 24 ++++--- collects/macro-debugger/model/reductions.ss | 5 +- .../syntax-browser/partition.ss | 1 - collects/macro-debugger/view/gui.ss | 68 +++++++++---------- collects/macro-debugger/view/hiding-panel.ss | 1 + 6 files changed, 57 insertions(+), 45 deletions(-) diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index 15efd885b6..4cf815a949 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -466,11 +466,12 @@ ;; BindSyntaxes Answer = Derivation (BindSyntaxes - [(phase-up (? EE/LetLifts) Eval) $2]) + [(phase-up (? EE/LetLifts) ! Eval) $2]) ;; NextBindSyntaxess Answer = (list-of Derivation) (NextBindSyntaxess (#:skipped null) + (#:no-wrap) [() null] [(next (? BindSyntaxes 'first) (? NextBindSyntaxess 'rest)) (cons $2 $3)]) diff --git a/collects/macro-debugger/model/hide.ss b/collects/macro-debugger/model/hide.ss index 64469f5b98..02454c89ee 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -491,7 +491,7 @@ [(and (struct error-wrap (exn tag inner)) ew) (values ew (deriv-e2 inner))] [deriv - (values (rewrap d deriv) (deriv-e2 deriv))])))])) + (values (rewrap d deriv) (lift/deriv-e2 deriv))])))])) ;; seek : Derivation -> Derivation ;; Expects macro-policy, subterms-table to be set up already @@ -505,7 +505,9 @@ ;; create-synth-deriv : syntax (list-of Subterm) -> Derivation (define (create-synth-deriv e1 subterm-derivs) - (define (error? x) (and (s:subterm? x) (not (s:subterm-path x)))) + (define (error? x) + (and (s:subterm? 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)]) @@ -514,9 +516,7 @@ (let ([e2 (substitute-subterms e1 subterms)]) (let ([d (make-p:synth e1 e2 null subterms)]) (if (pair? errors) - (make-error-wrap (error-wrap-exn (car errors)) - (error-wrap-tag (car errors)) - d) + (rewrap (car errors) d) d))))) ;; subterm-derivations : Derivation -> (list-of Subterm) @@ -638,6 +638,11 @@ [(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)) + (>>Seek (for-deriv first) + (for-deriv next))] + ;; Errors ; [(struct error-wrap (exn tag (? deriv? inner))) @@ -763,9 +768,11 @@ (let* ([subterm0 (car subterm-derivs)] [path0 (s:subterm-path subterm0)] [deriv0 (s:subterm-deriv subterm0)]) - (substitute-subterms - (if path0 (path-replace stx path0 (deriv-e2 deriv0)) stx) - (cdr subterm-derivs)))] + (let ([e2 (lift/deriv-e2 deriv0)]) + (and e2 + (substitute-subterms + (if path0 (path-replace stx path0 (deriv-e2 deriv0)) stx) + (cdr subterm-derivs)))))] [(s:rename? (car subterm-derivs)) (let ([subterm0 (car subterm-derivs)]) (substitute-subterms @@ -1182,6 +1189,7 @@ (make-lift-deriv head-e1 begin-stx2 deriv + begin-stx1 (make-p:begin begin-stx1 begin-stx2 null (make-lderiv (append inners-es1 (list head-e2)) (append inners-es2 (list head-e2)) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 70c19a96e6..69e51a3744 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -6,6 +6,7 @@ "context.ss" "deriv.ss" "reductions-engine.ss") + (provide reductions) ;; Setup for reduction-engines @@ -266,7 +267,9 @@ ;; Skipped - [#f null])) + [#f null] + + #;[else (error 'reductions "unmatched case: ~s" d)])) ;; reductions-transformation : Transformation -> ReductionSequence (define (reductions-transformation tx) diff --git a/collects/macro-debugger/syntax-browser/partition.ss b/collects/macro-debugger/syntax-browser/partition.ss index 2704181519..8a25624779 100644 --- a/collects/macro-debugger/syntax-browser/partition.ss +++ b/collects/macro-debugger/syntax-browser/partition.ss @@ -150,7 +150,6 @@ (make-parameter `(("" . #f) ("bound-identifier=?" . ,bound-identifier=?) - ("same marks" . ,id:same-marks?) ("module-identifier=?" . ,module-identifier=?) ("module-or-top-identifier=?" . ,module-or-top-identifier=?) ("symbolic-identifier=?" . ,symbolic-identifier=?) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index 0b3fb7f42a..7d9063ebf1 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -179,10 +179,10 @@ (pair? (cdr (append derivs-prefix derivs)))) (send super-navigator add-child updown-navigator) (send updown-navigator show #t)) - (when (null? (cdr derivs)) - ;; There is nothing currently displayed - (refresh)) - (update)) + (if (null? (cdr derivs)) + ;; There is nothing currently displayed + (refresh) + (update))) (define/public (get-controller) sbc) (define/public (get-view) sbview) @@ -321,30 +321,21 @@ (let ([result (lift/deriv-e2 synth-deriv)]) (when result (send sbview add-text "Expansion finished\n") - (send sbview add-syntax (lift/deriv-e2 synth-deriv))) + (send sbview add-syntax result)) (unless result (send sbview add-text "Error\n")))) (when (step? step) (when (pair? (step-lctx step)) (for-each (lambda (bc) (send sbview add-text "While executing macro transformer in:\n") - (send sbview add-syntax (cdr bc) (car bc) "MistyRose")) + (insert-syntax/redex (cdr bc) (car bc))) (step-lctx step)) (send sbview add-text "\n")) - (send sbview add-syntax - (step-e1 step) - (foci (step-redex step)) - "MistyRose") + (insert-syntax/redex (step-e1 step) (foci (step-redex step))) (insert-step-separator (step-note step)) - (send sbview add-syntax - (step-e2 step) - (foci (step-contractum step)) - "LightCyan")) + (insert-syntax/contractum (step-e2 step) (foci (step-contractum step)))) (when (misstep? step) - (send sbview add-syntax - (misstep-e1 step) - (foci (misstep-redex step)) - "MistyRose") + (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") @@ -363,7 +354,16 @@ (send text last-position) 'start) (enable/disable-buttons)) + + ;; insert-syntax/redex : syntax syntaxes -> void + (define/private (insert-syntax/redex stx foci) + (send sbview add-syntax stx foci "MistyRose")) + ; insert-syntax/contractum : syntax syntaxes -> void + (define/private (insert-syntax/contractum stx foci) + (send sbview add-syntax stx foci "LightCyan")) + + ;; enable/disable-buttons : -> void (define/private (enable/disable-buttons) (send nav:start enable (and steps (cursor:can-move-previous? steps))) (send nav:previous enable (and steps (cursor:can-move-previous? steps))) @@ -401,17 +401,10 @@ ;; 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 (reduce d))]) - (set! synth-deriv d) - (set! steps s))))) + (let ([d (synthesize deriv)]) + (let ([s (cursor:new (reduce d))]) + (set! synth-deriv d) + (set! steps s)))) (update)) ;; synthesize : Derivation -> Derivation @@ -440,13 +433,20 @@ "Trying again with macro hiding disabled.")) (send macro-hiding-prefs enable-hiding #f) (synthesize deriv)) - + ;; reduce : Derivation -> ReductionSequence (define/private (reduce d) - (if (show-rename-steps?) - (reductions d) - (filter (lambda (x) (not (rename-step? x))) - (reductions d)))) + (with-handlers ([(lambda (e) (catch-errors?)) + (lambda (e) + (message-box + "Error" + "Internal error in macro stepper (reductions)") + (set! synth-deriv #f) + (set! steps #f))]) + (if (show-rename-steps?) + (reductions d) + (filter (lambda (x) (not (rename-step? x))) + (reductions d))))) (define/private (foci x) (if (list? x) x (list x))) diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index b8c25c7473..1d22e752ee 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/collects/macro-debugger/view/hiding-panel.ss @@ -100,6 +100,7 @@ ;; 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?