From e12fde12600534527ac2b382295e2a4ef1da131d Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 2 Nov 2008 23:18:03 +0000 Subject: [PATCH] macro stepper: added duplicate-frame command (menu items) svn: r12219 --- collects/macro-debugger/tool.ss | 66 ++++++++++++++------- collects/macro-debugger/view/frame.ss | 65 +++++++++++--------- collects/macro-debugger/view/stepper.ss | 18 +++++- collects/macro-debugger/view/term-record.ss | 3 + collects/macro-debugger/view/view.ss | 55 ++++++++++++++++- 5 files changed, 155 insertions(+), 52 deletions(-) diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index b4ce5fa9b0..9bae30f5ec 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require scheme/base scheme/list @@ -13,6 +12,7 @@ "model/deriv.ss" "model/deriv-util.ss" "view/frame.ss" + (only-in "view/view.ss" macro-stepper-director%) "view/stepper.ss" "view/prefs.ss") @@ -23,7 +23,7 @@ (interface () enable-macro-stepper?)) -(define (ext-macro-stepper-frame-mixin %) +(define (drscheme-macro-stepper-frame-mixin %) (class % (define/override (get-macro-stepper-widget%) (macro-stepper-widget/process-mixin @@ -31,15 +31,41 @@ (super-new))) (define macro-stepper-frame% - (ext-macro-stepper-frame-mixin + (drscheme-macro-stepper-frame-mixin (macro-stepper-frame-mixin (frame:standard-menus-mixin frame:basic%)))) +(define drscheme-macro-stepper-director% + (class macro-stepper-director% + (init-field filename) + (define stepper #f) + (inherit new-stepper) + + (define/public (lazy-new-stepper) + (unless stepper + (set! stepper (new-stepper)))) + + (define/override (add-trace events) + (lazy-new-stepper) + (super add-trace events)) + (define/override (add-deriv deriv) + (lazy-new-stepper) + (super add-deriv deriv)) + + (define/override (new-stepper-frame) + (new macro-stepper-frame% + (config (new macro-stepper-config/prefs%)) + (filename filename) + (director this))) + + (super-new))) + + (define tool@ (unit (import drscheme:tool^) (export drscheme:tool-exports^) - + (define (phase1) (drscheme:language:extend-language-interface language/macro-stepper<%> @@ -147,18 +173,16 @@ (define debugging? #f) - (define current-stepper #f) + (define current-stepper-director #f) (define/public (enable-macro-debugging ?) (set! debugging? ?)) (define/override (reset-console) (super reset-console) - (when current-stepper - #;(message-box "obsoleting stepper" "before" #f '(ok)) - (send current-stepper add-obsoleted-warning) - #;(message-box "obsoleting stepper" "after" #f '(ok)) - (set! current-stepper #f)) + (when current-stepper-director + (send current-stepper-director add-obsoleted-warning) + (set! current-stepper-director #f)) (run-in-evaluation-thread (lambda () (let-values ([(e mnr) @@ -168,23 +192,21 @@ (current-module-name-resolver mnr))))) (define/private (make-stepper filename) - (let ([frame (new macro-stepper-frame% - (filename filename) - (config (new macro-stepper-config/prefs%)))]) - (set! current-stepper frame) - (send frame show #t) - (send frame get-widget))) + (new drscheme-macro-stepper-director% (filename filename))) - (define/private (make-handlers original-eval-handler original-module-name-resolver) - (let* ([filename (send (send (get-top-level-window) get-definitions-text) + (define/private (make-handlers original-eval-handler + original-module-name-resolver) + (let* ([filename (send (send (get-top-level-window) + get-definitions-text) get-filename/untitled-name)] - [stepperp (delay (make-stepper filename))] + [director (make-stepper filename)] [debugging? debugging?]) + (set! current-stepper-director director) (values (lambda (expr) (if (and debugging? (syntax? expr)) (let-values ([(e-expr events derivp) (trace* expr expand)]) - (show-deriv stepperp events) + (show-deriv director events) (if (syntax? e-expr) (parameterize ((current-eval original-eval-handler)) (original-eval-handler e-expr)) @@ -203,11 +225,11 @@ (set! debugging? saved-debugging?) (when eo (current-expand-observe eo))))))))) - (define/private (show-deriv stepperp events) + (define/private (show-deriv director events) (parameterize ([current-eventspace drscheme-eventspace]) (queue-callback (lambda () - (send (force stepperp) add-trace events))))) + (send director add-trace events))))) )) ;; Borrowed from mztake/debug-tool.ss diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 7c4b95e43a..c921f78e63 100644 --- a/collects/macro-debugger/view/frame.ss +++ b/collects/macro-debugger/view/frame.ss @@ -26,6 +26,7 @@ (define (macro-stepper-frame-mixin base-frame%) (class base-frame% (init-field config) + (init-field director) (init-field (filename #f)) (define obsoleted? #f) @@ -56,25 +57,6 @@ (send config set-height h) (send widget update/preserve-view)) - (override/return-false file-menu:create-new? - file-menu:create-open? - file-menu:create-open-recent? - file-menu:create-revert? - file-menu:create-save? - file-menu:create-save-as? - ;file-menu:create-print? - edit-menu:create-undo? - edit-menu:create-redo? - ;edit-menu:create-cut? - ;edit-menu:create-paste? - edit-menu:create-clear?) - - (define file-menu (get-file-menu)) - (define edit-menu (get-edit-menu)) - (define stepper-menu - (new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) - (define help-menu (get-help-menu)) - (define warning-panel (new horizontal-panel% (parent (get-area-container)) @@ -87,6 +69,7 @@ (define widget (new (get-macro-stepper-widget%) (parent (get-area-container)) + (director director) (config config))) (define controller (send widget get-controller)) @@ -110,6 +93,32 @@ ;; Set up menus + (override/return-false file-menu:create-new? + file-menu:create-open? + file-menu:create-open-recent? + file-menu:create-revert? + file-menu:create-save? + file-menu:create-save-as? + ;file-menu:create-print? + edit-menu:create-undo? + edit-menu:create-redo? + ;edit-menu:create-cut? + ;edit-menu:create-paste? + edit-menu:create-clear?) + + (define stepper-menu + (new (get-menu%) (parent (get-menu-bar)) (label "Stepper"))) + + (define/override (file-menu:between-new-and-open file-menu) + (new (get-menu-item%) + (label "Duplicate stepper") + (parent file-menu) + (callback (lambda _ (send widget duplicate-stepper)))) + (new (get-menu-item%) + (label "Duplicate stepper (current term only)") + (parent file-menu) + (callback (lambda _ (send widget show-in-new-frame))))) + (menu-option/notify-box stepper-menu "Show syntax properties" (get-field show-syntax-properties? config)) @@ -148,11 +157,7 @@ (menu-option/notify-box stepper-menu "Show macro hiding panel" (get-field show-hiding-panel? config)) - #; - (new (get-menu-item%) - (label "Show in new frame") - (parent stepper-menu) - (callback (lambda _ (send widget show-in-new-frame)))) + (new (get-menu-item%) (label "Remove selected term") (parent stepper-menu) @@ -240,9 +245,12 @@ (let ([dc (get-dc)]) (send dc set-font warning-font) (let-values ([(cw ch) (get-client-size)] - [(tw th dont-care dont-care2) (send dc get-text-extent warning)]) - (send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid)) + [(tw th dont-care dont-care2) + (send dc get-text-extent warning)]) + (send dc set-pen + (send the-pen-list find-or-create-pen warning-color 1 'solid)) + (send dc set-brush + (send the-brush-list find-or-create-brush warning-color 'solid)) (send dc draw-rectangle 0 0 cw ch) (send dc draw-text warning @@ -250,7 +258,8 @@ (- (/ ch 2) (/ th 2)))))) (super-new) (inherit min-width min-height stretchable-height) - (let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)]) + (let-values ([(tw th dc dc2) + (send (get-dc) get-text-extent warning warning-font)]) (min-width (+ 2 (inexact->exact (ceiling tw)))) (min-height (+ 2 (inexact->exact (ceiling th))))) (stretchable-height #f))) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index fe28c3dabf..7bf2df047f 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -33,6 +33,7 @@ (class* object% () (init-field parent) (init-field config) + (init-field director) ;; Terms @@ -76,6 +77,20 @@ (trim-navigator) (refresh)) + ;; show-in-new-frame : -> void + (define/public (show-in-new-frame) + (let ([term (focused-term)]) + (when term + (let ([new-stepper (send director new-stepper '(no-new-traces))]) + (send new-stepper add-deriv (send term get-raw-deriv)) + (void))))) + + ;; duplicate-stepper : -> void + (define/public (duplicate-stepper) + (let ([new-stepper (send director new-stepper)]) + (for ([term (cursor->list terms)]) + (send new-stepper add-deriv (send term get-raw-deriv))))) + (define/public (get-config) config) (define/public (get-controller) sbc) (define/public (get-view) sbview) @@ -414,7 +429,8 @@ [(for/or ([x (base-resolves deriv)]) (top-interaction-kw? x)) ;; Just mzscheme's top-interaction; strip it out (adjust-deriv/top (mrule-next deriv))] - [(equal? (map syntax-e (base-resolves deriv)) '(#%top-interaction)) + [(equal? (map syntax-e (base-resolves deriv)) + '(#%top-interaction)) ;; A *different* top interaction; keep it deriv] [else diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss index 8fd5861370..85e9042efc 100644 --- a/collects/macro-debugger/view/term-record.ss +++ b/collects/macro-debugger/view/term-record.ss @@ -70,6 +70,9 @@ [(define-guarded-getters guard (method expr) ...) (begin (define/public (method) guard expr) ...)])) + (define/public (get-events) events) + (define/public (get-raw-deriv) raw-deriv) + (define-guarded-getters (recache-deriv!) [get-deriv deriv] [get-deriv-hidden? deriv-hidden?] diff --git a/collects/macro-debugger/view/view.ss b/collects/macro-debugger/view/view.ss index 120ad30dff..47150cf64f 100644 --- a/collects/macro-debugger/view/view.ss +++ b/collects/macro-debugger/view/view.ss @@ -8,7 +8,52 @@ "frame.ss" "prefs.ss" "../model/trace.ss") -(provide (all-defined-out)) +(provide macro-stepper-director% + macro-stepper-frame% + go) + +(define macro-stepper-director% + (class object% + (define stepper-frames (make-hasheq)) + + ;; Flags is a subset(list) of '(no-obsolete no-new-traces) + + (define/private (add-stepper! s flags) + (hash-set! stepper-frames s flags)) + (define/public (remove-stepper! s) + (hash-remove! stepper-frames s)) + + (define/public (add-obsoleted-warning) + (hash-for-each stepper-frames + (lambda (stepper-frame flags) + (unless (memq 'no-obsolete flags) + (send stepper-frame add-obsoleted-warning))))) + (define/public (add-trace events) + (hash-for-each stepper-frames + (lambda (stepper-frame flags) + (unless (memq 'no-new-traces flags) + (send (send stepper-frame get-widget) + add-trace events))))) + (define/public (add-deriv deriv) + (hash-for-each stepper-frames + (lambda (stepper-frame flags) + (unless (memq 'no-new-traces flags) + (send (send stepper-frame get-widget) + add-deriv deriv))))) + + (define/public (new-stepper [flags '()]) + (define stepper-frame (new-stepper-frame)) + (define stepper (send stepper-frame get-widget)) + (send stepper-frame show #t) + (add-stepper! stepper-frame flags) + stepper) + + (define/public (new-stepper-frame) + (new macro-stepper-frame% + (config (new macro-stepper-config/prefs%)) + (director this))) + + (super-new))) (define macro-stepper-frame% (macro-stepper-frame-mixin @@ -17,6 +62,13 @@ ;; Main entry points +(define (go stx) + (define director (new macro-stepper-director%)) + (define stepper (send director new-stepper)) + (send director add-deriv (trace stx)) + (void)) + +#| (define (make-macro-stepper) (let ([f (new macro-stepper-frame% (config (new macro-stepper-config/prefs%)))]) @@ -39,3 +91,4 @@ (let* ([w (make-macro-stepper)]) (send w add-trace events) w)) +|#