reformatting only
This commit is contained in:
John Clements
parent
ac0bb2b98f
commit
615f687d7c
|
|
@ -308,7 +308,8 @@
|
|||
[(step=? rhs-exps last-rhs-exps)
|
||||
(when DEBUG
|
||||
(printf "SKIPPING STEP (LHS = ellipses and RHS = last RHS)\n"))]
|
||||
; SKIPPING step, lhs = ellipses and highlight-stack = null and last-rhs = null
|
||||
; SKIPPING step, lhs = ellipses and highlight-stack = null and
|
||||
; last-rhs = null
|
||||
; if last-rhs != null, send step (lhs = ...)
|
||||
[(null? highlight-stack)
|
||||
(if (not (null? last-rhs-exps))
|
||||
|
|
@ -384,8 +385,11 @@
|
|||
(λ ()
|
||||
(when DEBUG
|
||||
(printf "\nforcing saved MARKLIST\n")
|
||||
(for-each (λ (x) (printf "~a\n" (display-mark x))) mark-list)
|
||||
(printf "saved RETURNED VALUE LIST: ~a\n" returned-value-list))
|
||||
(for-each (λ (x)
|
||||
(printf "~a\n" (display-mark x)))
|
||||
mark-list)
|
||||
(printf "saved RETURNED VALUE LIST: ~a\n"
|
||||
returned-value-list))
|
||||
(map (λ (exp) (unwind exp render-settings))
|
||||
(maybe-lift
|
||||
(r:reconstruct-left-side
|
||||
|
|
@ -396,29 +400,26 @@
|
|||
|
||||
; CASE: result-exp-break or result-value-break ----------------
|
||||
[(result-exp-break result-value-break)
|
||||
(let ([reconstruct
|
||||
(lambda ()
|
||||
(let* ([rhs-reconstructed
|
||||
(r:reconstruct-right-side
|
||||
mark-list returned-value-list render-settings)]
|
||||
[print-rhs-recon
|
||||
(when DEBUG
|
||||
(printf "RHS (pre-unwound):\n ~a\n"
|
||||
(syntax->hilite-datum rhs-reconstructed)))]
|
||||
[rhs-unwound
|
||||
(map (λ (exp) (unwind exp render-settings))
|
||||
(maybe-lift rhs-reconstructed #f))]
|
||||
[print-rhs-unwound
|
||||
(when DEBUG
|
||||
(for-each
|
||||
(λ (x) (printf "RHS (unwound): ~a\n"
|
||||
(syntax->hilite-datum x)))
|
||||
rhs-unwound))])
|
||||
rhs-unwound))])
|
||||
(define (reconstruct)
|
||||
(define rhs-reconstructed
|
||||
(r:reconstruct-right-side
|
||||
mark-list returned-value-list render-settings))
|
||||
(when DEBUG
|
||||
(printf "RHS (pre-unwound):\n ~a\n"
|
||||
(syntax->hilite-datum
|
||||
rhs-reconstructed)))
|
||||
(define rhs-unwound
|
||||
(map (λ (exp) (unwind exp render-settings))
|
||||
(maybe-lift rhs-reconstructed #f)))
|
||||
(when DEBUG
|
||||
(for-each
|
||||
(λ (x) (printf "RHS (unwound): ~a\n"
|
||||
(syntax->hilite-datum x)))
|
||||
rhs-unwound)))
|
||||
(match held-exp-list
|
||||
[(struct skipped-step ())
|
||||
(when DEBUG (printf "LHS = skipped, so skipping RHS\n"))
|
||||
;; don't render if before step was a skipped-step
|
||||
;; don't render if before step was a skipped-step
|
||||
(reset-held-exp-list)]
|
||||
[(struct no-sexp ())
|
||||
(when DEBUG (printf "LHS = none\n"))
|
||||
|
|
@ -437,7 +438,7 @@
|
|||
(reconstruct) (reconstruct-all-completed)
|
||||
(compute-step-kind held-step-was-app?)
|
||||
held-posn-info (compute-posn-info))
|
||||
(reset-held-exp-list)]))]
|
||||
(reset-held-exp-list)])]
|
||||
|
||||
; CASE: double-break ------------------------------------------
|
||||
[(double-break)
|
||||
|
|
@ -447,31 +448,31 @@
|
|||
(error
|
||||
'break-reconstruction
|
||||
"held-exp-list not empty when a double-break occurred"))
|
||||
(let* ([new-finished-list (reconstruct-all-completed)]
|
||||
[reconstruct-result
|
||||
(r:reconstruct-double-break mark-list render-settings)]
|
||||
[print-recon
|
||||
(when DEBUG
|
||||
(printf "LHS (pre-unwound):\n ~a\n"
|
||||
(syntax->hilite-datum (car reconstruct-result)))
|
||||
(printf "RHS (pre-unwound):\n ~a\n"
|
||||
(syntax->hilite-datum (cadr reconstruct-result))))]
|
||||
[lhs-unwound (map (lambda (exp) (unwind exp render-settings))
|
||||
(maybe-lift (car reconstruct-result) #f))]
|
||||
[rhs-unwound (map (lambda (exp) (unwind exp render-settings))
|
||||
(maybe-lift (cadr reconstruct-result) #t))]
|
||||
[print-unwound
|
||||
(when DEBUG
|
||||
(for-each (λ (x) (printf "LHS (unwound):\n ~a\n"
|
||||
(syntax->hilite-datum x)))
|
||||
lhs-unwound)
|
||||
(for-each (λ (x) (printf "right side (unwound):\n ~a\n"
|
||||
(syntax->hilite-datum x)))
|
||||
rhs-unwound))])
|
||||
(send-step lhs-unwound new-finished-list
|
||||
rhs-unwound new-finished-list
|
||||
'normal
|
||||
(compute-posn-info) (compute-posn-info)))]
|
||||
(define new-finished-list (reconstruct-all-completed))
|
||||
(define reconstruct-result
|
||||
(r:reconstruct-double-break mark-list render-settings))
|
||||
(when DEBUG
|
||||
(printf "LHS (pre-unwound):\n ~a\n"
|
||||
(syntax->hilite-datum (car reconstruct-result)))
|
||||
(printf "RHS (pre-unwound):\n ~a\n"
|
||||
(syntax->hilite-datum (cadr reconstruct-result))))
|
||||
(define lhs-unwound
|
||||
(map (lambda (exp) (unwind exp render-settings))
|
||||
(maybe-lift (car reconstruct-result) #f)))
|
||||
(define rhs-unwound
|
||||
(map (lambda (exp) (unwind exp render-settings))
|
||||
(maybe-lift (cadr reconstruct-result) #t)))
|
||||
(when DEBUG
|
||||
(for-each (λ (x) (printf "LHS (unwound):\n ~a\n"
|
||||
(syntax->hilite-datum x)))
|
||||
lhs-unwound)
|
||||
(for-each (λ (x) (printf "right side (unwound):\n ~a\n"
|
||||
(syntax->hilite-datum x)))
|
||||
rhs-unwound))
|
||||
(send-step lhs-unwound new-finished-list
|
||||
rhs-unwound new-finished-list
|
||||
'normal
|
||||
(compute-posn-info) (compute-posn-info))]
|
||||
|
||||
; CASE: expr-finished-break -----------------------------------
|
||||
[(expr-finished-break)
|
||||
|
|
@ -489,7 +490,8 @@
|
|||
(printf " source: ~a\n" (syntax->hilite-datum ((car x))))
|
||||
(printf " index: ~a\n" (second x))
|
||||
(printf " getter: ")
|
||||
(if (stepper-syntax-property ((car x)) 'stepper-black-box-expr)
|
||||
(if (stepper-syntax-property ((car x))
|
||||
'stepper-black-box-expr)
|
||||
(printf "no getter for term with stepper-black-box-expr property\n")
|
||||
(printf "~a\n" ((third x)))))
|
||||
returned-value-list))
|
||||
|
|
@ -502,7 +504,8 @@
|
|||
(define maybe-lift
|
||||
(if (render-settings-lifting? render-settings)
|
||||
lift
|
||||
;; ... oh dear; model.rkt should disable the double-break & late-let break when lifting is off.
|
||||
;; ... oh dear; model.rkt should disable the double-break & late-let
|
||||
;; break when lifting is off.
|
||||
(lambda (stx dont-care) (list stx))))
|
||||
|
||||
(define (step-through-expression expanded expand-next-expression)
|
||||
|
|
|
|||
|
|
@ -47,21 +47,31 @@
|
|||
(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))
|
||||
(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)
|
||||
(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))
|
||||
(send language-level stepper:render-to-sexp
|
||||
val simple-settings language-level))
|
||||
|
||||
;; channel for incoming views
|
||||
(define view-channel (make-async-channel))
|
||||
|
|
@ -78,7 +88,8 @@
|
|||
;; 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.
|
||||
;; wait for steps to show up on the channel.
|
||||
;; When they do, add them to the list.
|
||||
(define (start-listener-thread stepper-frame-eventspace)
|
||||
(thread
|
||||
(lambda ()
|
||||
|
|
@ -99,15 +110,16 @@
|
|||
;; 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
|
||||
;; 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))])]
|
||||
(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)
|
||||
|
|
@ -117,7 +129,8 @@
|
|||
;; 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."))
|
||||
(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])
|
||||
|
|
@ -152,12 +165,13 @@
|
|||
(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
|
||||
;; 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.
|
||||
;; 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)
|
||||
|
|
@ -225,7 +239,8 @@
|
|||
;; choice box option
|
||||
(define (jump-to-prior-application)
|
||||
(prior-of-specified-kind application-step?
|
||||
(string-constant stepper-no-earlier-application-step)))
|
||||
(string-constant
|
||||
stepper-no-earlier-application-step)))
|
||||
|
||||
|
||||
;; GUI ELEMENTS:
|
||||
|
|
@ -315,7 +330,8 @@
|
|||
(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 insert
|
||||
(format "~a/~a" (if view (+ 1 view) "none") (length view-history)))
|
||||
(send status-text lock #t)
|
||||
(send status-text end-edit-sequence))
|
||||
|
||||
|
|
@ -338,21 +354,24 @@
|
|||
(make-step (new x:stepper-text%
|
||||
[left-side pre-exps]
|
||||
[right-side post-exps]
|
||||
[show-inexactness? (send language-level stepper:show-inexactness?)])
|
||||
[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?)])
|
||||
[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?)])
|
||||
[show-inexactness?
|
||||
(send language-level stepper:show-inexactness?)])
|
||||
'finished-or-error
|
||||
(list))]
|
||||
[(struct finished-stepping ())
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user