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

reverted changes from 782 to 303 for 299.400 release

Browse Source 
svn: r783
This commit is contained in:
John Clements 2005-09-07 03:04:30 +00:00
parent 8d40bf8fd9
commit 9575d74aa2
10 changed files with 642 additions and 648 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

285
collects/stepper/private/annotate.ss
View File

@ -9,6 +9,7 @@
"my-macros.ss"
"xml-box.ss"
(prefix beginner-defined: "beginner-defined.ss"))
; CONTRACTS
@ -57,8 +58,23 @@
; `(#%let-values ((,arg-temp-syms ,annotated)) ,@full-body)))
;;;;;;;;;;
;;
;; collapse-let-values: for the purposes of the annotater, it's easier to simply collapse let's and
;; let*'s into one big let*. The lexical-binding information attached to each variable reference
;; guarantees that this won't affect correctness
;;
;;;;;;;;;;
; test exps:
;; uh... apparently this isn't used. 2005-01-15, JBC
#;(define (collapse-let-values stx)
(syntax-case stx (let-values let*-values)
[(_ (outer-binding ...) (let-values (inner-binding ...) . bodies))
(collapse-let-values (syntax/loc stx (let*-values (outer-binding ... inner-binding ...) . bodies)))]
[else stx]))
; test exprs:
; (andmap (lambda (arg-list)
; (let* ([stx (car arg-list)]
; [elaborated (cadr arg-list)]
@ -101,7 +117,7 @@
[let-bound-bindings null]
[cond-test (lx #f)])
(if (or (syntax-property stx 'stepper-skip-completely)
(syntax-property stx '.stepper-define-struct-hint))
(syntax-property stx 'stepper-define-struct-hint))
stx
(let* ([recur-regular
(lambda (stx)
@ -179,8 +195,6 @@
; let/letrec :
[(let-values x ...) (do-let/rec stx #f)]
[(letrec-values x ...) (do-let/rec stx #t)]
; varref :
[var
(identifier? (syntax var))
(syntax-property
@ -216,7 +230,7 @@
; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ;;; ;; ;;;;; ;; ;;;;
; oh-say-can-you-see,by-the-dawn's-early-light,what-so-proudly-we-hailed,at-the-twilight's-last-gle
@ -253,7 +267,7 @@
; c) a boolean indicating whether to store inferred names.
;
(define (annotate main-exp break track-inferred-names?)
(define (annotate expr break track-inferred-names?)
(define binding-indexer
(let ([binding-index 0])
@ -271,12 +285,15 @@
(define (result-value-break vals-list)
(break (current-continuation-marks) 'result-value-break vals-list))
(define (exp-finished-break info-list)
(break #f 'expr-finished-break info-list))
(define (expr-finished-break vals-list)
(break (current-continuation-marks) 'expr-finished-break vals-list))
(define (double-break)
(break (current-continuation-marks) 'double-break))
(define (late-let-break . interlaced-info)
(break (current-continuation-marks) 'late-let-break interlaced-info))
; here are the possible configurations of wcm's, pre-breaks, and breaks (not including late-let & double-breaks):
; (for full-on stepper)
@ -284,38 +301,44 @@
; wcm, normal-break
; wcm-pre-break-wrap : call wcm-wrap with a pre-break on the expr
(define (wcm-pre-break-wrap debug-info exp)
(wcm-wrap debug-info #`(begin (#,result-exp-break) #,exp)))
(define (wcm-pre-break-wrap debug-info expr)
(wcm-wrap debug-info #`(begin (#,result-exp-break) #,expr)))
(define (break-wrap exp)
#`(begin (#,normal-break) #,exp))
(define (break-wrap expr)
#`(begin (#,normal-break) #,expr))
(define (double-break-wrap exp)
#`(begin (#,double-break) #,exp))
(define (double-break-wrap expr)
#`(begin (#,double-break) #,expr))
(define (return-value-wrap exp)
(define (late-let-break-wrap var-names lifted-gensyms expr)
(let* ([interlaced (apply append (map list var-names lifted-gensyms))])
#`(begin (#,late-let-break #,@interlaced) #,expr)))
(define (return-value-wrap expr)
#`(call-with-values
(lambda () #,exp)
(lambda () #,expr)
(lambda args
(#,result-value-break args)
(apply values args))))
(define (expr-finished-break-wrap expr)
#`(call-with-values
(lambda () #,expr)
(lambda args (#,expr-finished-break args) (apply values args))))
(define (make-define-struct-break exp)
(define (make-define-struct-break expr)
(lambda ()
(break #f 'expr-finished-break (list (list (lambda () exp)
#f
(lambda () (error 'make-define-struct-break
"no getter for a define-struct")))))))
(define (top-level-annotate/inner exp source-exp defined-name)
(break #f 'define-struct-break (list expr))))
(define (top-level-annotate/inner expr source-expr defined-name)
(let*-2vals ([(annotated dont-care)
(annotate/inner exp 'all #f defined-name)])
#`(with-continuation-mark #,debug-key
#,(make-top-level-mark source-exp)
;; inserting eta-expansion to prevent destruction of top-level mark
(call-with-values (lambda () #,annotated)
(lambda args (apply values args))))))
(annotate/inner expr 'all #f defined-name)]
[top-level-wrapped #`(with-continuation-mark #,debug-key
#,(make-top-level-mark source-expr)
#,(expr-finished-break-wrap annotated))])
top-level-wrapped))
; annotate/inner takes
; a) an expression to annotate
@ -351,15 +374,15 @@
(define annotate/inner
;(-> syntax? binding-set? boolean? (union false/c syntax? (list/p syntax? syntax?)) (vector/p syntax? binding-set?))
(lambda (exp tail-bound pre-break? procedure-name-info)
(lambda (expr tail-bound pre-break? procedure-name-info)
(cond [(syntax-property exp 'stepper-skipto)
(cond [(syntax-property expr 'stepper-skipto)
(let* ([free-vars-captured #f] ; this will be set!'ed
;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (syntax-property expr 'stepper-skipto))]
; WARNING! I depend on the order of evaluation in application arguments here:
[annotated (skipto-annotate
(syntax-property exp 'stepper-skipto)
exp
(syntax-property expr 'stepper-skipto)
expr
(lambda (subterm)
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
(set! free-vars-captured free-vars)
@ -369,32 +392,32 @@
annotated)
free-vars-captured))]
[(syntax-property exp 'stepper-skip-completely)
(2vals (wcm-wrap 13 exp) null)]
[(syntax-property expr 'stepper-skip-completely)
(2vals (wcm-wrap 13 expr) null)]
[else
(let* ([tail-recur (lambda (exp) (annotate/inner exp tail-bound #t procedure-name-info))]
[non-tail-recur (lambda (exp) (annotate/inner exp null #f #f))]
[result-recur (lambda (exp) (annotate/inner exp null #f procedure-name-info))]
[set!-rhs-recur (lambda (exp name) (annotate/inner exp null #f name))]
[let-rhs-recur (lambda (exp binding-names dyn-index-syms)
(let* ([tail-recur (lambda (expr) (annotate/inner expr tail-bound #t procedure-name-info))]
[non-tail-recur (lambda (expr) (annotate/inner expr null #f #f))]
[result-recur (lambda (expr) (annotate/inner expr null #f procedure-name-info))]
[set!-rhs-recur (lambda (expr name) (annotate/inner expr null #f name))]
[let-rhs-recur (lambda (expr binding-names dyn-index-syms)
(let* ([proc-name-info
(if (not (null? binding-names))
(list (car binding-names) (car dyn-index-syms))
#f)])
(annotate/inner exp null #f proc-name-info)))]
[lambda-body-recur (lambda (exp) (annotate/inner exp 'all #t #f))]
(annotate/inner expr null #f proc-name-info)))]
[lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))]
; note: no pre-break for the body of a let; it's handled by the break for the
; let itself.
[let-body-recur (lambda (bindings)
(lambda (exp)
(annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))]
(lambda (expr)
(annotate/inner expr (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))]
[make-debug-info-normal (lambda (free-bindings)
(make-debug-info exp tail-bound free-bindings 'none #t))]
(make-debug-info expr tail-bound free-bindings 'none #t))]
[make-debug-info-app (lambda (tail-bound free-bindings label)
(make-debug-info exp tail-bound free-bindings label #t))]
(make-debug-info expr tail-bound free-bindings label #t))]
[make-debug-info-let (lambda (free-bindings binding-list let-counter)
(make-debug-info exp
(make-debug-info expr
(binding-set-union (list tail-bound
binding-list
(list let-counter)))
@ -406,8 +429,8 @@
[outer-wcm-wrap (if pre-break?
wcm-pre-break-wrap
wcm-wrap)]
[wcm-break-wrap (lambda (debug-info exp)
(outer-wcm-wrap debug-info (break-wrap exp)))]
[wcm-break-wrap (lambda (debug-info expr)
(outer-wcm-wrap debug-info (break-wrap expr)))]
[normal-bundle
(lambda (free-vars annotated)
@ -495,13 +518,7 @@
; known otherwise.
; whoops! hold the phone. I think I can get away with a break before, and
; a mark after, so only one of each. groovy, eh?
; 2005-08: note that the set!-based approach on the let-counter is broken in the presence of
; continuations; backing up a computation using a set! will not revert the
; counter, and the stepper may think that the computation is in a different
; place. To fix this, we must go to a pure let* with nested marks at each right-hand-side.
[let-abstraction
(lambda (stx output-identifier make-init-list)
(with-syntax ([(_ ([(var ...) val] ...) . bodies) stx])
@ -540,27 +557,19 @@
(map (lambda (binding-set val)
#`(set!-values #,binding-set #,val))
binding-sets
annotated-vals)]
[exp-finished-clauses
(with-syntax ([(_ let-clauses . dc) stx]
[((lifted-var ...) ...) lifted-var-sets])
(with-syntax ([(exp-thunk ...) (map (lx (lambda () _))
(syntax->list #`let-clauses))])
#`(list (list exp-thunk
(list lifted-var ...)
(lambda () (list var ...))) ...)))]
annotated-vals)]
; time to work from the inside out again
; without renaming, this would all be much much simpler.
[wrapped-begin (outer-wcm-wrap (make-debug-info-let free-varrefs
binding-list
let-counter)
(double-break-wrap
#`(begin #,@(apply append (zip set!-clauses counter-clauses))
(#,exp-finished-break #,exp-finished-clauses)
#,annotated-body)))])
#`(begin #,@(apply append (zip set!-clauses counter-clauses))
#,(late-let-break-wrap binding-list
lifted-vars
annotated-body))))])
(2vals (quasisyntax/loc
exp
expr
(let ([#,counter-id (#,binding-indexer)])
(#,output-identifier #,outer-initialization #,wrapped-begin)))
free-varrefs)))))]
@ -584,8 +593,8 @@
#`(begin (set! #,if-temp #,annotated-test)
(#,normal-break)
#,(if else
(quasisyntax/loc exp (if #,if-temp #,annotated-then #,annotated-else))
(quasisyntax/loc exp (if #,if-temp #,annotated-then))))]
(quasisyntax/loc expr (if #,if-temp #,annotated-then #,annotated-else))
(quasisyntax/loc expr (if #,if-temp #,annotated-then))))]
[wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list if-temp)))
(varref-set-union (list free-varrefs (list if-temp)))
'none)
@ -594,7 +603,7 @@
(with-syntax ([test-var if-temp]
[wrapped-stx wrapped]
[unevaluated-stx *unevaluated*])
(syntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx)))
(syntax/loc expr (let ([test-var unevaluated-stx]) wrapped-stx)))
free-varrefs)))]
[varref-abstraction
@ -633,32 +642,32 @@
[recertifier
(lambda (vals)
(let*-2vals ([(new-exp bindings) vals])
(2vals (syntax-recertify new-exp exp (current-code-inspector) #f)
(let*-2vals ([(new-expr bindings) vals])
(2vals (syntax-recertify new-expr expr (current-code-inspector) #f)
bindings)))]
)
; find the source expression and associate it with the parsed expression
; (when (and red-exprs foot-wrap?)
; (set-exp-read! exp (find-read-expr exp)))
; (set-expr-read! expr (find-read-expr expr)))
(recertifier
(kernel:kernel-syntax-case exp #f
(kernel:kernel-syntax-case expr #f
[(lambda . clause)
(let*-2vals ([(annotated-clause free-varrefs)
(lambda-clause-abstraction (syntax clause))]
[annotated-lambda
(with-syntax ([annotated-clause annotated-clause])
(syntax/loc exp (lambda . annotated-clause)))])
(syntax/loc expr (lambda . annotated-clause)))])
(outer-lambda-abstraction annotated-lambda free-varrefs))]
[(case-lambda . clauses)
(let*-2vals ([(annotated-cases free-varrefs-cases)
(2vals-map lambda-clause-abstraction (syntax->list (syntax clauses)))]
[annotated-case-lambda (with-syntax ([annotated-cases annotated-cases])
(syntax/loc exp (case-lambda . annotated-cases)))]
(syntax/loc expr (case-lambda . annotated-cases)))]
[free-varrefs (varref-set-union free-varrefs-cases)])
(outer-lambda-abstraction annotated-case-lambda free-varrefs))]
@ -669,7 +678,7 @@
[(begin . bodies-stx)
(if (null? (syntax->list (syntax bodies-stx)))
(normal-bundle null exp)
(normal-bundle null expr)
(let*-2vals
([reversed-bodies (reverse (syntax->list (syntax bodies-stx)))]
[last-body (car reversed-bodies)]
@ -679,7 +688,7 @@
[(annotated-final free-varrefs-final)
(tail-recur last-body)])
(normal-bundle (varref-set-union (cons free-varrefs-final free-varrefs-a))
(quasisyntax/loc exp (begin #,@annotated-a #,annotated-final)))))]
(quasisyntax/loc expr (begin #,@annotated-a #,annotated-final)))))]
[(begin0 . bodies-stx)
(let*-2vals
@ -689,16 +698,16 @@
[(annotated-bodies free-varref-sets)
(2vals-map non-tail-recur (cdr bodies))])
(normal-bundle (varref-set-union (cons free-varrefs-first free-varref-sets))
(quasisyntax/loc exp (begin0 #,annotated-first #,@annotated-bodies))))]
(quasisyntax/loc expr (begin0 #,annotated-first #,@annotated-bodies))))]
[(let-values . _)
(let-abstraction exp
(let-abstraction expr
#`let-values
(lambda (bindings)
(map (lambda (_) *unevaluated*) bindings)))]
[(letrec-values . _)
(let-abstraction exp
(let-abstraction expr
#`letrec-values
(lambda (bindings) (map (lambda (b) #`#,b) bindings)))]
@ -707,30 +716,16 @@
([(annotated-val val-free-varrefs)
(set!-rhs-recur (syntax val) (syntax-case (syntax var) (#%top)
[(#%top . real-var) (syntax-e (syntax real-var))]
[else (syntax var)]))]
[free-varrefs (varref-set-union (list val-free-varrefs (list #`var)))]
[annotated-set!
#`(begin (set! #,set!-temp #,annotated-val)
(#,normal-break)
#,(return-value-wrap
(quasisyntax/loc exp (set! var #,set!-temp))))]
[wrapped (outer-wcm-wrap (make-debug-info-app (binding-set-union (list tail-bound (list set!-temp)))
(varref-set-union (list free-varrefs (list set!-temp)))
'none)
annotated-set!)])
(2vals
(with-syntax ([test-var set!-temp]
[wrapped-stx wrapped]
[unevaluated-stx *unevaluated*])
(quasisyntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx)))
free-varrefs))]
[else (syntax var)]))])
(normal-bundle (varref-set-union (list (list (syntax var)) val-free-varrefs))
(quasisyntax/loc expr (set! #,(syntax var) #,annotated-val))))]
[(quote _)
(normal-bundle null exp)]
(normal-bundle null expr)]
[(quote-syntax _)
(normal-bundle null exp)]
(normal-bundle null expr)]
[(with-continuation-mark key mark body)
;(let*-2vals ([(annotated-key free-varrefs-key)
@ -795,12 +790,12 @@
arg-temps)]
[let-clauses #`((#,tagged-arg-temps
(values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))]
[set!-list (map (lambda (arg-symbol annotated-sub-exp)
#`(set! #,arg-symbol #,annotated-sub-exp))
[set!-list (map (lambda (arg-symbol annotated-sub-expr)
#`(set! #,arg-symbol #,annotated-sub-expr))
tagged-arg-temps annotated-terms)]
[new-tail-bound (binding-set-union (list tail-bound tagged-arg-temps))]
[app-debug-info (make-debug-info-app new-tail-bound tagged-arg-temps 'called)]
[app-term (quasisyntax/loc exp #,tagged-arg-temps)]
[app-term (quasisyntax/loc expr #,tagged-arg-temps)]
[debug-info (make-debug-info-app new-tail-bound
(varref-set-union (list free-varrefs tagged-arg-temps)) ; NB using bindings as vars
'not-yet-called)]
@ -816,7 +811,7 @@
free-varrefs))]
[(#%datum . _)
(normal-bundle null exp)]
(normal-bundle null expr)]
[(#%top . var-stx)
(varref-abstraction #`var-stx)]
@ -826,7 +821,7 @@
(varref-abstraction #`var-stx)]
[else
(error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))])))
(error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum expr))])))])))
;; annotate/top-level : syntax-> syntax
@ -838,72 +833,64 @@
(define/contract annotate/top-level
(syntax? . -> . syntax?)
(lambda (exp)
(syntax-case exp (module #%plain-module-begin let-values dynamic-wind lambda)
[(module name lang
(#%plain-module-begin . bodies))
#`(module name lang (#%plain-module-begin #,@(map annotate/module-top-level (syntax->list #`bodies))))]
(lambda (expr)
(syntax-case expr (module #%plain-module-begin let-values dynamic-wind lambda)
[(m1 n1 l1
(pm1 . bodies))
#`(m1 n1 l1 (pm1 #,@(map annotate/module-top-level (syntax->list #`bodies))))]
; the 'require' form is used for the test harness
[(require module-name) exp]
[(require module-name)
expr]
; the 'dynamic-require' form is used by the actual expander
[(let-values ([(done-already?) . rest1])
(#%app dynamic-wind
void
(lambda () . rest2)
(lambda () . rest3)))
exp]
[else (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax-object->datum exp))])))
expr]
[else (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax-object->datum expr))])))
(define/contract annotate/module-top-level
(syntax? . -> . syntax?)
(lambda (exp)
(cond [(syntax-property exp 'stepper-skip-completely) exp]
[(syntax-property exp 'stepper-define-struct-hint)
#`(begin #,exp
(#,(make-define-struct-break exp)))]
[(syntax-property exp 'stepper-skipto)
(skipto-annotate (syntax-property exp 'stepper-skipto) exp annotate/module-top-level)]
(lambda (expr)
(cond [(syntax-property expr 'stepper-skip-completely) expr]
[(syntax-property expr 'stepper-define-struct-hint)
#`(begin #,expr
(#,(make-define-struct-break (syntax-property expr 'stepper-define-struct-hint))))]
[(syntax-property expr 'stepper-skipto)
(skipto-annotate (syntax-property expr 'stepper-skipto) expr annotate/module-top-level)]
[else
(syntax-case exp (#%app call-with-values define-values define-syntaxes require require-for-syntax provide begin lambda)
[(define-values (new-var ...) e)
(let* ([name-list (syntax->list #`(new-var ...))]
(syntax-case expr (#%app call-with-values define-values define-syntaxes require require-for-syntax provide begin lambda)
[(define-values (new-vars ...) e)
(let* ([name-list (syntax->list #`(new-vars ...))]
[defined-name (if (and (pair? name-list) (null? (cdr name-list)))
(car name-list)
#f)])
#`(begin
(define-values (new-var ...)
#,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name))
;; this next expression should deliver the newly computed values to an exp-finished-break
(#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () (list new-var ...)))))))]
#`(define-values (new-vars ...)
#,(top-level-annotate/inner (top-level-rewrite #`e) expr defined-name)))]
[(define-syntaxes (new-vars ...) e)
exp]
expr]
[(require specs ...)
exp]
expr]
[(require-for-syntax specs ...)
exp]
expr]
[(provide specs ...)
exp]
expr]
[(begin . bodies)
#`(begin #,@(map annotate/module-top-level (syntax->list #`bodies)))]
[(#%app call-with-values (lambda () body) print-values)
#`(call-with-values
(lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f))
(lambda vals
(begin
(#,exp-finished-break (list (list #,(lambda () exp) #f (lambda () vals))))
(call-with-values (lambda () vals)
print-values))))]
#`(#%app call-with-values (lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) expr #f)) print-values)]
[any
(syntax-property exp 'stepper-test-suite-hint)
(top-level-annotate/inner (top-level-rewrite exp) exp #f)]
(syntax-property expr 'stepper-test-suite-hint)
(top-level-annotate/inner (top-level-rewrite expr) expr #f)]
[else
(top-level-annotate/inner (top-level-rewrite exp) exp #f)
(top-level-annotate/inner (top-level-rewrite expr) expr #f)
;; the following check can't be permitted in the presence of things like test-suite cases
;; which produce arbitrary expressions at the top level.
#;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax-object->datum exp))])])))
#;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax-object->datum expr))])])))
; body of local
#;(printf "input: ~a\n" exp)
(let* ([annotated-exp (annotate/top-level main-exp)])
#;(printf "annotated: \n~a\n" (syntax-object->datum annotated-exp))
annotated-exp)))
#;(printf "input: ~a\n" expr)
(let* ([annotated-expr (annotate/top-level expr)])
#;(printf "annotated: \n~a\n" (syntax-object->datum annotated-expr))
annotated-expr)))

34
collects/stepper/private/display-exp-interface.ss Normal file
View File

@ -0,0 +1,34 @@
(module display-exp-interface mzscheme
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "contract.ss")
"my-macros.ss"
"highlight-placeholder.ss")
(provide exp-without-holes?
exp-with-holes?)
; an exp-with-holes is either:
; - a pair of exp-with-holes's,
; - null,
; - a symbol, or
; - the highlight-placeholder
(define exp-without-holes-base-case? (union symbol? number? string? null? (lambda (v) (is-a? v snip%))))
(define exp-without-holes?
(union exp-without-holes-base-case?
(and/c pair? (cons/c (lx ((flat-contract-predicate exp-without-holes?) _))
(lx ((flat-contract-predicate exp-without-holes?) _))))))
(define exp-with-holes-base-case?
(union exp-without-holes-base-case?
(lx (eq? _ highlight-placeholder))))
(define exp-with-holes?
(union exp-with-holes-base-case?
(and/c pair? (cons/c (lx ((flat-contract-predicate exp-with-holes?) _))
(lx ((flat-contract-predicate exp-with-holes?) _))))))
)

13
collects/stepper/private/highlight-placeholder.ss Normal file
View File

@ -0,0 +1,13 @@
(module highlight-placeholder mzscheme
(provide highlight-placeholder highlight-placeholder-stx)
; highlight-placeholder : symbol
; highlight-placeholder-stx : syntax
; we rely upon the fact that the highlight-placeholder-stx is a syntax-object, so that
; syntax objects containing the highlight-placeholder-stx still fit the data definition
; for syntax objects
(define highlight-placeholder (gensym "highlight-placeholder"))
(define highlight-placeholder-stx #`#,highlight-placeholder))

7
collects/stepper/private/lifting.ss
View File

@ -16,7 +16,7 @@
(define-struct try-record (index try-fn expr))
; try-records are
(provide/contract [lift (syntax? ; syntax to perform lifting in
(provide/contract [lift (syntax? ; syntax to perform lifiting in
boolean? ; lift-at-highlight?
. -> .
(listof syntax?))]) ; result
@ -27,9 +27,6 @@
(lift-local-defs context-records highlight lift-in-highlight?)))
; [find-highlight (-> syntax? (listof context-record?))]
; Accepts a syntax expression where one subexpression is highlighted: that is, has the
; 'stepper-highlight syntax property. Returns a list of context records representing the
; path through the syntax tree down to the highlight.
(define (find-highlight stx)
(let/ec success-escape
@ -159,7 +156,7 @@
(test-begin (require (lib "mz-testing.ss" "tests" "utils")))
(test-begin (SECTION 'stepper-lifting))
(test-begin (section 'stepper-lifting))
(test-begin
; TEST OF FIND-HIGHLIGHT

5
collects/stepper/private/model-settings.ss
View File

@ -41,7 +41,6 @@
[fake-beginner-wla-render-settings render-settings?]
[fake-intermediate-render-settings render-settings?]
[fake-intermediate/lambda-render-settings render-settings?]
[fake-advanced-render-settings render-settings?]
[fake-mz-render-settings render-settings?])
(define (make-fake-render-to-sexp true/false constructor-style abbreviate)
@ -67,10 +66,6 @@
(define fake-intermediate/lambda-render-settings
fake-beginner-wla-render-settings)
;; this is a guess:
(define fake-advanced-render-settings
fake-beginner-wla-render-settings)
(define fake-mz-render-settings
(make-render-settings (booleans-as-true/false)
(constructor-style-printing)

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

@ -37,7 +37,6 @@
(require (lib "contract.ss")
(lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
"my-macros.ss"
(prefix a: "annotate.ss")
(prefix r: "reconstruct.ss")
@ -67,27 +66,18 @@
(local
(;; finished-exps: (listof (list/c syntax-object? (union number? false?)( -> any)))
;; because of mutation, these cannot be fixed renderings, but must be re-rendered at each step.
(define finished-exps null)
(define/contract add-to-finished
((-> syntax?) (union (listof natural-number/c) false/c) (-> any) . -> . void?)
(lambda (exp-thunk lifting-indices getter)
(set! finished-exps (append finished-exps (list (list exp-thunk lifting-indices getter))))))
((define finished-exprs null)
;; the "held" variables are used to store the "before" step.
(define held-exp-list no-sexp)
(define held-expr-list no-sexp)
(define held-step-was-app? #f)
(define held-finished-list null)
(define basic-eval (current-eval))
;; REDIVIDE MAKES NO SENSE IN THE NEW INTERFACE. THIS WILL BE DELETED AFTER BEING PARTED OUT.
; redivide takes a list of sexps and divides them into the 'before', 'during', and 'after' lists,
; where the before and after sets are maximal-length lists where none of the s-expressions contain
; a highlight-placeholder
; (->* ((listof syntax)) (list/c syntax syntax syntax))
#;(define (redivide exprs)
(define (redivide exprs)
(letrec ([contains-highlight
(lambda (expr)
(or (syntax-property expr 'stepper-highlight)
@ -125,15 +115,8 @@
(opt-lambda (mark-set break-kind [returned-value-list null])
(let* ([mark-list (and mark-set (extract-mark-list mark-set))])
(define (reconstruct-all-completed)
(map (match-lambda
[`(,source-thunk ,lifting-indices ,getter)
(r:reconstruct-completed (source-thunk) lifting-indices getter render-settings)])
finished-exps))
;; TO BE SCRAPPED
#;(define (double-redivide finished-exps new-exprs-before new-exprs-after)
(define (double-redivide finished-exprs new-exprs-before new-exprs-after)
(let*-values ([(before current after) (redivide new-exprs-before)]
[(before-2 current-2 after-2) (redivide new-exprs-after)])
(unless (equal? (map syntax-object->hilite-datum before)
@ -142,77 +125,71 @@
(unless (equal? (map syntax-object->hilite-datum after)
(map syntax-object->hilite-datum after-2))
(error 'double-redivide "reconstructed after defs are not equal."))
(values (append finished-exps before) current current-2 after)))
(values (append finished-exprs before) current current-2 after)))
(define (reconstruct-helper)
(r:reconstruct-current mark-list break-kind returned-value-list render-settings))
(if (r:skip-step? break-kind mark-list render-settings)
(when (eq? break-kind 'normal-break)
(set! held-exp-list skipped-step))
(set! held-expr-list skipped-step))
(case break-kind
[(normal-break)
(begin
(set! held-finished-list (reconstruct-all-completed))
(set! held-exp-list (r:reconstruct-left-side mark-list render-settings))
(set! held-expr-list (reconstruct-helper))
(set! held-step-was-app? (r:step-was-app? 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 (r:reconstruct-right-side mark-list returned-value-list render-settings)]
(if (eq? held-expr-list skipped-step)
(set! held-expr-list no-sexp)
(let* ([reconstructed (reconstruct-helper)]
[result
(if (eq? held-exp-list 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.
(make-before-after-result
(list #`(... ...))
(append new-finished-list reconstructed)
'normal)
(if (not (eq? held-expr-list no-sexp))
(let*-values
([(step-kind) (if (and held-step-was-app?
(eq? break-kind 'result-exp-break))
'user-application
'normal)]
[(left-exps right-exps)
;; write this later:
#;(identify-changed (append held-finished-list held-exps) (append new-finished-list reconstructed))
(values (append held-finished-list held-exp-list)
(append new-finished-list reconstructed))])
(make-before-after-result left-exps right-exps step-kind)))])
(set! held-exp-list no-sexp)
[(new-finished current-pre current-post after)
(double-redivide finished-exprs held-expr-list reconstructed)])
(make-before-after-result new-finished current-pre current-post after step-kind))
(let*-values
([(before current after) (redivide reconstructed)])
(make-before-after-result (append finished-exprs before) (list
(syntax-property #`(... ...)
'stepper-highlight
#t))
current after 'normal)))])
(set! held-expr-list no-sexp)
(receive-result result)))]
[(double-break)
; a double-break occurs at the beginning of a let's evaluation.
(when (not (eq? held-exp-list no-sexp))
(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)]
[left-side (car reconstruct-result)]
[right-side (cadr reconstruct-result)])
;; add highlighting code as for other cases...
(receive-result (make-before-after-result (append new-finished-list left-side)
(append new-finished-list right-side)
'normal)))]
(let* ([reconstruct-quadruple (reconstruct-helper)])
(when (not (eq? held-expr-list no-sexp))
(error 'break-reconstruction
"held-expr-list not empty when a double-break occurred"))
(let*-values
([(new-finished current-pre current-post after)
(double-redivide finished-exprs
(list-ref reconstruct-quadruple 0)
(list-ref reconstruct-quadruple 1))])
(receive-result (make-before-after-result new-finished
current-pre
current-post
after
'normal))))]
[(late-let-break)
(let ([new-finished (r:reconstruct-current mark-list break-kind returned-value-list render-settings)])
(set! finished-exprs (append finished-exprs new-finished)))]
[(expr-finished-break)
(unless (not mark-list)
(error 'break "expected no mark-list with expr-finished-break"))
;; in an expr-finished-break, the returned-vals hold (listof (list/c source lifting-index getter))
;; this will now include define-struct breaks, for which the source is the source and the getter
;; causes an error.
(for-each (lambda (source/index/getter)
(apply add-to-finished source/index/getter))
returned-value-list)]
(let ([reconstructed (r:reconstruct-completed mark-list returned-value-list render-settings)])
(set! finished-exprs (append finished-exprs (list reconstructed))))]
[(define-struct-break)
(set! finished-exprs (append finished-exprs
(list (car returned-value-list))))]
[else (error 'break "unknown label on break")])))))
@ -222,12 +199,12 @@
(expand-next-expression)))
(define (err-display-handler message exn)
(if (not (eq? held-exp-list no-sexp))
(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)))))
(if (not (eq? held-expr-list no-sexp))
(let*-values ([(before current after) (redivide held-expr-list)])
(set! held-expr-list no-sexp)
(receive-result (make-before-error-result (append finished-exprs before)
current message after)))
(receive-result (make-error-result finished-exprs message)))))
(program-expander
(lambda ()
@ -238,6 +215,7 @@
(lambda (expanded continue-thunk) ; iter
(if (eof-object? expanded)
(begin
(receive-result (make-finished-result finished-exprs))
(receive-result (make-finished-stepping)))
(step-through-expression expanded continue-thunk)))))))

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

@ -3,17 +3,19 @@
(lib "mred.ss" "mred")
(prefix f: (lib "framework.ss" "framework"))
(lib "pretty.ss")
"highlight-placeholder.ss"
"testing-shared.ss"
(lib "string-constant.ss" "string-constants")
(lib "bitmap-label.ss" "mrlib"))
(lib "string-constant.ss" "string-constants"))
(provide
stepper-bitmap
stepper-canvas%
stepper-text%
snip?
separator-snip% ;; these last two aren't required, but are useful
vertical-separator-snip% ;; for debugging purposes
stepper-warning%
finished-text)
finished-text
stepper-text-test)
(define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1)))
(define reduct-highlight-color (make-object color% 255 255 255))
@ -27,8 +29,91 @@
(define snip-delta (make-object style-delta% 'change-alignment 'top))
;;;;;; copied from /plt/collects/drscheme/snip.ss :
(define separator-snipclass
(make-object
(class snip-class% ()
(override read)
(define (read s)
(let ([size-box (box 0)])
(send s get size-box)
(make-object separator-snip%)))
(super-instantiate ()))))
(send* separator-snipclass
(set-version 1)
(set-classname "drscheme:separator-snip%"))
(send (get-the-snip-class-list) add separator-snipclass)
;; the two numbers 1 and 2 which appear here are to line up this snip
;; with the embedded snips around it in the drscheme rep.
;; I have no idea where the extra pixels are going.
(define separator-snip%
(class snip% ()
(inherit get-style set-snipclass set-flags get-flags get-admin)
(public reset-width)
(override write copy get-extent draw)
(define width 800)
;;;; VERTICAL-SEPARATOR : the red arrow that separates the left half of the display from the right half.
(define (reset-width)
(let* ([admin (get-admin)]
[reporting-media (send admin get-editor)]
[reporting-admin (send reporting-media get-admin)]
[widthb (box 0)])
(send reporting-admin get-view #f #f widthb #f)
(set! width (- (unbox widthb) 2))
(send admin resized this #t)))
(define (write s)
(send s put (char->integer #\r)))
(define (copy)
(let ([s (make-object separator-snip%)])
(send s set-style (get-style))
s))
(define height 1)
(define white-around 2)
(define (get-extent dc x y w-box h-box descent-box space-box lspace-box rspace-box)
(for-each (lambda (box) (unless (not box) (set-box! box 0)))
(list descent-box space-box lspace-box rspace-box))
(unless (not w-box)
(set-box! w-box width))
(unless (not h-box)
(set-box! h-box (+ (* 2 white-around) height))))
(define body-pen
(send the-pen-list find-or-create-pen
"BLUE" 0 'solid))
(define body-brush
(send the-brush-list find-or-create-brush
"BLUE" 'solid))
(define (draw dc x y left top right bottom dx dy draw-caret)
(let ([orig-pen (send dc get-pen)]
[orig-brush (send dc get-brush)])
(send dc set-pen body-pen)
(send dc set-brush body-brush)
(send dc draw-rectangle (+ x 1)
(+ white-around y) width height)
(send dc set-pen orig-pen)
(send dc set-brush orig-brush)))
(super-instantiate ())
(set-flags (cons 'hard-newline (get-flags)))
(set-snipclass separator-snipclass)))
;;;; end of copied region
;;;; duplicated for vertical-snip
(define red-arrow-bitmap
(make-object bitmap% (build-path (collection-path "icons") "red-arrow.bmp") 'bmp))
@ -48,12 +133,15 @@
(super-instantiate ()))))
(send* vertical-separator-snipclass
(send* separator-snipclass
(set-version 1)
(set-classname "drscheme:vertical-separator-snip%"))
(send (get-the-snip-class-list) add vertical-separator-snipclass)
;; the two numbers 1 and 2 which appear here are to line up this snip
;; with the embedded snips around it in the drscheme rep.
;; I have no idea where the extra pixels are going.
(define vertical-separator-snip%
(class snip% ()
(inherit get-style set-snipclass set-flags get-flags get-admin)
@ -124,7 +212,7 @@
; ;
; the stepper-sub-text% class is used to hold an individual list of sexps, with one or more highlights.
; there are four of them (* NB: now only two! 2005-08) in the stepper window.
; there are four of them in the stepper window.
(define stepper-sub-text%
(class f:text:standard-style-list% ()
@ -169,62 +257,61 @@
(define/private (format-sexp sexp)
(define text-port (open-output-text-editor this))
(parameterize
([pretty-print-columns pretty-printed-width]
; the pretty-print-size-hook decides whether this object should be printed by the new pretty-print-hook
[pretty-print-size-hook
(lambda (value display? port)
(let ([looked-up (hash-table-get highlight-table value (lambda () #f))])
(cond
[(is-a? value snip%)
;; Calculate the effective width of the snip, so that
;; too-long lines (as a result of large snips) are broken
;; correctly. When the snip is actusally inserted, its width
;; will be determined by `(send snip get-count)', but the number
;; returned here triggers line breaking in the pretty printer.
(let ([dc (get-dc)]
[wbox (box 0)])
(send value get-extent dc 0 0 wbox #f #f #f #f #f)
(let-values ([(xw dc dc2 dc3) (send dc get-text-extent "x")])
(max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))]
[(and looked-up (not (eq? looked-up 'non-confusable)))
(string-length (format "~s" (car looked-up)))]
[else #f])))]
[pretty-print-print-hook
; this print-hook is called for confusable highlights and for images.
(lambda (value display? port)
(let ([to-display (cond
[(hash-table-get highlight-table value (lambda () #f)) => car]
[else value])])
(cond
[(is-a? to-display snip%)
(write-special (send to-display copy) port) (set-last-style)]
[else
(write-string (format "~s" to-display) port)])))]
[pretty-print-print-line
(lambda (number port old-length dest-columns)
(when (and number (not (eq? number 0)))
(newline port))
0)]
[pretty-print-pre-print-hook
(lambda (value p)
(when (hash-table-get highlight-table value (lambda () #f))
(set! highlight-begin (get-start-position))))]
[pretty-print-post-print-hook
(lambda (value p)
(when (hash-table-get highlight-table value (lambda () #f))
(let ([highlight-end (get-start-position)])
(unless highlight-begin
(error 'format-whole-step "no highlight-begin to match highlight-end"))
(set! clear-highlight-thunks
(cons (highlight-range highlight-begin highlight-end highlight-color #f #f)
clear-highlight-thunks))
(set! highlight-begin #f))))]
;; mflatt: MAJOR HACK - this setting needs to come from the language
;; somehow
[read-case-sensitive #t])
(parameterize ([pretty-print-columns pretty-printed-width]
; the pretty-print-size-hook decides whether this object should be printed by the new pretty-print-hook
[pretty-print-size-hook
(lambda (value display? port)
(let ([looked-up (hash-table-get highlight-table value (lambda () #f))])
(cond
[(is-a? value snip%)
;; Calculate the effective width of the snip, so that
;; too-long lines (as a result of large snips) are broken
;; correctly. When the snip is actusally inserted, its width
;; will be determined by `(send snip get-count)', but the number
;; returned here triggers line breaking in the pretty printer.
(let ([dc (get-dc)]
[wbox (box 0)])
(send value get-extent dc 0 0 wbox #f #f #f #f #f)
(let-values ([(xw dc dc2 dc3) (send dc get-text-extent "x")])
(max 1 (inexact->exact (ceiling (/ (unbox wbox) xw))))))]
[(and looked-up (not (eq? looked-up 'non-confusable)))
(string-length (format "~s" (car looked-up)))]
[else #f])))]
[pretty-print-print-hook
; this print-hook is called for confusable highlights and for images.
(lambda (value display? port)
(let ([to-display (cond
[(hash-table-get highlight-table value (lambda () #f)) => car]
[else value])])
(cond
[(is-a? to-display snip%)
(write-special (send to-display copy) port) (set-last-style)]
[else
(write-string (format "~s" to-display) port)])))]
[pretty-print-print-line
(lambda (number port old-length dest-columns)
(when (and number (not (eq? number 0)))
(newline port))
0)]
[pretty-print-pre-print-hook
(lambda (value p)
(when (hash-table-get highlight-table value (lambda () #f))
(set! highlight-begin (get-start-position))))]
[pretty-print-post-print-hook
(lambda (value p)
(when (hash-table-get highlight-table value (lambda () #f))
(let ([highlight-end (get-start-position)])
(unless highlight-begin
(error 'format-whole-step "no highlight-begin to match highlight-end"))
(set! clear-highlight-thunks
(cons (highlight-range highlight-begin highlight-end highlight-color #f #f)
clear-highlight-thunks))
(set! highlight-begin #f))))]
;; mflatt: MAJOR HACK - this setting needs to come from the language
;; somehow
[read-case-sensitive #t])
(pretty-print sexp text-port)))
(define/public (format-whole-step)
@ -258,7 +345,7 @@
; ;
; ;
; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four^H^H^H^Htwo stepper "text" spots.
; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four stepper "text" spots.
; it is used for error messages.
(define stepper-sub-error-text%
@ -291,10 +378,7 @@
;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;;;;; ; ; ; ;;;;; ;;; ; ;;
; ;
; ;
;; the stepper-canvas% overrides the editor-canvas simply so that on-size messages get passed to
;; the enclosed editor.
(define stepper-canvas%
(class editor-canvas% ()
(inherit get-editor)
@ -323,12 +407,12 @@
; the stepper-text% is the principal inhabitant of the stepper window. It keeps
; track of all of the sexps & error messages in a given step, reformatting as necessary.
;; constructor : ((union (listof sexp) string) (union (listof sexp) string) -> )
; constructor : ((listof sexp) (listof sexp) (listof sexp) (union string #f) (listof sexp) -> )
(define stepper-text%
(class f:text:standard-style-list% ()
(init-field left-side right-side)
(init-field finished-exprs exps post-exps error-msg after-exprs)
(inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap
begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list
@ -341,6 +425,7 @@
[canvas-width (begin (send (get-admin) get-view #f #f width-box #f) (unbox width-box))]
[dc (send canvas get-dc)])
(unless (and old-width (= canvas-width old-width))
(set! old-width canvas-width)
(let* ([minus-cursor-margin (- canvas-width 2)]
[vert-separator-width-box (box 0)]
[_ (send vert-separator get-extent dc 0 0 vert-separator-width-box
@ -348,19 +433,30 @@
[vert-separator-width (unbox vert-separator-width-box)]
[minus-center-bar (- minus-cursor-margin vert-separator-width)]
[l-r-box-widths (floor (/ minus-center-bar 2))])
(send top-defs-snip set-new-width minus-cursor-margin canvas)
(send before-snip set-new-width l-r-box-widths canvas)
(send after-snip set-new-width l-r-box-widths canvas)
(coordinate-snip-sizes))
(set! old-width canvas-width))
(send bottom-defs-snip set-new-width minus-cursor-margin canvas)
(coordinate-snip-sizes)
(send horiz-separator-1 reset-width)
(send horiz-separator-2 reset-width)))
(end-edit-sequence)
(lock #t)))])
(define old-width #f)
(define top-defs-snip (make-object stepper-editor-snip%))
(define horiz-separator-1 (make-object separator-snip%))
(define before-snip (make-object stepper-editor-snip%))
(define vert-separator (make-object vertical-separator-snip% 10))
(define after-snip (make-object stepper-editor-snip%))
;; coordinate-snip-sizes : make the vertical separator snip the right size, then notify the administrator.
(define horiz-separator-2 (make-object separator-snip%))
(define bottom-defs-snip (make-object stepper-editor-snip%))
(define/private (release-snip-sizes)
(for-each (lambda (snip)
(send snip set-min-height 0.0)
(send snip set-max-height 0.0)
(send snip set-max-height 'none))
(list before-snip after-snip)))
(define/private (coordinate-snip-sizes)
(let* ([get-snip-height
(lambda (snip)
@ -369,7 +465,7 @@
(get-snip-location snip #f top-box #f)
(get-snip-location snip #f bottom-box #t)
(- (unbox bottom-box) (unbox top-box))))]
[max-height (max (get-snip-height before-snip) (get-snip-height after-snip))])
[max-height (apply max (map get-snip-height (list before-snip after-snip)))])
(send vert-separator set-height! (- max-height 4))
(let ([w-box (box 0)]
[h-box (box 0)])
@ -380,28 +476,23 @@
(super-instantiate ())
(hide-caret #t)
;; insert the editor-snips & separator-snip, and change the style.
(let ([before-position (last-position)])
(for-each (lambda (x) (insert x)) ;; NB: eta-expansion necessary because insert is a method, not a procedure.
(list before-snip vert-separator after-snip))
(for-each (lambda (x) (insert x)) (list top-defs-snip (string #\newline) horiz-separator-1
before-snip vert-separator
after-snip (string #\newline)
horiz-separator-2 bottom-defs-snip))
(change-style snip-delta before-position (last-position)))
;; attach the editors to the snips, and populate those editors.
(define (setup-editor-snip snip error-or-exps highlight-color)
(send snip set-editor
(cond [(string? error-or-exps)
(make-object stepper-sub-error-text% error-or-exps)]
[else
(make-object stepper-sub-text% error-or-exps highlight-color)])))
(setup-editor-snip before-snip left-side redex-highlight-color)
(setup-editor-snip after-snip right-side reduct-highlight-color)
(send top-defs-snip set-editor
(make-object stepper-sub-text% finished-exprs #f))
(send before-snip set-editor
(make-object stepper-sub-text% exps redex-highlight-color))
(if (eq? error-msg #f)
(send after-snip set-editor
(make-object stepper-sub-text% post-exps reduct-highlight-color))
(send after-snip set-editor
(make-object stepper-sub-error-text% error-msg)))
(send bottom-defs-snip set-editor
(make-object stepper-sub-text% after-exprs #f))
(lock #t)))
(define finished-text
@ -416,6 +507,7 @@
(lock #t))
()))
(define (snip? val)
(is-a? val snip%))
@ -506,39 +598,33 @@
)
(strip-regular stx))
;; 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
(define (stepper-text-test . args)
(let* ([new-frame (make-object frame% "test-frame")]
[new-text (apply make-object stepper-text% args)]
[new-canvas (make-object stepper-canvas% new-frame new-text)])
(send new-canvas min-width 200)
(send new-canvas min-width 800)
(send new-canvas min-height 200)
(send new-frame show #t)
(send new-text reset-width new-canvas)
new-canvas))
#;(define a
(stepper-text-test (build-stx-with-highlight `((* 13 (hilite (* 15 16)))))
(build-stx-with-highlight `((hilite (+ 3 4)) (define y 4) 13 14 (+ (hilite 13) (hilite #f)) 13
298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f)))))
; (define a
; (stepper-text-test (build-stx-with-highlight `((define x 3) 14 15 #f 1))
; (build-stx-with-highlight `((* 13 (hilite (* 15 16)))))
; (build-stx-with-highlight `((hilite (+ 3 4)) (define y 4) 13 14 (+ (hilite 13) (hilite #f)) 13
; 298 1 1 (+ (x 398 (hilite (+ x 398))) (hilite (x 398 (+ x 398)))) (hilite #f)))
; #f
; (build-stx-with-highlight `((define y (+ 13 14)) 80))))
;; test out scroll bars
#;(stepper-text-test (build-stx-with-highlight `(1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8))
(build-stx-with-highlight `(free!)))
#;(stepper-text-test `() "This is an error message" )
#;(stepper-text-test "This is another error message" `(poomp))
; (stepper-text-test `() `(uninteresting but long series of lines) `() "This is an error message" `((define x 3 4 5)))
; (stepper-text-test `() `() `() "This is another error message" `(poomp))
)

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

@ -15,28 +15,11 @@
"lifting.ss")
(provide/contract
[reconstruct-completed (syntax?
(union (listof natural-number/c) false/c)
(-> (listof any/c))
render-settings?
. -> .
syntax?)]
;; front ends for reconstruct-current
[reconstruct-left-side (mark-list?
render-settings?
. -> .
(listof syntax?))]
[reconstruct-right-side (mark-list?
(listof any/c)
render-settings?
. -> .
(listof syntax?))]
[reconstruct-double-break (mark-list?
render-settings?
. -> .
(list/c (listof syntax?) (listof syntax?)))]
[reconstruct-completed (-> mark-list? (listof any/c) render-settings?
syntax?)]
[reconstruct-current (-> mark-list? symbol? (listof any/c) render-settings?
(union (listof syntax?)
(list/c (listof syntax?) (listof syntax?))))]
[final-mark-list? (-> mark-list? boolean?)]
[skip-step? (-> break-kind? (union mark-list? false/c) render-settings? boolean?)]
[step-was-app? (-> mark-list? boolean?)])
@ -316,26 +299,22 @@
(define (inner stx)
(define (fall-through)
(kernel:kernel-syntax-case stx #f
[id
(identifier? stx)
(or (syntax-property stx 'stepper-lifted-name)
stx)]
[(define-values dc ...)
(unwind-define stx)]
[(#%app exp ...)
(recur-on-pieces #'(exp ...))]
[(#%datum . datum)
#'datum]
[(let-values . rest)
(unwind-mz-let stx)]
[(letrec-values . rest)
(unwind-mz-let stx)]
[(set! var rhs)
(with-syntax ([unwound-var (or (syntax-property #`var 'stepper-lifted-name) #`var)]
[unwound-body (inner #`rhs)])
#`(set! unwound-var unwound-body))]
[else
(recur-on-pieces stx)]))
[id
(identifier? stx)
(or (syntax-property stx 'stepper-lifted-name)
stx)]
[(define-values dc ...)
(unwind-define stx)]
[(#%app exp ...)
(recur-on-pieces #'(exp ...))]
[(#%datum . datum)
#'datum]
[(let-values . rest)
(unwind-mz-let stx)]
[(letrec-values . rest)
(unwind-mz-let stx)]
[else
(recur-on-pieces stx)]))
(transfer-info
(if (syntax-property stx 'user-stepper-hint)
@ -385,30 +364,29 @@
(define (unwind-define stx)
(kernel:kernel-syntax-case stx #f
[(define-values (name . others) body)
(begin
(unless (null? (syntax-e #'others))
(error 'reconstruct "reconstruct fails on multiple-values define: ~v\n" (syntax-object->datum stx)))
(let* ([printed-name (or (syntax-property #`name 'stepper-lifted-name)
(syntax-property #'name 'stepper-orig-name)
#'name)]
[unwound-body (inner #'body)]
[define-type (syntax-property unwound-body 'user-stepper-define-type)]) ; see notes in internal-docs.txt
(if define-type
(kernel:kernel-syntax-case unwound-body #f
[(lambda arglist lam-body ...)
(case define-type
[(shortened-proc-define)
(let ([proc-define-name (syntax-property unwound-body 'user-stepper-proc-define-name)])
(if (or (module-identifier=? proc-define-name #'name)
(and (syntax-property #'name 'stepper-orig-name)
(module-identifier=? proc-define-name (syntax-property #'name 'stepper-orig-name))))
#`(define (#,printed-name . arglist) lam-body ...)
#`(define #,printed-name #,unwound-body)))]
[(lambda-define)
#`(define #,printed-name #,unwound-body)]
[else (error 'unwind-define "unknown value for syntax property 'user-stepper-define-type: ~e" define-type)])]
[else (error 'unwind-define "expr with stepper-define-type is not a lambda: ~e" (syntax-object->datum unwound-body))])
#`(define #,printed-name #,unwound-body))))]
(unless (null? (syntax-e #'others))
(error 'reconstruct "reconstruct fails on multiple-values define: ~v\n" (syntax-object->datum stx)))
(let* ([printed-name (or (syntax-property #`name 'stepper-lifted-name)
(syntax-property #'name 'stepper-orig-name)
#'name)]
[unwound-body (inner #'body)]
[define-type (syntax-property unwound-body 'user-stepper-define-type)]) ; see notes in internal-docs.txt
(if define-type
(kernel:kernel-syntax-case unwound-body #f
[(lambda arglist lam-body ...)
(case define-type
[(shortened-proc-define)
(let ([proc-define-name (syntax-property unwound-body 'user-stepper-proc-define-name)])
(if (or (module-identifier=? proc-define-name #'name)
(and (syntax-property #'name 'stepper-orig-name)
(module-identifier=? proc-define-name (syntax-property #'name 'stepper-orig-name))))
#`(define (#,printed-name . arglist) lam-body ...)
#`(define #,printed-name #,unwound-body)))]
[(lambda-define)
#`(define #,printed-name #,unwound-body)]
[else (error 'unwind-define "unknown value for syntax property 'user-stepper-define-type: ~e" define-type)])]
[else (error 'unwind-define "expr with stepper-define-type is not a lambda: ~e" (syntax-object->datum unwound-body))])
#`(define #,printed-name #,unwound-body)))]
[else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))]))
(define (unwind-mz-let stx)
@ -592,18 +570,7 @@
[(let-values . rest) (recon-let/rec #f)]
[(letrec-values . rest) (recon-let/rec #t)]
; set!
[(set! var rhs)
(let ([rendered-var
(if (and (ormap (lambda (binding)
(bound-identifier=? binding #`var))
dont-lookup)
(not (ormap (lambda (binding)
(bound-identifier=? binding #`var))
use-lifted-names)))
#`var
(reconstruct-set!-var mark-list #`var))])
#`(set! #,rendered-var #,(recur #'rhs)))]
; set! : set! doesn't fit into this scheme. It would be a mistake to allow it to proceed.
; quote
[(quote body) (recon-value (syntax-e (syntax body)) render-settings)]
@ -635,20 +602,20 @@
use-lifted-names)))
var
(case (syntax-property var 'stepper-binding-type)
((lambda-bound)
(recon-value (lookup-binding mark-list var) render-settings))
((macro-bound)
; for the moment, let-bound vars occur only in and/or :
(recon-value (lookup-binding mark-list var) render-settings))
((top-level) var)
((let-bound)
(syntax-property var
'stepper-lifted-name
(binding-lifted-name mark-list var)))
((stepper-temp)
(error 'recon-source-expr "stepper-temp showed up in source?!?"))
((non-lexical)
(error 'recon-source-expr "can't get here: lexical identifier labeled as non-lexical"))
(else
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
(syntax-property var 'stepper-binding-type)))))]
@ -662,25 +629,6 @@
(error 'recon-source "no matching clause for syntax: ~a" expr)])])
(attach-info recon expr))))))
;; reconstruct-set!-var
(define (reconstruct-set!-var mark-list var)
(case (syntax-property var 'stepper-binding-type)
((lambda-bound)
(error 'reconstruct-inner "lambda-bound variables can't be mutated"))
((macro-bound)
; for the moment, let-bound vars occur only in and/or :
(error 'reconstruct-inner "macro-bound variables can't occur in a set!"))
((non-lexical) var)
((let-bound)
(syntax-property var
'stepper-lifted-name
(binding-lifted-name mark-list var)))
((stepper-temp)
(error 'recon-source-expr "stepper-temp showed up in source?!?"))
(else
(error 'recon-source-expr "unknown 'stepper-binding-type property: ~a"
(syntax-property var 'stepper-binding-type)))))
;; filter-skipped : (listof syntax?) -> (listof syntax?)
;; filter out any elements of the list with 'stepper-skip-completely set, except those with stepper-prim-name set. (HACK).
@ -713,55 +661,37 @@
; reconstruct-completed : reconstructs a completed expression or definition.
; Accepts the source expression, a lifting-index which is either a number (indicating
; a lifted binding) or false (indicating a top-level expression), a list of values
; currently bound to the bindings, and the language level's render-settings.
(define (reconstruct-completed exp lifting-indices vals-getter render-settings)
(if lifting-indices
(syntax-case exp ()
[(vars-stx rhs ...)
(let* ([vars (map (lambda (var index) (syntax-property var 'stepper-lifted-name (construct-lifted-name var index)))
(syntax->list #`vars-stx)
lifting-indices)])
(first-of-one (unwind-no-highlight
(reconstruct-completed-define exp vars (vals-getter) render-settings))))])
(let skipto-loop ([exp exp])
(cond
[(syntax-property exp 'stepper-skipto) =>
(lambda (skipto)
(skipto-reconstruct skipto exp
skipto-loop))]
[(syntax-property exp 'stepper-define-struct-hint)
;; the hint contains the original syntax
(syntax-property exp 'stepper-define-struct-hint)]
[else
(first-of-one
(unwind-no-highlight
(kernel:kernel-syntax-case exp #f
[(define-values vars-stx body)
(reconstruct-completed-define exp (syntax->list #`vars-stx) (vals-getter) render-settings)]
[else
(let* ([recon-vals (map (lambda (val)
(recon-value val render-settings))
(vals-getter))])
(if (= (length recon-vals) 1)
(attach-info (car recon-vals) exp)
(attach-info #`(values #,@recon-vals) exp)))])))]))))
;; an abstraction lifted from reconstruct-completed
(define (reconstruct-completed-define exp vars vals render-settings)
(let* ([_ (unless (equal? (length vars) (length vals))
(error "length of var list and val list unequal: ~v ~v" (map syntax->list vars) vals))]
[recon-vals (map (lambda (val var)
(recon-value val render-settings var))
vals
vars)])
(if (= (length recon-vals) 1)
(attach-info #`(define-values #,vars #,(car recon-vals)) exp)
(attach-info #'(define-values #,vars (values #,@recon-vals)) exp))))
(define (reconstruct-completed mark-list vals render-settings)
(unless (and (pair? mark-list) (null? (cdr mark-list)) (eq? (mark-label (car mark-list)) 'top-level))
(error `reconstruct-completed "expected mark-list of length one with mark having label 'top-level, got: ~a" mark-list))
(let skipto-loop ([expr (mark-source (car mark-list))])
(cond
[(syntax-property expr 'stepper-skipto) =>
(lambda (skipto)
(skipto-reconstruct skipto expr
skipto-loop))]
[(syntax-property expr 'stepper-define-struct-hint)
(error 'reconstruct-completed "define-structs should not be passed to reconstruct-completed")]
[else
(first-of-one (unwind-no-highlight
(kernel:kernel-syntax-case expr #f
[(define-values vars-stx body)
(let* ([vars (syntax->list #'vars-stx)]
[recon-vals (map (lambda (val var)
(recon-value val render-settings (or (syntax-property var 'stepper-lifted-name) var)))
vals
vars)])
(if (= (length recon-vals) 1)
(attach-info #`(define-values vars-stx #,(car recon-vals)) expr)
(attach-info #'(define-values vars-stx (values #,@recon-vals)) expr)))]
[else
(let* ([recon-vals (map (lambda (val)
(recon-value val render-settings))
vals)])
(if (= (length recon-vals) 1)
(attach-info (car recon-vals) expr)
(attach-info #`(values #,@recon-vals) expr)))])))])))
; : (-> syntax? syntax? syntax?)
(define (reconstruct-top-level source reconstructed)
@ -790,21 +720,9 @@
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;
; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;; ; ; ; ;;;; ; ; ;;
;; front ends for reconstruct-current:
(define (reconstruct-left-side mark-list render-settings)
(reconstruct-current mark-list 'left-side null render-settings))
(define (reconstruct-right-side mark-list returned-value-list render-settings)
(reconstruct-current mark-list 'right-side returned-value-list render-settings))
(define (reconstruct-double-break mark-list render-settings)
(reconstruct-current mark-list 'double-break null render-settings))
; reconstruct-current : takes a list of marks, the kind of break, and
; any values that may have been returned at the break point. It produces a list of sexps
@ -829,11 +747,11 @@
(lambda (expr)
(recon-source-expr expr mark-list null null render-settings))]
[top-mark (car mark-list)]
[exp (mark-source top-mark)]
[expr (mark-source top-mark)]
[recon-let
(lambda ()
(with-syntax ([(label ((vars rhs) ...) . bodies) exp])
(with-syntax ([(label ((vars rhs) ...) . bodies) expr])
(let*-2vals ([binding-sets (map syntax->list (syntax->list #'(vars ...)))]
[binding-list (apply append binding-sets)]
[glumps
@ -885,19 +803,19 @@
[recon-bindings (append before-bindings after-bindings)]
[rectified-bodies (map (lambda (body) (recon-source-expr body mark-list binding-list binding-list render-settings))
(syntax->list (syntax bodies)))])
(attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))])
(kernel:kernel-syntax-case exp #f
(attach-info #`(label #,recon-bindings #,@rectified-bodies) expr))))])
(kernel:kernel-syntax-case expr #f
; variable references
[id
(identifier? (syntax id))
(if (eq? so-far nothing-so-far)
(recon-source-current-marks exp)
(error 'recon-inner "variable reference given as context: ~a" exp))]
(recon-source-current-marks expr)
(error 'recon-inner "variable reference given as context: ~a" expr))]
[(#%top . id)
(if (eq? so-far nothing-so-far)
(recon-source-current-marks exp)
(error 'recon-inner "variable reference given as context: ~a" exp))]
(recon-source-current-marks expr)
(error 'recon-inner "variable reference given as context: ~a" expr))]
; applications
[(#%app . terms)
@ -923,8 +841,8 @@
(datum->syntax-object #'here `(,#'#%app ...)) ; in unannotated code
(datum->syntax-object #'here `(,#'#%app ... ,so-far ...))))
(else
(error "bad label in application mark in expr: ~a" exp))))
exp)]
(error "bad label in application mark in expr: ~a" expr))))
expr)]
; define-struct
;
@ -948,7 +866,7 @@
#`(if #,test-exp
#,(recon-source-current-marks (syntax then))
#,(recon-source-current-marks (syntax else))))
exp)]
expr)]
; one-armed if
@ -959,7 +877,7 @@
so-far)])
#`(if #,test-exp
#,(recon-source-current-marks (syntax then))))
exp)]
expr)]
; quote : there is no break on a quote.
@ -972,8 +890,8 @@
#`(begin #,(recon-source-current-marks (syntax clause)))
(error
'recon-inner
"stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp)))
exp)]
"stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum expr)))
expr)]
; begin0 : may not occur directly except in advanced
@ -983,21 +901,14 @@
[(letrec-values . rest) (recon-let)]
[(set! var rhs)
(attach-info
(let ([rhs-exp (if (eq? so-far nothing-so-far)
(recon-value (lookup-binding mark-list set!-temp) render-settings)
so-far)]
[rendered-var (reconstruct-set!-var mark-list #`var)])
#`(set! #,rendered-var #,rhs-exp))
exp)]
; define-values : define's don't get marks, so they can't occur here
; lambda : there is no break on a lambda
[else
(error
'recon-inner
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum exp))])))
"stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum expr))])))
; the main recursive reconstruction loop is in recon:
; recon : (syntax-object mark-list boolean -> syntax-object)
@ -1023,19 +934,19 @@
#f))])]))
; uncomment to see all breaks coming in:
#;(define _ (printf "break-kind: ~a\ninnermost source: ~a\n" break-kind
(and (pair? mark-list)
(syntax-object->datum (mark-source (car mark-list))))))
; (define _ (printf "break-kind: ~a\ninnermost source: ~a\n" break-kind
; (and (pair? mark-list)
; (syntax-object->datum (mark-source (car mark-list))))))
(define answer
(case break-kind
((left-side)
(unwind (recon nothing-so-far mark-list #t) #f))
((right-side)
((result-value-break result-exp-break)
(let* ([innermost (if (null? returned-value-list) ; is it an expr -> expr reduction?
(recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings)
(recon-value (car returned-value-list) render-settings))])
(unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f)))
((normal-break)
(unwind (recon nothing-so-far mark-list #t) #f))
((double-break)
(let* ([source-expr (mark-source (car mark-list))]
[innermost-before (mark-as-highlight (recon-source-expr source-expr mark-list null null render-settings))]
@ -1048,12 +959,11 @@
(syntax-object->datum source-expr))])]
[innermost-after (mark-as-highlight (recon-source-expr (mark-source (car mark-list)) mark-list null newly-lifted-bindings render-settings))])
(list (unwind (recon innermost-before (cdr mark-list) #f) #f)
(unwind (recon innermost-after (cdr mark-list) #f) #t))))))
)
(unwind (recon innermost-after (cdr mark-list) #f) #t))))
((late-let-break)
(let* ([one-level-recon (unwind-only-highlight (mark-as-highlight (recon-inner mark-list nothing-so-far)))])
(sublist 0 (- (length one-level-recon) 1) one-level-recon)))
(else
(error 'reconstruct-current-def "unknown break kind: " break-kind)))))
answer))
)
answer)))

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

@ -3,8 +3,7 @@
(require "my-macros.ss"
(lib "contract.ss")
(lib "list.ss")
(lib "etc.ss")
(lib "match.ss"))
(lib "etc.ss"))
; CONTRACTS
@ -41,9 +40,10 @@
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 before-after-result (finished-exprs exp post-exp after-exprs kind))
(struct before-error-result (finished-exprs exp err-msg after-exprs))
(struct error-result (finished-exprs err-msg))
(struct finished-result (finished-exprs))
(struct finished-stepping ())
list-take
list-partition
@ -72,7 +72,6 @@
; get-binding-name
; bogus-binding?
if-temp
set!-temp
; get-lifted-gensym
; expr-read
; set-expr-read!
@ -84,17 +83,18 @@
finished-xml-box-table)
; A step-result is either:
; (make-before-after-result finished-exps exp redex reduct)
; or (make-before-error-result finished-exps exp redex err-msg)
; or (make-error-result finished-exps err-msg)
; or (make-finished-result finished-exps)
; (make-before-after-result finished-exprs exp redex reduct)
; or (make-before-error-result finished-exprs exp redex err-msg)
; or (make-error-result finished-exprs err-msg)
; or (make-finished-result finished-exprs)
(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 before-after-result (finished-exprs exp post-exp after-exprs kind) (make-inspector))
(define-struct before-error-result (finished-exprs exp err-msg after-exprs) (make-inspector))
(define-struct error-result (finished-exprs err-msg) (make-inspector))
(define-struct finished-result (finished-exprs) (make-inspector))
(define-struct finished-stepping () (make-inspector))
(define step-result? (union before-after-result? before-error-result? error-result? finished-stepping?))
(define step-result? (union before-after-result? before-error-result? error-result? finished-result? finished-stepping?))
; the closure record is placed in the closure table
@ -215,8 +215,7 @@
(weak-assoc-add assoc-table stx new-binding)
new-binding)))))))
(define if-temp (syntax-property (datum->syntax-object #`here `if-temp) 'stepper-binding-type 'stepper-temp))
(define set!-temp (syntax-property (datum->syntax-object #`here `set!-temp) 'stepper-binding-type 'stepper-temp))
(define if-temp (syntax-property (datum->syntax-object #'here 'if-temp) 'stepper-binding-type 'stepper-temp))
; gensyms needed by many modules:
@ -478,46 +477,31 @@
; attach-info : SYNTAX-OBJECT SYNTAX-OBJECT -> SYNTAX-OBJECT
; attach-info attaches to a generated piece of syntax the origin & source information of another.
; we do this so that macro unwinding can tell what reconstructed syntax came from what original syntax
(define (attach-info stx expr)
(let* ([it (syntax-property stx 'user-origin (syntax-property expr 'origin))]
[it (syntax-property it 'user-stepper-hint (syntax-property expr 'stepper-hint))]
[it (syntax-property it 'user-stepper-else (syntax-property expr 'stepper-else))]
[it (syntax-property it 'user-stepper-define-type (syntax-property expr 'stepper-define-type))]
[it (syntax-property it 'user-stepper-proc-define-name (syntax-property expr 'stepper-proc-define-name))]
[it (syntax-property it 'user-stepper-and/or-clauses-consumed (syntax-property expr 'stepper-and/or-clauses-consumed))]
[it (syntax-property it 'stepper-xml-hint (syntax-property expr 'stepper-xml-hint))]
[it (syntax-property it 'user-source (syntax-source expr))]
[it (syntax-property it 'user-position (syntax-position expr))])
it))
(define labels-to-attach
`((user-origin origin)
(user-stepper-hint stepper-hint)
(user-stepper-else stepper-else)
(user-stepper-define-type stepper-define-type)
(user-stepper-proc-define-name stepper-proc-define-name)
(user-stepper-and/or-clauses-consumed stepper-and/or-clauses-consumed)
(stepper-xml-hint stepper-xml-hint))) ; I find it mildly worrisome that this breaks the pattern
; by failing to preface the identifier with 'user-'. JBC, 2005-08
; take info from source expressions to reconstructed expressions
; (from native property names to 'user-' style property names)
(define (attach-info to-exp from-exp)
(let* ([attached (foldl (lambda (labels stx)
(match labels
[`(,new-label ,old-label)
(syntax-property stx new-label (syntax-property from-exp old-label))]))
to-exp
labels-to-attach)]
[attached (syntax-property attached 'user-source (syntax-source from-exp))]
[attached (syntax-property attached 'user-position (syntax-position from-exp))])
attached))
; transfer info from reconstructed expressions to other reconstructed expressions
; (from 'user-' style names to 'user-' style names)
(define (transfer-info to-stx from-exp)
(let* ([attached (foldl (lambda (labels stx)
(match labels
[`(,new-label ,old-label)
(syntax-property stx new-label (syntax-property from-exp new-label))]))
to-stx
labels-to-attach)]
[attached (syntax-property attached 'user-source (syntax-property from-exp 'user-source))]
[attached (syntax-property attached 'user-position (syntax-property from-exp 'user-position))]
[attached (syntax-property attached 'stepper-highlight (or (syntax-property from-exp 'stepper-highlight)
(syntax-property attached 'stepper-highlight)))])
attached))
(define (transfer-info stx expr)
(let* ([it (syntax-property stx 'user-origin (syntax-property expr 'user-origin))]
[it (syntax-property it 'user-stepper-hint (syntax-property stx 'user-stepper-hint))]
[it (syntax-property it 'user-stepper-else (syntax-property expr 'user-stepper-else))]
[it (syntax-property it 'user-stepper-define-type (syntax-property expr 'user-stepper-define-type))]
[it (syntax-property it 'user-stepper-proc-define-name (syntax-property expr 'user-stepper-proc-define-name))]
[it (syntax-property it 'user-stepper-and/or-clauses-consumed (syntax-property expr 'user-stepper-and/or-clauses-consumed))]
[it (syntax-property it 'stepper-xml-hint (syntax-property expr 'stepper-xml-hint))]
[it (syntax-property it 'user-source (syntax-property expr 'user-source))]
[it (syntax-property it 'user-position (syntax-property expr 'user-position))]
[it (syntax-property it 'stepper-highlight (or (syntax-property expr 'stepper-highlight)
(syntax-property it 'stepper-highlight)))])
it))
(define (values-map fn . lsts)
(apply values (apply map list

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

@ -1,20 +1,21 @@
(module stepper-tool mzscheme
(require (lib "contract.ss")
(lib "tool.ss" "drscheme")
(lib "mred.ss" "mred")
(lib "pconvert.ss")
(lib "string-constant.ss" "string-constants")
(lib "async-channel.ss")
(lib "mred.ss" "mred")
(prefix frame: (lib "framework.ss" "framework"))
(lib "unitsig.ss")
(lib "class.ss")
(lib "etc.ss")
(lib "list.ss")
(prefix model: "private/model.ss")
"private/my-macros.ss"
(prefix x: "private/mred-extensions.ss")
"private/shared.ss"
"private/model-settings.ss")
"private/model-settings.ss"
(lib "pconvert.ss")
(lib "string-constant.ss" "string-constants")
(lib "async-channel.ss")
(lib "bitmap-label.ss" "mrlib"))
;; mflatt: MINOR HACK - work around temporary
;; print-convert problems
@ -29,8 +30,7 @@
(list (string-constant beginning-student)
(string-constant beginning-student/abbrev)
(string-constant intermediate-student)
(string-constant intermediate-student/lambda)
(string-constant advanced-student)))
(string-constant intermediate-student/lambda)))
(provide stepper-tool@)
@ -43,21 +43,18 @@
(define (phase1) (void))
(define (phase2) (void))
;; this should be a preference
(define stepper-initial-width 500)
(define stepper-initial-height 500)
(define drscheme-eventspace (current-eventspace))
;; the stepper's frame:
(define stepper-frame%
(class (drscheme:frame:basics-mixin (frame:frame:standard-menus-mixin frame:frame:basic%))
(init-field drscheme-frame)
;; PRINTING-PROC
;; I frankly don't think that printing (i.e., to a printer) works correctly. 2005-07-01, JBC
(public set-printing-proc)
(define (set-printing-proc proc)
@ -75,8 +72,6 @@
(define/override (file-menu:between-save-as-and-print file-menu) (void))
;; CUSTODIANS
;; The custodian is used to halt the stepped computation when the stepper window
;; closes. The custodian is captured when the stepped computation starts.
(define custodian #f)
(define/public (set-custodian! cust)
@ -128,22 +123,20 @@
;; 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
(send (send drscheme-frame get-definitions-text) get-next-settings))
(define language
(drscheme:language-configuration:language-settings-language language-settings))
(define language-level-name
(car (last-pair (send language get-language-position))))
;; VALUE CONVERSION CODE:
(define simple-settings
(drscheme: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)])
@ -154,31 +147,29 @@
string-port)
(get-output-string string-port)))
;; 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)
;; 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)
(lambda (expr basic-convert sub-convert)
(cond
[(is-a? exp snip%)
(send exp copy)]
#;[((drscheme:rep:use-number-snip) exp)
[(is-a? expr snip%)
(send expr copy)]
#;[((drscheme:rep:use-number-snip) expr)
(let ([number-snip-type (drscheme:language:simple-settings-fraction-style simple-settings)])
(cond
[(eq? number-snip-type 'repeating-decimal)
(drscheme:number-snip:make-repeating-decimal-snip exp #f)]
(drscheme:number-snip:make-repeating-decimal-snip expr #f)]
[(eq? number-snip-type 'repeating-decimal-e)
(drscheme:number-snip:make-repeating-decimal-snip exp #t)]
(drscheme:number-snip:make-repeating-decimal-snip expr #t)]
[(eq? number-snip-type 'mixed-fraction)
(drscheme:number-snip:make-fraction-snip exp #f)]
(drscheme:number-snip:make-fraction-snip expr #f)]
[(eq? number-snip-type 'mixed-fraction-e)
(drscheme:number-snip:make-fraction-snip exp #t)]
(drscheme:number-snip:make-fraction-snip expr #t)]
[else
(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 expr)])))
;; render-to-sexp : TST -> sexp
(define (render-to-sexp val)
@ -204,7 +195,7 @@
(define view 0)
; whether the stepper is waiting for a new view to become available
; (initially 'waiting-for-any-step)
; (initially true)
; possible values: #f, 'waiting-for-any-step, 'waiting-for-application
(define stepper-is-waiting? 'waiting-for-any-step)
@ -383,16 +374,32 @@
(let ([step-text
(cond [(before-after-result? result)
(instantiate x:stepper-text% ()
[left-side (before-after-result-pre-exps result)]
[right-side (before-after-result-post-exps result)])]
[finished-exprs (before-after-result-finished-exprs result)]
[exps (before-after-result-exp result)]
[post-exps (before-after-result-post-exp result)]
[error-msg #f]
[after-exprs (before-after-result-after-exprs result)])]
[(before-error-result? result)
(instantiate x:stepper-text% ()
[left-side (before-error-result-pre-exps result)]
[right-side (before-error-result-err-msg result)])]
[finished-exprs (before-error-result-finished-exprs result)]
[exps (before-error-result-exp result)]
[post-exps null]
[error-msg (before-error-result-err-msg result)]
[after-exprs (before-error-result-after-exprs result)])]
[(error-result? result)
(instantiate x:stepper-text% ()
[left-side null]
[right-side (error-result-err-msg result)])]
[finished-exprs (error-result-finished-exprs result)]
[exps null]
[post-exps null]
[error-msg (error-result-err-msg result)]
[after-exprs null])]
[(finished-result? result)
(instantiate x:stepper-text% ()
[finished-exprs (finished-result-finished-exprs result)]
[exps null]
[post-exps null]
[error-msg #f]
[after-exprs null])]
[(finished-stepping? result)
x:finished-text])]
[step-kind (or (and (before-after-result? result)
@ -419,12 +426,16 @@
; START THE MODEL
(model:go program-expander-prime receive-result (get-render-settings render-to-string render-to-sexp #t)
(not (member language-level-name
(list (string-constant intermediate-student/lambda)
(string-constant advanced-student)))))
(not (string=? language-level-name (string-constant intermediate-student/lambda))))
(send s-frame show #t)
s-frame)
;; 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")))
;; stepper-unit-frame<%> : the interface that the extended drscheme frame fulfils
(define stepper-unit-frame<%>
@ -476,7 +487,7 @@
(define/public (get-stepper-button) stepper-button)
(define stepper-button
(make-object button%
(x:stepper-bitmap this)
(stepper-bitmap this)
(get-button-panel)
(lambda (button evt)
(if stepper-frame
@ -484,8 +495,7 @@
(let* ([settings (send (get-definitions-text) get-next-settings)]
[language (drscheme:language-configuration:language-settings-language settings)]
[language-level (car (last-pair (send language get-language-position)))])
(if (or (member language-level stepper-works-for)
(getenv "PLTSTEPPERUNSAFE"))
(if (member language-level stepper-works-for)
(set! stepper-frame (view-controller-go this program-expander))
(message-box (string-constant stepper-name)
(format (string-constant stepper-language-level-message)