suzanne.soy/racket
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
This commit is contained in:
Ryan Culpepper 2008-11-02 23:18:03 +00:00
parent d5f796211a
commit e12fde1260
5 changed files with 155 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/macro-debugger/tool.ss
View File

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

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