From 81e6d8cb6785959ac742cdf229a1bf5b59983260 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 original commit: e12fde12600534527ac2b382295e2a4ef1da131d --- 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 ++++++++++++++++- 4 files changed, 111 insertions(+), 30 deletions(-) diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss index 7c4b95e..c921f78 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 fe28c3d..7bf2df0 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 8fd5861..85e9042 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 120ad30..47150cf 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)) +|#