diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index 660ffda..bbe8fba 100644 --- a/collects/macro-debugger/model/reductions-engine.ss +++ b/collects/macro-debugger/model/reductions-engine.ss @@ -8,6 +8,8 @@ (provide context big-context current-derivation + current-definites + learn-definites with-context with-derivation with-new-local-context @@ -28,6 +30,9 @@ ;; current-derivation : parameter of Derivation (define current-derivation (make-parameter #f)) + ;; current-definites : parameter of (list-of identifier) + (define current-definites (make-parameter null)) + (define-syntax with-context (syntax-rules () [(with-context f . body) @@ -49,6 +54,9 @@ [context null]) . body)])) + (define (learn-definites ids) + (current-definites (append ids (current-definites)))) + ;; ----------------------------------- ;; CC @@ -62,7 +70,7 @@ ;; the threaded reductions engine (define-syntax R (syntax-rules () - [(R form pattern . clauses) + [(R form . clauses) (R** #f _ [#:set-syntax form] [#:pattern pattern] . clauses)])) (define-syntax (R** stx) @@ -106,6 +114,9 @@ (values form2 description))]) (cons (walk f form2-var description-var) (R** form2-var p . more)))] + [(R** f p [#:learn ids] . more) + #'(begin (learn-definites ids) + (R** f p . more))] ;; Conditional [(R** f p [#:if test consequent ...] . more) @@ -178,22 +189,22 @@ ;; walk : syntax(es) syntax(es) StepType -> Reduction ;; Lifts a local step into a term step. (define (walk e1 e2 type) - (make-step (current-derivation) (big-context) type (context) + (make-step (current-derivation) (big-context) type (context) (current-definites) (foci e1) (foci e2) e1 e2)) ;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction (define (walk/foci foci1 foci2 Ee1 Ee2 type) - (make-step (current-derivation) (big-context) type (context) + (make-step (current-derivation) (big-context) type (context) (current-definites) (foci foci1) (foci foci2) Ee1 Ee2)) ;; stumble : syntax exception -> Reduction (define (stumble stx exn) - (make-misstep (current-derivation) (big-context) 'error (context) + (make-misstep (current-derivation) (big-context) 'error (context) (current-definites) (foci stx) stx exn)) ;; stumble/E : syntax(s) syntax exn -> Reduction (define (stumble/E focus Ee1 exn) - (make-misstep (current-derivation) (big-context) 'error (context) + (make-misstep (current-derivation) (big-context) 'error (context) (current-definites) (foci focus) Ee1 exn)) ;; ------------------------------------ diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index f4dd14c..4ff982f 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -13,7 +13,7 @@ (define-syntax Expr (syntax-id-rules () - [Expr (values reductions deriv-e1 deriv-e2)])) + [Expr (values reductions* deriv-e1 deriv-e2)])) (define-syntax List (syntax-id-rules () [List (values list-reductions lderiv-es1 lderiv-es2)])) @@ -34,6 +34,14 @@ ;; reductions : Derivation -> ReductionSequence (define (reductions d) + (parameterize ((current-definites null)) + (reductions* d))) + + (define (reductions* d) + (match d + [(AnyQ prule (e1 e2 rs)) + (and rs (learn-definites rs))] + [_ (void)]) (match/with-derivation d ;; Primitives @@ -47,12 +55,12 @@ [body-e1 (match body [(AnyQ deriv (body-e1 _)) body-e1])]) (cons (walk e1 (ctx body-e1) 'tag-module-begin) (with-context ctx - (reductions body)))))] + (reductions* body)))))] [(IntQ p:module (e1 e2 rs #t body)) (with-syntax ([(?module name language . BODY) e1]) (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]) (with-context ctx - (reductions body))))] + (reductions* body))))] [(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)))]) @@ -67,57 +75,58 @@ (list (stumble (frame final-stxs2) (error-wrap-exn d)))) (append reductions1 reductions2))))))] [(AnyQ p:define-syntaxes (e1 e2 rs rhs) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?define-syntaxes formals RHS)] [Expr RHS rhs])] [(AnyQ p:define-values (e1 e2 rs rhs) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?define-values formals RHS)] [#:if rhs [Expr RHS rhs]])] [(AnyQ p:if (e1 e2 rs full? test then else) exni) (if full? - (R e1 _ + (R e1 [! exni] [#:pattern (?if TEST THEN ELSE)] [Expr TEST test] [Expr THEN then] [Expr ELSE else]) - (R e1 _ + (R e1 [! exni] [#:pattern (?if TEST THEN)] [Expr TEST test] [Expr THEN then]))] [(AnyQ p:wcm (e1 e2 rs key mark body) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?wcm KEY MARK BODY)] [Expr KEY key] [Expr MARK mark] [Expr BODY body])] [(AnyQ p:begin (e1 e2 rs lderiv) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?begin . LDERIV)] [List LDERIV lderiv])] [(AnyQ p:begin0 (e1 e2 rs first lderiv) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?begin0 FIRST . LDERIV)] [Expr FIRST first] [List LDERIV lderiv])] [(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni) (let ([tail - (R tagged-stx (?#%app . LDERIV) + (R tagged-stx [! exni] + [#:pattern (?#%app . LDERIV)] [List LDERIV lderiv])]) (if (eq? tagged-stx e1) tail (cons (walk e1 tagged-stx 'tag-app) tail)))] [(AnyQ p:lambda (e1 e2 rs renames body) exni) - (R e1 _ + (R e1 [! exni] [#:bind (?formals* . ?body*) renames] [#:pattern (?lambda ?formals . ?body)] @@ -127,7 +136,7 @@ [Block ?body body])] [(struct p:case-lambda (e1 e2 rs renames+bodies)) #; - (R e1 _ + (R e1 [! exni] [#:pattern (?case-lambda [?formals . ?body] ...)] [#:bind [(?formals* . ?body*) ...] (map car renames+bodies)] @@ -144,10 +153,11 @@ (syntax->list #'(?formals* ...)) e1 mid 'rename-case-lambda) ;; FIXME: Missing renames frames here - (R mid (CASE-LAMBDA [FORMALS . BODY] ...) + (R mid + [#:pattern (CASE-LAMBDA [FORMALS . BODY] ...)] [Block (BODY ...) (map cdr renames+bodies)]))))] [(AnyQ p:let-values (e1 e2 rs renames rhss body) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] @@ -159,7 +169,7 @@ [Expr (?rhs ...) rhss] [Block ?body body])] [(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames] @@ -172,7 +182,7 @@ [Block ?body body])] [(AnyQ p:letrec-syntaxes+values (e1 e2 rs srenames srhss vrenames vrhss body) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs] ...) . ?body*) srenames] @@ -216,18 +226,19 @@ ;; The rest of the automatic primitives [(AnyQ p::STOP (e1 e2 rs) exni) - (R e1 _ + (R e1 [! exni])] [(AnyQ p:set!-macro (e1 e2 rs deriv) exni) - (R e1 _ + (R e1 [! exni] => (lambda (mid) - (reductions deriv)))] + (reductions* deriv)))] [(AnyQ p:set! (e1 e2 rs id-rs rhs) exni) - (R e1 _ + (R e1 [! exni] [#:pattern (SET! VAR RHS)] + [#:learn id-rs] [Expr RHS rhs])] ;; Synthetic primitives @@ -245,7 +256,7 @@ [deriv0 (s:subterm-deriv subterm0)]) (let ([ctx (lambda (x) (path-replace term path0 x))]) (append (with-context ctx - (reductions deriv0)) + (reductions* deriv0)) (loop (and (deriv? deriv0) (path-replace term path0 (deriv-e2 deriv0))) (cdr subterms)))))] @@ -260,21 +271,21 @@ ;; FIXME [(IntQ p:rename (e1 e2 rs rename inner)) - (reductions inner)] + (reductions* inner)] ;; Error ;; Macros [(IntQ mrule (e1 e2 transformation next)) (append (reductions-transformation transformation) - (reductions next))] + (reductions* next))] ;; Lifts [(IntQ lift-deriv (e1 e2 first lifted-stx second)) - (append (reductions first) + (append (reductions* first) (list (walk (deriv-e2 first) lifted-stx 'capture-lifts)) - (reductions second))] + (reductions* second))] ;; Skipped @@ -287,13 +298,17 @@ (define (reductions-transformation tx) (match tx [(struct transformation (e1 e2 rs me1 me2 locals seq)) + (learn-definites rs) (append (reductions-locals e1 locals) (list (walk e1 e2 'macro-step)))] [(IntW transformation (e1 e2 rs me1 me2 locals seq) 'locals) + (learn-definites rs) (reductions-locals e1 locals)] [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'bad-transformer exn) + (learn-definites rs) (list (stumble e1 exn))] [(ErrW transformation (e1 e2 rs me1 me2 locals seq) 'transform exn) + (learn-definites rs) (append (reductions-locals e1 locals) (list (stumble e1 exn)))])) @@ -306,13 +321,13 @@ (define (reductions-local local) (match/with-derivation local [(struct local-expansion (e1 e2 me1 me2 deriv)) - (reductions deriv)] + (reductions* deriv)] [(struct local-lift (expr id)) (list (walk expr id 'local-lift))] [(struct local-lift-end (decl)) (list (walk decl decl 'module-lift))] [(struct local-bind (deriv)) - (reductions deriv)])) + (reductions* deriv)])) ;; list-reductions : ListDerivation -> ReductionSequence (define (list-reductions ld) @@ -322,7 +337,7 @@ (cond [(pair? derivs) (append (with-context (lambda (x) (cons x (stx-cdr suffix))) - (reductions (car derivs))) + (reductions* (car derivs))) (with-context (lambda (x) (cons (deriv-e2 (car derivs)) x)) (loop (cdr derivs) (stx-cdr suffix))))] [(null? derivs) @@ -362,17 +377,17 @@ (let ([estx (deriv-e2 head)]) (loop next (stx-cdr suffix) (cons estx prefix) (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (reductions head)) + (reductions* head)) rss)))] [(IntW b:expr (renames head) tag) (loop next #f #f (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (reductions head)) + (reductions* head)) rss))] [(struct b:defvals (renames head)) (let ([head-rs (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (reductions head))]) + (reductions* head))]) (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix) (cons head-rs rss)))] [(AnyQ b:defstx (renames head rhs)) @@ -386,8 +401,8 @@ (loop next (stx-cdr suffix) (cons estx2 prefix) (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) (cons (with-context (CC ?rhs estx (?ds ?vars ?rhs)) - (reductions rhs)) - (cons (reductions head) + (reductions* rhs)) + (cons (reductions* head) rss)))))] [(struct b:splice (renames head tail)) (loop next tail prefix @@ -401,7 +416,7 @@ 'splice-block)) (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) - (reductions head)) + (reductions* head)) rss)))] [(struct b:begin (renames head derivs)) ;; FIXME @@ -430,24 +445,24 @@ [(struct mod:skip ()) (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))] [(struct mod:cons (head)) - (append (with-context the-context (append (reductions head))) + (append (with-context the-context (append (reductions* head))) (let ([estx (and (deriv? head) (deriv-e2 head))]) (loop next (stx-cdr suffix) (cons estx prefix))))] [(AnyQ mod:prim (head prim)) (append (with-context the-context - (append (reductions head) - (reductions prim))) + (append (reductions* head) + (reductions* prim))) (let ([estx (if prim (lift/deriv-e2 prim) (and (deriv? head) (deriv-e2 head)))]) (loop next (stx-cdr suffix) (cons estx prefix))))] [(ErrW mod:splice (head stxs) exn) - (append (with-context the-context (reductions head)) + (append (with-context the-context (reductions* head)) (list (stumble (deriv-e2 head) exn)))] [(struct mod:splice (head stxs)) (append - (with-context the-context (reductions head)) + (with-context the-context (reductions* head)) (let ([suffix-tail (stx-cdr suffix)] [head-e2 (deriv-e2 head)]) (cons (walk/foci head-e2 @@ -460,7 +475,7 @@ (loop next stxs prefix))))] [(struct mod:lift (head stxs)) (append - (with-context the-context (reductions head)) + (with-context the-context (reductions* head)) (let ([suffix-tail (stx-cdr suffix)] [head-e2 (deriv-e2 head)]) (let ([new-suffix (append stxs (cons head-e2 suffix-tail))]) diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss index b1f6611..934bbdc 100644 --- a/collects/macro-debugger/model/steps.ss +++ b/collects/macro-debugger/model/steps.ss @@ -5,7 +5,7 @@ ;; A ReductionSequence is a (list-of Reduction) - ;; A ProtoStep is (make-protostep Derivation BigContext StepType Context) + ;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites) ;; A Context is a list of Frames ;; A Frame is either: @@ -14,6 +14,8 @@ ;; - 'phase-up (define-struct renames (old new)) + ;; A Definite is a (list-of identifier) + ;; A BigContext is (list-of BigFrame) ;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax) (define-struct bigframe (deriv ctx foci e)) @@ -22,7 +24,7 @@ ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) ;; - (make-misstep ... Syntax Syntax Exception) - (define-struct protostep (deriv lctx type ctx) #f) + (define-struct protostep (deriv lctx type ctx definites) #f) (define-struct (step protostep) (foci1 foci2 e1 e2) #f) (define-struct (misstep protostep) (foci1 e1 exn) #f) diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss index c642551..dc6d9f3 100644 --- a/collects/macro-debugger/syntax-browser/text.ss +++ b/collects/macro-debugger/syntax-browser/text.ss @@ -57,7 +57,8 @@ (define text:arrows<%> (interface (text:mouse-drawings<%>) - add-arrow)) + add-arrow + add-question-arrow)) (define text:drawings-mixin (mixin (text:basic<%>) (text:drawings<%>) @@ -136,8 +137,14 @@ (define (?-font dc) (let ([size (send (send dc get-font) get-point-size)]) (send the-font-list find-or-create-font size 'default 'normal 'bold))) - + (define/public (add-arrow from1 from2 to1 to2 color) + (internal-add-arrow from1 from2 to1 to2 color #f)) + + (define/public (add-question-arrow from1 from2 to1 to2 color) + (internal-add-arrow from1 from2 to1 to2 color #t)) + + (define/private (internal-add-arrow from1 from2 to1 to2 color question?) (unless (and (= from1 to1) (= from2 to2)) (let ([draw (lambda (text dc left top right bottom dx dy) @@ -158,15 +165,16 @@ (send dc set-brush arrow-brush) (draw-arrow dc startx starty endx endy dx dy) #;(send dc set-text-mode 'solid) - (send dc set-font (?-font dc)) - (send dc set-text-foreground - (send the-color-database find-color color)) - (send dc draw-text "?" - (+ (+ startx dx) fw) - (- (+ starty dy) fh)))))))]) + (when question? + (send dc set-font (?-font dc)) + (send dc set-text-foreground + (send the-color-database find-color color)) + (send dc draw-text "?" + (+ (+ startx dx) fw) + (- (+ starty dy) fh))))))))]) (add-mouse-drawing from1 from2 draw) (add-mouse-drawing to1 to2 draw)))) - + (define/private (position->location p) (define xbox (box 0.0)) (define ybox (box 0.0)) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 938fd92..aa414dc 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -96,10 +96,12 @@ (send -text insert text))) (define/public add-syntax - (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table) + (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]) (when (and (pair? hi-stxs) (not hi-color)) (error 'syntax-widget%::add-syntax "no highlight color specified")) - (let ([colorer (internal-add-syntax stx hi-stxs hi-color)]) + (let ([colorer (internal-add-syntax stx hi-stxs hi-color)] + [definite-table (make-hash-table)]) + (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites) (when alpha-table (let ([range (send colorer get-range)]) (for-each (lambda (id) @@ -111,10 +113,15 @@ (for-each (lambda (binder-r) (for-each (lambda (id-r) - (send -text add-arrow - (car id-r) (cdr id-r) - (car binder-r) (cdr binder-r) - "purple")) + (if (hash-table-get definite-table id #f) + (send -text add-arrow + (car id-r) (cdr id-r) + (car binder-r) (cdr binder-r) + "blue") + (send -text add-question-arrow + (car id-r) (cdr id-r) + (car binder-r) (cdr binder-r) + "purple"))) (send range get-ranges id))) (send range get-ranges binder))))) (send colorer get-identifier-list))))