278 lines
10 KiB
Scheme
278 lines
10 KiB
Scheme
|
|
(module tool mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "unit.ss")
|
|
(lib "plt-match.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(lib "tool.ss" "drscheme")
|
|
(lib "bitmap-label.ss" "mrlib")
|
|
(lib "string-constant.ss" "string-constants")
|
|
"model/trace.ss"
|
|
"model/deriv.ss"
|
|
"model/deriv-util.ss"
|
|
"view/frame.ss"
|
|
"view/prefs.ss")
|
|
|
|
(provide tool@
|
|
language/macro-stepper<%>)
|
|
|
|
(define language/macro-stepper<%>
|
|
(interface ()
|
|
enable-macro-stepper?))
|
|
|
|
(define (ext-macro-stepper-frame-mixin %)
|
|
(class %
|
|
(define/override (get-macro-stepper-widget%)
|
|
(ext-macro-stepper-widget-mixin
|
|
(super get-macro-stepper-widget%)))
|
|
(super-new)))
|
|
|
|
(define (ext-macro-stepper-widget-mixin %)
|
|
(class %
|
|
(super-new)
|
|
(define/override (get-preprocess-deriv)
|
|
get-original-part)))
|
|
|
|
(define macro-stepper-frame%
|
|
(ext-macro-stepper-frame-mixin
|
|
(macro-stepper-frame-mixin
|
|
(frame:standard-menus-mixin
|
|
frame:basic%))))
|
|
|
|
(define tool@
|
|
(unit (import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
|
|
(define (phase1)
|
|
(drscheme:language:extend-language-interface
|
|
language/macro-stepper<%>
|
|
(mixin (drscheme:language:language<%>) (language/macro-stepper<%>)
|
|
(inherit get-language-position)
|
|
(define/public (enable-macro-stepper?)
|
|
(macro-stepper-works-for? (get-language-position)))
|
|
(super-new))))
|
|
(define (phase2) (void))
|
|
|
|
(define drscheme-eventspace (current-eventspace))
|
|
|
|
(define-local-member-name check-language)
|
|
(define-local-member-name get-debug-button)
|
|
|
|
(define (macro-debugger-unit-frame-mixin %)
|
|
(class %
|
|
(super-new)
|
|
(inherit get-button-panel
|
|
get-interactions-text
|
|
get-definitions-text)
|
|
|
|
(define macro-debug-panel
|
|
(new vertical-pane% (parent (get-button-panel))))
|
|
(define macro-debug-button
|
|
(new button%
|
|
(label (make-bitmap-label
|
|
"Macro Stepper"
|
|
(build-path (collection-path "macro-debugger")
|
|
"view"
|
|
"icon-small.png")))
|
|
(parent macro-debug-panel)
|
|
(callback (lambda (button event) (execute #t)))))
|
|
|
|
(define/override (execute-callback)
|
|
(execute #f))
|
|
|
|
(define/private (execute debugging?)
|
|
(send (get-interactions-text) enable-macro-debugging debugging?)
|
|
(super execute-callback))
|
|
|
|
(define/public (get-debug-button) macro-debug-button)
|
|
|
|
;; Hide button for inappropriate languages
|
|
|
|
(define/augment (on-tab-change old new)
|
|
(check-language)
|
|
(inner (void) on-tab-change old new))
|
|
|
|
(define/public (check-language)
|
|
(let ([lang
|
|
(drscheme:language-configuration:language-settings-language
|
|
(send (get-definitions-text) get-next-settings))])
|
|
(if (send lang enable-macro-stepper?)
|
|
(unless (send macro-debug-button is-shown?)
|
|
(send macro-debug-panel
|
|
add-child macro-debug-button))
|
|
(when (send macro-debug-button is-shown?)
|
|
(send macro-debug-panel
|
|
delete-child macro-debug-button)))))
|
|
|
|
(send (get-button-panel) change-children
|
|
(lambda (_)
|
|
(cons macro-debug-panel
|
|
(remq macro-debug-panel _))))
|
|
(check-language)
|
|
))
|
|
|
|
(define (macro-debugger-definitions-text-mixin %)
|
|
(class %
|
|
(inherit get-top-level-window)
|
|
(define/augment (after-set-next-settings s)
|
|
(let ([tlw (get-top-level-window)])
|
|
(when tlw
|
|
(send tlw check-language)))
|
|
(inner (void) after-set-next-settings s))
|
|
(super-new)))
|
|
|
|
(define (macro-debugger-tab-mixin %)
|
|
(class %
|
|
(inherit get-frame)
|
|
(define/override (enable-evaluation)
|
|
(super enable-evaluation)
|
|
(send (send (get-frame) get-debug-button) enable #t))
|
|
(define/override (disable-evaluation)
|
|
(super disable-evaluation)
|
|
(send (send (get-frame) get-debug-button) enable #f))
|
|
(super-new)))
|
|
|
|
(define (macro-debugger-interactions-text-mixin %)
|
|
(class %
|
|
(super-new)
|
|
(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
|
|
#;(message-box "obsoleting stepper" "before" #f '(ok))
|
|
(send current-stepper add-obsoleted-warning)
|
|
#;(message-box "obsoleting stepper" "after" #f '(ok))
|
|
(set! current-stepper #f))
|
|
(run-in-evaluation-thread
|
|
(lambda ()
|
|
(let-values ([(e mnr)
|
|
(make-handlers (current-eval)
|
|
(current-module-name-resolver))])
|
|
(current-eval e)
|
|
(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)))
|
|
|
|
(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))]
|
|
[debugging? debugging?])
|
|
(values
|
|
(lambda (expr)
|
|
(if (and debugging? (syntax? expr))
|
|
(let-values ([(e-expr events derivp) (trace* expr expand)])
|
|
(show-deriv stepperp events)
|
|
(if (syntax? e-expr)
|
|
(parameterize ((current-eval original-eval-handler))
|
|
(original-eval-handler e-expr))
|
|
(raise e-expr)))
|
|
(original-eval-handler expr)))
|
|
(lambda args
|
|
(let ([eo (current-expand-observe)]
|
|
[saved-debugging? debugging?])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(set! debugging? #f)
|
|
(when eo (current-expand-observe void)))
|
|
(lambda ()
|
|
(apply original-module-name-resolver args))
|
|
(lambda ()
|
|
(set! debugging? saved-debugging?)
|
|
(when eo (current-expand-observe eo)))))))))
|
|
|
|
(define/private (show-deriv stepperp events)
|
|
(parameterize ([current-eventspace drscheme-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(send (force stepperp) add-trace events)))))
|
|
))
|
|
|
|
;; Borrowed from mztake/debug-tool.ss
|
|
|
|
(define (macro-stepper-works-for? lang)
|
|
(let ([main-group (car lang)]
|
|
[second (and (pair? (cdr lang)) (cadr lang))]
|
|
[third (and (pair? (cdr lang)) (pair? (cddr lang)) (caddr lang))])
|
|
(and (equal? main-group (string-constant legacy-languages))
|
|
(or (member second
|
|
(list (string-constant r5rs-lang-name)
|
|
"Module"
|
|
"Swindle"))
|
|
(member third
|
|
(list (string-constant mzscheme-w/debug)
|
|
(string-constant mred-w/debug)
|
|
(string-constant pretty-big-scheme)))))))
|
|
|
|
;; Macro debugger code
|
|
|
|
(drscheme:get/extend:extend-unit-frame
|
|
macro-debugger-unit-frame-mixin)
|
|
(drscheme:get/extend:extend-interactions-text
|
|
macro-debugger-interactions-text-mixin)
|
|
(drscheme:get/extend:extend-definitions-text
|
|
macro-debugger-definitions-text-mixin)
|
|
(drscheme:get/extend:extend-tab
|
|
macro-debugger-tab-mixin)
|
|
|
|
))
|
|
|
|
;; get-original-part : Deriv -> Deriv/#f
|
|
;; Strip off mzscheme's #%top-interaction
|
|
;; Careful: the #%top-interaction node may be inside of a lift-deriv
|
|
(define (get-original-part deriv)
|
|
;; adjust-deriv/lift : Derivation -> (list-of Derivation)
|
|
(define (adjust-deriv/lift deriv)
|
|
(match deriv
|
|
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
|
|
(let ([first (adjust-deriv/top first)])
|
|
(and first
|
|
(let ([e1 (wderiv-e1 first)])
|
|
(make-lift-deriv e1 e2 first lifted-stx second))))]
|
|
[else (adjust-deriv/top deriv)]))
|
|
;; adjust-deriv/top : Derivation -> Derivation
|
|
(define (adjust-deriv/top deriv)
|
|
(if (syntax-source (wderiv-e1 deriv))
|
|
deriv
|
|
;; It's not original...
|
|
;; Strip out mzscheme's top-interactions
|
|
;; Keep anything that is a non-mzscheme top-interaction
|
|
;; Drop everything else (not original program)
|
|
(match deriv
|
|
[(Wrap mrule (e1 e2 tx next))
|
|
(match tx
|
|
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
|
|
(cond [(ormap (lambda (x)
|
|
(module-identifier=? x #'#%top-interaction))
|
|
rs)
|
|
;; Just mzscheme's top-interaction; strip it out
|
|
(adjust-deriv/top next)]
|
|
[(equal? (map syntax-e rs) '(#%top-interaction))
|
|
;; A *different* top interaction; keep it
|
|
deriv]
|
|
[else
|
|
;; Not original and not tagged with top-interaction
|
|
#f])])]
|
|
[else #f])))
|
|
(let ([deriv* (adjust-deriv/lift deriv)])
|
|
deriv*))
|
|
|
|
)
|