From 059ec602fbbd73fc137fa00d28dff59d19d94448 Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 13 Oct 2009 18:46:29 +0000 Subject: [PATCH] new non-blocking stepper implemented svn: r16310 --- collects/stepper/stepper+xml-tool.ss | 4 +- .../stepper/view-controller-non-blocking.ss | 387 ------------------ collects/stepper/view-controller.ss | 226 ++++------ 3 files changed, 92 insertions(+), 525 deletions(-) delete mode 100644 collects/stepper/view-controller-non-blocking.ss diff --git a/collects/stepper/stepper+xml-tool.ss b/collects/stepper/stepper+xml-tool.ss index 40a6b91bbe..6a13023fc2 100644 --- a/collects/stepper/stepper+xml-tool.ss +++ b/collects/stepper/stepper+xml-tool.ss @@ -3,7 +3,7 @@ drscheme/tool "stepper-tool.ss" "xml-tool.ss" - "view-controller-non-blocking.ss" + "view-controller.ss" "private/shared.ss") (provide tool@) @@ -21,5 +21,5 @@ (import drscheme:tool^) (export STEPPER-TOOL) (link xml-tool@ - view-controller-non-blocking@ + view-controller@ [((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@])))) diff --git a/collects/stepper/view-controller-non-blocking.ss b/collects/stepper/view-controller-non-blocking.ss deleted file mode 100644 index 3c0f72e890..0000000000 --- a/collects/stepper/view-controller-non-blocking.ss +++ /dev/null @@ -1,387 +0,0 @@ -#lang scheme/unit - -;; this version of the view-controller (will) just collect the steps up front rather -;; than blocking until the user presses the "next" button. - -;; contracts are bogus all over the place. - -(require scheme/class - scheme/match - scheme/list - drscheme/tool - mred - string-constants - scheme/async-channel - (prefix-in model: "private/model.ss") - (prefix-in x: "private/mred-extensions.ss") - "private/shared.ss" - "private/model-settings.ss" - "xml-sig.ss" - (only-in scheme/pretty pretty-print-show-inexactness)) - - -(import drscheme:tool^ xml^ stepper-frame^) -(export view-controller^) - -(define drscheme-eventspace (current-eventspace)) - -(define (definitions-text->settings definitions-text) - (send definitions-text get-next-settings)) - -;; the stored representation of a step -(define-struct step (text kind posns) #:transparent) - -(define (go drscheme-frame program-expander selection-start selection-end) - - ;; get the language-level: - (define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) - (define language-level (drscheme:language-configuration:language-settings-language language-settings)) - (define simple-settings (drscheme:language-configuration:language-settings-settings language-settings)) - - ;; VALUE CONVERSION CODE: - - ;; render-to-string : TST -> string - (define (render-to-string val) - (let ([string-port (open-output-string)]) - (send language-level render-value val simple-settings string-port) - (get-output-string string-port))) - - ;; render-to-sexp : TST -> sexp - (define (render-to-sexp val) - (send language-level stepper:render-to-sexp val simple-settings language-level)) - - ;; channel for incoming views - (define view-channel (make-async-channel)) - - ;; the list of available views - (define view-history null) - - ;; the number of available steps - (define num-steps-available 0) - - ;; the view in the stepper window - (define view #f) - - ;; hand-off-and-block : (-> text%? any (listof (or/c posn-info? false?)) void?) - ;; puts the step on the channel, to be fetched by the aggregator - (define (hand-off result) - (async-channel-put view-channel result)) - - ;; wait for steps to show up on the channel. When they do, add them to the list. - (define (start-listener-thread) - (thread - (lambda () - (let loop () - (let* ([new-result (async-channel-get view-channel)] - [new-step (format-result new-result)]) - (set! view-history (append view-history (list new-step))) - (set! num-steps-available (length view-history))) - (update-status-bar) - (loop))))) - - - ;; find-later-step : given a predicate on history-entries, search through - ;; the history for the first step that satisfies the predicate and whose - ;; number is greater than n (or -1 if n is #f), return # of step on success, - ;; on failure return (list 'nomatch last-step) or (list 'nomatch/seen-final last-step) - ;; if we went past the final step - (define (find-later-step p n) - (let* ([n-as-num (or n -1)]) - (let loop ([step 0] - [remaining view-history] - [seen-final? #f]) - (cond [(null? remaining) (cond [seen-final? (list 'nomatch/seen-final (- step 1))] - [else (list 'nomatch step)])] - [(and (> step n-as-num) (p (car remaining))) step] - [else (loop (+ step 1) - (cdr remaining) - (or seen-final? (finished-stepping-step? (car remaining))))])))) - - ;; find-later-step/boolean : similar, but just return #f or #t. - (define (find-later-step/boolean p n) - (number? (find-later-step p n))) - - ;; find-earlier-step : like find-later-step, but searches backward from - ;; the given step. - (define (find-earlier-step p n) - (unless (number? n) - (error 'find-earlier-step "can't find earlier step when no step is displayed.")) - (let* ([to-search (reverse (take view-history n))]) - (let loop ([step (- n 1)] - [remaining to-search]) - (cond [(null? remaining) 'nomatch] - [(p (car remaining)) step] - [else (loop (- step 1) (cdr remaining))])))) - - - ;; STEP PREDICATES: - - ;; is this an application step? - (define (application-step? history-entry) - (match history-entry - [(struct step (text (or 'user-application 'finished-or-error) posns)) #t] - [else #f])) - - ;; is this the finished-stepping step? - (define (finished-stepping-step? history-entry) - (match (step-kind history-entry) - ['finished-or-error #t] - [else #f])) - - ;; is this step on the selected expression? - (define (selected-exp-step? history-entry) - (ormap (span-overlap selection-start selection-end) (step-posns history-entry))) - - ;; build gui object: - - - ;; next-of-specified-kind : starting at the current view, search forward for the - ;; desired step or wait for it if not found - (define (next-of-specified-kind right-kind?) - (next-of-specified-kind/helper right-kind? view)) - - ;; first-of-specified-kind : similar to next-of-specified-kind, but always start at zero - (define (first-of-specified-kind right-kind?) - (next-of-specified-kind/helper right-kind? #f)) - - ;; next-of-specified-kind/helper : if the desired step is already in the list, display - ;; it; otherwise, give up. - (define (next-of-specified-kind/helper right-kind? starting-step) - (match (find-later-step right-kind? starting-step) - [(? number? n) - (update-view/existing n)] - [(list 'nomatch step) - (message-box (string-constant stepper-no-such-step/title) - (string-constant stepper-no-such-step)) - (when (>= num-steps-available 0) - (update-view/existing step))] - [(list 'nomatch/seen-final step) - (message-box (string-constant stepper-no-such-step/title) - (string-constant stepper-no-such-step)) - (when (>= num-steps-available 0) - (update-view/existing step))])) - - ;; prior-of-specified-kind: if the desired step is already in the list, display - ;; it; otherwise, put up a dialog and jump to the first step. - (define (prior-of-specified-kind right-kind?) - (match (find-earlier-step right-kind? view) - [(? number? found-step) - (update-view/existing found-step)] - ['nomatch - (message-box (string-constant stepper-no-such-step/title) - (string-constant stepper-no-such-step/earlier)) - (when (>= num-steps-available 0) - (update-view/existing 0))])) - - ;; BUTTON/CHOICE BOX PROCEDURES - - - ;; respond to a click on the "next" button - (define (next) - (next-of-specified-kind (lambda (x) #t))) - - ;; respond to a click on the "next application" button - (define (next-application) - (next-of-specified-kind application-step?)) - - ;; respond to a click on the "Jump To..." choice - (define (jump-to control event) - ((second (list-ref pulldown-choices (send control get-selection))))) - - ;; previous : the action of the 'previous' button - (define (previous) - (prior-of-specified-kind (lambda (x) #t))) - - ;; previous-application : the action of the 'previous-application' - ;; button - (define (previous-application) - (prior-of-specified-kind application-step?)) - - ;; jump-to-beginning : the action of the choice menu entry - (define (jump-to-beginning) - (first-of-specified-kind (lambda (x) #t))) - - ;; jump-to-end : the action of the choice menu entry - (define (jump-to-end) - (next-of-specified-kind finished-stepping-step?)) - - ;; jump-forward-to-selected : the action of the choice menu entry - (define (jump-to-selected) - (first-of-specified-kind selected-exp-step?)) - - ;; jump-back-to-selection : the action of the choice menu entry - (define (jump-back-to-selection) - (prior-of-specified-kind selected-exp-step?)) - - ;; 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 (add-button name fun) - (make-object button% name button-panel (lambda (_1 _2) (fun)))) - (define (add-choice-box name fun) - (new choice% [label name] - [choices (map first pulldown-choices)] - [parent button-panel] - [callback fun])) - - (define pulldown-choices - `((,(string-constant stepper-jump-to-beginning) ,jump-to-beginning) - (,(string-constant stepper-jump-to-end) ,jump-to-end) - (,(string-constant stepper-jump-to-selected) ,jump-to-selected))) - - (define previous-application-button (add-button (string-constant stepper-previous-application) previous-application)) - (define previous-button (add-button (string-constant stepper-previous) previous)) - (define next-button (add-button (string-constant stepper-next) next)) - (define next-application-button (add-button (string-constant stepper-next-application) next-application)) - (define jump-button (add-choice-box (string-constant stepper-jump) jump-to)) - - (define canvas - (make-object x:stepper-canvas% (send s-frame get-area-container))) - - ;; counting steps... - (define status-text - (new text%)) - (define _2 (send status-text insert "")) - - (define status-canvas - (new editor-canvas% - [parent button-panel] - [editor status-text] - [style '(transparent no-border no-hscroll no-vscroll)] - ;; some way to get the height of a line of text? - [min-width 100])) - - - ;; update-view/existing : set an existing step as the one shown in the - ;; frame - (define (update-view/existing new-view) - (set! view new-view) - (let ([e (step-text (list-ref view-history view))]) - (send e begin-edit-sequence) - (send canvas set-editor e) - (send e reset-width canvas) - (send e set-position (send e last-position)) - (send e end-edit-sequence)) - (update-status-bar)) - - - ;; update the X/Y display in the upper right corner of the stepper; - ;; this should be one-at-a-time. - (define (update-status-bar) - (call-with-semaphore update-status-bar-semaphore update-status-bar/inner)) - - (define (update-status-bar/inner) - (send status-text lock #f) - (send status-text delete 0 (send status-text last-position)) - (send status-text insert (format "~a/~a" view (length view-history))) - (send status-text lock #t)) - - (define update-status-bar-semaphore (make-semaphore 1)) - - (define (print-current-view item evt) - (send (send canvas get-editor) print)) - - - ;; translates a result into a step - ;; format-result : result -> step? - (define (format-result result) - (match result - [(struct before-after-result (pre-exps post-exps kind pre-src post-src)) - (make-step (new x:stepper-text% - [left-side pre-exps] - [right-side post-exps] - [show-inexactness? (send language-level stepper:show-inexactness?)]) - kind - (list pre-src post-src))] - [(struct before-error-result (pre-exps err-msg pre-src)) - (make-step (new x:stepper-text% - [left-side pre-exps] - [right-side err-msg] - [show-inexactness? (send language-level stepper:show-inexactness?)]) - 'finished-or-error - (list pre-src))] - [(struct error-result (err-msg)) - (make-step (new x:stepper-text% - [left-side null] - [right-side err-msg] - [show-inexactness? (send language-level stepper:show-inexactness?)]) - 'finished-or-error - (list))] - [(struct finished-stepping ()) - (make-step x:finished-text 'finished-or-error (list))])) - - ;; program-expander-prime : wrap the program-expander for a couple of reasons: - ;; 1) we need to capture the custodian as the thread starts up: - ;; ok, it was just one. - ;; - (define (program-expander-prime init 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) - (send button-panel stretchable-height #f) - (send canvas stretchable-height #t) - (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 - (start-listener-thread) - (model:go - program-expander-prime - hand-off - (get-render-settings render-to-string render-to-sexp - (send language-level stepper:enable-let-lifting?) - (send language-level stepper:show-consumed-and/or-clauses?)) - (send language-level stepper:show-lambdas-as-lambdas?) - language-level - #f) - (send s-frame show #t) - - s-frame) - - - -;; UTILITY FUNCTIONS: - -;; span-overlap : number number -> posn-info -> boolean -;; return true if the selection is of zero length and precedes a char of the -;; stepping expression, *or* if the selection has positive overlap with the -;; stepping expression. -(define ((span-overlap selection-start selection-end) source-posn-info) - (match source-posn-info - [#f #f] - [(struct model:posn-info (posn span)) - (let ([end (+ posn span)]) - (and posn - ;; you can *almost* combine these two, but not quite. - (cond [(= selection-start selection-end) - (and (<= posn selection-start) (< selection-start end))] - [else - (let ([overlap-begin (max selection-start posn)] - ;; nb: we don't want zero-length overlaps at the end. - ;; compensate by subtracting one from the end of the - ;; current expression. - [overlap-end (min selection-end end)]) - ;; #t if there's positive overlap: - (< overlap-begin overlap-end))])))])) - -;; a few unit tests. Use them if changing span-overlap. -#;(and -;; zero-length selection cases: -(equal? ((span-overlap 13 13) (model:make-posn-info 14 4)) #f) -(equal? ((span-overlap 14 14) (model:make-posn-info 14 4)) #t) -(equal? ((span-overlap 18 18) (model:make-posn-info 14 4)) #f) -;; nonzero-length selection cases: -(equal? ((span-overlap 13 14) (model:make-posn-info 14 4)) #f) -(equal? ((span-overlap 13 15) (model:make-posn-info 14 4)) #t) -(equal? ((span-overlap 13 23) (model:make-posn-info 14 4)) #t) -(equal? ((span-overlap 16 17) (model:make-posn-info 14 4)) #t) -(equal? ((span-overlap 16 24) (model:make-posn-info 14 4)) #t) -(equal? ((span-overlap 18 21) (model:make-posn-info 14 4)) #f)) diff --git a/collects/stepper/view-controller.ss b/collects/stepper/view-controller.ss index 00db486795..3f68e889e7 100644 --- a/collects/stepper/view-controller.ss +++ b/collects/stepper/view-controller.ss @@ -1,5 +1,10 @@ #lang scheme/unit +;; this version of the view-controller (will) just collect the steps up front rather +;; than blocking until the user presses the "next" button. + +;; contracts are bogus all over the place. + (require scheme/class scheme/match scheme/list @@ -48,86 +53,47 @@ ;; 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. - (define release-for-next-step #f) - ;; the list of available views (define view-history null) + ;; the number of available steps + (define num-steps-available 0) + ;; the view in the stepper window (define view #f) - ;; whether the stepper is waiting for a new view to become available - ;; possible values: #f, or a predicate on steps. - (define stepper-is-waiting? (lambda (x) #t)) - ;; hand-off-and-block : (-> text%? any (listof (or/c posn-info? false?)) 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 text kind posns) - (let ([new-semaphore (make-semaphore)]) - (run-on-drscheme-side - (lambda () - (async-channel-put view-channel - (list (make-step text kind posns) new-semaphore)) - (match stepper-is-waiting? - [#f (void)] - [step-pred - (match (async-channel-try-get view-channel) - [#f (error - 'check-for-stepper-waiting - "queue is empty, even though a step was just added")] - [(list new-step semaphore) - (add-view-step new-step semaphore) - (cond [(step-pred new-step) - ;; got the desired step; show the user: - (begin (set! stepper-is-waiting? #f) - (update-view/existing (- (length view-history) 1)))] - [else - ;; nope, keep running: - (begin (if (finished-stepping-step? new-step) - (begin (message-box (string-constant stepper-no-such-step/title) - (string-constant stepper-out-of-steps)) - (update-view/existing (- (length view-history) 1))) - (semaphore-post semaphore)))])])]))) - (semaphore-wait new-semaphore))) + ;; puts the step on the channel, to be fetched by the aggregator + (define (hand-off result) + (async-channel-put view-channel result)) - ;; 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))) - - - ;; add-view-triple : set the release-semaphore to be the new one, add - ;; the view to the list. - (define (add-view-step view-step semaphore) - (set! release-for-next-step semaphore) - (set! view-history (append view-history (list view-step))) - (update-status-bar)) + ;; wait for steps to show up on the channel. When they do, add them to the list. + (define (start-listener-thread) + (thread + (lambda () + (let loop () + (let* ([new-result (async-channel-get view-channel)] + [new-step (format-result new-result)]) + (set! view-history (append view-history (list new-step))) + (set! num-steps-available (length view-history))) + (update-status-bar) + (loop))))) + ;; find-later-step : given a predicate on history-entries, search through ;; the history for the first step that satisfies the predicate and whose ;; number is greater than n (or -1 if n is #f), return # of step on success, - ;; on failure return 'nomatch or 'nomatch/seen-final if we went past the final step + ;; on failure return (list 'nomatch last-step) or (list 'nomatch/seen-final last-step) + ;; if we went past the final step (define (find-later-step p n) (let* ([n-as-num (or n -1)]) (let loop ([step 0] [remaining view-history] [seen-final? #f]) - (cond [(null? remaining) (cond [seen-final? 'nomatch/seen-final] - [else 'nomatch])] + (cond [(null? remaining) (cond [seen-final? (list 'nomatch/seen-final (- step 1))] + [else (list 'nomatch (- step 1))])] [(and (> step n-as-num) (p (car remaining))) step] - [else (loop (+ step 1) + [else (loop (+ step 1) (cdr remaining) (or seen-final? (finished-stepping-step? (car remaining))))])))) @@ -143,7 +109,7 @@ (let* ([to-search (reverse (take view-history n))]) (let loop ([step (- n 1)] [remaining to-search]) - (cond [(null? remaining) #f] + (cond [(null? remaining) 'nomatch] [(p (car remaining)) step] [else (loop (- step 1) (cdr remaining))])))) @@ -179,47 +145,33 @@ (next-of-specified-kind/helper right-kind? #f)) ;; next-of-specified-kind/helper : if the desired step is already in the list, display - ;; it; otherwise, wait for it. + ;; it; otherwise, give up. (define (next-of-specified-kind/helper right-kind? starting-step) - (set! stepper-is-waiting? #f) (match (find-later-step right-kind? starting-step) [(? number? n) (update-view/existing n)] - ['nomatch - (begin - ;; each step has its own semaphore, so releasing one twice is - ;; no problem. - (when release-for-next-step - (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 ([wait-for-it (lambda () - (set! stepper-is-waiting? right-kind?) - (en/dis-able-buttons))]) - (match (async-channel-try-get view-channel) - [(list new-step semaphore) - (add-view-step new-step semaphore) - (if (right-kind? (list-ref view-history (+ view 1))) - (update-view/existing (+ view 1)) - (wait-for-it))] - [#f (wait-for-it)])))] - ['nomatch/seen-final + [(list 'nomatch step) (message-box (string-constant stepper-no-such-step/title) (string-constant stepper-no-such-step)) - (update-view/existing (- (length view-history) 1))])) + (when (>= num-steps-available 0) + (update-view/existing step))] + [(list 'nomatch/seen-final step) + (message-box (string-constant stepper-no-such-step/title) + (string-constant stepper-no-such-step)) + (when (>= num-steps-available 0) + (update-view/existing step))])) ;; prior-of-specified-kind: if the desired step is already in the list, display ;; it; otherwise, put up a dialog and jump to the first step. (define (prior-of-specified-kind right-kind?) - (set! stepper-is-waiting? #f) - (let* ([found-step (find-earlier-step right-kind? view)]) - (if found-step - (update-view/existing found-step) - (begin - (message-box (string-constant stepper-no-such-step/title) - (string-constant stepper-no-such-step/earlier)) - (update-view/existing 0))))) + (match (find-earlier-step right-kind? view) + [(? number? found-step) + (update-view/existing found-step)] + ['nomatch + (message-box (string-constant stepper-no-such-step/title) + (string-constant stepper-no-such-step/earlier)) + (when (>= num-steps-available 0) + (update-view/existing 0))])) ;; BUTTON/CHOICE BOX PROCEDURES @@ -291,7 +243,6 @@ ;; counting steps... (define status-text (new text%)) - (define _2 (send status-text insert "")) (define status-canvas (new editor-canvas% @@ -311,53 +262,56 @@ (send canvas set-editor e) (send e reset-width canvas) (send e set-position (send e last-position)) - (update-status-bar) (send e end-edit-sequence)) - (en/dis-able-buttons)) + (update-status-bar)) + + ;; update the X/Y display in the upper right corner of the stepper; + ;; this should be one-at-a-time. (define (update-status-bar) + (call-with-semaphore update-status-bar-semaphore update-status-bar/inner)) + + (define (update-status-bar/inner) + (send status-text begin-edit-sequence) + (send status-text lock #f) (send status-text delete 0 (send status-text last-position)) - (send status-text insert (format "~a/~a" view (length view-history)))) + (send status-text insert (format "~a/~a" view (length view-history))) + (send status-text lock #t) + (send status-text end-edit-sequence)) - ;; en/dis-able-buttons : set enable & disable the stepper buttons, - ;; based on view-controller state - (define (en/dis-able-buttons) - ;; let's just leave all the buttons enabled... - (void)) + (define update-status-bar-semaphore (make-semaphore 1)) (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) - (define (receive-result result) - ;; let's make sure this works: - (parameterize ([pretty-print-show-inexactness #t]) - (match-let* - ([(list step-text step-kind posns) - (match result - [(struct before-after-result (pre-exps post-exps kind pre-src post-src)) - (list (new x:stepper-text% - [left-side pre-exps] - [right-side post-exps] - [show-inexactness? (send language-level stepper:show-inexactness?)]) - kind (list pre-src post-src))] - [(struct before-error-result (pre-exps err-msg pre-src)) - (list (new x:stepper-text% - [left-side pre-exps] - [right-side err-msg] - [show-inexactness? (send language-level stepper:show-inexactness?)]) - 'finished-or-error (list pre-src))] - [(struct error-result (err-msg)) - (list (new x:stepper-text% - [left-side null] - [right-side err-msg] - [show-inexactness? (send language-level stepper:show-inexactness?)]) - 'finished-or-error (list))] - [(struct finished-stepping ()) - (list x:finished-text 'finished-or-error (list))])]) - (hand-off-and-block step-text step-kind posns)))) + + ;; translates a result into a step + ;; format-result : result -> step? + (define (format-result result) + (match result + [(struct before-after-result (pre-exps post-exps kind pre-src post-src)) + (make-step (new x:stepper-text% + [left-side pre-exps] + [right-side post-exps] + [show-inexactness? (send language-level stepper:show-inexactness?)]) + kind + (list pre-src post-src))] + [(struct before-error-result (pre-exps err-msg pre-src)) + (make-step (new x:stepper-text% + [left-side pre-exps] + [right-side err-msg] + [show-inexactness? (send language-level stepper:show-inexactness?)]) + 'finished-or-error + (list pre-src))] + [(struct error-result (err-msg)) + (make-step (new x:stepper-text% + [left-side null] + [right-side err-msg] + [show-inexactness? (send language-level stepper:show-inexactness?)]) + 'finished-or-error + (list))] + [(struct finished-stepping ()) + (make-step x:finished-text 'finished-or-error (list))])) ;; program-expander-prime : wrap the program-expander for a couple of reasons: ;; 1) we need to capture the custodian as the thread starts up: @@ -375,19 +329,19 @@ (send button-panel stretchable-width #f) (send button-panel stretchable-height #f) (send canvas stretchable-height #t) - (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 + (start-listener-thread) (model:go - program-expander-prime receive-result + program-expander-prime + hand-off (get-render-settings render-to-string render-to-sexp (send language-level stepper:enable-let-lifting?) (send language-level stepper:show-consumed-and/or-clauses?)) (send language-level stepper:show-lambdas-as-lambdas?) language-level - run-on-drscheme-side #f) (send s-frame show #t)