suzanne.soy/macro-debugger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro stepper: added duplicate-frame command (menu items)

Browse Source 
svn: r12219

original commit: e12fde12600534527ac2b382295e2a4ef1da131d
This commit is contained in:
Ryan Culpepper 2008-11-02 23:18:03 +00:00
parent 6ccfbba3bb
commit 81e6d8cb67
4 changed files with 111 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/macro-debugger/view/frame.ss
View File

@ -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)))

18
collects/macro-debugger/view/stepper.ss
View File

@ -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

3
collects/macro-debugger/view/term-record.ss
View File

@ -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?]

55
collects/macro-debugger/view/view.ss
View File

@ -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))
|#