diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 2bc84e30b8..b7c6f04378 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -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))) diff --git a/collects/stepper/private/display-exp-interface.ss b/collects/stepper/private/display-exp-interface.ss new file mode 100644 index 0000000000..d5bf4470c6 --- /dev/null +++ b/collects/stepper/private/display-exp-interface.ss @@ -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?) _)))))) + +) \ No newline at end of file diff --git a/collects/stepper/private/highlight-placeholder.ss b/collects/stepper/private/highlight-placeholder.ss new file mode 100644 index 0000000000..711932a52c --- /dev/null +++ b/collects/stepper/private/highlight-placeholder.ss @@ -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)) diff --git a/collects/stepper/private/lifting.ss b/collects/stepper/private/lifting.ss index d9d3c36791..2b0d8042ed 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 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 diff --git a/collects/stepper/private/model-settings.ss b/collects/stepper/private/model-settings.ss index 5862a8605e..26db64a527 100644 --- a/collects/stepper/private/model-settings.ss +++ b/collects/stepper/private/model-settings.ss @@ -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) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index a0db64c9f0..7d0068104f 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -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))))))) diff --git a/collects/stepper/private/mred-extensions.ss b/collects/stepper/private/mred-extensions.ss index 653d89f487..a613295f10 100644 --- a/collects/stepper/private/mred-extensions.ss +++ b/collects/stepper/private/mred-extensions.ss @@ -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)) + ) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index 0642a18e4d..d015117871 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -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))) diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index bcc28aad6b..e9fe2b9a89 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -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 diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 3c8d86c208..0d25b0966e 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -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)