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 (require mzlib/list
mzlib/contract mzlib/contract
@ -180,4 +180,4 @@
(define (make-top-level-mark source-expr) (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 ; double(x) : ERROR
; late-let(x) : ERROR ; late-let(x) : ERROR
#lang scheme/base
(module model scheme/base
(require scheme/contract (require scheme/contract
scheme/match scheme/match
scheme/class scheme/class
@ -92,8 +92,10 @@
(list (list exp-thunk lifting-indices getter)))))) (list (list exp-thunk lifting-indices getter))))))
;; the "held" variables are used to store the "before" step. ;; the "held" variables are used to store the "before" step.
(define held-exp-list no-sexp) (define held-exp-list the-no-sexp)
(define held-step-was-app? #f)
(define-struct held (exps was-app? source-pos))
(define held-finished-list null) (define held-finished-list null)
;; highlight-mutated-expressions : ;; highlight-mutated-expressions :
@ -192,7 +194,7 @@
(when (or (eq? break-kind 'normal-break) (when (or (eq? break-kind 'normal-break)
;; not sure about this... ;; not sure about this...
(eq? break-kind 'nomal-break/values)) (eq? break-kind 'nomal-break/values))
(set! held-exp-list skipped-step))) (set! held-exp-list the-skipped-step)))
(begin (begin
#;(fprintf (current-error-port) "and it wasn't skipped.\n") #;(fprintf (current-error-port) "and it wasn't skipped.\n")
@ -205,42 +207,48 @@
"broken invariant: normal-break can't have returned values")) "broken invariant: normal-break can't have returned values"))
(set! held-finished-list (reconstruct-all-completed)) (set! held-finished-list (reconstruct-all-completed))
(set! held-exp-list (set! held-exp-list
(make-held
(map (lambda (exp) (map (lambda (exp)
(unwind exp render-settings)) (unwind exp render-settings))
(maybe-lift (maybe-lift
(r:reconstruct-left-side (r:reconstruct-left-side
mark-list returned-value-list render-settings) mark-list returned-value-list render-settings)
#f))) #f))
(set! held-step-was-app? (r:step-was-app? mark-list)))] (r:step-was-app? mark-list)
(syntax-position (mark-source (car mark-list))))))]
[(result-exp-break result-value-break) [(result-exp-break result-value-break)
(if (eq? held-exp-list skipped-step) (let ([reconstruct
;; don't render if before step was a skipped-step (lambda ()
(set! held-exp-list no-sexp)
(let* ([new-finished-list (reconstruct-all-completed)]
[reconstructed
(map (lambda (exp) (map (lambda (exp)
(unwind exp render-settings)) (unwind exp render-settings))
(maybe-lift (maybe-lift
(r:reconstruct-right-side (r:reconstruct-right-side
mark-list returned-value-list render-settings) mark-list returned-value-list render-settings)
#f))] #f)))]
[result [send-result (lambda (result)
(if (eq? held-exp-list no-sexp) (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 ;; in this case, there was no "before" step, due
;; to unannotated code. In this case, we make the ;; to unannotated code. In this case, we make the
;; optimistic guess that none of the finished ;; optimistic guess that none of the finished
;; expressions were mutated. It would be somewhat ;; expressions were mutated. It would be somewhat
;; painful to do a better job, and the stepper ;; painful to do a better job, and the stepper
;; makes no guarantees in this case. ;; makes no guarantees in this case.
(send-result
(make-before-after-result (make-before-after-result
;; NB: this (... ...) IS UNRELATED TO ;; NB: this (... ...) IS UNRELATED TO
;; THE MACRO IDIOM OF THE SAME NAME ;; THE MACRO IDIOM OF THE SAME NAME
(list #`(... ...)) (list #`(... ...))
(append new-finished-list reconstructed) (append (reconstruct-all-completed) (reconstruct))
'normal) 'normal
#f #f))]
[(struct held (held-exps held-step-was-app? held-source-pos))
(let*-values (let*-values
([(step-kind) ([(step-kind)
(if (and held-step-was-app? (if (and held-step-was-app?
@ -253,19 +261,19 @@
;; (append held-finished-list held-exps) ;; (append held-finished-list held-exps)
;; (append new-finished-list reconstructed)) ;; (append new-finished-list reconstructed))
(values (append held-finished-list (values (append held-finished-list
held-exp-list) held-exps)
(append new-finished-list (append (reconstruct-all-completed)
reconstructed))]) (reconstruct)))])
(send-result
(make-before-after-result (make-before-after-result
left-exps right-exps step-kind)))]) left-exps right-exps step-kind held-source-pos
(set! held-exp-list no-sexp) (syntax-position (mark-source (car mark-list))))))]))]
(receive-result result)))]
[(double-break) [(double-break)
;; a double-break occurs at the beginning of a let's ;; a double-break occurs at the beginning of a let's
;; evaluation. ;; evaluation.
(when (not (eq? held-exp-list no-sexp)) (when (not (eq? held-exp-list the-no-sexp))
(error (error
'break-reconstruction 'break-reconstruction
"held-exp-list not empty when a double-break occurred")) "held-exp-list not empty when a double-break occurred"))
@ -281,7 +289,8 @@
(make-before-after-result (make-before-after-result
(append new-finished-list left-side) (append new-finished-list left-side)
(append new-finished-list right-side) (append new-finished-list right-side)
'normal)))] 'normal
#f #f)))]
[(expr-finished-break) [(expr-finished-break)
(unless (not mark-list) (unless (not mark-list)
@ -311,13 +320,17 @@
(expand-next-expression))) (expand-next-expression)))
(define (err-display-handler message exn) (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 (begin
(receive-result (receive-result
(make-before-error-result (append held-finished-list held-exp-list) (make-before-error-result (append held-finished-list exps)
message)) message
(set! held-exp-list no-sexp)) #f
(receive-result (make-error-result message)))) source-pos))
(set! held-exp-list the-no-sexp))]))
(program-expander (program-expander
(lambda () (lambda ()
@ -328,5 +341,14 @@
(if (eof-object? expanded) (if (eof-object? expanded)
(begin (begin
(receive-result (make-finished-stepping))) (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 mred
(prefix f: framework) (prefix f: framework)
mzlib/pretty mzlib/pretty
"testing-shared.ss" #;"testing-shared.ss"
"shared.ss" "shared.ss")
string-constants
mrlib/bitmap-label)
(provide (provide
foot-img/horizontal foot-img/horizontal
@ -529,12 +527,6 @@
(define foot-img/vertical (make-object bitmap% (build-path (collection-path (define foot-img/vertical (make-object bitmap% (build-path (collection-path
"icons") "foot-up.png") 'png/mask)) "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 ;; testing code

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

@ -173,8 +173,8 @@
(define (varref-skip-step? varref) (define (varref-skip-step? varref)
(with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)]) (with-handlers ([exn:fail:contract:variable? (lambda (dc-exn) #f)])
(let ([val (lookup-binding mark-list varref)]) (let ([val (lookup-binding mark-list varref)])
(equal? (syntax-object->interned-datum (recon-value val render-settings)) (equal? (syntax->interned-datum (recon-value val render-settings))
(syntax-object->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type) (syntax->interned-datum (case (stepper-syntax-property varref 'stepper-binding-type)
([let-bound] ([let-bound]
(binding-lifted-name mark-list varref)) (binding-lifted-name mark-list varref))
([non-lexical] ([non-lexical]
@ -497,7 +497,7 @@
(define re:beginner: (regexp "^beginner:(.*)$")) (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. ;; Frankly, I'm worried by the fact that this isn't done at expansion time.
(define (eval-quoted stx) (define (eval-quoted stx)
@ -878,7 +878,7 @@
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))])))) "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax->datum exp))]))))
; the main recursive reconstruction loop is in recon: ; 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) (define (recon so-far mark-list first)
(cond [(null? mark-list) ; now taken to indicate a callback: (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" (require "my-macros.ss"
mzlib/contract
mzlib/list
mzlib/etc
mzlib/match
srfi/26 srfi/26
mzlib/class) scheme/class)
(require (for-syntax mzlib/list)) #;(require (for-syntax mzlib/list))
; CONTRACTS ; CONTRACTS
@ -51,16 +47,14 @@
varref-set-remove-bindings varref-set-remove-bindings
binding-set-varref-set-intersect binding-set-varref-set-intersect
step-result? step-result?
(struct before-after-result (pre-exps post-exps kind)) (struct-out before-after-result)
(struct before-error-result (pre-exps err-msg)) (struct-out before-error-result)
(struct error-result (err-msg)) (struct-out error-result)
(struct finished-stepping ()) (struct-out finished-stepping)
list-take list-take
list-partition list-partition
(struct closure-record (name mark constructor? lifted-index)) (struct-out closure-record)
*unevaluated* *unevaluated*
no-sexp
skipped-step
struct-flag struct-flag
multiple-highlight multiple-highlight
flatten-take flatten-take
@ -76,7 +70,7 @@
queue-push ; queue val -> queue-push ; queue val ->
queue-pop ; queue -> val queue-pop ; queue -> val
queue-length ; queue -> num queue-length ; queue -> num
rebuild-stx ; datum syntax-object -> syntax-object rebuild-stx ; datum syntax -> syntax
break-kind? ; predicate break-kind? ; predicate
varref-set? ; predicate varref-set? ; predicate
binding-set? ; predicate binding-set? ; predicate
@ -102,7 +96,11 @@
skipto/second skipto/second
skipto/third skipto/third
skipto/fourth skipto/fourth
skipto/firstarg) skipto/firstarg
view-controller^
stepper-frame^
)
;; stepper-syntax-property : like syntax property, but adds properties to an association ;; stepper-syntax-property : like syntax property, but adds properties to an association
;; list associated with the syntax property 'stepper-properties ;; list associated with the syntax property 'stepper-properties
@ -135,10 +133,10 @@
; or (make-error-result finished-exps err-msg) ; or (make-error-result finished-exps err-msg)
; or (make-finished-result finished-exps) ; or (make-finished-result finished-exps)
(define-struct before-after-result (pre-exps post-exps kind) (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) (make-inspector)) (define-struct before-error-result (pre-exps err-msg pre-src) #:transparent)
(define-struct error-result (err-msg) (make-inspector)) (define-struct error-result (err-msg) #:transparent)
(define-struct finished-stepping () (make-inspector)) (define-struct finished-stepping () #:transparent)
(define step-result? (or/c before-after-result? before-error-result? error-result? finished-stepping?)) (define step-result? (or/c before-after-result? before-error-result? error-result? finished-stepping?))
@ -150,7 +148,7 @@
(define (create-bogus-binding name) (define (create-bogus-binding name)
(let* ([gensymed-name (gensym name)] (let* ([gensymed-name (gensym name)]
[binding (datum->syntax-object #'here gensymed-name)]) [binding (datum->syntax #'here gensymed-name)])
binding)) binding))
; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings ; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings
@ -162,14 +160,14 @@
; make-gensym-source : (string -> (key -> binding)) ; make-gensym-source : (string -> (key -> binding))
(define (make-binding-source id-string binding-maker key-displayer) (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) (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 (or maybe-fetch
(begin (begin
(let* ([new-binding (binding-maker (let* ([new-binding (binding-maker
(string-append id-string (key-displayer key) "-"))]) (string-append id-string (key-displayer key) "-"))])
(hash-table-put! assoc-table key new-binding) (hash-set! assoc-table key new-binding)
new-binding))))))) new-binding)))))))
@ -249,27 +247,21 @@
(define (next-lifted-symbol str) (define (next-lifted-symbol str)
(let ([index lifted-index]) (let ([index lifted-index])
(set! lifted-index (+ lifted-index 1)) (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 (define get-lifted-var
(let ([assoc-table (box null)]) (let ([assoc-table (box null)])
(lambda (stx) (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 (or maybe-fetch
(begin (begin
(let* ([new-binding (next-lifted-symbol (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) (weak-assoc-add assoc-table stx new-binding)
new-binding))))))) new-binding)))))))
; gensyms needed by many modules: ; 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 ; multiple-highlight is used to indicate multiple highlighted expressions
(define multiple-highlight (gensym "multiple-highlight-")) (define multiple-highlight (gensym "multiple-highlight-"))
@ -306,16 +298,16 @@
(apply append (list-take n a-list))) (apply append (list-take n a-list)))
(define-values (closure-table-put! closure-table-lookup in-closure-table) (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 (values
(lambda (key value) (lambda (key value)
(hash-table-put! closure-table key value) (hash-set! closure-table key value)
key) ; this return allows a run-time-optimization key) ; this return allows a run-time-optimization
(lambda args ; key or key & failure-thunk (lambda args ; key or key & failure-thunk
(apply hash-table-get closure-table args)) (apply hash-ref closure-table args))
(lambda (key) (lambda (key)
(let/ec k (let/ec k
(hash-table-get closure-table key (lambda () (k #f))) (hash-ref closure-table key (lambda () (k #f)))
#t))))) #t)))))
;(begin (closure-table-put! 'foo 'bar) ;(begin (closure-table-put! 'foo 'bar)
@ -395,7 +387,7 @@
(length (unbox queue))) (length (unbox queue)))
(define (rebuild-stx new old) (define (rebuild-stx new old)
(syntax-recertify (datum->syntax-object old new old old) (syntax-recertify (datum->syntax old new old old)
old old
(current-code-inspector) (current-code-inspector)
#f)) #f))
@ -472,9 +464,9 @@
(define skipto/fourth `(syntax-e cdr cdr cdr car)) (define skipto/fourth `(syntax-e cdr cdr cdr car))
(define skipto/firstarg (append skipto/cdr skipto/second)) (define skipto/firstarg (append skipto/cdr skipto/second))
;; skipto/auto : syntax-object? ;; skipto/auto : syntax?
;; (symbols 'rebuild 'discard) ;; (symbols 'rebuild 'discard)
;; (syntax-object? . -> . syntax-object?) ;; (syntax? . -> . syntax?)
;; "skips over" part of a tree to find a subtree indicated by the ;; "skips over" part of a tree to find a subtree indicated by the
;; stepper-skipto property. If the traversal argument is 'rebuild, the ;; stepper-skipto property. If the traversal argument is 'rebuild, the
;; result of transformation is embedded again in the same tree. if the ;; result of transformation is embedded again in the same tree. if the
@ -488,7 +480,7 @@
[else (transformer stx)])) [else (transformer stx)]))
; small test case: ; small test case:
#;(display (equal? (syntax-object->datum #;(display (equal? (syntax->datum
(skipto/auto (stepper-syntax-property #`(a #,(stepper-syntax-property #`(b c) (skipto/auto (stepper-syntax-property #`(a #,(stepper-syntax-property #`(b c)
'stepper-skipto 'stepper-skipto
'(syntax-e cdr car))) '(syntax-e cdr car)))
@ -509,12 +501,12 @@
; binding-set-union: (listof BINDING-SET) -> BINDING-SET ; binding-set-union: (listof BINDING-SET) -> BINDING-SET
; varref-set-union: (listof VARREF-SET) -> VARREF-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) (define (reset-profiling-table)
(set! profiling-table (make-hash-table 'equal))) (set! profiling-table (make-hash)))
(define (get-set-pair-union-stats) (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 : ;; test cases :
;; (profiling-table-incr 1 2) ;; (profiling-table-incr 1 2)
@ -623,12 +615,10 @@
#`#,(string->symbol (symbol->string (syntax-e identifier)))) #`#,(string->symbol (symbol->string (syntax-e identifier))))
(provide/contract [syntax-object->hilite-datum ((syntax?) ; input (provide/contract [syntax->hilite-datum
(boolean?) ; ignore-highlight? ((syntax?) (#:ignore-highlight? boolean?) . ->* . any)]) ; sexp with explicit tags
. opt-> .
any/c)]) ; 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 ;; 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 ;; 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 ;; 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. ;; this procedure is useful in checking the output of the stepper.
(define syntax-object->hilite-datum (define (syntax->hilite-datum stx #:ignore-highlight? [ignore-highlight? #f])
(opt-lambda (stx [ignore-highlight? #f])
(let ([datum (syntax-case stx () (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 [id
(identifier? stx) (identifier? stx)
(string->symbol (symbol->string (syntax-e stx)))] (string->symbol (symbol->string (syntax-e stx)))]
[else (if (syntax? stx) [else (if (syntax? stx)
(syntax-object->datum stx) (syntax->datum stx)
stx)])]) stx)])])
(let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint) (let* ([it (case (stepper-syntax-property stx 'stepper-xml-hint)
[(from-xml-box) `(xml-box ,datum)] [(from-xml-box) `(xml-box ,datum)]
@ -659,30 +648,30 @@
(stepper-syntax-property stx 'stepper-highlight)) (stepper-syntax-property stx 'stepper-highlight))
`(hilite ,it) `(hilite ,it)
it)]) it)])
it)))) it)))
;; finished-xml-box-table : this table tracks values that are the result ;; finished-xml-box-table : this table tracks values that are the result
;; of evaluating xml boxes. These values should be rendered as xml boxes, ;; of evaluating xml boxes. These values should be rendered as xml boxes,
;; and not as simple lists. ;; 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 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 ;; that it re-interns all identifiers. Useful in checking whether
;; two sexps will have the same printed representation. ;; two sexps will have the same printed representation.
(define (syntax-object->interned-datum stx) (define (syntax->interned-datum stx)
(syntax-case 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 [id
(identifier? stx) (identifier? stx)
(string->symbol (symbol->string (syntax-e stx)))] (string->symbol (symbol->string (syntax-e stx)))]
[else (if (syntax? stx) [else (if (syntax? stx)
(syntax-object->datum stx) (syntax->datum stx)
stx)])) stx)]))
@ -727,7 +716,11 @@
(define (language-level->name language) (define (language-level->name language)
(car (last-pair (send language get-language-position)))) (car (last-pair (send language get-language-position))))
)
(define-signature view-controller^ (go))
(define-signature stepper-frame^ (stepper-frame%))
; test cases ; test cases
@ -736,12 +729,12 @@
;(load (build-path (collection-path "tests" "mzscheme") "testing.ss")) ;(load (build-path (collection-path "tests" "mzscheme") "testing.ss"))
; ;
;(define (a sym) ;(define (a sym)
; (syntax-object->datum (get-lifted-var sym))) ; (syntax->datum (get-lifted-var sym)))
;(define cd-stx ;(define cd-stx
; (datum->syntax-object #f 'cd)) ; (datum->syntax #f 'cd))
;(test 'lifter-ab-0 a (datum->syntax-object #f 'ab)) ;(test 'lifter-ab-0 a (datum->syntax #f 'ab))
;(test 'lifter-cd-1 a cd-stx) ;(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 'lifter-cd-1 a cd-stx)
; ;
;(test '(a b c) map syntax-e (arglist->ilist #'(a b c))) ;(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 #`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 'no) 'abc 'yes) 'abc)
;(test 'yes stepper-syntax-property (stepper-syntax-property (stepper-syntax-property #`13 'abc 'yes) 'def 'arg) '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 (require mzlib/unit
drscheme/tool drscheme/tool
"stepper-tool.ss" "stepper-tool.ss"
"xml-tool.ss") "xml-tool.ss"
"view-controller.ss"
"private/shared.ss")
(provide tool@) (provide tool@)
@ -19,4 +21,5 @@
(import drscheme:tool^) (import drscheme:tool^)
(export STEPPER-TOOL) (export STEPPER-TOOL)
(link xml-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 drscheme/tool
mred mred
mzlib/pconvert mzlib/pconvert
string-constants string-constants
mzlib/async-channel (prefix-in frame: framework)
(prefix frame: framework)
mzlib/unit
mzlib/class
mzlib/list
mrlib/switchable-button mrlib/switchable-button
(prefix model: "private/model.ss")
"private/my-macros.ss" "private/my-macros.ss"
(prefix x: "private/mred-extensions.ss") (prefix-in x: "private/mred-extensions.ss")
"private/shared.ss" "private/shared.ss"
"private/model-settings.ss"
lang/stepper-language-interface lang/stepper-language-interface
"xml-sig.ss") "xml-sig.ss")
(provide stepper-tool@ (import drscheme:tool^ xml^ view-controller^)
make-print-convert-hook (export drscheme:tool-exports^ stepper-frame^)
set-print-settings
simple-module-based-language-convert-value)
(define-unit stepper-tool@
(import drscheme:tool^ xml^)
(export drscheme:tool-exports^)
;; tool magic here: ;; tool magic here:
(define (phase1) (define (phase1)
@ -44,8 +32,7 @@
(define (stepper:show-lambdas-as-lambdas?) #t) (define (stepper:show-lambdas-as-lambdas?) #t)
(public stepper:render-to-sexp) (public stepper:render-to-sexp)
(define (stepper:render-to-sexp val settings language-level) (define (stepper:render-to-sexp val settings language-level)
(parameterize ([current-print-convert-hook (parameterize ([current-print-convert-hook stepper-print-convert-hook])
(make-print-convert-hook settings)])
(set-print-settings (set-print-settings
language-level language-level
settings settings
@ -63,8 +50,6 @@
(define stepper-initial-width 500) (define stepper-initial-width 500)
(define stepper-initial-height 500) (define stepper-initial-height 500)
(define drscheme-eventspace (current-eventspace))
(define (extract-language-level definitions-text) (define (extract-language-level definitions-text)
(settings->language-level (definitions-text->settings definitions-text))) (settings->language-level (definitions-text->settings definitions-text)))
@ -157,324 +142,6 @@
[width stepper-initial-width] [width stepper-initial-width]
[height stepper-initial-height]))) [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 ;; stepper-unit-frame<%> : the interface that the extended drscheme frame
;; fulfils ;; fulfils
@ -542,7 +209,7 @@
[label (string-constant stepper-button-label)] [label (string-constant stepper-button-label)]
[bitmap x:foot-img/horizontal] [bitmap x:foot-img/horizontal]
[alternate-bitmap x:foot-img/vertical] [alternate-bitmap x:foot-img/vertical]
[callback (lambda (button) [callback (lambda (dont-care)
(if stepper-frame (if stepper-frame
(send stepper-frame show #t) (send stepper-frame show #t)
(let* ([language-level (let* ([language-level
@ -550,7 +217,9 @@
[language-level-name (language-level->name language-level)]) [language-level-name (language-level->name language-level)])
(if (stepper-works-for? language-level) (if (stepper-works-for? language-level)
(set! stepper-frame (set! stepper-frame
(view-controller-go this program-expander)) (go this
program-expander
(+ 1 (send (get-definitions-text) get-start-position))))
(message-box (message-box
(string-constant stepper-name) (string-constant stepper-name)
(format (string-constant stepper-language-level-message) (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-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)
)
;; COPIED FROM drscheme/private/language.ss ;; COPIED FROM drscheme/private/language.ss
;; simple-module-based-language-convert-value : TST STYLE boolean -> TST ;; simple-module-based-language-convert-value : TST STYLE boolean -> TST
(define (simple-module-based-language-convert-value value style show-sharing?) (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) ;; WE REALLY WANT TO GET RID OF THIS STUFF (2005-07-01, JBC)
;; make-print-convert-hook: ;; stepper-convert-hook:
;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) ;; (TST (TST -> TST) (TST -> TST) -> TST)
;; this code copied from various locations in language.ss and rep.ss ;; this code copied from various locations in language.ss and rep.ss
(define (make-print-convert-hook simple-settings) (define (stepper-print-convert-hook exp basic-convert sub-convert)
(lambda (exp basic-convert sub-convert)
(cond (cond
[(is-a? exp snip%) [(is-a? exp snip%)
(send exp copy)] (send exp copy)]
@ -714,6 +380,5 @@
(error 'which-number-snip (error 'which-number-snip
"expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e" "expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e"
number-snip-type)]))] number-snip-type)]))]
[else (basic-convert exp)]))) [else (basic-convert exp)]))
)