993cd40208
For example, a new DrRacket window (with a file named tmp.rkt in the and 356 afterwards. This is under mac os x with, I believe, the default system font sizes. (The file is important because different languages can have different buttons in the toolbar and the filename's length itself can affect the minimum size.) Mostly this change is the addition of a new kind of panel that lets its children have multiple fixed sizes (as opposed to just a single minimum size and (optionally arbitrarily large)) It also adjusts the various toolbar buttons to use this new code. Also, there's a few tweaks to shrink other things that became the limiting factor in shrinking the width of the DrRacket window. Currently, at least for #lang racket programs, the toolbar buttons along the top of the window are the limiting factor (including the save button). With a bogus language (ie, #lang rackeeet), the bottom bar is the limiting factor, since that will have only the Save, Run, and Stop buttons. related to PR 13281
474 lines
18 KiB
Racket
474 lines
18 KiB
Racket
#lang racket/base
|
|
(require racket/unit
|
|
racket/gui/base
|
|
racket/class
|
|
framework
|
|
drracket/tool
|
|
mrlib/switchable-button
|
|
"model/trace.rkt"
|
|
"view/frame.rkt"
|
|
(only-in "view/view.rkt" macro-stepper-director%)
|
|
"view/stepper.rkt"
|
|
"view/prefs.rkt"
|
|
images/compile-time
|
|
(for-syntax racket/base images/icons/tool)
|
|
;; FIXME:
|
|
drracket/private/syncheck/local-member-names
|
|
drracket/private/eval-helpers)
|
|
|
|
;; Capability name: 'macro-stepper:enabled
|
|
|
|
(provide tool@)
|
|
|
|
(define-local-member-name allow-macro-stepper?)
|
|
(define-local-member-name run-macro-stepper)
|
|
|
|
(define frame/supports-macro-stepper<%>
|
|
(interface ()
|
|
allow-macro-stepper?
|
|
run-macro-stepper))
|
|
|
|
(define (drracket-macro-stepper-frame-mixin %)
|
|
(class %
|
|
(define/override (get-macro-stepper-widget%)
|
|
(macro-stepper-widget/process-mixin
|
|
(super get-macro-stepper-widget%)))
|
|
(super-new)))
|
|
|
|
(define macro-stepper-frame%
|
|
(drracket-macro-stepper-frame-mixin
|
|
(macro-stepper-frame-mixin
|
|
(frame:standard-menus-mixin
|
|
frame:basic%))))
|
|
|
|
(define drracket-macro-stepper-director%
|
|
(class macro-stepper-director%
|
|
(init-field filename)
|
|
(inherit-field stepper-frames)
|
|
(define eventspace (current-eventspace))
|
|
|
|
(define stepper #f)
|
|
(inherit new-stepper)
|
|
|
|
(define/private (lazy-new-stepper)
|
|
(unless stepper
|
|
(set! stepper (new-stepper))))
|
|
|
|
(define/override (add-trace events)
|
|
(parameterize ((current-eventspace eventspace))
|
|
(queue-callback
|
|
(lambda ()
|
|
(lazy-new-stepper)
|
|
(super add-trace events)))))
|
|
(define/override (add-deriv deriv)
|
|
(parameterize ((current-eventspace eventspace))
|
|
(queue-callback
|
|
(lambda ()
|
|
(lazy-new-stepper)
|
|
(super add-deriv deriv)))))
|
|
|
|
(define/override (new-stepper-frame)
|
|
(parameterize ((current-eventspace eventspace))
|
|
(new macro-stepper-frame%
|
|
(config (new macro-stepper-config/prefs%))
|
|
(filename filename)
|
|
(director this))))
|
|
|
|
(define/public (shutdown)
|
|
(when (pref:close-on-reset-console?)
|
|
(for ([(frame flags) (in-hash stepper-frames)])
|
|
(unless (memq 'no-obsolete flags)
|
|
(send frame show #f)))))
|
|
|
|
(super-new)))
|
|
|
|
|
|
(define macro-stepper-button-label "Macro Stepper")
|
|
|
|
(define macro-debugger-bitmap (compiled-bitmap (macro-stepper-icon)))
|
|
(define small-macro-debugger-bitmap (compiled-bitmap (small-macro-stepper-icon)))
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drracket:tool^)
|
|
(export drracket:tool-exports^)
|
|
|
|
(define (phase1)
|
|
(drracket:module-language-tools:add-opt-out-toolbar-button
|
|
(λ (frame parent)
|
|
(new switchable-button%
|
|
(label macro-stepper-button-label)
|
|
(bitmap macro-debugger-bitmap)
|
|
(alternate-bitmap small-macro-debugger-bitmap)
|
|
(parent parent)
|
|
(callback (lambda (button) (send frame run-macro-stepper)))))
|
|
'macro-stepper
|
|
#:number 70)
|
|
(drracket:language:register-capability
|
|
'macro-stepper:enabled
|
|
boolean?
|
|
#f))
|
|
(define (phase2) (void))
|
|
|
|
(define drracket-eventspace (current-eventspace))
|
|
(define drracket-custodian (current-custodian))
|
|
|
|
(define-local-member-name check-language)
|
|
|
|
(define (macro-debugger-unit-frame-mixin %)
|
|
(class* % (frame/supports-macro-stepper<%>)
|
|
(super-new)
|
|
(inherit get-button-panel
|
|
get-language-menu
|
|
get-interactions-text
|
|
get-definitions-text
|
|
get-top-level-window
|
|
ensure-rep-hidden
|
|
get-current-tab)
|
|
|
|
(define macro-debug-panel
|
|
(new panel:horizontal-discrete-sizes%
|
|
(parent (get-button-panel))))
|
|
(define macro-debug-button
|
|
(new switchable-button%
|
|
(label macro-stepper-button-label)
|
|
(bitmap macro-debugger-bitmap)
|
|
(alternate-bitmap small-macro-debugger-bitmap)
|
|
(parent macro-debug-panel)
|
|
(callback (lambda (button) (run-macro-stepper)))))
|
|
(inherit register-toolbar-button)
|
|
(register-toolbar-button macro-debug-button #:number 70)
|
|
|
|
(define/augment (enable-evaluation)
|
|
(send macro-debug-button enable #t)
|
|
(inner (void) enable-evaluation))
|
|
(define/augment (disable-evaluation)
|
|
(send macro-debug-button enable #f)
|
|
(inner (void) disable-evaluation))
|
|
|
|
(define macro-debug-menu-item
|
|
(let ([lang-menu (get-language-menu)])
|
|
(new separator-menu-item% (parent lang-menu))
|
|
(new menu-item%
|
|
(label "Macro Stepper")
|
|
(parent lang-menu)
|
|
(callback (lambda _ (run-macro-stepper))))))
|
|
|
|
;; 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)
|
|
(enable/disable-stuff (allow-macro-stepper?)))
|
|
|
|
(define/public (allow-macro-stepper?)
|
|
(let ([lang
|
|
(drracket:language-configuration:language-settings-language
|
|
(send (get-definitions-text) get-next-settings))])
|
|
(send lang capability-value 'macro-stepper:enabled)))
|
|
|
|
(define/private (enable/disable-stuff enable?)
|
|
(if enable?
|
|
(begin (send macro-debug-menu-item enable #t)
|
|
(unless (send macro-debug-button is-shown?)
|
|
(send macro-debug-panel
|
|
add-child macro-debug-button)))
|
|
(begin (send macro-debug-menu-item enable #f)
|
|
(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/public-final (run-macro-stepper)
|
|
|
|
;; FIXME!!! Lots of this is copied out of drracket/private/syncheck/gui.rkt
|
|
;; except some of the code (eg error handling) thrown away to avoid pulling
|
|
;; in lots more. Need to abstract.
|
|
|
|
(ensure-rep-hidden)
|
|
(define definitions-text (get-definitions-text))
|
|
(define interactions-text (get-interactions-text))
|
|
(define drs-eventspace (current-eventspace))
|
|
(define drs-custodian (current-custodian))
|
|
(define the-tab (get-current-tab))
|
|
(define-values (old-break-thread old-custodian) (send the-tab get-breakables))
|
|
(define error-port (send (send the-tab get-error-report-text) get-err-port))
|
|
(define output-port (send (send the-tab get-error-report-text) get-out-port))
|
|
(send the-tab disable-evaluation) ;; this locks the editor, so must be outside.
|
|
(define settings (send definitions-text get-next-settings))
|
|
(define module-language?
|
|
(is-a? (drracket:language-configuration:language-settings-language settings)
|
|
drracket:module-language:module-language<%>))
|
|
(define error-display-semaphore (make-semaphore 0))
|
|
|
|
;; --
|
|
|
|
(define user-custodian #f)
|
|
(define normal-termination? #f)
|
|
(define original-module-name-resolver #f)
|
|
|
|
;; --
|
|
|
|
(define director
|
|
(parameterize ((current-eventspace drracket-eventspace)
|
|
(current-custodian drracket-custodian))
|
|
(let ([filename (send definitions-text get-filename/untitled-name)])
|
|
(new drracket-macro-stepper-director% (filename filename)))))
|
|
(send interactions-text set-macro-stepper-director director)
|
|
|
|
(define (the-module-name-resolver . args)
|
|
(parameterize ((current-expand-observe void))
|
|
(apply original-module-name-resolver args)))
|
|
|
|
;; --
|
|
|
|
(define (init-proc) ;; =user=
|
|
(set! original-module-name-resolver (current-module-name-resolver))
|
|
(current-module-name-resolver the-module-name-resolver)
|
|
|
|
(send the-tab set-breakables (current-thread) (current-custodian))
|
|
(set-directory definitions-text)
|
|
(current-load-relative-directory #f)
|
|
(current-error-port error-port)
|
|
(current-output-port output-port)
|
|
(error-display-handler
|
|
(λ (msg exn) ;; =user=
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(λ () ;; =drs=
|
|
;; this has to come first or else the positioning
|
|
;; computations in the highlight-errors/exn method
|
|
;; will be wrong by the size of the error report box
|
|
(show-error-report/tab)
|
|
;; a call like this one also happens in
|
|
;; drracket:debug:error-display-handler/stacktrace
|
|
;; but that call won't happen here, because
|
|
;; the rep is not in the current-rep parameter
|
|
(send interactions-text highlight-errors/exn exn))))
|
|
(drracket:debug:error-display-handler/stacktrace
|
|
msg exn '()
|
|
#:definitions-text definitions-text)
|
|
(semaphore-post error-display-semaphore)))
|
|
(error-print-source-location #f) ; need to build code to render error first
|
|
(uncaught-exception-handler
|
|
(let ([oh (uncaught-exception-handler)])
|
|
(λ (exn)
|
|
(uncaught-exception-raised)
|
|
(oh exn))))
|
|
(set! user-custodian (current-custodian)))
|
|
|
|
(define (uncaught-exception-raised) ;; =user=
|
|
(set! normal-termination? #t)
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(cleanup)
|
|
(custodian-shutdown-all user-custodian)))))
|
|
(define (show-error-report/tab) ;; =drs=
|
|
(send the-tab turn-on-error-report)
|
|
(send (send the-tab get-error-report-text) scroll-to-position 0)
|
|
(when (eq? (get-current-tab) the-tab)
|
|
;; (show-error-report)
|
|
(void)))
|
|
(define (cleanup) ;; =drs=
|
|
(send the-tab set-breakables old-break-thread old-custodian)
|
|
(send the-tab enable-evaluation)
|
|
;; do this with some lag ... not great, but should be okay.
|
|
(let ([err-port (send (send the-tab get-error-report-text) get-err-port)])
|
|
(thread
|
|
(λ ()
|
|
(flush-output err-port)
|
|
(queue-callback
|
|
(λ ()
|
|
(unless (= 0 (send (send the-tab get-error-report-text) last-position))
|
|
(show-error-report/tab))))))))
|
|
(define (kill-termination)
|
|
(unless normal-termination?
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(λ ()
|
|
(cleanup)
|
|
(custodian-shutdown-all user-custodian))))))
|
|
|
|
(with-lock/edit-sequence definitions-text
|
|
(lambda ()
|
|
(send the-tab clear-annotations)
|
|
(send the-tab reset-offer-kill)
|
|
(define get-terms
|
|
(drracket:eval:traverse-program/multiple
|
|
settings init-proc kill-termination
|
|
#:gui-modules? #f))
|
|
(get-terms
|
|
(drracket:language:make-text/pos definitions-text
|
|
0
|
|
(send definitions-text last-position))
|
|
(λ (sexp loop) ; =user=
|
|
(cond [(eof-object? sexp)
|
|
(set! normal-termination? #t)
|
|
(parameterize ([current-eventspace drs-eventspace])
|
|
(queue-callback
|
|
(λ () ; =drs=
|
|
(cleanup)
|
|
(custodian-shutdown-all user-custodian))))]
|
|
[(syntax? sexp)
|
|
(let-values ([(e-expr events derivp) (expand+trace sexp)])
|
|
(send director add-trace events)
|
|
(cond [(syntax? e-expr)
|
|
;; FIXME: eval compile-time parts?
|
|
(void)]
|
|
[else (raise e-expr)]))
|
|
(loop)]
|
|
[else
|
|
(eprintf "Got non-syntax: ~e" sexp)
|
|
(loop)]))
|
|
#t)))
|
|
(void))
|
|
|
|
;; set-directory : text -> void
|
|
;; sets the current-directory based on the file saved in the definitions-text
|
|
(define/private (set-directory definitions-text)
|
|
(define tmp-b (box #f))
|
|
(define fn (send definitions-text get-filename tmp-b))
|
|
(define dir (get-init-dir (and (not (unbox tmp-b)) fn)))
|
|
(current-directory dir))
|
|
|
|
;; with-lock/edit-sequence : text (-> void) -> void
|
|
;; sets and restores some state of the definitions text
|
|
;; so that edits to the definitions text work out.
|
|
(define/private (with-lock/edit-sequence definitions-text thnk)
|
|
(let* ([locked? (send definitions-text is-locked?)])
|
|
(send definitions-text begin-edit-sequence)
|
|
(send definitions-text lock #f)
|
|
(thnk)
|
|
(send definitions-text end-edit-sequence)
|
|
(send definitions-text lock locked?)))
|
|
|
|
(define/private (expand+trace expr)
|
|
(define (handle-macro-limit c)
|
|
(define option
|
|
(message-box/custom
|
|
"Macro stepper"
|
|
(string-append "Macro expansion has taken a suspiciously large number of steps.\n"
|
|
"\n"
|
|
"Click Stop to stop macro expansion and see the steps taken "
|
|
"so far, or click Continue to let it run a bit longer.")
|
|
"Continue"
|
|
"Stop"
|
|
#f
|
|
(get-top-level-window)))
|
|
(case option
|
|
((2) (error "Macro expansion was stopped because it took too many steps."))
|
|
(else (* 2 c))))
|
|
(parameterize ((trace-macro-limit (pref:macro-step-limit))
|
|
(trace-limit-handler handle-macro-limit))
|
|
(trace* expr)))
|
|
|
|
))
|
|
|
|
;; ============================================================
|
|
|
|
;; Catch modifications => obsolete macro stepper
|
|
(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))
|
|
|
|
;; Borrowed from stepper/stepper-tool
|
|
(define metadata-changing-now? #f)
|
|
|
|
(define modified-since-macro-stepper? #f) ;; mutable
|
|
(define/public (modified-since-macro-stepper ?)
|
|
(set! modified-since-macro-stepper? ?))
|
|
|
|
;; don't pay attention to changes that occur on metadata.
|
|
;; this assumes that metadata changes cannot be nested.
|
|
(define/augment (begin-metadata-changes)
|
|
(set! metadata-changing-now? #t)
|
|
(inner (void) begin-metadata-changes))
|
|
|
|
(define/augment (end-metadata-changes)
|
|
(set! metadata-changing-now? #f)
|
|
(inner (void) end-metadata-changes))
|
|
|
|
(define/private (notify-macro-stepper-of-change)
|
|
(unless modified-since-macro-stepper?
|
|
(set! modified-since-macro-stepper? #f)
|
|
(let ([win (get-top-level-window)])
|
|
;; should only be #f when win is #f
|
|
(when (is-a? win drracket:unit:frame<%>)
|
|
(send (send win get-interactions-text)
|
|
obsolete-macro-stepper)))))
|
|
|
|
;; Catch program changes and mark macro stepper obsolete.
|
|
(define/augment (on-insert x y)
|
|
(unless metadata-changing-now?
|
|
(notify-macro-stepper-of-change))
|
|
(inner (void) on-insert x y))
|
|
|
|
(define/augment (on-delete x y)
|
|
(unless metadata-changing-now?
|
|
(notify-macro-stepper-of-change))
|
|
(inner (void) on-delete x y))
|
|
|
|
(super-new)))
|
|
|
|
;; Catch reset => obsolete macro stepper
|
|
(define (macro-debugger-interactions-text-mixin %)
|
|
(class %
|
|
(define current-stepper-director #f)
|
|
(inherit get-top-level-window)
|
|
(super-new)
|
|
|
|
(define/override (reset-console)
|
|
(obsolete-macro-stepper)
|
|
(when current-stepper-director
|
|
(send current-stepper-director shutdown)
|
|
(set! current-stepper-director #f))
|
|
(super reset-console))
|
|
|
|
(define/public (obsolete-macro-stepper)
|
|
(when current-stepper-director
|
|
(send current-stepper-director add-obsoleted-warning)))
|
|
|
|
(define/public (set-macro-stepper-director director)
|
|
(set! current-stepper-director director))
|
|
))
|
|
|
|
;; Macro debugger code
|
|
|
|
(drracket:get/extend:extend-unit-frame
|
|
macro-debugger-unit-frame-mixin)
|
|
(drracket:get/extend:extend-interactions-text
|
|
macro-debugger-interactions-text-mixin)
|
|
(drracket:get/extend:extend-definitions-text
|
|
macro-debugger-definitions-text-mixin)
|
|
|
|
(define (add-macro-stepper-key-bindings keymap)
|
|
(send keymap add-function
|
|
"macro stepper"
|
|
(lambda (obj evt)
|
|
(when (is-a? obj editor<%>)
|
|
(let ([canvas (send obj get-canvas)])
|
|
(when canvas
|
|
(let ([frame (send canvas get-top-level-window)])
|
|
(when (is-a? frame frame/supports-macro-stepper<%>)
|
|
(when (send frame allow-macro-stepper?)
|
|
(send frame run-macro-stepper)))))))))
|
|
(send keymap map-function "c:c;c:m" "macro stepper"))
|
|
|
|
(add-macro-stepper-key-bindings (drracket:rep:get-drs-bindings-keymap))
|
|
))
|