From 9326b8cfbc8e51be35f9e9620fa59034fd47ff75 Mon Sep 17 00:00:00 2001 From: John Clements Date: Thu, 1 May 2008 22:33:54 +0000 Subject: [PATCH] check-expect largely supported svn: r9574 --- collects/stepper/internal-docs.txt | 7 +- collects/stepper/private/macro-unwind.ss | 198 ++++++++++++----------- collects/stepper/private/model.ss | 25 +-- collects/stepper/private/my-macros.ss | 3 + collects/stepper/private/reconstruct.ss | 127 ++++++++------- 5 files changed, 197 insertions(+), 163 deletions(-) diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index d685afe607..0100e3b2fa 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -86,7 +86,8 @@ stepper-hint : [ 'from-splice-box ] : expression was expanded from a scheme splice box (inside an xml box) [ 'comes-from-recur ] : expression was expanded from a 'recur' - [ 'comes-from-check-expect ] : expression was expanded from a 'check-expect' + [ 'comes-from-check-expect ] : expression was expanded from a 'check-expect', + or this identifier (use or binding) was created by the expansion of a 'check-expect'. stepper-define-type: this is attached to the right-hand sides of defines to indicate what @@ -100,8 +101,6 @@ stepper-define-type: [ 'lambda-define ] : this lambda arose from the expansion of (define id (lambda ( - - (Transferred.) Question 1: why the right-hand side? Why not on the define itself? @@ -231,7 +230,7 @@ stepper-fake-exp : this expression does not occur directly in the source; reconstruct specially. used for begin. -args-of-call [ADDED BY RECONSTRUCTOR] : +stepper-args-of-call [ADDED BY RECONSTRUCTOR] : this reconstructed (...) expression is the result of a call with these args. used by the check-expect unwinder to figure out the expected values. diff --git a/collects/stepper/private/macro-unwind.ss b/collects/stepper/private/macro-unwind.ss index 8e59593e3d..22bf6c9877 100644 --- a/collects/stepper/private/macro-unwind.ss +++ b/collects/stepper/private/macro-unwind.ss @@ -1,7 +1,7 @@ (module macro-unwind scheme/base - (require (prefix-in kernel: syntax/kerncase) - mzlib/etc - mzlib/contract + (require (only-in syntax/kerncase kernel-syntax-case) + scheme/contract + scheme/list "model-settings.ss" "shared.ss" #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") @@ -51,32 +51,32 @@ stx)) (define (fall-through stx settings) - (kernel:kernel-syntax-case stx #f - [id - (identifier? stx) - (or (stepper-syntax-property stx 'stepper-lifted-name) - stx)] - [(define-values dc ...) - (unwind-define stx settings)] - [(#%plain-app exp ...) - (recur-on-pieces #'(exp ...) settings)] - [(quote datum) - (if (symbol? #'datum) - stx - #'datum)] - [(let-values . rest) - (unwind-mz-let stx settings)] - [(letrec-values . rest) - (unwind-mz-let stx settings)] - [(#%plain-lambda . rest) - (recur-on-pieces #'(lambda . rest) settings)] - [(set! var rhs) - (with-syntax ([unwound-var (or (stepper-syntax-property - #`var 'stepper-lifted-name) - #`var)] - [unwound-body (unwind #`rhs settings)]) - #`(set! unwound-var unwound-body))] - [else (recur-on-pieces stx settings)])) + (kernel-syntax-case stx #f + [id + (identifier? stx) + (or (stepper-syntax-property stx 'stepper-lifted-name) + stx)] + [(define-values dc ...) + (unwind-define stx settings)] + [(#%plain-app exp ...) + (recur-on-pieces #'(exp ...) settings)] + [(quote datum) + (if (symbol? #'datum) + stx + #'datum)] + [(let-values . rest) + (unwind-mz-let stx settings)] + [(letrec-values . rest) + (unwind-mz-let stx settings)] + [(#%plain-lambda . rest) + (recur-on-pieces #'(lambda . rest) settings)] + [(set! var rhs) + (with-syntax ([unwound-var (or (stepper-syntax-property + #`var 'stepper-lifted-name) + #`var)] + [unwound-body (unwind #`rhs settings)]) + #`(set! unwound-var unwound-body))] + [else (recur-on-pieces stx settings)])) (define (unwind stx settings) (transfer-info @@ -89,6 +89,7 @@ [(comes-from-or) (unwind-and/or 'or)] [(comes-from-local) unwind-local] [(comes-from-recur) unwind-recur] + [(comes-from-check-expect) unwind-check-expect] ;;[(comes-from-begin) unwind-begin] [else fall-through])]) (process stx settings)))) @@ -116,61 +117,55 @@ [else #`(#,unwound new-argval ...)]))))) (define (unwind-define stx settings) - (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->datum stx))) - (if (eq? (stepper-syntax-property #`body 'stepper-hint) 'comes-from-check-expect) - (kernel:kernel-syntax-case - (unwind #`body settings) #f - [(c-e (lambda () a1) a2 a3) - #`(check-expect a1 a2)] - [else #`(c-e body)]) - (let* ([printed-name - (or (stepper-syntax-property #`name 'stepper-lifted-name) - (stepper-syntax-property #'name 'stepper-orig-name) - #'name)] - [unwound-body (unwind #'body settings)] - ;; see notes in internal-docs.txt - [define-type (stepper-syntax-property - unwound-body 'stepper-define-type)]) - (if define-type - (kernel:kernel-syntax-case - unwound-body #f - [(lambda arglist lam-body ...) - (case define-type - [(shortened-proc-define) - (let ([proc-define-name - (stepper-syntax-property - unwound-body - 'stepper-proc-define-name)]) - (if (or (free-identifier=? proc-define-name - #'name) - (and (stepper-syntax-property #'name - 'stepper-orig-name) - (free-identifier=? - proc-define-name - (stepper-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 'stepper-define-type: ~e" - define-type)])] - [else (error 'unwind-define - "expr with stepper-define-type is not a lambda: ~e" - (syntax->datum unwound-body))]) - #`(define #,printed-name #,unwound-body)))))] - [else (error 'unwind-define - "expression is not a define-values: ~e" - (syntax->datum stx))])) + (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->datum stx))) + (let* ([printed-name + (or (stepper-syntax-property #`name 'stepper-lifted-name) + (stepper-syntax-property #'name 'stepper-orig-name) + #'name)] + [unwound-body (unwind #'body settings)] + ;; see notes in internal-docs.txt + [define-type (stepper-syntax-property + unwound-body 'stepper-define-type)]) + (if define-type + (kernel-syntax-case + unwound-body #f + [(lambda arglist lam-body ...) + (case define-type + [(shortened-proc-define) + (let ([proc-define-name + (stepper-syntax-property + unwound-body + 'stepper-proc-define-name)]) + (if (or (free-identifier=? proc-define-name + #'name) + (and (stepper-syntax-property #'name + 'stepper-orig-name) + (free-identifier=? + proc-define-name + (stepper-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 'stepper-define-type: ~e" + define-type)])] + [else (error 'unwind-define + "expr with stepper-define-type is not a lambda: ~e" + (syntax->datum unwound-body))]) + #`(define #,printed-name #,unwound-body))))] + [else (error 'unwind-define + "expression is not a define-values: ~e" + (syntax->datum stx))])) (define (unwind-mz-let stx settings) (with-syntax ([(label ([(var) rhs] ...) . bodies) stx]) @@ -203,18 +198,18 @@ #`(new-label ([var rhs2] ...) . new-bodies)])))) (define (unwind-local stx settings) - (kernel:kernel-syntax-case stx #f - ;; at least through intermediate, define-values may not occur in - ;; local. - [(letrec-values ([vars exp] ...) body) - (with-syntax ([defns (map (lambda (def) - (unwind def settings)) - (syntax->list - #`((define-values vars exp) ...)))]) - #`(local defns #,(unwind #'body settings)))] - [else (error 'unwind-local - "expected a letrec-values, given: ~e" - (syntax->datum stx))])) + (kernel-syntax-case stx #f + ;; at least through intermediate, define-values may not occur in + ;; local. + [(letrec-values ([vars exp] ...) body) + (with-syntax ([defns (map (lambda (def) + (unwind def settings)) + (syntax->list + #`((define-values vars exp) ...)))]) + #`(local defns #,(unwind #'body settings)))] + [else (error 'unwind-local + "expected a letrec-values, given: ~e" + (syntax->datum stx))])) ;(define (unwind-quasiquote-the-cons-application stx settings) ; (syntax-case (recur-on-pieces stx settings) () @@ -301,4 +296,15 @@ (syntax->datum stx))]) null)))]) #`(#,label . clauses)))) + + (define (unwind-check-expect stx settings) + (kernel-syntax-case (fall-through stx settings) #f + [(c-e (lambda () a1) a2 a3 a4) + #`(check-expect a1 a2)] + [(dots1 actual dots2) + (and (eq? (syntax->datum #'dots1) '...) + (eq? (syntax->datum #'dots2) '...)) + (with-syntax ([expected (unwind (third (stepper-syntax-property stx 'stepper-args-of-call)) settings)]) + #`(check-expect actual expected))] + [any #`(c-e any) #;#`(check-expect )])) ) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 9e2531bcf3..99da61d503 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -39,8 +39,9 @@ (module model mzscheme (require mzlib/contract mzlib/etc - mzlib/match + scheme/match mzlib/class + scheme/list (prefix a: "annotate.ss") (prefix r: "reconstruct.ss") "shared.ss" @@ -48,6 +49,7 @@ "model-settings.ss" "macro-unwind.ss" "lifting.ss" + #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") ;; for breakpoint display ;; (commented out to allow nightly testing) #;"display-break-stuff.ss") @@ -169,15 +171,20 @@ (let* ([mark-list (and mark-set (extract-mark-list mark-set))]) (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) (unwind exp render-settings)] - [#(exp #t) exp])]) - finished-exps)) + (filter-map + (match-lambda + [(list source-thunk lifting-indices getter) + (let ([source (source-thunk)]) + (if (r:hide-completed? source) + #f + (match (r:reconstruct-completed + source lifting-indices + getter render-settings) + [(vector exp #f) (unwind exp render-settings)] + [(vector exp #t) exp])))]) + finished-exps)) + #;(>>> break-kind) #;(fprintf (current-error-port) "break called with break-kind: ~a ..." break-kind) (if (r:skip-step? break-kind mark-list render-settings) (begin diff --git a/collects/stepper/private/my-macros.ss b/collects/stepper/private/my-macros.ss index ce6bb1af04..d781a47017 100644 --- a/collects/stepper/private/my-macros.ss +++ b/collects/stepper/private/my-macros.ss @@ -42,6 +42,9 @@ ;; ;;;;;;;;;; + + ;; honestly, match-let* supersedes all of this, if I ever have time to redo it... + (provide 2vals let*-2vals 2vals-first 2vals-second 2vals-map apply-to-first-of-2vals) (define 2vals vector) diff --git a/collects/stepper/private/reconstruct.ss b/collects/stepper/private/reconstruct.ss index 72389744d9..413491fbcf 100644 --- a/collects/stepper/private/reconstruct.ss +++ b/collects/stepper/private/reconstruct.ss @@ -8,11 +8,13 @@ mzlib/list mzlib/etc mzlib/contract + scheme/match "marks.ss" "model-settings.ss" "shared.ss" "my-macros.ss" - (for-syntax scheme/base)) + (for-syntax scheme/base) + #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss")) (provide/contract [reconstruct-completed (syntax? @@ -21,6 +23,7 @@ render-settings? . -> . (vector/c syntax? boolean?))] + [hide-completed? (syntax? . -> . boolean?)] ;; front ends for reconstruct-current [reconstruct-left-side (mark-list? @@ -145,7 +148,9 @@ (define (skip-step? break-kind mark-list render-settings) (case break-kind [(result-value-break) - #f] + (and (pair? mark-list) + (let ([expr (mark-source (car mark-list))]) + (equal? (stepper-syntax-property expr 'stepper-hint) 'comes-from-check-expect)))] [(result-exp-break) ;; skip if clauses that are the result of and/or reductions (let ([and/or-clauses-consumed (stepper-syntax-property (mark-source (car mark-list)) 'stepper-and/or-clauses-consumed)]) @@ -180,34 +185,35 @@ (and (pair? mark-list) (let ([expr (mark-source (car mark-list))]) - (or (kernel:kernel-syntax-case expr #f - [id - (identifier? expr) - (case (stepper-syntax-property expr 'stepper-binding-type) - [(lambda-bound) #t] ; don't halt for lambda-bound vars - [(let-bound) - (varref-skip-step? expr)] - [(non-lexical) - (varref-skip-step? expr)])] - [(#%top . id-stx) - (varref-skip-step? #`id-stx)] - [(#%plain-app . terms) - ; don't halt for proper applications of constructors - (let ([fun-val (lookup-binding mark-list (get-arg-var 0))]) - (and (procedure? fun-val) - (procedure-arity-includes? - fun-val - (length (cdr (syntax->list (syntax terms))))) - (or (and (render-settings-constructor-style-printing? render-settings) - (if (render-settings-abbreviate-cons-as-list? render-settings) - (eq? fun-val special-list-value) - (and (eq? fun-val special-cons-value) - (second-arg-is-list? mark-list)))) - ;(model-settings:special-function? 'vector fun-val) - (and (eq? fun-val void) - (eq? (cdr (syntax->list (syntax terms))) null)) - (struct-constructor-procedure? fun-val))))] - [else #f]))))) + (or (equal? (stepper-syntax-property expr 'stepper-hint) 'comes-from-check-expect) + (kernel:kernel-syntax-case expr #f + [id + (identifier? expr) + (case (stepper-syntax-property expr 'stepper-binding-type) + [(lambda-bound) #t] ; don't halt for lambda-bound vars + [(let-bound) + (varref-skip-step? expr)] + [(non-lexical) + (varref-skip-step? expr)])] + [(#%top . id-stx) + (varref-skip-step? #`id-stx)] + [(#%plain-app . terms) + ; don't halt for proper applications of constructors + (let ([fun-val (lookup-binding mark-list (get-arg-var 0))]) + (and (procedure? fun-val) + (procedure-arity-includes? + fun-val + (length (cdr (syntax->list (syntax terms))))) + (or (and (render-settings-constructor-style-printing? render-settings) + (if (render-settings-abbreviate-cons-as-list? render-settings) + (eq? fun-val special-list-value) + (and (eq? fun-val special-cons-value) + (second-arg-is-list? mark-list)))) + ;(model-settings:special-function? 'vector fun-val) + (and (eq? fun-val void) + (eq? (cdr (syntax->list (syntax terms))) null)) + (struct-constructor-procedure? fun-val))))] + [else #f]))))) ;; find-special-value finds the value associated with the given name. Applications of functions ;; like 'list' should not be shown as steps, because the before and after steps will be the same. @@ -427,16 +433,18 @@ ; for the moment, let-bound vars occur only in and/or : (recon-value (lookup-binding mark-list var) render-settings)) ((let-bound) - (stepper-syntax-property var - 'stepper-lifted-name - (binding-lifted-name mark-list var))) + (if (stepper-syntax-property var 'stepper-no-lifting-info) + var + (stepper-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" - (stepper-syntax-property var 'stepper-binding-type)))))] + (error 'recon-source-expr "unknown 'stepper-binding-type property: ~a on var: ~a" + (stepper-syntax-property var 'stepper-binding-type) (syntax->datum var)))))] [else ; top-level-varref (fixup-name var)])))] @@ -571,8 +579,15 @@ [else reconstructed])))) - - + + ;; hide-completed? : syntax? -> boolean? + (define (hide-completed? stx) + (syntax-case stx () + [(define-values (v) rhs) + (equal? (stepper-syntax-property #'v 'stepper-hint) 'comes-from-check-expect) + #t] + [else #f])) + ; ; ; ; ;; ;;; ;;; ;;; ; ;; ;;; ;;;; ; ;; ; ; ;;; ;;;; ;;; ; ; ; ;; ; ;; ;;; ; ;; ;;;; @@ -722,26 +737,30 @@ ; applications [(#%plain-app . terms) (attach-info - (let* ([sub-exprs (syntax->list (syntax terms))] - [arg-temps (build-list (length sub-exprs) get-arg-var)] - [arg-vals (map (lambda (arg-temp) - (lookup-binding mark-list arg-temp)) - arg-temps)]) + (match-let* + ([sub-exprs (syntax->list (syntax terms))] + [arg-temps (build-list (length sub-exprs) get-arg-var)] + [arg-vals (map (lambda (arg-temp) + (lookup-binding mark-list arg-temp)) + arg-temps)] + [(vector evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*)) + (zip sub-exprs arg-vals))] + [rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))]) (case (mark-label (car mark-list)) ((not-yet-called) - (let*-2vals ([(evaluated unevaluated) (split-list (lambda (x) (eq? (cadr x) *unevaluated*)) - (zip sub-exprs arg-vals))] - [rectified-evaluated (map (lx (recon-value _ render-settings)) (map cadr evaluated))]) - (if (null? unevaluated) - #`(#%plain-app . #,rectified-evaluated) - #`(#%plain-app - #,@rectified-evaluated - #,so-far - #,@(map recon-source-current-marks (cdr (map car unevaluated))))))) + (if (null? unevaluated) + #`(#%plain-app . #,rectified-evaluated) + #`(#%plain-app + #,@rectified-evaluated + #,so-far + #,@(map recon-source-current-marks (cdr (map car unevaluated)))))) ((called) - (if (eq? so-far nothing-so-far) - (datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code - (datum->syntax #'here `(,#'#%plain-app ... ,so-far ...)))) + (stepper-syntax-property + (if (eq? so-far nothing-so-far) + (datum->syntax #'here `(,#'#%plain-app ...)) ; in unannotated code ... can this occur? + (datum->syntax #'here `(,#'#%plain-app ... ,so-far ...))) + 'stepper-args-of-call + rectified-evaluated)) (else (error 'recon-inner "bad label (~v) in application mark in expr: ~a" (mark-label (car mark-list)) exp)))) exp)]