diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 48e4141774..1810de534c 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -1,5 +1,5 @@ (module stepper-tool mzscheme - + (require (lib "contract.ss") (lib "tool.ss" "drscheme") (lib "mred.ss" "mred") @@ -11,73 +11,81 @@ (lib "class.ss") (lib "list.ss") (prefix model: "private/model.ss") - "private/my-macros.ss" + "private/my-macros.ss" (prefix x: "private/mred-extensions.ss") "private/shared.ss" "private/model-settings.ss") - ; hidden invariant: this list should be a sublist of the language-level dialog (i.e., same order): + ;; hidden invariant: this list should be a sublist of the language-level + ;; dialog (i.e., same order): (define stepper-works-for (list (string-constant beginning-student) (string-constant beginning-student/abbrev) (string-constant intermediate-student) (string-constant intermediate-student/lambda) - #;(string-constant advanced-student))) + #;(string-constant advanced-student) + )) (provide stepper-tool@) - + (define stepper-tool@ (unit/sig drscheme:tool-exports^ - (import drscheme:tool^ - (xml-snip% scheme-snip%)) - - ; tool magic here: + (import drscheme:tool^ (xml-snip% scheme-snip%)) + + ;; tool magic here: (define (phase1) (void)) (define (phase2) (void)) - + ;; this should be a preference (define stepper-initial-width 500) (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))))) - + (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"))) - + (or (member language-level stepper-works-for) + (getenv "PLTSTEPPERUNSAFE"))) + ;; the stepper's frame: - (define stepper-frame% - (class (drscheme:frame:basics-mixin (frame:frame:standard-menus-mixin frame:frame:basic%)) - + (class (drscheme:frame:basics-mixin + (frame:frame:standard-menus-mixin frame:frame:basic%)) + (init-field drscheme-frame) - - ;; PRINTING-PROC - ;; I frankly don't think that printing (i.e., to a printer) works correctly. 2005-07-01, JBC + + ;; PRINTING-PROC + ;; I frankly don't think that printing (i.e., to a printer) works + ;; correctly. 2005-07-01, JBC (public set-printing-proc) - + (define (set-printing-proc proc) (set! printing-proc proc)) - + (define (printing-proc item evt) (message-box "error?" "shouldn't be called")) - + (define/private (file-menu:print a b) (printing-proc a b)) - + ;; MENUS - - (define/override (edit-menu:between-find-and-preferences edit-menu) (void)) - (define/override (edit-menu:between-select-all-and-find edit-menu) (void)) - (define/override (file-menu:between-save-as-and-print file-menu) (void)) - + + (define/override (edit-menu:between-find-and-preferences edit-menu) + (void)) + (define/override (edit-menu:between-select-all-and-find edit-menu) + (void)) + (define/override (file-menu:between-save-as-and-print file-menu) + (void)) + ;; CUSTODIANS - ;; The custodian is used to halt the stepped computation when the stepper window - ;; closes. The custodian is captured when the stepped computation starts. - + ;; The custodian is used to halt the stepped computation when the + ;; stepper window closes. The custodian is captured when the stepped + ;; computation starts. + (define custodian #f) (define/public (set-custodian! cust) (set! custodian cust)) @@ -86,86 +94,87 @@ (custodian-shutdown-all custodian)) (send drscheme-frame on-stepper-close) (inner (void) on-close)) - + ;; WARNING BOXES: - - (define program-changed-warning-str (string-constant stepper-program-has-changed)) - (define window-closed-warning-str (string-constant stepper-program-window-closed)) - + + (define program-changed-warning-str + (string-constant stepper-program-has-changed)) + (define window-closed-warning-str + (string-constant stepper-program-window-closed)) + (define warning-message-visible-already #f) (define/private (add-warning-message warning-str) - (let ([warning-msg (instantiate x:stepper-warning% () - (warning-str warning-str) - (parent (get-area-container)))]) + (let ([warning-msg (new x:stepper-warning% + [warning-str warning-str] + [parent (get-area-container)])]) (send (get-area-container) change-children (if warning-message-visible-already - (lambda (l) - (list (car l) - warning-msg - (caddr l))) - (lambda (l) - (list (car l) - warning-msg - (cadr l))))) + (lambda (l) + (list (car l) warning-msg (caddr l))) + (lambda (l) + (list (car l) warning-msg (cadr l))))) (set! warning-message-visible-already #t))) - + (inherit get-area-container) (define program-change-already-warned? #f) (define/public (original-program-changed) (unless program-change-already-warned? (set! program-change-already-warned? #t) (add-warning-message program-changed-warning-str))) - + (define/public (original-program-gone) (add-warning-message window-closed-warning-str)) - - - (super-instantiate ("Stepper" #f stepper-initial-width stepper-initial-height)))) - - - ;; view-controller-go: called when the stepper starts; starts the stepper's view&controller + + (super-new [label "Stepper"] [parent #f] + [width stepper-initial-width] + [height stepper-initial-height]))) + + ;; view-controller-go: called when the stepper starts; starts the + ;; stepper's view&controller ;; drscheme-frame : the drscheme frame which is starting the stepper - ;; program-expander : see "model.ss" for the contract on a program-expander + ;; program-expander : see "model.ss" for the contract on a + ;; program-expander ;; -> returns the new frame% (define (view-controller-go drscheme-frame program-expander) - + ;; get the language-level name: - (define language-settings + (define language-settings (send (send drscheme-frame get-definitions-text) get-next-settings)) (define language - (drscheme:language-configuration:language-settings-language language-settings)) + (drscheme:language-configuration:language-settings-language + language-settings)) (define language-level-name (car (last-pair (send language get-language-position)))) - - + ;; VALUE CONVERSION CODE: - + (define simple-settings - (drscheme:language-configuration:language-settings-settings language-settings)) - + (drscheme:language-configuration:language-settings-settings + language-settings)) + ;; render-to-string : TST -> string (define (render-to-string val) (let ([string-port (open-output-string)]) - (send language - render-value - val - simple-settings - string-port) + (send language render-value val simple-settings string-port) (get-output-string string-port))) - + ;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC) - - ;; make-print-convert-hook: simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) + + ;; make-print-convert-hook: + ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) ;; this code copied from various locations in language.ss and rep.ss (define (make-print-convert-hook simple-settings) (lambda (exp basic-convert sub-convert) (cond - [(is-a? exp snip%) + [(is-a? exp snip%) (send exp copy)] - #;[((drscheme:rep:use-number-snip) exp) - (let ([number-snip-type (drscheme:language:simple-settings-fraction-style simple-settings)]) + #; + [((drscheme:rep:use-number-snip) exp) + (let ([number-snip-type + (drscheme:language:simple-settings-fraction-style + simple-settings)]) (cond [(eq? number-snip-type 'repeating-decimal) (drscheme:number-snip:make-repeating-decimal-snip exp #f)] @@ -180,197 +189,216 @@ "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e" number-snip-type)]))] [else (basic-convert exp)]))) - + ;; render-to-sexp : TST -> sexp (define (render-to-sexp val) (cond - [(string=? language-level-name "ACL2 Beginner (beta 8)") + [(string=? language-level-name "ACL2 Beginner (beta 8)") (simple-module-based-language-convert-value val simple-settings)] - [else (parameterize ([current-print-convert-hook (make-print-convert-hook simple-settings)]) + [else (parameterize ([current-print-convert-hook + (make-print-convert-hook simple-settings)]) (set-print-settings language simple-settings - (lambda () - (simple-module-based-language-convert-value val simple-settings))))])) - - (define (>>> x) - (fprintf (current-error-port) ">>> ~v\n" x) - x) - - ; channel for incoming views + (lambda () + (simple-module-based-language-convert-value + val simple-settings))))])) + + ;; channel for incoming views (define view-channel (make-async-channel)) - - ; the semaphore associated with the view at the end of the view-history - ; note that because these are fresh semaphores for every step, posting to a semaphore - ; multiple times is no problem. + + ;; the semaphore associated with the view at the end of the + ;; view-history note that because these are fresh semaphores for every + ;; step, posting to a semaphore multiple times is no problem. (define release-for-next-step #f) - - ; the list of available views + + ;; the list of available views (define view-history null) - - ; the view in the stepper window + + ;; the view in the stepper window (define view 0) - - ; whether the stepper is waiting for a new view to become available - ; (initially 'waiting-for-any-step) - ; possible values: #f, 'waiting-for-any-step, 'waiting-for-application + + ;; whether the stepper is waiting for a new view to become available + ;; (initially 'waiting-for-any-step) + ;; possible values: #f, 'waiting-for-any-step, 'waiting-for-application (define stepper-is-waiting? 'waiting-for-any-step) - - ; hand-off-and-block : (-> text%? boolean? void?) - ; hand-off-and-block generates a new semaphore, hands off a thunk to drscheme's eventspace, - ; and blocks on the new semaphore. The thunk adds the text% to the waiting queue, and checks - ; to see if the stepper is waiting for a new step. If so, takes that new text% out of the - ; queue and puts it on the list of available ones. If the stepper is waiting for a new step, - ; it checks to see whether this is of the kind that the stepper wants. If so, display it. - ; otherwise, release the stepped program to continue execution. - + + ;; hand-off-and-block : (-> text%? boolean? void?) + ;; hand-off-and-block generates a new semaphore, hands off a thunk to + ;; drscheme's eventspace, and blocks on the new semaphore. The thunk + ;; adds the text% to the waiting queue, and checks to see if the + ;; stepper is waiting for a new step. If so, takes that new text% out + ;; of the queue and puts it on the list of available ones. If the + ;; stepper is waiting for a new step, it checks to see whether this is + ;; of the kind that the stepper wants. If so, display it. otherwise, + ;; release the stepped program to continue execution. (define (hand-off-and-block step-text step-kind) (let ([new-semaphore (make-semaphore)]) (run-on-drscheme-side (lambda () - (async-channel-put view-channel (list step-text new-semaphore step-kind)) + (async-channel-put view-channel + (list step-text new-semaphore step-kind)) (when stepper-is-waiting? (let ([try-get (async-channel-try-get view-channel)]) (unless try-get - (error 'check-for-stepper-waiting "queue is empty, even though a step was just added.")) + (error + 'check-for-stepper-waiting + "queue is empty, even though a step was just added")) (add-view-triple try-get) (if (right-kind-of-step? (caddr try-get)) - ; got the desired step; show the user: - (begin - (set! stepper-is-waiting? #f) - (update-view/existing (- (length view-history) 1))) - ; nope, keep running: - (begin - (en/dis-able-buttons) - (semaphore-post new-semaphore))))))) + ;; got the desired step; show the user: + (begin (set! stepper-is-waiting? #f) + (update-view/existing (- (length view-history) 1))) + ;; nope, keep running: + (begin (en/dis-able-buttons) + (semaphore-post new-semaphore))))))) (semaphore-wait new-semaphore))) - + ;; run-on-drscheme-side : runs a thunk in the drscheme eventspace. ;; Passed to 'go' so that display-break-stuff can work. This would be ;; cleaner with two-way provides. (define (run-on-drscheme-side thunk) (parameterize ([current-eventspace drscheme-eventspace]) (queue-callback thunk))) - - ; right-kind-of-step? : (boolean? . -> . boolean?) - ; is this step the kind of step that the gui is waiting for? + + ;; right-kind-of-step? : (boolean? . -> . boolean?) + ;; is this step the kind of step that the gui is waiting for? (define (right-kind-of-step? step-kind) (case stepper-is-waiting? [(waiting-for-any-step) #t] - [(waiting-for-application) (or (eq? step-kind 'user-application) - (eq? step-kind 'finished-stepping))] + [(waiting-for-application) + (or (eq? step-kind 'user-application) + (eq? step-kind 'finished-stepping))] [(#f) (error 'right-kind-of-step "this code should be unreachable with stepper-is-waiting? set to #f")] [else (error 'right-kind-of-step "unknown value for stepper-is-waiting?: ~a" stepper-is-waiting?)])) - + ;; add-view-triple : set the release-semaphore to be the new one, add the view to the list. (define (add-view-triple view-triple) (set! release-for-next-step (cadr view-triple)) - (set! view-history (append view-history (list (list (car view-triple) (caddr view-triple)))))) - - ;; find-later-application-step : search through the history, starting at 'n', for an application step. + (set! view-history (append view-history + (list (list (car view-triple) + (caddr view-triple)))))) + + ;; find-later-application-step : search through the history, starting + ;; at 'n', for an application step. (define (find-later-application-step n) (let ([history-length (length view-history)]) (let loop ([step (+ n 1)]) (cond [(>= step history-length) #f] [(application-step? (list-ref view-history step)) step] [else (loop (+ step 1))])))) - + ;; is this an application step? (define (application-step? history-entry) (case (cadr history-entry) [(user-application finished stepping) #t] [else #f])) - - ; build gui object: - + + ;; build gui object: + ;; home : the action of the 'home' button (define (home) (when stepper-is-waiting? (set! stepper-is-waiting? #f)) (update-view/existing 0)) - + ;; next : the action of the 'next' button (define (next) (let ([new-view (+ view 1)]) (if (< new-view (length view-history)) - (update-view/existing new-view) - (begin - (semaphore-post release-for-next-step) ; each step has its own semaphore, so releasing one twice is no problem. - (when stepper-is-waiting? - (error 'try-to-get-view "try-to-get-view should not be reachable when already waiting for new step")) - (let ([try-get (async-channel-try-get view-channel)]) - (if try-get - (begin - (add-view-triple try-get) - (update-view/existing new-view)) - (begin - (set! stepper-is-waiting? 'waiting-for-any-step) - (en/dis-able-buttons)))))))) - + (update-view/existing new-view) + (begin + (semaphore-post release-for-next-step) ; each step has its own semaphore, so releasing one twice is no problem. + (when stepper-is-waiting? + (error 'try-to-get-view "try-to-get-view should not be reachable when already waiting for new step")) + (let ([try-get (async-channel-try-get view-channel)]) + (if try-get + (begin (add-view-triple try-get) + (update-view/existing new-view)) + (begin (set! stepper-is-waiting? 'waiting-for-any-step) + (en/dis-able-buttons)))))))) + ;; next-application : the action of the 'next-application' button - ;; NB: while this function looks a lot like (next), the abstractions of the two that I came up with - ;; were hard to read. So I left them separate -- JBC + ;; NB: while this function looks a lot like (next), the abstractions of + ;; the two that I came up with were hard to read. So I left them + ;; separate -- JBC (define (next-application) (let ([next-application-step (find-later-application-step view)]) (if next-application-step - (update-view/existing next-application-step) - (begin - (semaphore-post release-for-next-step) ; each step has its own semaphore, so releasing one twice is no problem. - (when stepper-is-waiting? - (error 'try-to-get-view "try-to-get-view should not be reachable when already waiting for new step")) - (let ([try-get (async-channel-try-get view-channel)]) - (if try-get - (begin - (add-view-triple try-get) - (if (application-step? (list-ref view-history (+ view 1))) - (update-view/existing (+ view 1)) - (begin - (set! stepper-is-waiting? 'waiting-for-application) - (en/dis-able-buttons)))) + (update-view/existing next-application-step) + (begin + ;; each step has its own semaphore, so releasing one twice is + ;; no problem. + (semaphore-post release-for-next-step) + (when stepper-is-waiting? + (error 'try-to-get-view + "try-to-get-view should not be reachable when already waiting for new step")) + (let ([try-get (async-channel-try-get view-channel)]) + (if try-get + (begin + (add-view-triple try-get) + (if (application-step? (list-ref view-history (+ view 1))) + (update-view/existing (+ view 1)) (begin (set! stepper-is-waiting? 'waiting-for-application) - (en/dis-able-buttons)))))))) - - ;; previous : the action of the 'previous' button + (en/dis-able-buttons)))) + (begin + (set! stepper-is-waiting? 'waiting-for-application) + (en/dis-able-buttons)))))))) + + ;; previous : the action of the 'previous' button (define (previous) (when stepper-is-waiting? (set! stepper-is-waiting? #f)) (when (= view 0) - (error 'previous-application "previous-step button should not be enabled in view zero.")) + (error 'previous-application + "previous-step button should not be enabled in view zero.")) (update-view/existing (- view 1))) - - ;; previous-application : the action of the 'previous-application' button + + ;; previous-application : the action of the 'previous-application' + ;; button (define (previous-application) (when stepper-is-waiting? (set! stepper-is-waiting? #f)) (when (= view 0) - (error 'previous-application "previous-application button should not be enabled in view zero.")) + (error 'previous-application + "previous-application button should not be enabled in view zero.")) (let loop ([new-view (- view 1)]) (cond [(= new-view 0) (update-view/existing new-view)] [(application-step? (list-ref view-history new-view)) (update-view/existing new-view)] - [else - (loop (- new-view 1))]))) - - ;; GUI ELEMENTS: - (define s-frame (make-object stepper-frame% drscheme-frame)) - (define button-panel (make-object horizontal-panel% (send s-frame get-area-container))) - (define home-button (make-object button% (string-constant stepper-home) button-panel - (lambda (_1 _2) (home)))) - (define previous-application-button (make-object button% (string-constant stepper-previous-application) button-panel - (lambda (dc-1 dc-2) (previous-application)))) - (define previous-button (make-object button% (string-constant stepper-previous) button-panel - (lambda (_1 _2) (previous)))) - (define next-button (make-object button% (string-constant stepper-next) button-panel - (lambda (_1 _2) (next)))) - (define next-application-button (make-object button% (string-constant stepper-next-application) button-panel - (lambda (dc-1 dc-2) (next-application)))) - (define canvas (make-object x:stepper-canvas% (send s-frame get-area-container))) + [else (loop (sub1 new-view))]))) - ;; update-view/existing : set an existing step as the one shown in the frame + ;; GUI ELEMENTS: + (define s-frame + (make-object stepper-frame% drscheme-frame)) + (define button-panel + (make-object horizontal-panel% (send s-frame get-area-container))) + (define home-button + (make-object button% (string-constant stepper-home) button-panel + (lambda (_1 _2) (home)))) + (define previous-application-button + (make-object button% (string-constant stepper-previous-application) + button-panel + (lambda (dc-1 dc-2) (previous-application)))) + (define previous-button + (make-object button% (string-constant stepper-previous) button-panel + (lambda (_1 _2) (previous)))) + (define next-button + (make-object button% (string-constant stepper-next) button-panel + (lambda (_1 _2) (next)))) + (define next-application-button + (make-object button% (string-constant stepper-next-application) + button-panel + (lambda (dc-1 dc-2) (next-application)))) + (define canvas + (make-object x:stepper-canvas% (send s-frame get-area-container))) + + ;; update-view/existing : set an existing step as the one shown in the + ;; frame (define (update-view/existing new-view) - (set! view new-view) + (set! view new-view) (let ([e (car (list-ref view-history view))]) (send e begin-edit-sequence) (send canvas set-editor e) @@ -378,33 +406,38 @@ (send e set-position (send e last-position)) (send e end-edit-sequence)) (en/dis-able-buttons)) - + ;; en/dis-able-buttons : set enable & disable the stepper buttons, based on view-controller state (define (en/dis-able-buttons) (let* ([can-go-back? (> view 0)]) (send previous-button enable can-go-back?) (send previous-application-button enable can-go-back?) (send home-button enable can-go-back?) - (send next-button enable (not (and (>= view (- (length view-history) 1)) stepper-is-waiting?))) - (send next-application-button enable (or (find-later-application-step view) (not stepper-is-waiting?))))) - + (send next-button + enable (not (and (>= view (- (length view-history) 1)) + stepper-is-waiting?))) + (send next-application-button + enable (or (find-later-application-step view) + (not stepper-is-waiting?))))) + (define (print-current-view item evt) (send (send canvas get-editor) print)) - - ; receive-result takes a result from the model and renders it on-screen. Runs on the user thread. - ; : (step-result -> void) + + ;; receive-result takes a result from the model and renders it + ;; on-screen. Runs on the user thread. + ;; : (step-result -> void) (define (receive-result result) (let ([step-text - (cond [(before-after-result? result) - (instantiate x:stepper-text% () + (cond [(before-after-result? result) + (new x:stepper-text% [left-side (before-after-result-pre-exps result)] [right-side (before-after-result-post-exps result)])] [(before-error-result? result) - (instantiate x:stepper-text% () + (new x:stepper-text% [left-side (before-error-result-pre-exps result)] [right-side (before-error-result-err-msg result)])] [(error-result? result) - (instantiate x:stepper-text% () + (new x:stepper-text% [left-side null] [right-side (error-result-err-msg result)])] [(finished-stepping? result) @@ -414,14 +447,15 @@ (and (finished-stepping? result) 'finished-stepping))]) (hand-off-and-block step-text step-kind))) - - ; need to capture the custodian as the thread starts up: + + ;; need to capture the custodian as the thread starts up: (define (program-expander-prime init iter) - (program-expander (lambda args - (send s-frame set-custodian! (current-custodian)) - (apply init args)) - iter)) - + (program-expander + (lambda args + (send s-frame set-custodian! (current-custodian)) + (apply init args)) + iter)) + ;; CONFIGURE GUI ELEMENTS (send s-frame set-printing-proc print-current-view) (send button-panel stretchable-width #f) @@ -430,48 +464,53 @@ (en/dis-able-buttons) (send (send s-frame edit-menu:get-undo-item) enable #f) (send (send s-frame edit-menu:get-redo-item) enable #f) - - ; START THE MODEL - (model:go program-expander-prime receive-result (get-render-settings render-to-string render-to-sexp #t) - (not (member language-level-name - (list (string-constant intermediate-student/lambda) - (string-constant advanced-student)))) - language-level-name - run-on-drscheme-side) + + ;; START THE MODEL + (model:go + program-expander-prime receive-result + (get-render-settings render-to-string render-to-sexp #t) + (not (member language-level-name + (list (string-constant intermediate-student/lambda) + (string-constant advanced-student)))) + language-level-name + run-on-drscheme-side) (send s-frame show #t) - + s-frame) - ;; stepper-unit-frame<%> : the interface that the extended drscheme frame fulfils + ;; stepper-unit-frame<%> : the interface that the extended drscheme frame + ;; fulfils (define stepper-unit-frame<%> (interface () get-stepper-frame on-stepper-close)) - - ;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme frame to interact with a possible stepper window + + ;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme + ;; frame to interact with a possible stepper window (define (stepper-unit-frame-mixin super%) (class* super% (stepper-unit-frame<%>) - + (inherit get-button-panel get-interactions-text get-definitions-text) - + (define stepper-frame #f) (define/public (on-stepper-close) (set! stepper-frame #f)) (define/public (get-stepper-frame) stepper-frame) - - (super-instantiate ()) - - ;; program-expander : produces expanded expressions from the definitions window one at a time and calls 'iter' on each one + + (super-new) + + ;; program-expander : produces expanded expressions from the + ;; definitions window one at a time and calls 'iter' on each one (define (program-expander init iter) - (let* ([lang-settings - (send (get-definitions-text) get-next-settings)] - [lang (drscheme:language-configuration:language-settings-language lang-settings)] - [settings (drscheme:language-configuration:language-settings-settings lang-settings)]) + (let* ([lang-settings + (send (get-definitions-text) get-next-settings)] + [lang (drscheme:language-configuration:language-settings-language lang-settings)] + [settings (drscheme:language-configuration:language-settings-settings lang-settings)]) (drscheme:eval:expand-program - (drscheme:language:make-text/pos (get-definitions-text) - 0 - (send (get-definitions-text) - last-position)) + (drscheme:language:make-text/pos + (get-definitions-text) + 0 + (send (get-definitions-text) last-position)) lang-settings #f (lambda () @@ -483,91 +522,97 @@ (let ([str (get-output-string sp)]) (if ((string-length str) . <= . len) str - (string-append (substring str 0 (max 0 (- len 3))) "..."))))))) + (string-append (substring str 0 (max 0 (- len 3))) + "..."))))))) void ; kill iter))) - + ;; STEPPER BUTTON - + (define/public (get-stepper-button) stepper-button) - (define stepper-button + (define stepper-button (make-object button% (x:stepper-bitmap this) (make-object vertical-pane% (get-button-panel)) (lambda (button evt) (if stepper-frame - (send stepper-frame show #t) - (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) - (car (reverse stepper-works-for)))))))))) - - + (send stepper-frame show #t) + (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) + (car (reverse stepper-works-for)))))))))) + (define/augment (enable-evaluation) (send stepper-button enable #t) (inner (void) enable-evaluation)) - + (define/augment (disable-evaluation) (send stepper-button enable #f) (inner (void) disable-evaluation)) - + (define/augment (on-close) (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/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: - (let ([p (send stepper-button get-parent)]) - (send (get-button-panel) change-children - (lx (cons p (remq p _))))) + (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)))) - ; 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 + ;; add the stepper button to the button panel: + (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 (define (stepper-definitions-text-mixin %) (class % - + (inherit get-top-level-window) (define/private (notify-stepper-frame-of-change) (let ([win (get-top-level-window)]) - (when (is-a? win stepper-unit-frame<%>) ;; should only be #f when win is #f. + ;; should only be #f when win is #f + (when (is-a? win stepper-unit-frame<%>) (let ([stepper-window (send win get-stepper-frame)]) (when stepper-window (send stepper-window original-program-changed)))))) - + (define/augment (on-insert x y) (notify-stepper-frame-of-change) (inner (void) on-insert x y)) - + (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 ()))) - + (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-new))) + ;; COPIED FROM drscheme/private/language.ss ;; simple-module-based-language-convert-value : TST settings -> TST (define (simple-module-based-language-convert-value value settings) @@ -575,29 +620,35 @@ (if (or (is-a? expr snip%) ;; FIXME: internal in language.ss (to-snip-value? expr) ) - expr - (sh expr basic-convert sub-convert))) + expr + (sh expr basic-convert sub-convert))) ;; mflatt: MINOR HACK - work around temporary ;; print-convert problems (define (stepper-print-convert v) (or (and (procedure? v) (object-name v)) (print-convert v))) - (case (drscheme:language:simple-settings-printing-style settings) - [(write) value] + (case (drscheme:language:simple-settings-printing-style settings) + [(write) value] [(current-print) value] - [(constructor) - (parameterize ([constructor-style-printing #t] - [show-sharing (drscheme:language:simple-settings-show-sharing settings)] - [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) + [(constructor) + (parameterize + ([constructor-style-printing #t] + [show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [current-print-convert-hook + (leave-snips-alone-hook (current-print-convert-hook))]) (stepper-print-convert value))] - [(quasiquote) - (parameterize ([constructor-style-printing #f] - [show-sharing (drscheme:language:simple-settings-show-sharing settings)] - [current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))]) + [(quasiquote) + (parameterize + ([constructor-style-printing #f] + [show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [current-print-convert-hook + (leave-snips-alone-hook (current-print-convert-hook))]) (stepper-print-convert value))] [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) - + ;; set-print-settings ; settings ( -> TST) -> TST (define (set-print-settings language simple-settings thunk) (if (method-in-interface? 'set-printing-parameters (object-interface language)) @@ -605,7 +656,9 @@ ;; assume that the current print-convert context is fine ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") (thunk))) - - ;; apply the mixins dynamically to the drscheme unit frame and definitions text: + + ;; apply the mixins dynamically to the drscheme unit frame and + ;; definitions text: (drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin) - (drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin)))) + (drscheme:get/extend:extend-definitions-text + stepper-definitions-text-mixin))))