misc reformat (including things like instantiate->new)
svn: r4010
This commit is contained in:
Eli Barzilay
parent
124b4ebaf3
commit
96846c44ff
|
|
@ -11,27 +11,28 @@
|
|||
(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%))
|
||||
(import drscheme:tool^ (xml-snip% scheme-snip%))
|
||||
|
||||
; tool magic here:
|
||||
;; tool magic here:
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
|
|
@ -42,22 +43,25 @@
|
|||
(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
|
||||
;; 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)
|
||||
|
|
@ -70,13 +74,17 @@
|
|||
|
||||
;; 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)
|
||||
|
|
@ -89,25 +97,23 @@
|
|||
|
||||
;; 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)
|
||||
|
|
@ -120,13 +126,15 @@
|
|||
(define/public (original-program-gone)
|
||||
(add-warning-message window-closed-warning-str))
|
||||
|
||||
(super-new [label "Stepper"] [parent #f]
|
||||
[width stepper-initial-width]
|
||||
[height stepper-initial-height])))
|
||||
|
||||
(super-instantiate ("Stepper" #f stepper-initial-width 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
|
||||
;; 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)
|
||||
|
|
@ -135,37 +143,38 @@
|
|||
(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%)
|
||||
(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)]
|
||||
|
|
@ -186,63 +195,63 @@
|
|||
(cond
|
||||
[(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))))]))
|
||||
(simple-module-based-language-convert-value
|
||||
val simple-settings))))]))
|
||||
|
||||
(define (>>> x)
|
||||
(fprintf (current-error-port) ">>> ~v\n" x)
|
||||
x)
|
||||
|
||||
; channel for incoming views
|
||||
;; 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.
|
||||
|
|
@ -252,22 +261,26 @@
|
|||
(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))))))
|
||||
(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.
|
||||
;; 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)])
|
||||
|
|
@ -281,7 +294,7 @@
|
|||
[(user-application finished stepping) #t]
|
||||
[else #f]))
|
||||
|
||||
; build gui object:
|
||||
;; build gui object:
|
||||
|
||||
;; home : the action of the 'home' button
|
||||
(define (home)
|
||||
|
|
@ -293,82 +306,97 @@
|
|||
(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))))))))
|
||||
(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))])))
|
||||
[else (loop (sub1 new-view))])))
|
||||
|
||||
;; 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)))
|
||||
(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
|
||||
;; 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 (car (list-ref view-history view))])
|
||||
|
|
@ -385,26 +413,31 @@
|
|||
(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% ()
|
||||
(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)
|
||||
|
|
@ -415,12 +448,13 @@
|
|||
'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)
|
||||
|
|
@ -431,24 +465,28 @@
|
|||
(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<%>)
|
||||
|
||||
|
|
@ -459,19 +497,20 @@
|
|||
(set! stepper-frame #f))
|
||||
(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)
|
||||
(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)])
|
||||
(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,7 +522,8 @@
|
|||
(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)))
|
||||
|
||||
|
|
@ -496,17 +536,19 @@
|
|||
(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)
|
||||
|
|
@ -521,35 +563,38 @@
|
|||
(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))))
|
||||
(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 _)))))
|
||||
;; 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)))
|
||||
;; 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
|
||||
;; 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))))))
|
||||
|
|
@ -562,11 +607,11 @@
|
|||
(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))
|
||||
(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 ())))
|
||||
(super-new)))
|
||||
|
||||
;; COPIED FROM drscheme/private/language.ss
|
||||
;; simple-module-based-language-convert-value : TST settings -> TST
|
||||
|
|
@ -575,26 +620,32 @@
|
|||
(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")]))
|
||||
|
||||
|
|
@ -606,6 +657,8 @@
|
|||
;; (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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user