db57b78e18
Changed most *-icon and *-logo function arguments to keyword arguments text-icon no longer uses font size Small doc changes
543 lines
20 KiB
Racket
543 lines
20 KiB
Racket
#lang racket/unit
|
|
|
|
;; this module implements the UI side of the stepper; it
|
|
;; opens a window, starts the stepper thread running,
|
|
;; and handles the resulting calls to 'break'.
|
|
|
|
;; this module lies outside of the "testing boundary"
|
|
;; of through-tests; it is not tested automatically at all.
|
|
|
|
;; this version of the view-controller just collects the steps up front rather
|
|
;; than blocking until the user presses the "next" button.
|
|
|
|
(require racket/class
|
|
racket/match
|
|
racket/list
|
|
drracket/tool
|
|
mred
|
|
string-constants
|
|
racket/async-channel
|
|
(prefix-in model: "model.rkt")
|
|
(prefix-in x: "mred-extensions.rkt")
|
|
"shared.rkt"
|
|
"model-settings.rkt"
|
|
"xml-sig.rkt"
|
|
images/compile-time
|
|
images/gui
|
|
(for-syntax racket/base images/icons/control images/icons/style images/logos))
|
|
|
|
|
|
(import drracket:tool^ xml^ stepper-frame^)
|
|
(export view-controller^)
|
|
|
|
(define drracket-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 (show-about-dialog parent)
|
|
(define dlg
|
|
(new logo-about-dialog%
|
|
[label "About the Stepper"]
|
|
[parent parent]
|
|
[bitmap (compiled-bitmap (stepper-logo))]
|
|
[messages '("The Algebraic Stepper is formalized and proved correct in\n"
|
|
"\n"
|
|
" John Clements, Matthew Flatt, Matthias Felleisen\n"
|
|
" Modeling an Algebraic Stepper\n"
|
|
" European Symposium on Programming, 2001\n")]))
|
|
(send dlg show #t))
|
|
|
|
(define (go drracket-tab program-expander selection-start selection-end)
|
|
|
|
;; get the language-level:
|
|
(define language-settings
|
|
(definitions-text->settings
|
|
(send drracket-tab get-defs)))
|
|
|
|
(define language-level
|
|
(drracket:language-configuration:language-settings-language
|
|
language-settings))
|
|
|
|
(define simple-settings
|
|
(drracket: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 first-step semaphore
|
|
(define first-step-sema (make-semaphore 0))
|
|
|
|
;; 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)
|
|
|
|
;; wait for steps to show up on the channel.
|
|
;; When they do, add them to the list.
|
|
(define (start-listener-thread stepper-frame-eventspace)
|
|
;; as of 2012-06-20, I no longer believe there's any
|
|
;; need for this thread, as the queue-callback handles
|
|
;; the needed separation.
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(define new-result (async-channel-get view-channel))
|
|
(receive-result-from-target new-result)
|
|
(loop)))))
|
|
|
|
;; handles an incoming result. Either adds it to the list of
|
|
;; steps, or prompts user to see whether to continue running.
|
|
(define (receive-result-from-target result)
|
|
(cond [(runaway-process? result)
|
|
(parameterize ([current-eventspace stepper-frame-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(when (confirm-running)
|
|
(semaphore-post (runaway-process-sema result)))
|
|
(void))))]
|
|
[else
|
|
(define new-step (format-result result))
|
|
(parameterize ([current-eventspace stepper-frame-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(set! view-history (append view-history (list new-step)))
|
|
(set! num-steps-available (length view-history))
|
|
;; this is only necessary the first time, but it's cheap:
|
|
(semaphore-post first-step-sema)
|
|
(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 (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 1))])]
|
|
[(and (> step n-as-num) (p (car remaining))) step]
|
|
[else (loop (+ step 1)
|
|
(cdr remaining)
|
|
(or seen-final? (finished-stepping-step? (car remaining))))]))))
|
|
|
|
;; 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? msg)
|
|
(next-of-specified-kind/helper right-kind? view msg))
|
|
|
|
;; first-of-specified-kind : similar to next-of-specified-kind, but
|
|
;; always start at zero
|
|
(define (first-of-specified-kind right-kind? msg)
|
|
(next-of-specified-kind/helper right-kind? #f msg))
|
|
|
|
;; 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 msg)
|
|
(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) msg)
|
|
(when (>= num-steps-available 0)
|
|
(update-view/existing step))]
|
|
[(list `nomatch/seen-final step)
|
|
(message-box (string-constant stepper-no-such-step/title) msg)
|
|
(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? msg)
|
|
(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) msg)
|
|
(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)
|
|
(string-constant stepper-no-later-step)))
|
|
|
|
;; previous : the action of the 'previous' button
|
|
(define (previous)
|
|
(prior-of-specified-kind (lambda (x) #t)
|
|
(string-constant stepper-no-earlier-step)))
|
|
|
|
;; respond to a click on the "Jump To..." choice
|
|
(define (jump-to control event)
|
|
((second (list-ref pulldown-choices (send control get-selection)))))
|
|
|
|
;; jump-to-beginning : the action of the choice menu entry
|
|
(define (jump-to-beginning)
|
|
(first-of-specified-kind (lambda (x) #t)
|
|
;; I don't believe this can fail...
|
|
"internal error 2010-01-10 21:48"))
|
|
|
|
;; jump-to-end : the action of the jump-to-end choice box option
|
|
(define (jump-to-end)
|
|
(first-of-specified-kind finished-stepping-step?
|
|
(string-constant stepper-no-last-step)))
|
|
|
|
;; jump-to-selected : the action of the jump to selected choice box option
|
|
(define (jump-to-selected)
|
|
(first-of-specified-kind selected-exp-step?
|
|
(string-constant stepper-no-selected-step)))
|
|
|
|
;; jump-to-next-application : the action of the jump to next application
|
|
;; choice box option
|
|
(define (jump-to-next-application)
|
|
(next-of-specified-kind application-step?
|
|
(string-constant stepper-no-later-application-step)))
|
|
|
|
;; jump-to-prior-application : the action of the "jump to prior application"
|
|
;; choice box option
|
|
(define (jump-to-prior-application)
|
|
(prior-of-specified-kind application-step?
|
|
(string-constant
|
|
stepper-no-earlier-application-step)))
|
|
|
|
|
|
;; GUI ELEMENTS:
|
|
(define s-frame
|
|
(make-object stepper-frame% drracket-tab))
|
|
|
|
(define top-panel
|
|
(new horizontal-panel% [parent (send s-frame get-area-container)] [horiz-margin 5]
|
|
;[style '(border)] ; for layout testing only
|
|
[stretchable-width #t]
|
|
[stretchable-height #f]))
|
|
|
|
(define button-panel
|
|
(new horizontal-panel% [parent top-panel] [alignment '(center top)]
|
|
;[style '(border)] ; for layout testing only
|
|
[stretchable-width #t]
|
|
[stretchable-height #f]))
|
|
|
|
(define logo-canvas
|
|
(new (class bitmap-canvas%
|
|
(super-new [parent top-panel] [bitmap (compiled-bitmap (stepper-logo #:height 32))])
|
|
(define/override (on-event evt)
|
|
(when (eq? (send evt get-event-type) 'left-up)
|
|
(show-about-dialog s-frame))))))
|
|
|
|
(define prev-img (compiled-bitmap (step-back-icon #:color run-icon-color
|
|
#:height (toolbar-icon-height))))
|
|
(define previous-button (new button%
|
|
[label (list prev-img (string-constant stepper-previous) 'left)]
|
|
[parent button-panel]
|
|
[callback (λ (_1 _2) (previous))]
|
|
[enabled #f]))
|
|
|
|
(define next-img (compiled-bitmap (step-icon #:color run-icon-color
|
|
#:height (toolbar-icon-height))))
|
|
(define next-button (new button%
|
|
[label (list next-img (string-constant stepper-next) 'right)]
|
|
[parent button-panel]
|
|
[callback (λ (_1 _2) (next))]
|
|
[enabled #f]))
|
|
|
|
(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)
|
|
(,(string-constant stepper-jump-to-next-application) ,jump-to-next-application)
|
|
(,(string-constant stepper-jump-to-previous-application) ,jump-to-prior-application)))
|
|
|
|
(define jump-button (new choice%
|
|
[label (string-constant stepper-jump)]
|
|
[choices (map first pulldown-choices)]
|
|
[parent button-panel]
|
|
[callback jump-to]
|
|
[enabled #f]))
|
|
|
|
(define canvas
|
|
(make-object x:stepper-canvas% (send s-frame get-area-container)))
|
|
|
|
;; counting steps...
|
|
(define status-text
|
|
(new text%))
|
|
|
|
(define status-canvas
|
|
(new editor-canvas%
|
|
[parent button-panel]
|
|
[editor status-text]
|
|
[stretchable-width #f]
|
|
[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)
|
|
;; why set the position within the step? I'm confused by this.--JBC
|
|
(send e set-position (send e last-position))
|
|
(send e end-edit-sequence))
|
|
(update-status-bar))
|
|
|
|
;; set the status bar to the correct m/n text.
|
|
(define (update-status-bar)
|
|
(send status-text begin-edit-sequence)
|
|
(send status-text lock #f)
|
|
(send status-text delete 0 (send status-text last-position))
|
|
;; updated to yield 1-based step numbering rather than 0-based numbering.
|
|
(send status-text insert
|
|
(format "~a/~a" (if view (+ 1 view) "none") (length view-history)))
|
|
(send status-text lock #t)
|
|
(send status-text end-edit-sequence))
|
|
|
|
(define update-status-bar-semaphore (make-semaphore 1))
|
|
|
|
(define (enable-all-buttons)
|
|
(send previous-button enable #t)
|
|
(send next-button enable #t)
|
|
(send jump-button enable #t))
|
|
|
|
|
|
(define (print-current-view item evt)
|
|
(send (send canvas get-editor) print))
|
|
|
|
;; code for dealing with runaway processes:
|
|
|
|
(define runaway-counter-limit 500)
|
|
(define disable-runaway-counter #f)
|
|
(define runaway-counter 0)
|
|
|
|
;; runs on the stepped-process side.
|
|
;; checks to see if the process has taken too
|
|
;; many steps. If so, send a message and block
|
|
;; for a response, then send the result. Otherwise,
|
|
;; just send the result.
|
|
(define (deliver-result-to-gui result)
|
|
(when (not disable-runaway-counter)
|
|
(set! runaway-counter (+ runaway-counter 1)))
|
|
(when (= runaway-counter runaway-counter-limit)
|
|
(define runaway-semaphore (make-semaphore 0))
|
|
(async-channel-put view-channel
|
|
(runaway-process runaway-semaphore))
|
|
;; wait for a signal to continue running:
|
|
(semaphore-wait runaway-semaphore))
|
|
(async-channel-put view-channel result))
|
|
|
|
(define keep-running-message
|
|
(string-append
|
|
"The program running in the stepper has taken a whole bunch of steps. "
|
|
"Do you want to continue running it for now, halt, or let it run "
|
|
"without asking again?"))
|
|
|
|
(define (confirm-running)
|
|
(define message-box-result
|
|
(message-box/custom
|
|
"Keep Running Program?"
|
|
keep-running-message
|
|
"Continue for now"
|
|
"Halt"
|
|
"Continue uninterrupted"
|
|
#f ;; use the stepper window instead?
|
|
'(stop disallow-close default=1)
|
|
))
|
|
(match message-box-result
|
|
;; continue-for-now:
|
|
[1 (set! runaway-counter 0)
|
|
#t]
|
|
;; halt:
|
|
[2 #f]
|
|
;; continue-forever:
|
|
[3 (set! runaway-counter 0)
|
|
(set! disable-runaway-counter #t)
|
|
#t]))
|
|
|
|
|
|
|
|
;; translates a result into a step
|
|
;; format-result : step-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 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)
|
|
|
|
(define stepper-frame-eventspace (send s-frame get-eventspace))
|
|
;; START THE MODEL
|
|
(start-listener-thread stepper-frame-eventspace)
|
|
(model:go
|
|
program-expander-prime
|
|
;; what do do with the results:
|
|
deliver-result-to-gui
|
|
(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?)))
|
|
|
|
(send s-frame show #t)
|
|
|
|
;; turn on the buttons and display the first step when it shows up:
|
|
(thread
|
|
(lambda ()
|
|
(semaphore-wait first-step-sema)
|
|
(parameterize
|
|
([current-eventspace stepper-frame-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(jump-to-beginning)
|
|
(enable-all-buttons))))))
|
|
|
|
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.
|
|
;; ...oops, can't use module+ inside of a unit.
|
|
#;(module+ test
|
|
(require rackunit)
|
|
;; zero-length selection cases:
|
|
(check-equal? ((span-overlap 13 13) (model:make-posn-info 14 4)) #f)
|
|
(check-equal? ((span-overlap 14 14) (model:make-posn-info 14 4)) #t)
|
|
(check-equal? ((span-overlap 18 18) (model:make-posn-info 14 4)) #f)
|
|
;; nonzero-length selection cases:
|
|
(check-equal? ((span-overlap 13 14) (model:make-posn-info 14 4)) #f)
|
|
(check-equal? ((span-overlap 13 15) (model:make-posn-info 14 4)) #t)
|
|
(check-equal? ((span-overlap 13 23) (model:make-posn-info 14 4)) #t)
|
|
(check-equal? ((span-overlap 16 17) (model:make-posn-info 14 4)) #t)
|
|
(check-equal? ((span-overlap 16 24) (model:make-posn-info 14 4)) #t)
|
|
(check-equal? ((span-overlap 18 21) (model:make-posn-info 14 4)) #f))
|