diff --git a/collects/stepper/private/macro-unwind.ss b/collects/stepper/private/macro-unwind.ss new file mode 100644 index 0000000000..2f48d5f6d1 --- /dev/null +++ b/collects/stepper/private/macro-unwind.ss @@ -0,0 +1,256 @@ +(module macro-unwind mzscheme + (require (prefix kernel: (lib "kerncase.ss" "syntax")) + (lib "etc.ss") + (lib "contract.ss") + "shared.ss" + "lifting.ss") + + (provide/contract [unwind (syntax? boolean? . -> . (listof syntax?))] + [unwind-no-highlight (syntax? . -> . (listof syntax?))]) + + ; ; ; + ; + ; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ; + ;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; + ; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; + ; + + ; unwind takes a syntax object with a single highlight, + ; and returns a list of syntax objects + + (define (unwind stx lift-at-highlight?) + (macro-unwind (lift stx lift-at-highlight?))) + + ; unwind-no-highlight is really just macro-unwind, but with the 'right' interface that + ; makes it more obvious what it does. + ; [unwind-no-highlight (-> syntax? (listof syntax?))] + + (define (unwind-no-highlight stx) + (macro-unwind (list stx))) + + ; unwind-only-highlight : syntax? -> (listof syntax?) + (define (unwind-only-highlight stx) + (unwind stx #t)) + + (define (improper-member elt improper-list) + (cond [(pair? improper-list) + (or (eq? elt (car improper-list)) + (improper-member elt (cdr improper-list)))] + [else + (eq? elt improper-list)])) + + (define-syntax (noisy-and stx) + (syntax-case stx () + [(_) #`#t] + [(_ a b ...) + (with-syntax ([inner (syntax/loc stx (noisy-and b ...))] + [error (syntax/loc #`a (error 'noisy-and "and clause failed"))]) + (syntax/loc stx (if a inner error)))] + [else + (error 'noisy-and "bad syntax for noisy-and")])) + + ;(->* (syntax? (listof syntax?)) + ; (syntax? (listof syntax?))) + + (define (macro-unwind stxs) + (local + ((define (recur-on-pieces stx) + (if (pair? (syntax-e stx)) + (datum->syntax-object stx (syntax-pair-map (syntax-e stx) inner) stx stx) + stx)) + + (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)])) + + (transfer-info + (if (syntax-property stx 'user-stepper-hint) + (case (syntax-property stx 'user-stepper-hint) + + + [(comes-from-cond) (unwind-cond stx + (syntax-property stx 'user-source) + (syntax-property stx 'user-position))] + + [(comes-from-and) (unwind-and/or stx + (syntax-property stx 'user-source) + (syntax-property stx 'user-position) + 'and)] + + [(comes-from-or) (unwind-and/or stx + (syntax-property stx 'user-source) + (syntax-property stx 'user-position) + 'or)] + + [(comes-from-local) + (unwind-local stx)] + + [(comes-from-recur) + (unwind-recur stx)] + + [(comes-from-begin) + (unwind-begin stx)] + + (else (fall-through))) + (fall-through)) + stx)) + + (define (transfer-highlight from to) + (if (syntax-property from 'stepper-highlight) + (syntax-property to 'stepper-highlight #t) + to)) + + (define (unwind-recur stx) + (with-syntax ([(app-keywd letrec-term argval ...) stx]) ; if you use #%app, it gets captured here + (with-syntax ([(new-argval ...) (map inner (syntax->list #`(argval ...)))]) + (let ([unwound (inner #`letrec-term)]) + (syntax-case unwound (letrec lambda) + [(letrec ([loop-name (lambda (argname ...) . bodies)]) loop-name-2) + (unless (module-identifier=? #`loop-name #`loop-name-2) + (error "unexpected syntax for 'recur': ~v" stx)) + (transfer-highlight unwound #`(recur loop-name ([argname new-argval] ...) . bodies))] + [else #`(#,unwound new-argval ...)]))))) + + (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))))] + [else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))])) + + (define (unwind-mz-let stx) + (with-syntax ([(label ([(var) rhs] ...) . bodies) stx]) + (with-syntax ([(rhs2 ...) (map inner (syntax->list #'(rhs ...)))] + [new-label (if (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint)) + #`let* + (case (syntax-e #'label) + [(let-values) #'let] + [(letrec-values) #'letrec]))] + [new-bodies (map inner (syntax->list #'bodies))]) + (syntax-case #`new-bodies (let*) ; is this let and the nested one part of a let*? + [((let* bindings inner-body ...)) + (and + (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint)) + (eq? (syntax-property stx 'user-stepper-source) + (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-source)) + (eq? (syntax-property stx 'user-stepper-position) + (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-position))) + #`(let* #,(append (syntax->list #`([var rhs2] ...)) (syntax->list #`bindings)) inner-body ...)] + [else + #`(new-label ([var rhs2] ...) . new-bodies)])))) + + (define (unwind-local stx) + (kernel:kernel-syntax-case stx #f + [(letrec-values ([vars exp] ...) body) ; at least through intermediate, define-values may not occur in local. + (with-syntax ([defns (map inner (syntax->list #`((define-values vars exp) ...)))]) + #`(local defns #,(inner #'body)))] + [else (error 'unwind-local "expected a letrec-values, given: ~e" (syntax-object->datum stx))])) + + ;(define (unwind-quasiquote-the-cons-application stx) + ; (syntax-case (recur-on-pieces stx) () + ; [(#%app the-cons . rest) + ; (syntax (cons . rest))] + ; [else + ; (error 'reconstruct "unexpected result for unwinding the-cons application")])) + + (define (unwind-cond-clause stx test-stx result-stx) + (with-syntax ([new-test (if (syntax-property stx 'user-stepper-else) + #`else + (inner test-stx))] + [result (inner result-stx)]) + #`(new-test result))) + + (define (unwind-cond stx user-source user-position) + (with-syntax ([clauses + (let loop ([stx stx]) + (if (and (eq? user-source (syntax-property stx 'user-source)) + (eq? user-position (syntax-property stx 'user-position))) + (syntax-case stx (if begin #%app) + [(if test result) ; the else clause disappears when it's a language-inserted else clause + (list (unwind-cond-clause stx #`test #`result))] + [(if test result else-clause) + (cons (unwind-cond-clause stx #`test #`result) + (loop (syntax else-clause)))] + [(begin . rest) ; else clause appears momentarily in 'before,' even though it's a 'skip-completely' + null] + [else-stx + (error 'unwind-cond "expected an if, got: ~e" (syntax-object->datum (syntax else-stx)))]) + (error 'unwind-cond "expected a cond clause expansion, got: ~e" (syntax-object->datum stx))))]) + (syntax (cond . clauses)))) + + (define (unwind-begin stx) + (syntax-case stx (let-values) + [(let-values () body ...) + (with-syntax ([(new-body ...) (map inner (syntax->list #`(body ...)))]) + #`(begin new-body ...))])) + + (define (unwind-and/or stx user-source user-position label) + (let ([clause-padder (case label + [(and) #`true] + [(or) #`false])]) + (with-syntax ([clauses + (append (build-list (syntax-property stx 'user-stepper-and/or-clauses-consumed) (lambda (dc) clause-padder)) + (let loop ([stx stx]) + (if (and (eq? user-source (syntax-property stx 'user-source)) + (eq? user-position (syntax-property stx 'user-position))) + (syntax-case stx (if let-values #%datum) + [(if part-1 part-2 part-3) + (cons (inner (syntax part-1)) + (case label + ((and) + (loop (syntax part-2))) + ((or) + (loop (syntax part-3))) + (else + (error 'unwind-and/or "unknown label ~a" label))))] + [else (error 'unwind-and/or "syntax: ~a does not match and/or patterns" (syntax-object->datum stx))]) + null)))]) + #`(#,label . clauses))))) + + (map inner stxs)))) \ No newline at end of file diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 7748eb976f..1995380bb5 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -36,24 +36,22 @@ (module model mzscheme (require (lib "contract.ss") (lib "etc.ss") - (lib "list.ss") (lib "match.ss") - "my-macros.ss" (prefix a: "annotate.ss") (prefix r: "reconstruct.ss") "shared.ss" "marks.ss" - "testing-shared.ss" - "model-settings.ss") - - + "model-settings.ss" + "macro-unwind.ss") + + (define program-expander-contract ((-> void?) ; init ((or/c eof-object? syntax? (cons/c string? any/c)) (-> void?) . -> . void?) ; iter . -> . void?)) - - + + (provide/contract [go (program-expander-contract ; program-expander (step-result? . -> . void?) ; receive-result (or/c render-settings? false/c) ; render-settings @@ -95,200 +93,202 @@ ;; in fact, just test for eq?-ness. #;(define (highlight-mutated-expressions lefts rights) - (if (or (null? lefts) (null? rights)) - (list lefts rights) - (let ([left-car (car lefts)] - [right-car (car rights)]) - (if (eq? (syntax-property left-car 'user-source) - (syntax-property right-car 'user-source)) - (let ([highlights-added (highlight-mutated-expression left-car right-car)] - [rest (highlight-mutated-expressions (cdr lefts) (cdr rights))]) - (cons (cons (car highlights-added) (car rest)) - (cons (cadr highlights-added) (cadr rest)))))))) - - ;; highlight-mutated-expression: syntax? syntax? -> syntax? - ;; given two expressions, highlight 'em both if they differ at all. - - ;; notes: wanted to use simple "eq?" test... but this will fail when a being-stepped definition (e.g. - ;; in a let) turns into a permanent one. We pay a terrible price for the lifting thing. And, for the fact - ;; that the highlighting follows from the reductions but can't obviously be deduced from them. - - #;(define (highlight-mutated-expression left right) - (cond - ;; if either one is already highlighted, leave them alone. - [(or (syntax-property left 'stepper-highlight) + (if (or (null? lefts) (null? rights)) + (list lefts rights) + (let ([left-car (car lefts)] + [right-car (car rights)]) + (if (eq? (syntax-property left-car 'user-source) + (syntax-property right-car 'user-source)) + (let ([highlights-added (highlight-mutated-expression left-car right-car)] + [rest (highlight-mutated-expressions (cdr lefts) (cdr rights))]) + (cons (cons (car highlights-added) (car rest)) + (cons (cadr highlights-added) (cadr rest)))))))) + + ;; highlight-mutated-expression: syntax? syntax? -> syntax? + ;; given two expressions, highlight 'em both if they differ at all. + + ;; notes: wanted to use simple "eq?" test... but this will fail when a being-stepped definition (e.g. + ;; in a let) turns into a permanent one. We pay a terrible price for the lifting thing. And, for the fact + ;; that the highlighting follows from the reductions but can't obviously be deduced from them. + + #;(define (highlight-mutated-expression left right) + (cond + ;; if either one is already highlighted, leave them alone. + [(or (syntax-property left 'stepper-highlight) (syntax-property right 'stepper-highlight)) (list left right)] + + ;; first pass: highlight if not eq?. Should be broken for local-bound things + ;; as they pass into permanence. + [(eq? left right) + (list left right)] + + [else (list (syntax-property left 'stepper-highlight) + (syntax-property right 'stepper-highlight))])) - ;; first pass: highlight if not eq?. Should be broken for local-bound things - ;; as they pass into permanence. - [(eq? left right) - (list left right)] - - [else (list (syntax-property left 'stepper-highlight) - (syntax-property right 'stepper-highlight))])) - - ;; 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) - (letrec ([contains-highlight - (lambda (expr) - (or (syntax-property expr 'stepper-highlight) - (syntax-case expr () - [(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))] - [else #f])))]) - (let* ([list-length (length exprs)] - [split-point-a (- list-length (length (or (memf contains-highlight exprs) null)))] - [split-point-b (length (or (memf contains-highlight (reverse exprs)) null))]) - (if (<= split-point-b split-point-a) - (error 'redivide-exprs "s-expressions did not contain the highlight-placeholder: ~v" (map syntax-object->hilite-datum exprs)) - (values (sublist 0 split-point-a exprs) ; before - (sublist split-point-a split-point-b exprs) ; during - (sublist split-point-b list-length exprs)))))) ; after - - -; (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6)) -; (values `(3 4) `((+ (define ,highlight-placeholder) 13)) `(5 6)) -; -; (redivide `(,highlight-placeholder 5 6)) -; (values `() `(,highlight-placeholder) `(5 6)) -; -; (redivide `(4 5 ,highlight-placeholder ,highlight-placeholder)) -; (values `(4 5) `(,highlight-placeholder ,highlight-placeholder) `()) -; -; (printf "will be errors:~n") -; (equal? (redivide `(1 2 3 4)) -; error-value) -; -; (redivide `(1 2 ,highlight-placeholder 3 ,highlight-placeholder 4 5)) -; (values `(1 2) `(,highlight-placeholder 3 ,highlight-placeholder) `(4 5)) - - (define (>>> x) - (fprintf (current-output-port) ">>> ~v\n" x) - x) - - (define break - (opt-lambda (mark-set break-kind [returned-value-list #f]) - - - (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) + ;; 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) + (letrec ([contains-highlight + (lambda (expr) + (or (syntax-property expr 'stepper-highlight) + (syntax-case expr () + [(a . rest) (or (contains-highlight #`a) (contains-highlight #`rest))] + [else #f])))]) + (let* ([list-length (length exprs)] + [split-point-a (- list-length (length (or (memf contains-highlight exprs) null)))] + [split-point-b (length (or (memf contains-highlight (reverse exprs)) null))]) + (if (<= split-point-b split-point-a) + (error 'redivide-exprs "s-expressions did not contain the highlight-placeholder: ~v" (map syntax-object->hilite-datum exprs)) + (values (sublist 0 split-point-a exprs) ; before + (sublist split-point-a split-point-b exprs) ; during + (sublist split-point-b list-length 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) - (map syntax-object->hilite-datum before-2)) - (error 'double-redivide "reconstructed before defs are not equal.")) - (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))) + ; (redivide `(3 4 (+ (define ,highlight-placeholder) 13) 5 6)) + ; (values `(3 4) `((+ (define ,highlight-placeholder) 13)) `(5 6)) + ; + ; (redivide `(,highlight-placeholder 5 6)) + ; (values `() `(,highlight-placeholder) `(5 6)) + ; + ; (redivide `(4 5 ,highlight-placeholder ,highlight-placeholder)) + ; (values `(4 5) `(,highlight-placeholder ,highlight-placeholder) `()) + ; + ; (printf "will be errors:~n") + ; (equal? (redivide `(1 2 3 4)) + ; error-value) + ; + ; (redivide `(1 2 ,highlight-placeholder 3 ,highlight-placeholder 4 5)) + ; (values `(1 2) `(,highlight-placeholder 3 ,highlight-placeholder) `(4 5)) - #;(printf "break called with break-kind: ~a ..." break-kind) - (if (r:skip-step? break-kind mark-list render-settings) - (begin - #;(printf " but it was skipped!\n") - (when (or (eq? break-kind 'normal-break) - (eq? break-kind 'nomal-break/values)) ;; not sure about this... - (set! held-exp-list skipped-step))) + (define (>>> x) + (fprintf (current-output-port) ">>> ~v\n" x) + x) + + (define break + (opt-lambda (mark-set break-kind [returned-value-list #f]) - (begin - #;(printf "and it wasn't skipped.\n") - (case break-kind - [(normal-break normal-break/values) - (begin - (when (and (eq? break-kind 'normal-break) returned-value-list) - (error 'break "broken invariant: normal-break can't have returned values")) - (set! held-finished-list (reconstruct-all-completed)) - (set! held-exp-list (r:reconstruct-left-side mark-list returned-value-list render-settings)) - (set! held-step-was-app? (r:step-was-app? mark-list)))] + + (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) - [(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)] - [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) - - (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) - (receive-result result)))] + (define (reconstruct-all-completed) + (map (match-lambda + [`(,source-thunk ,lifting-indices ,getter) + (match (r:reconstruct-completed (source-thunk) lifting-indices getter render-settings) + [#(exp #f) (first-of-one (unwind-no-highlight exp))] + [#(exp #t) exp])]) + finished-exps)) - [(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)))] + ;; 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) + (map syntax-object->hilite-datum before-2)) + (error 'double-redivide "reconstructed before defs are not equal.")) + (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))) - - [(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)] - - [else (error 'break "unknown label on break")])))))) - - - - - (define (step-through-expression expanded expand-next-expression) - (let* ([annotated (a:annotate expanded break track-inferred-names?)]) - (eval-syntax annotated) - (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))))) + #;(printf "break called with break-kind: ~a ..." break-kind) + (if (r:skip-step? break-kind mark-list render-settings) + (begin + #;(printf " but it was skipped!\n") + (when (or (eq? break-kind 'normal-break) + (eq? break-kind 'nomal-break/values)) ;; not sure about this... + (set! held-exp-list skipped-step))) + + (begin + #;(printf "and it wasn't skipped.\n") + (case break-kind + [(normal-break normal-break/values) + (begin + (when (and (eq? break-kind 'normal-break) returned-value-list) + (error 'break "broken invariant: normal-break can't have returned values")) + (set! held-finished-list (reconstruct-all-completed)) + (set! held-exp-list (unwind (r:reconstruct-left-side mark-list returned-value-list render-settings) #f)) + (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 (unwind (r:reconstruct-right-side mark-list returned-value-list render-settings) #f)] + [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) + + (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) + (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 (unwind (car reconstruct-result) #f)] + [right-side (unwind (cadr reconstruct-result) #t)]) + ;; 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) + (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")])))))) + + + + + (define (step-through-expression expanded expand-next-expression) + (let* ([annotated (a:annotate expanded break track-inferred-names?)]) + (eval-syntax annotated) + (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))))) (program-expander (lambda () @@ -300,5 +300,11 @@ (if (eof-object? expanded) (begin (receive-result (make-finished-stepping))) - (step-through-expression expanded continue-thunk))))))) + (step-through-expression expanded continue-thunk)))))) + + + (define (first-of-one x) + (unless (and (pair? x) (null? (cdr x))) + (error 'first-of-one "expected a list of length one in: ~v" x)) + (car x))) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index 3d4f95aa20..ffc2947e55 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -11,8 +11,7 @@ "marks.ss" "model-settings.ss" "shared.ss" - "my-macros.ss" - "lifting.ss") + "my-macros.ss") (provide/contract [reconstruct-completed (syntax? @@ -20,23 +19,23 @@ (-> (listof any/c)) render-settings? . -> . - syntax?)] + (vector/c syntax? boolean?))] ;; front ends for reconstruct-current [reconstruct-left-side (mark-list? (or/c (listof any/c) false/c) render-settings? . -> . - (listof syntax?))] + syntax?)] [reconstruct-right-side (mark-list? (or/c (listof any/c) false/c) render-settings? . -> . - (listof syntax?))] + syntax?)] [reconstruct-double-break (mark-list? render-settings? . -> . - (list/c (listof syntax?) (listof syntax?)))] + (list/c syntax? syntax?))] [final-mark-list? (-> mark-list? boolean?)] [skip-step? (-> break-kind? (or/c mark-list? false/c) render-settings? boolean?)] @@ -257,258 +256,7 @@ #t] [else #f]))) - - ; ; ; - ; - ; ;;; ;; ;;; ;;; ; ;; ;;; ; ; ; ;; ; ; ; ; ; ;; ;;; ; ; ; ;; ;; ; - ;; ;; ; ; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ;; ; ; ;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;; - ; ; ; ;;;;; ;;; ; ;;; ;; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ;; ; - ; - - ; unwind takes a syntax object with a single highlight, - ; and returns a list of syntax objects - - (define (unwind stx lift-at-highlight?) - (macro-unwind (lift stx lift-at-highlight?))) - - ; unwind-no-highlight is really just macro-unwind, but with the 'right' interface that - ; makes it more obvious what it does. - ; [unwind-no-highlight (-> syntax? (listof syntax?))] - - (define (unwind-no-highlight stx) - (macro-unwind (list stx))) - - ; unwind-only-highlight : syntax? -> (listof syntax?) - (define (unwind-only-highlight stx) - (unwind stx #t)) - - (define (first-of-one x) - (unless (= (length x) 1) - (error 'first-of-one "expected a list of length one in: ~v" x)) - (car x)) - - (define (improper-member elt improper-list) - (cond [(pair? improper-list) - (or (eq? elt (car improper-list)) - (improper-member elt (cdr improper-list)))] - [else - (eq? elt improper-list)])) - - (define-syntax (noisy-and stx) - (syntax-case stx () - [(_) #`#t] - [(_ a b ...) - (with-syntax ([inner (syntax/loc stx (noisy-and b ...))] - [error (syntax/loc #`a (error 'noisy-and "and clause failed"))]) - (syntax/loc stx (if a inner error)))] - [else - (error 'noisy-and "bad syntax for noisy-and")])) - - ;(->* (syntax? (listof syntax?)) - ; (syntax? (listof syntax?))) - - (define (macro-unwind stxs) - (local - ((define (recur-on-pieces stx) - (if (pair? (syntax-e stx)) - (datum->syntax-object stx (syntax-pair-map (syntax-e stx) inner) stx stx) - stx)) - - (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)])) - - (transfer-info - (if (syntax-property stx 'user-stepper-hint) - (case (syntax-property stx 'user-stepper-hint) - - - [(comes-from-cond) (unwind-cond stx - (syntax-property stx 'user-source) - (syntax-property stx 'user-position))] - - [(comes-from-and) (unwind-and/or stx - (syntax-property stx 'user-source) - (syntax-property stx 'user-position) - 'and)] - - [(comes-from-or) (unwind-and/or stx - (syntax-property stx 'user-source) - (syntax-property stx 'user-position) - 'or)] - - [(comes-from-local) - (unwind-local stx)] - - [(comes-from-recur) - (unwind-recur stx)] - - [(comes-from-begin) - (unwind-begin stx)] - - (else (fall-through))) - (fall-through)) - stx)) - - (define (transfer-highlight from to) - (if (syntax-property from 'stepper-highlight) - (syntax-property to 'stepper-highlight #t) - to)) - - (define (unwind-recur stx) - (with-syntax ([(app-keywd letrec-term argval ...) stx]) ; if you use #%app, it gets captured here - (with-syntax ([(new-argval ...) (map inner (syntax->list #`(argval ...)))]) - (let ([unwound (inner #`letrec-term)]) - (syntax-case unwound (letrec lambda) - [(letrec ([loop-name (lambda (argname ...) . bodies)]) loop-name-2) - (unless (module-identifier=? #`loop-name #`loop-name-2) - (error "unexpected syntax for 'recur': ~v" stx)) - (transfer-highlight unwound #`(recur loop-name ([argname new-argval] ...) . bodies))] - [else #`(#,unwound new-argval ...)]))))) - - (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))))] - [else (error 'unwind-define "expression is not a define-values: ~e" (syntax-object->datum stx))])) - - (define (unwind-mz-let stx) - (with-syntax ([(label ([(var) rhs] ...) . bodies) stx]) - (with-syntax ([(rhs2 ...) (map inner (syntax->list #'(rhs ...)))] - [new-label (if (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint)) - #`let* - (case (syntax-e #'label) - [(let-values) #'let] - [(letrec-values) #'letrec]))] - [new-bodies (map inner (syntax->list #'bodies))]) - (syntax-case #`new-bodies (let*) ; is this let and the nested one part of a let*? - [((let* bindings inner-body ...)) - (and - (improper-member 'comes-from-let* (syntax-property stx 'user-stepper-hint)) - (eq? (syntax-property stx 'user-stepper-source) - (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-source)) - (eq? (syntax-property stx 'user-stepper-position) - (syntax-property (car (syntax->list #`new-bodies)) 'user-stepper-position))) - #`(let* #,(append (syntax->list #`([var rhs2] ...)) (syntax->list #`bindings)) inner-body ...)] - [else - #`(new-label ([var rhs2] ...) . new-bodies)])))) - - (define (unwind-local stx) - (kernel:kernel-syntax-case stx #f - [(letrec-values ([vars exp] ...) body) ; at least through intermediate, define-values may not occur in local. - (with-syntax ([defns (map inner (syntax->list #`((define-values vars exp) ...)))]) - #`(local defns #,(inner #'body)))] - [else (error 'unwind-local "expected a letrec-values, given: ~e" (syntax-object->datum stx))])) - - ;(define (unwind-quasiquote-the-cons-application stx) - ; (syntax-case (recur-on-pieces stx) () - ; [(#%app the-cons . rest) - ; (syntax (cons . rest))] - ; [else - ; (error 'reconstruct "unexpected result for unwinding the-cons application")])) - - (define (unwind-cond-clause stx test-stx result-stx) - (with-syntax ([new-test (if (syntax-property stx 'user-stepper-else) - #`else - (inner test-stx))] - [result (inner result-stx)]) - #`(new-test result))) - - (define (unwind-cond stx user-source user-position) - (with-syntax ([clauses - (let loop ([stx stx]) - (if (and (eq? user-source (syntax-property stx 'user-source)) - (eq? user-position (syntax-property stx 'user-position))) - (syntax-case stx (if begin #%app) - [(if test result) ; the else clause disappears when it's a language-inserted else clause - (list (unwind-cond-clause stx #`test #`result))] - [(if test result else-clause) - (cons (unwind-cond-clause stx #`test #`result) - (loop (syntax else-clause)))] - [(begin . rest) ; else clause appears momentarily in 'before,' even though it's a 'skip-completely' - null] - [else-stx - (error 'unwind-cond "expected an if, got: ~e" (syntax-object->datum (syntax else-stx)))]) - (error 'unwind-cond "expected a cond clause expansion, got: ~e" (syntax-object->datum stx))))]) - (syntax (cond . clauses)))) - - (define (unwind-begin stx) - (syntax-case stx (let-values) - [(let-values () body ...) - (with-syntax ([(new-body ...) (map inner (syntax->list #`(body ...)))]) - #`(begin new-body ...))])) - - (define (unwind-and/or stx user-source user-position label) - (let ([clause-padder (case label - [(and) #`true] - [(or) #`false])]) - (with-syntax ([clauses - (append (build-list (syntax-property stx 'user-stepper-and/or-clauses-consumed) (lambda (dc) clause-padder)) - (let loop ([stx stx]) - (if (and (eq? user-source (syntax-property stx 'user-source)) - (eq? user-position (syntax-property stx 'user-position))) - (syntax-case stx (if let-values #%datum) - [(if part-1 part-2 part-3) - (cons (inner (syntax part-1)) - (case label - ((and) - (loop (syntax part-2))) - ((or) - (loop (syntax part-3))) - (else - (error 'unwind-and/or "unknown label ~a" label))))] - [else (error 'unwind-and/or "syntax: ~a does not match and/or patterns" (syntax-object->datum stx))]) - null)))]) - #`(#,label . clauses))))) - - (map inner stxs))) + @@ -522,7 +270,7 @@ ; ;;;; ;;; ;;; ; ; ;;; ;;; ;; ; ; ;;; ;;;; ;;;; ; ; ; ;;; ; ; ; - 7 + ; recon-source-expr @@ -743,6 +491,8 @@ ; 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. + ;; returns a vectory containing a reconstructed expression and a boolean indicating whether this is source syntax + ;; from a define-struct and therefore should not be unwound. (define (reconstruct-completed exp lifting-indices vals-getter render-settings) (if lifting-indices @@ -751,8 +501,7 @@ (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))))]) + (vector (reconstruct-completed-define exp vars (vals-getter) render-settings) #f))]) (let skipto-loop ([exp exp]) (cond [(syntax-property exp 'stepper-skipto) => @@ -761,20 +510,20 @@ skipto-loop))] [(syntax-property exp 'stepper-define-struct-hint) ;; the hint contains the original syntax - (syntax-property exp 'stepper-define-struct-hint)] + (vector (syntax-property exp 'stepper-define-struct-hint) #t)] [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)))])))])))) + (vector + (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)))]) + #f)])))) ;; an abstraction lifted from reconstruct-completed (define (reconstruct-completed-define exp vars vals render-settings) @@ -1120,14 +869,14 @@ (error 'reconstruct "context expected one value, given ~v" returned-value-list)) (recon-value (car returned-value-list) render-settings)) nothing-so-far)]) - (unwind (recon innermost mark-list #t) #f))) + (recon innermost mark-list #t))) ((right-side) (let* ([innermost (if returned-value-list ; is it an expr -> value reduction? (begin (unless (and (pair? returned-value-list) (null? (cdr returned-value-list))) (error 'reconstruct "context expected one value, given ~v" returned-value-list)) (recon-value (car returned-value-list) render-settings)) (recon-source-expr (mark-source (car mark-list)) mark-list null null render-settings))]) - (unwind (recon (mark-as-highlight innermost) (cdr mark-list) #f) #f))) + (recon (mark-as-highlight innermost) (cdr mark-list) #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))] @@ -1139,8 +888,8 @@ [else (error 'reconstruct "expected a let-values as source for a double-break, got: ~e" (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)))))) + (list (recon innermost-before (cdr mark-list) #f) + (recon innermost-after (cdr mark-list) #f)))))) )