From 75b2415a967ae31ca774e4ece3f8c596616087b9 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 12 Dec 2007 22:56:05 +0000 Subject: [PATCH] macro stepper: enabled for "Module", improved debugging setup svn: r7981 --- collects/macro-debugger/tool.ss | 70 +++++-------------------- collects/macro-debugger/view/debug.ss | 25 ++++++++- collects/macro-debugger/view/stepper.ss | 54 ++++++++++++++++++- 3 files changed, 88 insertions(+), 61 deletions(-) diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index f80fc018d0..281c856d92 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -13,6 +13,7 @@ "model/deriv.ss" "model/deriv-util.ss" "view/frame.ss" + "view/stepper.ss" "view/prefs.ss") (provide tool@ @@ -25,16 +26,10 @@ (define (ext-macro-stepper-frame-mixin %) (class % (define/override (get-macro-stepper-widget%) - (ext-macro-stepper-widget-mixin + (macro-stepper-widget/process-mixin (super get-macro-stepper-widget%))) (super-new))) - (define (ext-macro-stepper-widget-mixin %) - (class % - (super-new) - (define/override (get-preprocess-deriv) - get-original-part))) - (define macro-stepper-frame% (ext-macro-stepper-frame-mixin (macro-stepper-frame-mixin @@ -211,16 +206,16 @@ (let ([main-group (car lang)] [second (and (pair? (cdr lang)) (cadr lang))] [third (and (pair? (cdr lang)) (pair? (cddr lang)) (caddr lang))]) - (and (equal? main-group (string-constant legacy-languages)) - (or (member second - (list (string-constant r5rs-lang-name) - "Module" - "Swindle")) - (member third - (list (string-constant mzscheme-w/debug) - (string-constant mred-w/debug) - (string-constant pretty-big-scheme))))))) - + (or (equal? main-group "Module") + (and (equal? main-group (string-constant legacy-languages)) + (or (member second + (list (string-constant r5rs-lang-name) + "Swindle")) + (member third + (list (string-constant mzscheme-w/debug) + (string-constant mred-w/debug) + (string-constant pretty-big-scheme)))))))) + ;; Macro debugger code (drscheme:get/extend:extend-unit-frame @@ -233,45 +228,4 @@ macro-debugger-tab-mixin) )) - - ;; get-original-part : Deriv -> Deriv/#f - ;; Strip off mzscheme's #%top-interaction - ;; Careful: the #%top-interaction node may be inside of a lift-deriv - (define (get-original-part deriv) - ;; adjust-deriv/lift : Derivation -> (list-of Derivation) - (define (adjust-deriv/lift deriv) - (match deriv - [(Wrap lift-deriv (e1 e2 first lifted-stx second)) - (let ([first (adjust-deriv/top first)]) - (and first - (let ([e1 (wderiv-e1 first)]) - (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 (wderiv-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 - [(Wrap mrule (e1 e2 tx next)) - (match tx - [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 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)]) - deriv*)) - ) diff --git a/collects/macro-debugger/view/debug.ss b/collects/macro-debugger/view/debug.ss index cf10fee5df..c3de7b7439 100644 --- a/collects/macro-debugger/view/debug.ss +++ b/collects/macro-debugger/view/debug.ss @@ -1,14 +1,35 @@ (module debug mzscheme (require (lib "pretty.ss") + (lib "class.ss") "debug-format.ss" + "prefs.ss" "view.ss") (provide debug-file) + (define (widget-mixin %) + (class % + (define/override (top-interaction-kw? x) + (eq? (syntax-e x) '#%top-interaction)) + (super-new))) + + (define stepper-frame% + (class macro-stepper-frame% + (define/override (get-macro-stepper-widget%) + (widget-mixin (super get-macro-stepper-widget%))) + (super-new))) + + (define (make-stepper) + (let ([f (new macro-stepper-frame% + (config (new macro-stepper-config/prefs%)))]) + (send f show #t) + (send f get-widget))) + (define (debug-file file) (let-values ([(events msg ctx) (load-debug-file file)]) (pretty-print msg) (pretty-print ctx) - (go/trace events))) - + (let* ([w (make-stepper)]) + (send w add-trace events) + w))) ) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 816c3cc624..0a161b4a9a 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -24,7 +24,8 @@ "../model/steps.ss" "cursor.ss" "util.ss") - (provide macro-stepper-widget%) + (provide macro-stepper-widget% + macro-stepper-widget/process-mixin) ;; Macro Stepper @@ -378,4 +379,55 @@ (refresh/move) )) + (define (macro-stepper-widget/process-mixin %) + (class % + (super-new) + (define/override (get-preprocess-deriv) + (lambda (d) (get-original-part d))) + + ;; get-original-part : Deriv -> Deriv/#f + ;; Strip off mzscheme's #%top-interaction + ;; Careful: the #%top-interaction node may be inside of a lift-deriv + (define/private (get-original-part deriv) + (let ([deriv* (adjust-deriv/lift deriv)]) + deriv*)) + + ;; adjust-deriv/lift : Derivation -> (list-of Derivation) + (define/private (adjust-deriv/lift deriv) + (match deriv + [(Wrap lift-deriv (e1 e2 first lifted-stx second)) + (let ([first (adjust-deriv/top first)]) + (and first + (let ([e1 (wderiv-e1 first)]) + (make-lift-deriv e1 e2 first lifted-stx second))))] + [else (adjust-deriv/top deriv)])) + + ;; adjust-deriv/top : Derivation -> Derivation + (define/private (adjust-deriv/top deriv) + (if (syntax-source (wderiv-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 + [(Wrap mrule (e1 e2 tx next)) + (match tx + [(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq)) + (cond [(ormap (lambda (x) (top-interaction-kw? x)) + 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]))) + + (define/public (top-interaction-kw? x) + (module-identifier=? x #'#%top-interaction)) + + )) )