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

Macro stepper:

Browse Source 
added obsolete warning
  added filename to frame label

svn: r6218
This commit is contained in:
Ryan Culpepper 2007-05-12 23:55:17 +00:00
parent e569fae266
commit abe929fda8
2 changed files with 56 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -136,14 +136,21 @@
(define (macro-debugger-interactions-text-mixin %)
(class %
(super-new)
(inherit run-in-evaluation-thread)
(inherit run-in-evaluation-thread
get-top-level-window)
(define debugging? #f)
(define current-stepper #f)
(define/public (enable-macro-debugging ?)
(set! debugging? ?))
(define/override (reset-console)
(super reset-console)
(when current-stepper
(send current-stepper add-obsoleted-warning)
(set! current-stepper #f))
(run-in-evaluation-thread
(lambda ()
(let-values ([(e mnr)
@ -152,13 +159,17 @@
(current-eval e)
(current-module-name-resolver mnr)))))
(define/private (make-stepper filename)
(let ([frame (new macro-stepper-frame% (filename filename))])
(set! current-stepper frame)
(send frame show #t)
(send frame get-widget)))
(define/private (make-handlers original-eval-handler original-module-name-resolver)
(let ([stepper
(delay
(let ([frame (new macro-stepper-frame%)])
(send frame show #t)
(send frame get-widget)))]
[debugging? debugging?])
(let* ([filename (send (send (get-top-level-window) get-definitions-text)
get-filename/untitled-name)]
[stepper (delay (make-stepper filename))]
[debugging? debugging?])
(values
(lambda (expr)
(if (and debugging? (syntax? expr))

45
collects/macro-debugger/view/gui.ss
View File

@ -3,6 +3,7 @@
(require (lib "class.ss")
(lib "unit.ss")
(lib "list.ss")
(lib "file.ss")
(lib "plt-match.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
@ -97,20 +98,33 @@
(define macro-stepper-frame%
(class base-frame%
(init-field (filename #f))
(init (identifier=? (pref:identifier=?)))
(init-field (config (new macro-stepper-config%)))
(inherit get-menu%
(define obsoleted? #f)
(inherit get-area-container
set-label
get-menu%
get-menu-item%
get-menu-bar
get-file-menu
get-edit-menu
get-help-menu)
(super-new (label "Macro stepper")
(super-new (label (make-label))
(width (send config get-width))
(height (send config get-height)))
(define/private (make-label)
(if filename
(string-append (path->string
(file-name-from-path filename))
(if obsoleted? " (old)" "")
" - Macro stepper")
"Macro stepper"))
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
@ -142,13 +156,31 @@
(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))
(stretchable-height #f)
(style '(deleted))))
(define widget
(new macro-stepper-widget%
(parent (send this get-area-container))
(parent (get-area-container))
(config config)))
(define/public (get-widget) widget)
(define/public (add-obsoleted-warning)
(unless obsoleted?
(set! obsoleted? #t)
(new message%
(label "Warning: This macro stepper session is obsolete. The program may have changed.")
(parent warning-panel))
(set-label (make-label))
(send (get-area-container) change-children
(lambda (children)
(cons warning-panel
(remq warning-panel children))))))
;; Set up menus
(menu-option/notify-box stepper-menu
@ -483,9 +515,8 @@
"Internal error computing reductions. Original term:\n")
(send sbview add-syntax
(lift/deriv-e1 (trec-deriv (focused-term))))
(print-struct #t)
(send sbview add-text
(format "~s~n" (focused-term))))))
#;(print-struct #t)
#;(send sbview add-text (format "~s~n" (focused-term))))))
;; update:show-lctx : Step -> void
(define/private (update:show-lctx step)