commit 81e6d8cb6785959ac742cdf229a1bf5b59983260
parent 6ccfbba3bba76b14fff29c35073f0568c69b8bc1
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Sun, 2 Nov 2008 23:18:03 +0000
macro stepper: added duplicate-frame command (menu items)
svn: r12219
original commit: e12fde12600534527ac2b382295e2a4ef1da131d
Diffstat:
4 files changed, 111 insertions(+), 30 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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))
+|#
