From 4629487985c96d020ca774cb71b664edee6aa8f7 Mon Sep 17 00:00:00 2001 From: John Clements Date: Mon, 12 Sep 2005 23:53:31 +0000 Subject: [PATCH] re-applied changes by merging back to 782 svn: r844 --- collects/stepper/private/annotate.ss | 285 ++++++++-------- .../stepper/private/display-exp-interface.ss | 34 -- .../stepper/private/highlight-placeholder.ss | 13 - collects/stepper/private/lifting.ss | 7 +- collects/stepper/private/model-settings.ss | 5 + collects/stepper/private/model.ss | 136 ++++---- collects/stepper/private/mred-extensions.ss | 312 +++++++----------- collects/stepper/private/reconstruct.ss | 308 +++++++++++------ collects/stepper/private/shared.ss | 94 +++--- collects/stepper/stepper-tool.ss | 96 +++--- 10 files changed, 648 insertions(+), 642 deletions(-) delete mode 100644 collects/stepper/private/display-exp-interface.ss delete mode 100644 collects/stepper/private/highlight-placeholder.ss diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index b7c6f04378..2bc84e30b8 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -9,7 +9,6 @@ "my-macros.ss" "xml-box.ss" (prefix beginner-defined: "beginner-defined.ss")) - ; CONTRACTS @@ -58,23 +57,8 @@ ; `(#%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 - ;; - ;;;;;;;;;; - ;; 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: + ; test exps: ; (andmap (lambda (arg-list) ; (let* ([stx (car arg-list)] ; [elaborated (cadr arg-list)] @@ -117,7 +101,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) @@ -195,6 +179,8 @@ ; 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 @@ -230,7 +216,7 @@ ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;; ;;;;; ;; ;;;; - + ; oh-say-can-you-see,by-the-dawn's-early-light,what-so-proudly-we-hailed,at-the-twilight's-last-gle @@ -267,7 +253,7 @@ ; c) a boolean indicating whether to store inferred names. ; - (define (annotate expr break track-inferred-names?) + (define (annotate main-exp break track-inferred-names?) (define binding-indexer (let ([binding-index 0]) @@ -285,15 +271,12 @@ (define (result-value-break vals-list) (break (current-continuation-marks) 'result-value-break vals-list)) - (define (expr-finished-break vals-list) - (break (current-continuation-marks) 'expr-finished-break vals-list)) + (define (exp-finished-break info-list) + (break #f 'expr-finished-break info-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) @@ -301,44 +284,38 @@ ; wcm, normal-break ; wcm-pre-break-wrap : call wcm-wrap with a pre-break on the expr - (define (wcm-pre-break-wrap debug-info expr) - (wcm-wrap debug-info #`(begin (#,result-exp-break) #,expr))) + (define (wcm-pre-break-wrap debug-info exp) + (wcm-wrap debug-info #`(begin (#,result-exp-break) #,exp))) - (define (break-wrap expr) - #`(begin (#,normal-break) #,expr)) + (define (break-wrap exp) + #`(begin (#,normal-break) #,exp)) - (define (double-break-wrap expr) - #`(begin (#,double-break) #,expr)) + (define (double-break-wrap exp) + #`(begin (#,double-break) #,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) + (define (return-value-wrap exp) #`(call-with-values - (lambda () #,expr) + (lambda () #,exp) (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 expr) + (define (make-define-struct-break exp) (lambda () - (break #f 'define-struct-break (list expr)))) - - (define (top-level-annotate/inner expr source-expr defined-name) + (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) (let*-2vals ([(annotated dont-care) - (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 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 takes ; a) an expression to annotate @@ -374,15 +351,15 @@ (define annotate/inner ;(-> syntax? binding-set? boolean? (union false/c syntax? (list/p syntax? syntax?)) (vector/p syntax? binding-set?)) - (lambda (expr tail-bound pre-break? procedure-name-info) + (lambda (exp tail-bound pre-break? procedure-name-info) - (cond [(syntax-property expr 'stepper-skipto) + (cond [(syntax-property exp '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 expr 'stepper-skipto) - expr + (syntax-property exp 'stepper-skipto) + exp (lambda (subterm) (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)]) (set! free-vars-captured free-vars) @@ -392,32 +369,32 @@ annotated) free-vars-captured))] - [(syntax-property expr 'stepper-skip-completely) - (2vals (wcm-wrap 13 expr) null)] + [(syntax-property exp 'stepper-skip-completely) + (2vals (wcm-wrap 13 exp) null)] [else - (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* ([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* ([proc-name-info (if (not (null? binding-names)) (list (car binding-names) (car dyn-index-syms)) #f)]) - (annotate/inner expr null #f proc-name-info)))] - [lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))] + (annotate/inner exp null #f proc-name-info)))] + [lambda-body-recur (lambda (exp) (annotate/inner exp '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 (expr) - (annotate/inner expr (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))] + (lambda (exp) + (annotate/inner exp (binding-set-union (list tail-bound bindings)) #f procedure-name-info)))] [make-debug-info-normal (lambda (free-bindings) - (make-debug-info expr tail-bound free-bindings 'none #t))] + (make-debug-info exp tail-bound free-bindings 'none #t))] [make-debug-info-app (lambda (tail-bound free-bindings label) - (make-debug-info expr tail-bound free-bindings label #t))] + (make-debug-info exp tail-bound free-bindings label #t))] [make-debug-info-let (lambda (free-bindings binding-list let-counter) - (make-debug-info expr + (make-debug-info exp (binding-set-union (list tail-bound binding-list (list let-counter))) @@ -429,8 +406,8 @@ [outer-wcm-wrap (if pre-break? wcm-pre-break-wrap wcm-wrap)] - [wcm-break-wrap (lambda (debug-info expr) - (outer-wcm-wrap debug-info (break-wrap expr)))] + [wcm-break-wrap (lambda (debug-info exp) + (outer-wcm-wrap debug-info (break-wrap exp)))] [normal-bundle (lambda (free-vars annotated) @@ -518,7 +495,13 @@ ; 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]) @@ -557,19 +540,27 @@ (map (lambda (binding-set val) #`(set!-values #,binding-set #,val)) binding-sets - annotated-vals)] + 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 ...))) ...)))] ; 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)) - #,(late-let-break-wrap binding-list - lifted-vars - annotated-body))))]) + #`(begin #,@(apply append (zip set!-clauses counter-clauses)) + (#,exp-finished-break #,exp-finished-clauses) + #,annotated-body)))]) (2vals (quasisyntax/loc - expr + exp (let ([#,counter-id (#,binding-indexer)]) (#,output-identifier #,outer-initialization #,wrapped-begin))) free-varrefs)))))] @@ -593,8 +584,8 @@ #`(begin (set! #,if-temp #,annotated-test) (#,normal-break) #,(if else - (quasisyntax/loc expr (if #,if-temp #,annotated-then #,annotated-else)) - (quasisyntax/loc expr (if #,if-temp #,annotated-then))))] + (quasisyntax/loc exp (if #,if-temp #,annotated-then #,annotated-else)) + (quasisyntax/loc exp (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) @@ -603,7 +594,7 @@ (with-syntax ([test-var if-temp] [wrapped-stx wrapped] [unevaluated-stx *unevaluated*]) - (syntax/loc expr (let ([test-var unevaluated-stx]) wrapped-stx))) + (syntax/loc exp (let ([test-var unevaluated-stx]) wrapped-stx))) free-varrefs)))] [varref-abstraction @@ -642,32 +633,32 @@ [recertifier (lambda (vals) - (let*-2vals ([(new-expr bindings) vals]) - (2vals (syntax-recertify new-expr expr (current-code-inspector) #f) + (let*-2vals ([(new-exp bindings) vals]) + (2vals (syntax-recertify new-exp exp (current-code-inspector) #f) bindings)))] ) ; find the source expression and associate it with the parsed expression ; (when (and red-exprs foot-wrap?) - ; (set-expr-read! expr (find-read-expr expr))) + ; (set-exp-read! exp (find-read-expr exp))) (recertifier - (kernel:kernel-syntax-case expr #f + (kernel:kernel-syntax-case exp #f [(lambda . clause) (let*-2vals ([(annotated-clause free-varrefs) (lambda-clause-abstraction (syntax clause))] [annotated-lambda (with-syntax ([annotated-clause annotated-clause]) - (syntax/loc expr (lambda . annotated-clause)))]) + (syntax/loc exp (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 expr (case-lambda . annotated-cases)))] + (syntax/loc exp (case-lambda . annotated-cases)))] [free-varrefs (varref-set-union free-varrefs-cases)]) (outer-lambda-abstraction annotated-case-lambda free-varrefs))] @@ -678,7 +669,7 @@ [(begin . bodies-stx) (if (null? (syntax->list (syntax bodies-stx))) - (normal-bundle null expr) + (normal-bundle null exp) (let*-2vals ([reversed-bodies (reverse (syntax->list (syntax bodies-stx)))] [last-body (car reversed-bodies)] @@ -688,7 +679,7 @@ [(annotated-final free-varrefs-final) (tail-recur last-body)]) (normal-bundle (varref-set-union (cons free-varrefs-final free-varrefs-a)) - (quasisyntax/loc expr (begin #,@annotated-a #,annotated-final)))))] + (quasisyntax/loc exp (begin #,@annotated-a #,annotated-final)))))] [(begin0 . bodies-stx) (let*-2vals @@ -698,16 +689,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 expr (begin0 #,annotated-first #,@annotated-bodies))))] + (quasisyntax/loc exp (begin0 #,annotated-first #,@annotated-bodies))))] [(let-values . _) - (let-abstraction expr + (let-abstraction exp #`let-values (lambda (bindings) (map (lambda (_) *unevaluated*) bindings)))] [(letrec-values . _) - (let-abstraction expr + (let-abstraction exp #`letrec-values (lambda (bindings) (map (lambda (b) #`#,b) bindings)))] @@ -716,16 +707,30 @@ ([(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)]))]) - (normal-bundle (varref-set-union (list (list (syntax var)) val-free-varrefs)) - (quasisyntax/loc expr (set! #,(syntax var) #,annotated-val))))] + [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))] [(quote _) - (normal-bundle null expr)] + (normal-bundle null exp)] [(quote-syntax _) - (normal-bundle null expr)] + (normal-bundle null exp)] [(with-continuation-mark key mark body) ;(let*-2vals ([(annotated-key free-varrefs-key) @@ -790,12 +795,12 @@ arg-temps)] [let-clauses #`((#,tagged-arg-temps (values #,@(map (lambda (_) *unevaluated*) tagged-arg-temps))))] - [set!-list (map (lambda (arg-symbol annotated-sub-expr) - #`(set! #,arg-symbol #,annotated-sub-expr)) + [set!-list (map (lambda (arg-symbol annotated-sub-exp) + #`(set! #,arg-symbol #,annotated-sub-exp)) 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 expr #,tagged-arg-temps)] + [app-term (quasisyntax/loc exp #,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)] @@ -811,7 +816,7 @@ free-varrefs))] [(#%datum . _) - (normal-bundle null expr)] + (normal-bundle null exp)] [(#%top . var-stx) (varref-abstraction #`var-stx)] @@ -821,7 +826,7 @@ (varref-abstraction #`var-stx)] [else - (error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum expr))])))]))) + (error 'annotate "unexpected syntax for expression: ~v" (syntax-object->datum exp))])))]))) ;; annotate/top-level : syntax-> syntax @@ -833,64 +838,72 @@ (define/contract annotate/top-level (syntax? . -> . syntax?) - (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))))] + (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))))] ; the 'require' form is used for the test harness - [(require module-name) - expr] + [(require module-name) exp] ; the 'dynamic-require' form is used by the actual expander [(let-values ([(done-already?) . rest1]) (#%app dynamic-wind void (lambda () . rest2) (lambda () . rest3))) - expr] - [else (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax-object->datum expr))]))) + exp] + [else (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax-object->datum exp))]))) (define/contract annotate/module-top-level (syntax? . -> . syntax?) - (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)] + (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)] [else - (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 ...))] + (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 ...))] [defined-name (if (and (pair? name-list) (null? (cdr name-list))) (car name-list) #f)]) - #`(define-values (new-vars ...) - #,(top-level-annotate/inner (top-level-rewrite #`e) expr defined-name)))] + #`(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-syntaxes (new-vars ...) e) - expr] + exp] [(require specs ...) - expr] + exp] [(require-for-syntax specs ...) - expr] + exp] [(provide specs ...) - expr] + exp] [(begin . bodies) #`(begin #,@(map annotate/module-top-level (syntax->list #`bodies)))] [(#%app call-with-values (lambda () body) print-values) - #`(#%app call-with-values (lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) expr #f)) 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))))] [any - (syntax-property expr 'stepper-test-suite-hint) - (top-level-annotate/inner (top-level-rewrite expr) expr #f)] + (syntax-property exp 'stepper-test-suite-hint) + (top-level-annotate/inner (top-level-rewrite exp) exp #f)] [else - (top-level-annotate/inner (top-level-rewrite expr) expr #f) + (top-level-annotate/inner (top-level-rewrite exp) exp #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 expr))])]))) + #;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax-object->datum exp))])]))) ; body of local - #;(printf "input: ~a\n" expr) - (let* ([annotated-expr (annotate/top-level expr)]) - #;(printf "annotated: \n~a\n" (syntax-object->datum annotated-expr)) - annotated-expr))) + #;(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))) diff --git a/collects/stepper/private/display-exp-interface.ss b/collects/stepper/private/display-exp-interface.ss deleted file mode 100644 index d5bf4470c6..0000000000 --- a/collects/stepper/private/display-exp-interface.ss +++ /dev/null @@ -1,34 +0,0 @@ -(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?) _)))))) - -) \ No newline at end of file diff --git a/collects/stepper/private/highlight-placeholder.ss b/collects/stepper/private/highlight-placeholder.ss deleted file mode 100644 index 711932a52c..0000000000 --- a/collects/stepper/private/highlight-placeholder.ss +++ /dev/null @@ -1,13 +0,0 @@ -(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)) diff --git a/collects/stepper/private/lifting.ss b/collects/stepper/private/lifting.ss index 2b0d8042ed..d9d3c36791 100644 --- a/collects/stepper/private/lifting.ss +++ b/collects/stepper/private/lifting.ss @@ -16,7 +16,7 @@ (define-struct try-record (index try-fn expr)) ; try-records are - (provide/contract [lift (syntax? ; syntax to perform lifiting in + (provide/contract [lift (syntax? ; syntax to perform lifting in boolean? ; lift-at-highlight? . -> . (listof syntax?))]) ; result @@ -27,6 +27,9 @@ (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 @@ -156,7 +159,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 diff --git a/collects/stepper/private/model-settings.ss b/collects/stepper/private/model-settings.ss index 26db64a527..5862a8605e 100644 --- a/collects/stepper/private/model-settings.ss +++ b/collects/stepper/private/model-settings.ss @@ -41,6 +41,7 @@ [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) @@ -66,6 +67,10 @@ (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) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 7d0068104f..a0db64c9f0 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -37,6 +37,7 @@ (require (lib "contract.ss") (lib "etc.ss") (lib "list.ss") + (lib "match.ss") "my-macros.ss" (prefix a: "annotate.ss") (prefix r: "reconstruct.ss") @@ -66,18 +67,27 @@ (local - ((define finished-exprs null) + (;; 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 held-expr-list no-sexp) + ;; the "held" variables are used to store the "before" step. + (define held-exp-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) @@ -115,8 +125,15 @@ (opt-lambda (mark-set break-kind [returned-value-list null]) (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) - - (define (double-redivide finished-exprs new-exprs-before new-exprs-after) + + (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) (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) @@ -125,71 +142,77 @@ (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-exprs before) current current-2 after))) - - (define (reconstruct-helper) - (r:reconstruct-current mark-list break-kind returned-value-list render-settings)) + (values (append finished-exps before) current current-2 after))) (if (r:skip-step? break-kind mark-list render-settings) (when (eq? break-kind 'normal-break) - (set! held-expr-list skipped-step)) + (set! held-exp-list skipped-step)) + (case break-kind [(normal-break) (begin - (set! held-expr-list (reconstruct-helper)) + (set! held-finished-list (reconstruct-all-completed)) + (set! held-exp-list (r:reconstruct-left-side mark-list render-settings)) (set! held-step-was-app? (r:step-was-app? mark-list)))] [(result-exp-break result-value-break) - (if (eq? held-expr-list skipped-step) - (set! held-expr-list no-sexp) - (let* ([reconstructed (reconstruct-helper)] + (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)] [result - (if (not (eq? held-expr-list no-sexp)) + (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) + (let*-values ([(step-kind) (if (and held-step-was-app? (eq? break-kind 'result-exp-break)) 'user-application 'normal)] - [(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) + [(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) (receive-result result)))] + [(double-break) ; a double-break occurs at the beginning of a let's evaluation. - (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)))] + (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)))] + [(expr-finished-break) - (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))))] + (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)] [else (error 'break "unknown label on break")]))))) @@ -199,12 +222,12 @@ (expand-next-expression))) (define (err-display-handler message exn) - (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))))) + (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))))) (program-expander (lambda () @@ -215,7 +238,6 @@ (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))))))) diff --git a/collects/stepper/private/mred-extensions.ss b/collects/stepper/private/mred-extensions.ss index a613295f10..653d89f487 100644 --- a/collects/stepper/private/mred-extensions.ss +++ b/collects/stepper/private/mred-extensions.ss @@ -3,19 +3,17 @@ (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 "string-constant.ss" "string-constants") + (lib "bitmap-label.ss" "mrlib")) (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 - stepper-text-test) + finished-text) (define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1))) (define reduct-highlight-color (make-object color% 255 255 255)) @@ -29,91 +27,8 @@ (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) - (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 + ;;;; VERTICAL-SEPARATOR : the red arrow that separates the left half of the display from the right half. (define red-arrow-bitmap (make-object bitmap% (build-path (collection-path "icons") "red-arrow.bmp") 'bmp)) @@ -133,15 +48,12 @@ (super-instantiate ())))) - (send* separator-snipclass + (send* vertical-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) @@ -212,7 +124,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 in the stepper window. + ; there are four of them (* NB: now only two! 2005-08) in the stepper window. (define stepper-sub-text% (class f:text:standard-style-list% () @@ -257,61 +169,62 @@ (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) @@ -345,7 +258,7 @@ ; ; ; ; - ; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four stepper "text" spots. + ; the stepper-sub-error-text%, like stepper-sub-text%, fits in one of the four^H^H^H^Htwo stepper "text" spots. ; it is used for error messages. (define stepper-sub-error-text% @@ -378,7 +291,10 @@ ;;; ;; ;;;; ; ;;; ; ;;; ;;;; ; ;;; ;;;;; ; ; ; ;;;;; ;;; ; ;; ; ; ; ; - + + ;; 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) @@ -407,12 +323,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 : ((listof sexp) (listof sexp) (listof sexp) (union string #f) (listof sexp) -> ) + ;; constructor : ((union (listof sexp) string) (union (listof sexp) string) -> ) (define stepper-text% (class f:text:standard-style-list% () - (init-field finished-exprs exps post-exps error-msg after-exprs) + (init-field left-side right-side) (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 @@ -425,7 +341,6 @@ [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 @@ -433,30 +348,19 @@ [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) - (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))) + (coordinate-snip-sizes)) + (set! old-width canvas-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%)) - (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))) + + ;; coordinate-snip-sizes : make the vertical separator snip the right size, then notify the administrator. (define/private (coordinate-snip-sizes) (let* ([get-snip-height (lambda (snip) @@ -465,7 +369,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 (apply max (map get-snip-height (list before-snip after-snip)))]) + [max-height (max (get-snip-height before-snip) (get-snip-height after-snip))]) (send vert-separator set-height! (- max-height 4)) (let ([w-box (box 0)] [h-box (box 0)]) @@ -476,23 +380,28 @@ (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)) (list top-defs-snip (string #\newline) horiz-separator-1 - before-snip vert-separator - after-snip (string #\newline) - horiz-separator-2 bottom-defs-snip)) + (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)) (change-style snip-delta before-position (last-position))) - (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)) + + ;; 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) + + + + (lock #t))) (define finished-text @@ -507,7 +416,6 @@ (lock #t)) ())) - (define (snip? val) (is-a? val snip%)) @@ -598,33 +506,39 @@ ) (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 800) + (send new-canvas min-width 200) (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 `((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)))) + #;(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))))) + ;; 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 `() `(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)) - + #;(stepper-text-test "This is another error message" `(poomp)) ) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index d015117871..0642a18e4d 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -15,11 +15,28 @@ "lifting.ss") (provide/contract - [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?))))] + [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?)))] + [final-mark-list? (-> mark-list? boolean?)] [skip-step? (-> break-kind? (union mark-list? false/c) render-settings? boolean?)] [step-was-app? (-> mark-list? boolean?)]) @@ -299,22 +316,26 @@ (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)] - [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)] + [(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)])) (transfer-info (if (syntax-property stx 'user-stepper-hint) @@ -364,29 +385,30 @@ (define (unwind-define stx) (kernel:kernel-syntax-case stx #f [(define-values (name . others) 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)))] + (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))))] [else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))])) (define (unwind-mz-let stx) @@ -570,7 +592,18 @@ [(let-values . rest) (recon-let/rec #f)] [(letrec-values . rest) (recon-let/rec #t)] - ; set! : set! doesn't fit into this scheme. It would be a mistake to allow it to proceed. + ; 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)))] ; quote [(quote body) (recon-value (syntax-e (syntax body)) render-settings)] @@ -602,20 +635,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)))))] @@ -629,6 +662,25 @@ (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). @@ -661,37 +713,55 @@ ; 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) @@ -720,9 +790,21 @@ ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ;;;; ;;; ;;; ; ; ;;; ;; ; ;; ; ;;; ;; ;;; ;; ; ; ; ;;;; ; ; ;; - - - + + + ;; 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 @@ -747,11 +829,11 @@ (lambda (expr) (recon-source-expr expr mark-list null null render-settings))] [top-mark (car mark-list)] - [expr (mark-source top-mark)] + [exp (mark-source top-mark)] [recon-let (lambda () - (with-syntax ([(label ((vars rhs) ...) . bodies) expr]) + (with-syntax ([(label ((vars rhs) ...) . bodies) exp]) (let*-2vals ([binding-sets (map syntax->list (syntax->list #'(vars ...)))] [binding-list (apply append binding-sets)] [glumps @@ -803,19 +885,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) expr))))]) - (kernel:kernel-syntax-case expr #f + (attach-info #`(label #,recon-bindings #,@rectified-bodies) exp))))]) + (kernel:kernel-syntax-case exp #f ; variable references [id (identifier? (syntax id)) (if (eq? so-far nothing-so-far) - (recon-source-current-marks expr) - (error 'recon-inner "variable reference given as context: ~a" expr))] + (recon-source-current-marks exp) + (error 'recon-inner "variable reference given as context: ~a" exp))] [(#%top . id) (if (eq? so-far nothing-so-far) - (recon-source-current-marks expr) - (error 'recon-inner "variable reference given as context: ~a" expr))] + (recon-source-current-marks exp) + (error 'recon-inner "variable reference given as context: ~a" exp))] ; applications [(#%app . terms) @@ -841,8 +923,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" expr)))) - expr)] + (error "bad label in application mark in expr: ~a" exp)))) + exp)] ; define-struct ; @@ -866,7 +948,7 @@ #`(if #,test-exp #,(recon-source-current-marks (syntax then)) #,(recon-source-current-marks (syntax else)))) - expr)] + exp)] ; one-armed if @@ -877,7 +959,7 @@ so-far)]) #`(if #,test-exp #,(recon-source-current-marks (syntax then)))) - expr)] + exp)] ; quote : there is no break on a quote. @@ -890,8 +972,8 @@ #`(begin #,(recon-source-current-marks (syntax clause))) (error 'recon-inner - "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum expr))) - expr)] + "stepper:reconstruct: one-clause begin appeared as context: ~a" (syntax-object->datum exp))) + exp)] ; begin0 : may not occur directly except in advanced @@ -901,14 +983,21 @@ [(letrec-values . rest) (recon-let)] - ; define-values : define's don't get marks, so they can't occur here + [(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)] ; lambda : there is no break on a lambda [else (error 'recon-inner - "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum expr))]))) + "stepper:reconstruct: unknown object to reconstruct: ~a" (syntax-object->datum exp))]))) ; the main recursive reconstruction loop is in recon: ; recon : (syntax-object mark-list boolean -> syntax-object) @@ -934,19 +1023,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 - ((result-value-break result-exp-break) + ((left-side) + (unwind (recon nothing-so-far mark-list #t) #f)) + ((right-side) (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))] @@ -959,11 +1048,12 @@ (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)))) - ((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))))) + (unwind (recon innermost-after (cdr mark-list) #f) #t)))))) + + ) - answer))) + answer)) + + + + ) diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index e9fe2b9a89..bcc28aad6b 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -3,7 +3,8 @@ (require "my-macros.ss" (lib "contract.ss") (lib "list.ss") - (lib "etc.ss")) + (lib "etc.ss") + (lib "match.ss")) ; CONTRACTS @@ -40,10 +41,9 @@ varref-set-remove-bindings binding-set-varref-set-intersect step-result? - (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 before-after-result (pre-exps post-exps kind)) + (struct before-error-result (pre-exps err-msg)) + (struct error-result (err-msg)) (struct finished-stepping ()) list-take list-partition @@ -72,6 +72,7 @@ ; get-binding-name ; bogus-binding? if-temp + set!-temp ; get-lifted-gensym ; expr-read ; set-expr-read! @@ -83,18 +84,17 @@ finished-xml-box-table) ; A step-result is either: - ; (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) + ; (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) - (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 before-after-result (pre-exps post-exps kind) (make-inspector)) + (define-struct before-error-result (pre-exps err-msg) (make-inspector)) + (define-struct error-result (err-msg) (make-inspector)) (define-struct finished-stepping () (make-inspector)) - (define step-result? (union before-after-result? before-error-result? error-result? finished-result? finished-stepping?)) + (define step-result? (union before-after-result? before-error-result? error-result? finished-stepping?)) ; the closure record is placed in the closure table @@ -215,7 +215,8 @@ (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 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)) ; gensyms needed by many modules: @@ -477,31 +478,46 @@ ; 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 (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 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 (values-map fn . lsts) (apply values (apply map list diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 0d25b0966e..3c8d86c208 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -1,21 +1,20 @@ (module stepper-tool mzscheme + (require (lib "contract.ss") (lib "tool.ss" "drscheme") - (lib "mred.ss" "mred") + (lib "mred.ss" "mred") + (lib "pconvert.ss") + (lib "string-constant.ss" "string-constants") + (lib "async-channel.ss") (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" - (lib "pconvert.ss") - (lib "string-constant.ss" "string-constants") - (lib "async-channel.ss") - (lib "bitmap-label.ss" "mrlib")) + "private/model-settings.ss") ;; mflatt: MINOR HACK - work around temporary ;; print-convert problems @@ -30,7 +29,8 @@ (list (string-constant beginning-student) (string-constant beginning-student/abbrev) (string-constant intermediate-student) - (string-constant intermediate-student/lambda))) + (string-constant intermediate-student/lambda) + (string-constant advanced-student))) (provide stepper-tool@) @@ -43,18 +43,21 @@ (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) @@ -72,6 +75,8 @@ (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) @@ -123,20 +128,22 @@ ;; 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)]) @@ -147,29 +154,31 @@ 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 (expr basic-convert sub-convert) + (lambda (exp basic-convert sub-convert) (cond - [(is-a? expr snip%) - (send expr copy)] - #;[((drscheme:rep:use-number-snip) expr) + [(is-a? exp snip%) + (send exp copy)] + #;[((drscheme:rep:use-number-snip) exp) (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 expr #f)] + (drscheme:number-snip:make-repeating-decimal-snip exp #f)] [(eq? number-snip-type 'repeating-decimal-e) - (drscheme:number-snip:make-repeating-decimal-snip expr #t)] + (drscheme:number-snip:make-repeating-decimal-snip exp #t)] [(eq? number-snip-type 'mixed-fraction) - (drscheme:number-snip:make-fraction-snip expr #f)] + (drscheme:number-snip:make-fraction-snip exp #f)] [(eq? number-snip-type 'mixed-fraction-e) - (drscheme:number-snip:make-fraction-snip expr #t)] + (drscheme:number-snip:make-fraction-snip exp #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 expr)]))) + [else (basic-convert exp)]))) ;; render-to-sexp : TST -> sexp (define (render-to-sexp val) @@ -195,7 +204,7 @@ (define view 0) ; whether the stepper is waiting for a new view to become available - ; (initially true) + ; (initially 'waiting-for-any-step) ; possible values: #f, 'waiting-for-any-step, 'waiting-for-application (define stepper-is-waiting? 'waiting-for-any-step) @@ -374,32 +383,16 @@ (let ([step-text (cond [(before-after-result? result) (instantiate x:stepper-text% () - [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)])] + [left-side (before-after-result-pre-exps result)] + [right-side (before-after-result-post-exps result)])] [(before-error-result? result) (instantiate x:stepper-text% () - [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)])] + [left-side (before-error-result-pre-exps result)] + [right-side (before-error-result-err-msg result)])] [(error-result? result) (instantiate x:stepper-text% () - [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])] + [left-side null] + [right-side (error-result-err-msg result)])] [(finished-stepping? result) x:finished-text])] [step-kind (or (and (before-after-result? result) @@ -426,16 +419,12 @@ ; START THE MODEL (model:go program-expander-prime receive-result (get-render-settings render-to-string render-to-sexp #t) - (not (string=? language-level-name (string-constant intermediate-student/lambda)))) + (not (member language-level-name + (list (string-constant intermediate-student/lambda) + (string-constant advanced-student))))) (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<%> @@ -487,7 +476,7 @@ (define/public (get-stepper-button) stepper-button) (define stepper-button (make-object button% - (stepper-bitmap this) + (x:stepper-bitmap this) (get-button-panel) (lambda (button evt) (if stepper-frame @@ -495,7 +484,8 @@ (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 (member language-level stepper-works-for) + (if (or (member language-level stepper-works-for) + (getenv "PLTSTEPPERUNSAFE")) (set! stepper-frame (view-controller-go this program-expander)) (message-box (string-constant stepper-name) (format (string-constant stepper-language-level-message)