391 lines
15 KiB
Scheme
391 lines
15 KiB
Scheme
#lang scheme/unit
|
|
|
|
(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")
|
|
|
|
(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))
|
|
|
|
(define (settings->language-level settings)
|
|
(drscheme:language-configuration:language-settings-language settings))
|
|
|
|
;; the stored representation of a step
|
|
(define-struct step (text kind posns) #:transparent)
|
|
|
|
(define (go drscheme-frame program-expander selection-posn)
|
|
|
|
;; get the language-level name:
|
|
(define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text)))
|
|
(define language-level
|
|
(settings->language-level language-settings))
|
|
|
|
;; VALUE CONVERSION CODE:
|
|
|
|
(define simple-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-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 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 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%? 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 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 (eq? (step-kind new-step) 'finished-stepping)
|
|
(begin (message-box "Ran out of steps"
|
|
"Reached the end of evaluation before finding the kind of step you were looking for.")
|
|
(update-view/existing (- (length view-history) 1)))
|
|
(semaphore-post semaphore)))])])])))
|
|
(semaphore-wait new-semaphore)))
|
|
|
|
;; run-on-drscheme-side : runs a thunk in the drscheme eventspace.
|
|
;; Passed to 'go' so that display-break-stuff can work. This would be
|
|
;; cleaner with two-way provides.
|
|
(define (run-on-drscheme-side thunk)
|
|
(parameterize ([current-eventspace drscheme-eventspace])
|
|
(queue-callback thunk)))
|
|
|
|
|
|
;; 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))
|
|
|
|
;; 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
|
|
(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])]
|
|
[(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) #f]
|
|
[(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-stepping) posns)) #t]
|
|
[else #f]))
|
|
|
|
;; is this the finished-stepping step?
|
|
(define (finished-stepping-step? history-entry)
|
|
(match (step-kind history-entry)
|
|
['finished-stepping #t]
|
|
[else #f]))
|
|
|
|
;; is this step on the selected expression?
|
|
(define (selected-exp-step? history-entry)
|
|
(member selection-posn (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, wait for it.
|
|
(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.
|
|
(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
|
|
(message-box "Step Not Found"
|
|
"Couldn't find a step matching that criterion.")
|
|
(update-view/existing (- (length view-history) 1))]))
|
|
|
|
;; 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 "Step Not Found"
|
|
"Couldn't find an earlier step matching that criterion.")
|
|
(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)
|
|
(set! stepper-is-waiting? #f)
|
|
(update-view/existing 0))
|
|
|
|
;; 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 "Jump..."]
|
|
[choices (map first pulldown-choices)]
|
|
[parent button-panel]
|
|
[callback fun]))
|
|
|
|
(define pulldown-choices
|
|
`(("to beginning" ,jump-to-beginning)
|
|
("to end" ,jump-to-end)
|
|
("to beginning of 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 _1 (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))
|
|
(update-status-bar)
|
|
(send e end-edit-sequence))
|
|
(en/dis-able-buttons))
|
|
|
|
(define (update-status-bar)
|
|
(send status-text delete 0 (send status-text last-position))
|
|
(send status-text insert (format "~a/~a" view (length view-history))))
|
|
|
|
;; en/dis-able-buttons : set enable & disable the stepper buttons,
|
|
;; based on view-controller state
|
|
(define (en/dis-able-buttons)
|
|
(let* ([can-go-back? (and view (> view 0))])
|
|
(send previous-button enable can-go-back?)
|
|
(send previous-application-button enable can-go-back?)
|
|
(send next-button
|
|
enable (or (find-later-step/boolean (lambda (x) #t) view)
|
|
(not stepper-is-waiting?)))
|
|
(send next-application-button
|
|
enable (or (find-later-step/boolean 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)
|
|
(define (receive-result result)
|
|
(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]) 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]) #f (list pre-src))]
|
|
[(struct error-result (err-msg))
|
|
(list (new x:stepper-text% [left-side null] [right-side err-msg]) #f (list))]
|
|
[(struct finished-stepping ())
|
|
(list x:finished-text 'finished-stepping (list))])])
|
|
(hand-off-and-block step-text step-kind posns)))
|
|
|
|
;; 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))
|
|
|
|
;; 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)
|
|
(en/dis-able-buttons)
|
|
(send (send s-frame edit-menu:get-undo-item) enable #f)
|
|
(send (send s-frame edit-menu:get-redo-item) enable #f)
|
|
|
|
;; START THE MODEL
|
|
(model:go
|
|
program-expander-prime receive-result
|
|
(get-render-settings render-to-string render-to-sexp
|
|
(send language-level stepper:enable-let-lifting?))
|
|
(send language-level stepper:show-lambdas-as-lambdas?)
|
|
language-level
|
|
run-on-drscheme-side
|
|
#f)
|
|
(send s-frame show #t)
|
|
|
|
s-frame)
|
|
|