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

jump-to-beginning-of-selected

Browse Source 
svn: r14501
This commit is contained in:
John Clements 2009-04-13 23:48:15 +00:00
parent 09bec206d6
commit 9c93191241
7 changed files with 962 additions and 1286 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/stepper/private/marks.ss
View File

@ -1,4 +1,4 @@
(module marks scheme/base
#lang scheme/base
(require mzlib/list
mzlib/contract
@ -180,4 +180,4 @@
(define (make-top-level-mark source-expr)
(make-full-mark source-expr 'top-level null)))
(make-full-mark source-expr 'top-level null))

86
collects/stepper/private/model.ss
View File

@ -35,8 +35,8 @@
; double(x) : ERROR
; late-let(x) : ERROR
#lang scheme/base
(module model scheme/base
(require scheme/contract
scheme/match
scheme/class
@ -92,8 +92,10 @@
(list (list exp-thunk lifting-indices getter))))))
;; the "held" variables are used to store the "before" step.
(define held-exp-list no-sexp)
(define held-step-was-app? #f)
(define held-exp-list the-no-sexp)
(define-struct held (exps was-app? source-pos))
(define held-finished-list null)
;; highlight-mutated-expressions :
@ -192,7 +194,7 @@
(when (or (eq? break-kind 'normal-break)
;; not sure about this...
(eq? break-kind 'nomal-break/values))
(set! held-exp-list skipped-step)))
(set! held-exp-list the-skipped-step)))
(begin
#;(fprintf (current-error-port) "and it wasn't skipped.\n")
@ -205,42 +207,48 @@
"broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed))
(set! held-exp-list
(make-held
(map (lambda (exp)
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-left-side
mark-list returned-value-list render-settings)
#f)))
(set! held-step-was-app? (r:step-was-app? mark-list)))]
#f))
(r:step-was-app? mark-list)
(syntax-position (mark-source (car mark-list))))))]
[(result-exp-break result-value-break)
(if (eq? held-exp-list skipped-step)
;; don't render if before step was a skipped-step
(set! held-exp-list no-sexp)
(let* ([new-finished-list (reconstruct-all-completed)]
[reconstructed
(let ([reconstruct
(lambda ()
(map (lambda (exp)
(unwind exp render-settings))
(maybe-lift
(r:reconstruct-right-side
mark-list returned-value-list render-settings)
#f))]
[result
(if (eq? held-exp-list no-sexp)
#f)))]
[send-result (lambda (result)
(set! held-exp-list the-no-sexp)
(receive-result result))])
(match held-exp-list
[(struct skipped-step ())
;; don't render if before step was a skipped-step
(set! held-exp-list the-no-sexp)]
[(struct no-sexp ())
;; in this case, there was no "before" step, due
;; to unannotated code. In this case, we make the
;; optimistic guess that none of the finished
;; expressions were mutated. It would be somewhat
;; painful to do a better job, and the stepper
;; makes no guarantees in this case.
(send-result
(make-before-after-result
;; NB: this (... ...) IS UNRELATED TO
;; THE MACRO IDIOM OF THE SAME NAME
(list #`(... ...))
(append new-finished-list reconstructed)
'normal)
(append (reconstruct-all-completed) (reconstruct))
'normal
#f #f))]
[(struct held (held-exps held-step-was-app? held-source-pos))
(let*-values
([(step-kind)
(if (and held-step-was-app?
@ -253,19 +261,19 @@
;; (append held-finished-list held-exps)
;; (append new-finished-list reconstructed))
(values (append held-finished-list
held-exp-list)
(append new-finished-list
reconstructed))])
held-exps)
(append (reconstruct-all-completed)
(reconstruct)))])
(send-result
(make-before-after-result
left-exps right-exps step-kind)))])
(set! held-exp-list no-sexp)
(receive-result result)))]
left-exps right-exps step-kind held-source-pos
(syntax-position (mark-source (car mark-list))))))]))]
[(double-break)
;; a double-break occurs at the beginning of a let's
;; evaluation.
(when (not (eq? held-exp-list no-sexp))
(when (not (eq? held-exp-list the-no-sexp))
(error
'break-reconstruction
"held-exp-list not empty when a double-break occurred"))
@ -281,7 +289,8 @@
(make-before-after-result
(append new-finished-list left-side)
(append new-finished-list right-side)
'normal)))]
'normal
#f #f)))]
[(expr-finished-break)
(unless (not mark-list)
@ -311,13 +320,17 @@
(expand-next-expression)))
(define (err-display-handler message exn)
(if (not (eq? held-exp-list no-sexp))
(match held-exp-list
[(struct no-sexp ())
(receive-result (make-error-result message))]
[(struct held (exps dc source-pos))
(begin
(receive-result
(make-before-error-result (append held-finished-list held-exp-list)
message))
(set! held-exp-list no-sexp))
(receive-result (make-error-result message))))
(make-before-error-result (append held-finished-list exps)
message
#f
source-pos))
(set! held-exp-list the-no-sexp))]))
(program-expander
(lambda ()
@ -328,5 +341,14 @@
(if (eof-object? expanded)
(begin
(receive-result (make-finished-stepping)))
(step-through-expression expanded continue-thunk))))))
(step-through-expression expanded continue-thunk)))))
; no-sexp is used to indicate no sexpression for display.
; e.g., on an error message, there's no sexp.
(define-struct no-sexp ())
(define the-no-sexp (make-no-sexp))
; skipped-step is used to indicate that the "before" step was skipped.
(define-struct skipped-step ())
(define the-skipped-step (make-skipped-step))

12
collects/stepper/private/mred-extensions.ss
View File

@ -3,10 +3,8 @@
mred
(prefix f: framework)
mzlib/pretty
"testing-shared.ss"
"shared.ss"
string-constants
mrlib/bitmap-label)
#;"testing-shared.ss"
"shared.ss")
(provide
foot-img/horizontal
@ -529,12 +527,6 @@
(define foot-img/vertical (make-object bitmap% (build-path (collection-path
"icons") "foot-up.png") 'png/mask))
;; stepper-bitmap : the image used for the stepper button
#;(define stepper-bitmap
(bitmap-label-maker
(string-constant stepper-button-label)
(build-path (collection-path "icons") "foot.png")))
;; testing code

8
collects/stepper/private/reconstruct.ss
View File

@ -173,8 +173,8 @@
(define (varref-skip-step? varref)
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
(let ([val (lookup-binding mark-list varref)])
(equal? (syntax-object->interned-datum (recon-value val render-settings))
(syntax-object->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type)
(equal? (syntax->interned-datum (recon-value val render-settings))
(syntax->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type)
([let-bound]
(binding-lifted-name mark-list varref))
([non-lexical]
@ -497,7 +497,7 @@
(define re:beginner: (regexp "^beginner:(.*)$"))
;; eval-quoted : take a syntax-object that is an application of quote, and evaluate it (for display)
;; eval-quoted : take a syntax that is an application of quote, and evaluate it (for display)
;; Frankly, I'm worried by the fact that this isn't done at expansion time.
(define (eval-quoted stx)
@ -878,7 +878,7 @@
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))]))))
; the main recursive reconstruction loop is in recon:
; recon : (syntax-object mark-list boolean -> syntax-object)
; recon : (syntax mark-list boolean -> syntax)
(define (recon so-far mark-list first)
(cond [(null? mark-list) ; now taken to indicate a callback:

126
collects/stepper/private/shared.ss
View File

@ -1,14 +1,10 @@
(module shared mzscheme
#lang scheme
(require "my-macros.ss"
mzlib/contract
mzlib/list
mzlib/etc
mzlib/match
srfi/26
mzlib/class)
scheme/class)
(require (for-syntax mzlib/list))
#;(require (for-syntax mzlib/list))
; CONTRACTS
@ -51,16 +47,14 @@
varref-set-remove-bindings
binding-set-varref-set-intersect
step-result?
(struct before-after-result (pre-exps post-exps kind))
(struct before-error-result (pre-exps err-msg))
(struct error-result (err-msg))
(struct finished-stepping ())
(struct-out before-after-result)
(struct-out before-error-result)
(struct-out error-result)
(struct-out finished-stepping)
list-take
list-partition
(struct closure-record (name mark constructor? lifted-index))
(struct-out closure-record)
*unevaluated*
no-sexp
skipped-step
struct-flag
multiple-highlight
flatten-take
@ -76,7 +70,7 @@
queue-push ; queue val ->
queue-pop ; queue -> val
queue-length ; queue -> num
rebuild-stx ; datum syntax-object -> syntax-object
rebuild-stx ; datum syntax -> syntax
break-kind? ; predicate
varref-set? ; predicate
binding-set? ; predicate
@ -102,7 +96,11 @@
skipto/second
skipto/third
skipto/fourth
skipto/firstarg)
skipto/firstarg
view-controller^
stepper-frame^
)
;; stepper-syntax-property : like syntax property, but adds properties to an association
;; list associated with the syntax property 'stepper-properties
@ -135,10 +133,10 @@
; or (make-error-result finished-exps err-msg)
; or (make-finished-result finished-exps)
(define-struct before-after-result (pre-exps post-exps kind) (make-inspector))
(define-struct before-error-result (pre-exps err-msg) (make-inspector))
(define-struct error-result (err-msg) (make-inspector))
(define-struct finished-stepping () (make-inspector))
(define-struct before-after-result (pre-exps post-exps kind pre-src post-src) #:transparent)
(define-struct before-error-result (pre-exps err-msg pre-src) #:transparent)
(define-struct error-result (err-msg) #:transparent)
(define-struct finished-stepping () #:transparent)
(define step-result? (or/c before-after-result? before-error-result? error-result? finished-stepping?))
@ -150,7 +148,7 @@
(define (create-bogus-binding name)
(let* ([gensymed-name (gensym name)]
[binding (datum->syntax-object #'here gensymed-name)])
[binding (datum->syntax #'here gensymed-name)])
binding))
; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings
@ -162,14 +160,14 @@
; make-gensym-source : (string -> (key -> binding))
(define (make-binding-source id-string binding-maker key-displayer)
(let ([assoc-table (make-hash-table 'weak)])
(let ([assoc-table (make-weak-hash)])
(lambda (key)
(let ([maybe-fetch (hash-table-get assoc-table key (lambda () #f))])
(let ([maybe-fetch (hash-ref assoc-table key (lambda () #f))])
(or maybe-fetch
(begin
(let* ([new-binding (binding-maker
(string-append id-string (key-displayer key) "-"))])
(hash-table-put! assoc-table key new-binding)
(hash-set! assoc-table key new-binding)
new-binding)))))))
@ -249,27 +247,21 @@
(define (next-lifted-symbol str)
(let ([index lifted-index])
(set! lifted-index (+ lifted-index 1))
(datum->syntax-object #'here (string->symbol (string-append str (number->string index))))))
(datum->syntax #'here (string->symbol (string-append str (number->string index))))))
(define get-lifted-var
(let ([assoc-table (box null)])
(lambda (stx)
(let ([maybe-fetch (weak-assoc-search assoc-table stx module-identifier=?)])
(let ([maybe-fetch (weak-assoc-search assoc-table stx free-identifier=?)])
(or maybe-fetch
(begin
(let* ([new-binding (next-lifted-symbol
(string-append "lifter-" (format "~a" (syntax-object->datum stx)) "-"))])
(string-append "lifter-" (format "~a" (syntax->datum stx)) "-"))])
(weak-assoc-add assoc-table stx new-binding)
new-binding)))))))
; gensyms needed by many modules:
; no-sexp is used to indicate no sexpression for display.
; e.g., on an error message, there's no sexp.
(define no-sexp (gensym "no-sexp-"))
; skipped-step is used to indicate that the "before" step was skipped.
(define skipped-step (gensym "skipped-step-"))
; multiple-highlight is used to indicate multiple highlighted expressions
(define multiple-highlight (gensym "multiple-highlight-"))
@ -306,16 +298,16 @@
(apply append (list-take n a-list)))
(define-values (closure-table-put! closure-table-lookup in-closure-table)
(let ([closure-table (make-hash-table 'weak)])
(let ([closure-table (make-weak-hash)])
(values
(lambda (key value)
(hash-table-put! closure-table key value)
(hash-set! closure-table key value)
key) ; this return allows a run-time-optimization
(lambda args ; key or key & failure-thunk
(apply hash-table-get closure-table args))
(apply hash-ref closure-table args))
(lambda (key)
(let/ec k
(hash-table-get closure-table key (lambda () (k #f)))
(hash-ref closure-table key (lambda () (k #f)))
#t)))))
;(begin (closure-table-put! 'foo 'bar)
@ -395,7 +387,7 @@
(length (unbox queue)))
(define (rebuild-stx new old)
(syntax-recertify (datum->syntax-object old new old old)
(syntax-recertify (datum->syntax old new old old)
old
(current-code-inspector)
#f))
@ -472,9 +464,9 @@
(define skipto/fourth `(syntax-e cdr cdr cdr car))
(define skipto/firstarg (append skipto/cdr skipto/second))
;; skipto/auto : syntax-object?
;; skipto/auto : syntax?
;; (symbols 'rebuild 'discard)
;; (syntax-object? . -> . syntax-object?)
;; (syntax? . -> . syntax?)
;; "skips over" part of a tree to find a subtree indicated by the
;; stepper-skipto property. If the traversal argument is 'rebuild, the
;; result of transformation is embedded again in the same tree. if the
@ -488,7 +480,7 @@
[else (transformer stx)]))
; small test case:
#;(display (equal? (syntax-object->datum
#;(display (equal? (syntax->datum
(skipto/auto (stepper-syntax-property #`(a #,(stepper-syntax-property #`(b c)
'stepper-skipto
'(syntax-e cdr car)))
@ -509,12 +501,12 @@
; binding-set-union: (listof BINDING-SET) -> BINDING-SET
; varref-set-union: (listof VARREF-SET) -> VARREF-SET
(define profiling-table (make-hash-table 'equal))
(define profiling-table (make-hash))
(define (reset-profiling-table)
(set! profiling-table (make-hash-table 'equal)))
(set! profiling-table (make-hash)))
(define (get-set-pair-union-stats)
(hash-table-map profiling-table (lambda (k v) (list k (unbox v)))))
(hash-map profiling-table (lambda (k v) (list k (unbox v)))))
;; test cases :
;; (profiling-table-incr 1 2)
@ -623,12 +615,10 @@
#`#,(string->symbol (symbol->string (syntax-e identifier))))
(provide/contract [syntax-object->hilite-datum ((syntax?) ; input
(boolean?) ; ignore-highlight?
. opt-> .
any/c)]) ; sexp with explicit tags
(provide/contract [syntax->hilite-datum
((syntax?) (#:ignore-highlight? boolean?) . ->* . any)]) ; sexp with explicit tags
;; syntax-object->hilite-datum : takes a syntax object with zero or more
;; syntax->hilite-datum : takes a syntax object with zero or more
;; subexpressions tagged with the 'stepper-highlight', 'stepper-xml-hint', and 'stepper-xml-value-hint' syntax-properties
;; and turns it into a datum, where expressions with the named
;; properties result in (hilite <datum>), (xml-box <datum>), (scheme-box <datum>) and (splice-box <datum>) rather than <datum>. It also
@ -637,15 +627,14 @@
;;
;; this procedure is useful in checking the output of the stepper.
(define syntax-object->hilite-datum
(opt-lambda (stx [ignore-highlight? #f])
(define (syntax->hilite-datum stx #:ignore-highlight? [ignore-highlight? #f])
(let ([datum (syntax-case stx ()
[(a . rest) (cons (syntax-object->hilite-datum #`a) (syntax-object->hilite-datum #`rest))]
[(a . rest) (cons (syntax->hilite-datum #`a) (syntax->hilite-datum #`rest))]
[id
(identifier? stx)
(string->symbol (symbol->string (syntax-e stx)))]
[else (if (syntax? stx)
(syntax-object->datum stx)
(syntax->datum stx)
stx)])])
(let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint)
[(from-xml-box) `(xml-box ,datum)]
@ -659,30 +648,30 @@
(stepper-syntax-property stx 'stepper-highlight))
`(hilite ,it)
it)])
it))))
it)))
;; finished-xml-box-table : this table tracks values that are the result
;; of evaluating xml boxes. These values should be rendered as xml boxes,
;; and not as simple lists.
(define finished-xml-box-table (make-hash-table 'weak))
(define finished-xml-box-table (make-weak-hash))
(provide/contract [syntax-object->interned-datum (syntax? ; input
(provide/contract [syntax->interned-datum (syntax? ; input
. -> .
any)]) ; sexp
;; syntax-object->interned-datum : like syntax-object->datum, except
;; syntax->interned-datum : like syntax->datum, except
;; that it re-interns all identifiers. Useful in checking whether
;; two sexps will have the same printed representation.
(define (syntax-object->interned-datum stx)
(define (syntax->interned-datum stx)
(syntax-case stx ()
[(a . rest) (cons (syntax-object->interned-datum #`a) (syntax-object->interned-datum #`rest))]
[(a . rest) (cons (syntax->interned-datum #`a) (syntax->interned-datum #`rest))]
[id
(identifier? stx)
(string->symbol (symbol->string (syntax-e stx)))]
[else (if (syntax? stx)
(syntax-object->datum stx)
(syntax->datum stx)
stx)]))
@ -727,7 +716,11 @@
(define (language-level->name language)
(car (last-pair (send language get-language-position))))
)
(define-signature view-controller^ (go))
(define-signature stepper-frame^ (stepper-frame%))
; test cases
@ -736,12 +729,12 @@
;(load (build-path (collection-path "tests" "mzscheme") "testing.ss"))
;
;(define (a sym)
; (syntax-object->datum (get-lifted-var sym)))
; (syntax->datum (get-lifted-var sym)))
;(define cd-stx
; (datum->syntax-object #f 'cd))
;(test 'lifter-ab-0 a (datum->syntax-object #f 'ab))
; (datum->syntax #f 'cd))
;(test 'lifter-ab-0 a (datum->syntax #f 'ab))
;(test 'lifter-cd-1 a cd-stx)
;(test 'lifter-ef-2 a (datum->syntax-object #f 'ef))
;(test 'lifter-ef-2 a (datum->syntax #f 'ef))
;(test 'lifter-cd-1 a cd-stx)
;
;(test '(a b c) map syntax-e (arglist->ilist #'(a b c)))
@ -786,5 +779,6 @@
;(test 'yes stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'abc)
;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'no) 'abc 'yes) 'abc)
;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg) 'abc)
;(test 13 syntax-object->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg))
;(test 13 syntax->datum (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg))

7
collects/stepper/stepper+xml-tool.ss
View File

@ -2,7 +2,9 @@
(require mzlib/unit
drscheme/tool
"stepper-tool.ss"
"xml-tool.ss")
"xml-tool.ss"
"view-controller.ss"
"private/shared.ss")
(provide tool@)
@ -19,4 +21,5 @@
(import drscheme:tool^)
(export STEPPER-TOOL)
(link xml-tool@
(((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@)))))
view-controller@
[((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@]))))

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

@ -1,32 +1,20 @@
(module stepper-tool mzscheme
#lang scheme/unit
(require mzlib/contract
(require scheme/class
drscheme/tool
mred
mzlib/pconvert
string-constants
mzlib/async-channel
(prefix frame: framework)
mzlib/unit
mzlib/class
mzlib/list
(prefix-in frame: framework)
mrlib/switchable-button
(prefix model: "private/model.ss")
"private/my-macros.ss"
(prefix x: "private/mred-extensions.ss")
(prefix-in x: "private/mred-extensions.ss")
"private/shared.ss"
"private/model-settings.ss"
lang/stepper-language-interface
"xml-sig.ss")
(provide stepper-tool@
make-print-convert-hook
set-print-settings
simple-module-based-language-convert-value)
(define-unit stepper-tool@
(import drscheme:tool^ xml^)
(export drscheme:tool-exports^)
(import drscheme:tool^ xml^ view-controller^)
(export drscheme:tool-exports^ stepper-frame^)
;; tool magic here:
(define (phase1)
@ -44,8 +32,7 @@
(define (stepper:show-lambdas-as-lambdas?) #t)
(public stepper:render-to-sexp)
(define (stepper:render-to-sexp val settings language-level)
(parameterize ([current-print-convert-hook
(make-print-convert-hook settings)])
(parameterize ([current-print-convert-hook stepper-print-convert-hook])
(set-print-settings
language-level
settings
@ -63,8 +50,6 @@
(define stepper-initial-width 500)
(define stepper-initial-height 500)
(define drscheme-eventspace (current-eventspace))
(define (extract-language-level definitions-text)
(settings->language-level (definitions-text->settings definitions-text)))
@ -157,324 +142,6 @@
[width stepper-initial-width]
[height stepper-initial-height])))
;; 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
;; -> returns the new frame%
(define (view-controller-go drscheme-frame program-expander)
;; 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))
(define language-level-name
(language-level->name language-level))
;; 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 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, 'waiting-for-end
(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.
(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))
(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"))
(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)))))))
(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)))
;; 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-end)
(or (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))))))
;; 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
(define (find-later-step p n)
(let loop ([step 0]
[remaining view-history])
(cond [(null? remaining) #f]
[(and (> step n) (p (car remaining))) step]
[else (loop (+ step 1) (cdr remaining))])))
(define (find-later-application-step n)
(find-later-step application-step? n))
(define (find-later-finished-stepping-step n)
(find-later-step finished-stepping-step? n))
(define (find-later-any-step n)
(find-later-step (lambda (x) #t) n))
;; is this an application step?
(define (application-step? history-entry)
(case (cadr history-entry)
[(user-application finished-stepping) #t]
[else #f]))
;; is this the finished-stepping step?
(define (finished-stepping-step? history-entry)
(case (cadr history-entry)
[(finished-stepping) #t]
[else #f]))
;; build gui object:
;; home : the action of the 'home' button
(define (home)
(set! stepper-is-waiting? #f)
(update-view/existing 0))
;; next-of-specified-kind: if the desired step is already in the list, display
;; it; otherwise, wait for it.
(define (next-of-specified-kind find-step right-kind? wait-for-it-flag)
(set! stepper-is-waiting? #f)
(let ([found-step (find-step view)])
(if found-step
(update-view/existing found-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)])
(when try-get
(add-view-triple try-get))
(if (and try-get (right-kind? (list-ref view-history (+ view 1))))
(update-view/existing (+ view 1))
(begin
(set! stepper-is-waiting? wait-for-it-flag)
(en/dis-able-buttons))))))))
;; respond to a click on the "next" button
(define (next)
(next-of-specified-kind find-later-any-step
(lambda (x) #t)
'waiting-for-any-step))
;; respond to a click on the "next application" button
(define (next-application)
(next-of-specified-kind find-later-application-step
application-step?
'waiting-for-application))
;; respond to a click on the "jump to end" button
(define (jump-to-end)
(next-of-specified-kind find-later-finished-stepping-step
finished-stepping-step?
'waiting-for-end))
;; previous : the action of the 'previous' button
(define (previous)
(set! stepper-is-waiting? #f)
(when (= view 0)
(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
(define (previous-application)
(set! stepper-is-waiting? #f)
(when (= view 0)
(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 (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 (add-button name fun)
(make-object button% name button-panel (lambda (_1 _2) (fun))))
(define home-button (add-button (string-constant stepper-home) home))
(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-to-end-button (add-button (string-constant stepper-jump-to-end) jump-to-end))
(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)
(set! view new-view)
(let ([e (car (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))
(send e end-edit-sequence))
(en/dis-able-buttons))
;; en/dis-able-buttons : set enable & disable the stepper buttons,
;; based on view-controller state
(define (en/dis-able-buttons)
(let* ([can-go-back? (> view 0)])
(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 (or (find-later-any-step view)
(not stepper-is-waiting?)))
(send next-application-button
enable (or (find-later-application-step view)
(not stepper-is-waiting?)))
(send jump-to-end-button
enable (or (find-later-finished-stepping-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)
(let ([step-text
(cond [(before-after-result? result)
(new x:stepper-text%
[left-side (before-after-result-pre-exps result)]
[right-side (before-after-result-post-exps result)])]
[(before-error-result? result)
(new x:stepper-text%
[left-side (before-error-result-pre-exps result)]
[right-side (before-error-result-err-msg result)])]
[(error-result? result)
(new x:stepper-text%
[left-side null]
[right-side (error-result-err-msg result)])]
[(finished-stepping? result)
x:finished-text])]
[step-kind (or (and (before-after-result? result)
(before-after-result-kind result))
(and (finished-stepping? result)
'finished-stepping))])
(hand-off-and-block step-text step-kind)))
;; 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)
;; stepper-unit-frame<%> : the interface that the extended drscheme frame
;; fulfils
@ -542,7 +209,7 @@
[label (string-constant stepper-button-label)]
[bitmap x:foot-img/horizontal]
[alternate-bitmap x:foot-img/vertical]
[callback (lambda (button)
[callback (lambda (dont-care)
(if stepper-frame
(send stepper-frame show #t)
(let* ([language-level
@ -550,7 +217,9 @@
[language-level-name (language-level->name language-level)])
(if (stepper-works-for? language-level)
(set! stepper-frame
(view-controller-go this program-expander))
(go this
program-expander
(+ 1 (send (get-definitions-text) get-start-position))))
(message-box
(string-constant stepper-name)
(format (string-constant stepper-language-level-message)
@ -642,8 +311,6 @@
(drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin)
(drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin)
)
;; COPIED FROM drscheme/private/language.ss
;; simple-module-based-language-convert-value : TST STYLE boolean -> TST
(define (simple-module-based-language-convert-value value style show-sharing?)
@ -688,11 +355,10 @@
;; 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)
;; stepper-convert-hook:
;; (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)
(define (stepper-print-convert-hook exp basic-convert sub-convert)
(cond
[(is-a? exp snip%)
(send exp copy)]
@ -714,6 +380,5 @@
(error 'which-number-snip
"expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e"
number-snip-type)]))]
[else (basic-convert exp)])))
[else (basic-convert exp)]))
)