suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

misc reformat (including things like instantiate->new)

Browse Source 
svn: r4010
This commit is contained in:
Eli Barzilay 2006-08-09 22:03:00 +00:00
parent 124b4ebaf3
commit 96846c44ff
1 changed files with 353 additions and 300 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

653
collects/stepper/stepper-tool.ss
View File

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