diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 52293e6fa9..6fb8e15279 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -86,7 +86,8 @@ module browser threading seems wrong. (define definitions-text<%> (interface () get-tab - change-mode-to-match)) + get-next-settings + after-set-next-settings)) (keymap:add-to-right-button-menu (let ([old (keymap:add-to-right-button-menu)]) @@ -420,7 +421,7 @@ module browser threading seems wrong. get-language-position))]) (let loop ([modes (drscheme:modes:get-modes)]) (cond - [(null? modes) (error 'change-mode-to-match-filename + [(null? modes) (error 'change-mode-to-match "didn't find a matching mode")] [else (let ([mode (car modes)]) (if ((drscheme:modes:mode-matches-language mode) language-name) @@ -467,7 +468,11 @@ module browser threading seems wrong. (define/pubment (get-next-settings) next-settings) (define/pubment (set-next-settings _next-settings) (set! next-settings _next-settings) - (change-mode-to-match)) + (change-mode-to-match) + (after-set-next-settings _next-settings)) + + (define/pubment (after-set-next-settings s) + (inner (void) after-set-next-settings s)) (define/public (needs-execution) (or needs-execution-state diff --git a/collects/mztake/debug-tool.ss b/collects/mztake/debug-tool.ss index 7195654835..bd406ee960 100644 --- a/collects/mztake/debug-tool.ss +++ b/collects/mztake/debug-tool.ss @@ -15,7 +15,7 @@ "annotator.ss" "load-sandbox.ss" ;(lib "framework.ss" "framework") - #;(lib "string-constant.ss" "string-constants") + (lib "string-constant.ss" "string-constants") ) (provide tool@) @@ -23,13 +23,24 @@ ; QUESTIONS/IDEAS ; what is the right way to deal with macros? ; how can the three tool classes communicate with each other safely - + (define tool@ (unit/sig drscheme:tool-exports^ (import drscheme:tool^) (define phase1 void) (define phase2 void) + + (define (extract-language-level settings) + (let* ([language (drscheme:language-configuration:language-settings-language settings)]) + (car (last-pair (send language get-language-position))))) + + (define (debugger-does-not-work-for? lang) + (member lang (list (string-constant beginning-student) + (string-constant beginning-student/abbrev) + (string-constant intermediate-student) + (string-constant intermediate-student/lambda) + (string-constant advanced-student)))) (define (break-at bp p) (hash-table-get bp p)) @@ -404,7 +415,11 @@ [else (send dc set-pen pc-pen) (send dc set-brush pc-brush)])) (drscheme:arrow:draw-arrow dc xm0 ym0 xr ym dx dy) - (loop start-pos (rest marks))))))))))) + (loop start-pos (rest marks))))))))) + + (define/augment (after-set-next-settings s) + (send (get-top-level-window) check-current-language-for-debugger) + (inner (void) after-set-next-settings s)))) (define (debug-interactions-text-mixin super%) (class super% @@ -728,7 +743,7 @@ ((bitmap-label-maker "Debug" (build-path (collection-path "mztake" "icons") "icon-small.png")) this) - (get-button-panel) + (make-object vertical-pane% (get-button-panel)) (lambda (button evt) (my-execute #t)))) @@ -778,11 +793,26 @@ [label ""] [parent debug-panel] [stretchable-width #t])) + + (define/augment (on-tab-change old new) + (check-current-language-for-debugger) + (inner (void) on-tab-change old new)) + + (define/public (check-current-language-for-debugger) + (if (debugger-does-not-work-for? (extract-language-level + (send (get-definitions-text) get-next-settings))) + (when (send debug-button is-shown?) + (send (send debug-button get-parent) delete-child debug-button)) + (unless (send debug-button is-shown?) + (send (send debug-button get-parent) add-child debug-button)))) (send (get-button-panel) change-children (lambda (_) - (cons debug-button - (remq debug-button _)))))) + (cons (send debug-button get-parent) + (remq (send debug-button get-parent) _)))) + + ; hide debug button if it's not supported for the initial language: + (check-current-language-for-debugger))) (drscheme:get/extend:extend-definitions-text debug-definitions-text-mixin) (drscheme:get/extend:extend-interactions-text debug-interactions-text-mixin) (drscheme:get/extend:extend-unit-frame debug-unit-frame-mixin)))) diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 3c8d86c208..317b3f9b98 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -31,7 +31,7 @@ (string-constant intermediate-student) (string-constant intermediate-student/lambda) (string-constant advanced-student))) - + (provide stepper-tool@) (define stepper-tool@ @@ -48,6 +48,14 @@ (define stepper-initial-height 500) (define drscheme-eventspace (current-eventspace)) + + (define (extract-language-level settings) + (let* ([language (drscheme:language-configuration:language-settings-language settings)]) + (car (last-pair (send language get-language-position))))) + + (define (stepper-works-for? language-level) + (or (member language-level stepper-works-for) + (getenv "PLTSTEPPERUNSAFE"))) ;; the stepper's frame: @@ -477,17 +485,15 @@ (define stepper-button (make-object button% (x:stepper-bitmap this) - (get-button-panel) + (make-object vertical-pane% (get-button-panel)) (lambda (button evt) (if stepper-frame (send stepper-frame show #t) - (let* ([settings (send (get-definitions-text) get-next-settings)] - [language (drscheme:language-configuration:language-settings-language settings)] - [language-level (car (last-pair (send language get-language-position)))]) - (if (or (member language-level stepper-works-for) - (getenv "PLTSTEPPERUNSAFE")) - (set! stepper-frame (view-controller-go this program-expander)) - (message-box (string-constant stepper-name) + (let ([language-level (extract-language-level + (send (get-definitions-text) get-next-settings))]) + (if (stepper-works-for? language-level) + (set! stepper-frame (view-controller-go this program-expander)) + (message-box (string-constant stepper-name) (format (string-constant stepper-language-level-message) language-level (car stepper-works-for) @@ -506,10 +512,26 @@ (when stepper-frame (send stepper-frame original-program-gone)) (inner (void) on-close)) + + (define/augment (on-tab-change old new) + (check-current-language-for-stepper) + (inner (void) on-tab-change old new)) + + (define/public (check-current-language-for-stepper) + (if (stepper-works-for? (extract-language-level + (send (get-definitions-text) get-next-settings))) + (unless (send stepper-button is-shown?) + (send (send stepper-button get-parent) add-child stepper-button)) + (when (send stepper-button is-shown?) + (send (send stepper-button get-parent) delete-child stepper-button)))) ; add the stepper button to the button panel: - (send (get-button-panel) change-children - (lx (cons stepper-button (remq stepper-button _)))))) + (let ([p (send stepper-button get-parent)]) + (send (get-button-panel) change-children + (lx (cons p (remq p _))))) + + ; hide stepper button if it's not supported for the initial language: + (check-current-language-for-stepper))) ;; stepper-definitions-text-mixin : a mixin for the definitions text that alerts thet stepper when the definitions ;; text is altered or destroyed @@ -531,6 +553,10 @@ (define/augment (on-delete x y) (notify-stepper-frame-of-change) (inner (void) on-delete x y)) + + (define/augment (after-set-next-settings s) + (send (get-top-level-window) check-current-language-for-stepper) + (inner (void) after-set-next-settings s)) (super-instantiate ())))