(module tool mzscheme (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") (prefix view: "view/prefs.ss") (prefix sb: "syntax-browser/embed.ss")) (provide tool@ language/macro-stepper<%>) (define language/macro-stepper<%> (interface () enable-macro-stepper?)) (define view-base/tool@ (unit (import) (export view:view-base^) (define base-frame% (frame:standard-menus-mixin frame:basic%)))) (define stepper@ (compound-unit (import) (link [((BASE : view:view-base^)) view-base/tool@] [((STEPPER : view:view^)) view:pre-stepper@ BASE]) (export STEPPER))) (define-values/invoke-unit stepper@ (import) (export view:view^)) (define tool@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) (define (phase1) (drscheme:language:extend-language-interface language/macro-stepper<%> (mixin (drscheme:language:language<%>) (language/macro-stepper<%>) (inherit get-language-position) (define/public (enable-macro-stepper?) (macro-stepper-works-for? (get-language-position))) (super-new)))) (define (phase2) (void)) (define drscheme-eventspace (current-eventspace)) (define-local-member-name check-language) (define-local-member-name get-debug-button) (define (macro-debugger-unit-frame-mixin %) (class % (super-new) (inherit get-button-panel get-interactions-text get-definitions-text) (define macro-debug-panel (new vertical-pane% (parent (get-button-panel)))) (define macro-debug-button (new button% (label (make-bitmap-label "Macro Stepper" (build-path (collection-path "macro-debugger") "view" "icon-small.png"))) (parent macro-debug-panel) (callback (lambda (button event) (execute #t))))) (define/override (execute-callback) (execute #f)) (define/private (execute debugging?) (send (get-interactions-text) enable-macro-debugging debugging?) (super execute-callback)) (define/public (get-debug-button) macro-debug-button) ;; Hide button for inappropriate languages (define/augment (on-tab-change old new) (check-language) (inner (void) on-tab-change old new)) (define/public (check-language) (let ([lang (drscheme:language-configuration:language-settings-language (send (get-definitions-text) get-next-settings))]) (if (send lang enable-macro-stepper?) (unless (send macro-debug-button is-shown?) (send macro-debug-panel add-child macro-debug-button)) (when (send macro-debug-button is-shown?) (send macro-debug-panel delete-child macro-debug-button))))) (send (get-button-panel) change-children (lambda (_) (cons macro-debug-panel (remq macro-debug-panel _)))) (check-language) )) (define (macro-debugger-definitions-text-mixin %) (class % (inherit get-top-level-window) (define/augment (after-set-next-settings s) (let ([tlw (get-top-level-window)]) (when tlw (send tlw check-language))) (inner (void) after-set-next-settings s)) (super-new))) (define (macro-debugger-tab-mixin %) (class % (inherit get-frame) (define/override (enable-evaluation) (super enable-evaluation) (send (send (get-frame) get-debug-button) enable #t)) (define/override (disable-evaluation) (super disable-evaluation) (send (send (get-frame) get-debug-button) enable #f)) (super-new))) (define (macro-debugger-interactions-text-mixin %) (class % (super-new) (inherit run-in-evaluation-thread) (define debugging? #f) (define/public (enable-macro-debugging ?) (set! debugging? ?)) (define/override (reset-console) (super reset-console) (run-in-evaluation-thread (lambda () (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 (let ([frame (new macro-stepper-frame%)]) (send frame show #t) (send frame get-widget)))] [debugging? debugging?]) (values (lambda (expr) (if (and debugging? (syntax? expr)) (let-values ([(e-expr deriv) (trace/result expr)]) (show-deriv/orig-parts deriv stepper) (if (syntax? e-expr) (parameterize ((current-eval original-eval-handler)) (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))))))))) ;; 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) ;; 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]) (queue-callback (lambda () (send (force stepper-promise) add-deriv deriv))))) )) ;; Borrowed from mztake/debug-tool.ss (define (macro-stepper-works-for? lang) (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 professional-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))))))) ;; Macro debugger code (drscheme:get/extend:extend-unit-frame macro-debugger-unit-frame-mixin) (drscheme:get/extend:extend-interactions-text macro-debugger-interactions-text-mixin) (drscheme:get/extend:extend-definitions-text macro-debugger-definitions-text-mixin) (drscheme:get/extend:extend-tab macro-debugger-tab-mixin) )))