From 17a723a63ec63afd0d43d6731de0623a94a11df1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Apr 2012 15:19:29 -0500 Subject: [PATCH] Improve the contract error messages: - add context information, so we can see which part of the contract failed - re-arrange some of the information in the contracts --- .../racket/contract/private/arr-i-parse.rkt | 12 +- collects/racket/contract/private/arr-i.rkt | 806 ++++++++++-------- collects/racket/contract/private/arrow.rkt | 123 +-- collects/racket/contract/private/blame.rkt | 179 ++-- collects/racket/contract/private/prop.rkt | 32 +- collects/racket/private/class-internal.rkt | 5 +- .../scribblings/guide/contracts-intro.scrbl | 29 +- .../guide/contracts-simple-function.scrbl | 59 +- .../scribblings/guide/contracts-utils.rkt | 7 +- .../scribblings/reference/contracts.scrbl | 56 +- collects/tests/racket/contract-test.rktl | 282 +++++- 11 files changed, 988 insertions(+), 602 deletions(-) diff --git a/collects/racket/contract/private/arr-i-parse.rkt b/collects/racket/contract/private/arr-i-parse.rkt index f7d25a5b1f..a8d4e0f477 100644 --- a/collects/racket/contract/private/arr-i-parse.rkt +++ b/collects/racket/contract/private/arr-i-parse.rkt @@ -289,7 +289,7 @@ code does the parsing and validation of the syntax. (syntax->list #'(ctc-pr ...)))] [any #f] [[_ ctc] - (list (eres #'id #f #'ctc (car (generate-temporaries '(eres)))))] + (list (eres #'_ #f #'ctc (car (generate-temporaries '(eres)))))] [[id ctc] (begin (check-id stx #'id) @@ -370,7 +370,10 @@ code does the parsing and validation of the syntax. (syntax-case #'pre-leftover () [() (raise-syntax-error #f - "expected #:pre to be followed by at least three subterms (a sequence of identifiers, the pre-condition, and the range contract), but found only two" + (string-append + "expected #:pre to be followed by at least three subterms" + " (a sequence of identifiers, the pre-condition, and the" + " range contract), but found only two") stx (car (syntax->list leftover)))] [x (void)]) @@ -387,7 +390,10 @@ code does the parsing and validation of the syntax. (syntax-case #'pre-leftover () [() (raise-syntax-error #f - "expected #:pre/name to be followed by at least four subterms (a sequence of identifiers, a name, the pre-condition, and the range contract), but found only three" + (string-append + "expected #:pre/name to be followed by at least four subterms" + " (a sequence of identifiers, a name, the pre-condition, and the" + " range contract), but found only three") stx (car (syntax->list leftover)))] [x (void)]) diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 7329480552..aee34bf57c 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -23,62 +23,95 @@ (provide (rename-out [->i/m ->i])) -;; arg-ctcs : (listof contract) +;; blame-info : (listof (vector symbol boolean?[indy?] boolean?[swap?])) +;; arg-ctcs : (listof (cons symbol? contract)) ;; arg-dep-ctcs : (-> ??? (listof contract)) -;; indy-arg-ctcs : (listof contract) -;; rng-ctcs : (listof contract) +;; indy-arg-ctcs : (listof (cons symbol? contract)) +;; rng-ctcs : (listof (cons symbol? contract)) ;; rng-dep-ctcs : (-> ??? (listof contract)) -;; indy-rng-ctcs : (listof contract) +;; indy-rng-ctcs : (listof (cons symbol? contract)) ;; mandatory-args, opt-args : number ;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keywordi (arg-ctcs arg-dep-ctcs indy-arg-ctcs - rng-ctcs rng-dep-ctcs indy-rng-ctcs - pre/post-procs - mandatory-args opt-args mandatory-kwds opt-kwds rest? mtd? - here - mk-wrapper - name-info) +(struct ->i (blame-info + arg-ctcs arg-dep-ctcs indy-arg-ctcs + rng-ctcs rng-dep-ctcs indy-rng-ctcs + pre/post-procs + mandatory-args opt-args mandatory-kwds opt-kwds rest + mtd? here mk-wrapper name-info) #:property prop:contract (build-contract-property #:projection (λ (ctc) - (let ([arg-ctc-projs (map contract-projection (->i-arg-ctcs ctc))] - [indy-arg-ctc-projs (map contract-projection (->i-indy-arg-ctcs ctc))] - [rng-ctc-projs (map contract-projection (->i-rng-ctcs ctc))] - [indy-rng-ctc-projs (map contract-projection (->i-indy-rng-ctcs ctc))] - [func (->i-mk-wrapper ctc)] - [has-rest? (->i-rest? ctc)] - [here (->i-here ctc)]) - (λ (blame) - (let* ([swapped-blame (blame-swap blame)] - [indy-dom-blame (blame-replace-negative swapped-blame here)] - [indy-rng-blame (blame-replace-negative blame here)] - - [partial-doms (map (λ (dom) (dom swapped-blame)) arg-ctc-projs)] - [partial-indy-doms (map (λ (dom) (dom indy-dom-blame)) indy-arg-ctc-projs)] - - [partial-rngs (map (λ (rng) (rng blame)) rng-ctc-projs)] - [partial-indy-rngs (map (λ (rng) (rng indy-rng-blame)) indy-rng-ctc-projs)]) - (apply func - blame - swapped-blame - indy-dom-blame - indy-rng-blame - (λ (val mtd?) - (if has-rest? - (check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame) - (check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame))) - ctc - (append (->i-pre/post-procs ctc) - partial-doms - (->i-arg-dep-ctcs ctc) - partial-indy-doms - partial-rngs - (->i-rng-dep-ctcs ctc) - partial-indy-rngs)))))) + (define arg-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-arg-ctcs ctc))) + (define indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-indy-arg-ctcs ctc))) + (define rng-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-rng-ctcs ctc))) + (define indy-rng-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-indy-rng-ctcs ctc))) + (define func (->i-mk-wrapper ctc)) + (define has-rest (->i-rest ctc)) + (define here (->i-here ctc)) + (λ (blame) + (define blames (for/list ([blame-info (->i-blame-info ctc)]) + (define name (vector-ref blame-info 0)) + (define indy? (vector-ref blame-info 1)) + (define dom? (vector-ref blame-info 2)) + (define non-indy-blame + (blame-add-context blame + (format (if dom? "the ~a argument of" "the ~a result of") + name) + #:swap? dom?)) + (if indy? + (blame-replace-negative non-indy-blame here) + non-indy-blame))) + (define swapped-blame (blame-swap blame)) + (define indy-dom-blame (blame-replace-negative swapped-blame here)) + (define indy-rng-blame (blame-replace-negative blame here)) + + (define partial-doms + (for/list ([dom-proj (in-list arg-ctc-projs)] + [pr (in-list (->i-arg-ctcs ctc))]) + (dom-proj (blame-add-context swapped-blame + (format "the ~a argument of" (car pr)))))) + (define partial-indy-doms + (for/list ([dom-proj (in-list indy-arg-ctc-projs)] + [dom-pr (in-list (->i-indy-arg-ctcs ctc))]) + (dom-proj (blame-add-context indy-dom-blame (format "the ~a argument of" (car dom-pr)))))) + + (define partial-rngs + (for/list ([rng-proj (in-list rng-ctc-projs)] + [pr (in-list (->i-rng-ctcs ctc))] + [n (in-naturals 1)]) + (define name (car pr)) + (rng-proj (blame-add-context blame + (if (eq? '_ name) + (if (null? (cdr rng-ctc-projs)) + "the result of" + (format "the ~a result of" (n->th n))) + (format "the ~a result of" name)))))) + (define partial-indy-rngs + (for/list ([rng-proj (in-list indy-rng-ctc-projs)] + [rng-pr (in-list (->i-indy-rng-ctcs ctc))]) + (rng-proj (blame-add-context indy-rng-blame (format "the ~a result of" (car rng-pr)))))) + (apply func + (λ (val mtd?) + (if has-rest + (check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame) + (check-procedure val mtd? + (->i-mandatory-args ctc) (->i-opt-args ctc) + (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) + blame))) + ctc + blame swapped-blame ;; used by the #:pre and #:post checking + (append blames + (->i-pre/post-procs ctc) + partial-doms + (->i-arg-dep-ctcs ctc) + partial-indy-doms + partial-rngs + (->i-rng-dep-ctcs ctc) + partial-indy-rngs)))) #:name (λ (ctc) (define (arg/ress->spec infos ctcs dep-ctcs skip?) (let loop ([infos infos] @@ -118,11 +151,11 @@ [rng-info (vector-ref name-info 3)] [post-infos (vector-ref name-info 4)]) `(->i ,(arg/ress->spec args-info - (->i-arg-ctcs ctc) + (map cdr (->i-arg-ctcs ctc)) (->i-arg-dep-ctcs ctc) (λ (x) (list-ref x 4))) ,@(let ([rests (arg/ress->spec args-info - (->i-arg-ctcs ctc) + (map cdr (->i-arg-ctcs ctc)) (->i-arg-dep-ctcs ctc) (λ (x) (not (list-ref x 4))))]) (if (null? rests) @@ -130,7 +163,7 @@ (list rests))) ,@(if rest-info (case (car rest-info) - [(nodep) `(#:rest [,(list-ref rest-info 1) ,(contract-name (car (reverse (->i-arg-ctcs ctc))))])] + [(nodep) `(#:rest [,(list-ref rest-info 1) ,(contract-name (car (reverse (map cdr (->i-arg-ctcs ctc)))))])] [(dep) `(#:rest [,(list-ref rest-info 1) ,(list-ref rest-info 2) ...])]) '()) ,@(apply @@ -144,7 +177,7 @@ 'any] [else (let ([infos (arg/ress->spec rng-info - (->i-rng-ctcs ctc) + (map cdr (->i-rng-ctcs ctc)) (->i-rng-dep-ctcs ctc) (λ (x) #f))]) (cond @@ -160,14 +193,14 @@ `(#:post ,(car post-info) ...))))))) #:first-order (λ (ctc) - (let ([has-rest? (->i-rest? ctc)] + (let ([has-rest (->i-rest ctc)] [mtd? (->i-mtd? ctc)] [mand-args (->i-mandatory-args ctc)] [opt-args (->i-opt-args ctc)] [mand-kwds (->i-mandatory-kwds ctc)] [opt-kwds (->i-opt-kwds ctc)]) (λ (val) - (if has-rest? + (if has-rest (check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f) (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f))))) #:stronger (λ (this that) (eq? this that)))) ;; WRONG @@ -392,14 +425,17 @@ ;; -- the generated lets rebind these variables to their projected counterparts, with normal blame ;; (listof identifier) -- indy-arg-vars, bound to wrapped values with indy blame, sorted like the second input ;; (identifier arg -> identifier) -- maps the original var in the arg to the corresponding indy-var +;; free-identifier-mapping[id -o> (listof (list/c boolean?[indy?] boolean?[dom?]))] ;; adds nested lets that bind the wrapper-args and the indy-arg-vars to projected values, with 'body' in the body of the let -;; also handles adding code to checki to see if usupplied args are present (skipping the contract check, if so) +;; also handles adding code to check to see if usupplied args are present (skipping the contract check, if so) +;; mutates blame-var-table to record which blame records needs to be computed (and passed in) ;; WRONG: need to rename the variables in this function from "arg" to "arg/res" (define-for-syntax (add-wrapper-let body swapped-blame? ordered-args arg-indices arg-proj-vars indy-arg-proj-vars wrapper-args indy-arg-vars - arg/res-to-indy-var) + arg/res-to-indy-var + blame-var-table) (define (add-unsupplied-check arg wrapper-arg stx) (if (and (arg? arg) @@ -409,6 +445,14 @@ #,stx) stx)) + (define needed-blame-vars (make-hash)) + (define (add-blame-var indy? dom? id) + (define olds (free-identifier-mapping-get blame-var-table id (λ () '()))) + (define new (list indy? dom?)) + (unless (member new olds) + (free-identifier-mapping-put! blame-var-table id (cons new olds))) + (build-blame-identifier indy? dom? id)) + (for/fold ([body body]) ([indy-arg-var (in-list indy-arg-vars)] [arg (in-list ordered-args)] @@ -430,9 +474,7 @@ (if (arg/res-vars arg) #`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg)) #,wrapper-arg - #,(if swapped-blame? - #'indy-dom-blame - #'indy-rng-blame)) + #,(add-blame-var #t swapped-blame? (arg/res-var arg))) #`(#,indy-arg-proj-var #,wrapper-arg)))]) (list))]) #`(let (#,@indy-binding @@ -444,27 +486,32 @@ [(and (eres? arg) (arg/res-vars arg)) #`(un-dep #,(eres-eid arg) #,wrapper-arg - #,(if swapped-blame? - #'swapped-blame - #'blame))] + #,(add-blame-var #f swapped-blame? (arg/res-var arg)))] [(arg/res-vars arg) #`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg)) #,wrapper-arg - #,(if swapped-blame? - #'swapped-blame - #'blame))] + #,(add-blame-var #f swapped-blame? (arg/res-var arg)))] [else #`(#,arg-proj-var #,wrapper-arg)]))]) #,body))))) +(define-for-syntax (build-blame-identifier indy? dom? id) + (datum->syntax id + (string->symbol + (string-append (symbol->string (syntax-e id)) + (if indy? "-indy" "") + (if dom? "-dom" "-rng") + "-blame")))) + ;; Returns an empty list if no result contracts and a list of a single syntax value ;; which should be a function from results to projection-applied versions of the same ;; if there are result contracts. -(define-for-syntax (result-checkers an-istx - ordered-ress res-indices - res-proj-vars indy-res-proj-vars - wrapper-ress indy-res-vars - arg/res-to-indy-var) +(define-for-syntax (build-result-checkers an-istx + ordered-ress res-indices + res-proj-vars indy-res-proj-vars + wrapper-ress indy-res-vars + arg/res-to-indy-var + blame-var-table) (cond [(istx-ress an-istx) (list @@ -475,7 +522,8 @@ ordered-ress res-indices res-proj-vars indy-res-proj-vars wrapper-ress indy-res-vars - arg/res-to-indy-var)))] + arg/res-to-indy-var + blame-var-table)))] [else null])) @@ -491,138 +539,158 @@ #,body) body))] [else stx])) - -(define-for-syntax (mk-wrapper-func an-istx used-indy-vars) - (let ([args+rst (append (istx-args an-istx) - (if (istx-rst an-istx) - (list (istx-rst an-istx)) - '()))]) - (let-values ([(ordered-args arg-indices) (find-ordering args+rst)] - [(ordered-ress res-indices) (if (istx-ress an-istx) - (find-ordering (istx-ress an-istx)) - (values '() '()))]) - - (let ([wrapper-args (list->vector - (append (generate-temporaries (map arg/res-var (istx-args an-istx))) - (if (istx-rst an-istx) - (list #'rest-args) - '())))] - [indy-arg-vars (generate-temporaries (map arg/res-var ordered-args))] - [arg-proj-vars (list->vector (generate-temporaries (map arg/res-var args+rst)))] - - ;; this list is parallel to arg-proj-vars (so use arg-indices to find the right ones) - ;; but it contains #fs in places where we don't need the indy projections (because the corresponding - ;; argument is not dependened on by anything) - [indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary - (and (free-identifier-mapping-get used-indy-vars - (arg/res-var x) - (λ () #f)) - (arg/res-var x)))) - args+rst))] - - - [wrapper-ress (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))] - [indy-res-vars (generate-temporaries (map arg/res-var ordered-ress))] - [res-proj-vars (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))] - - ;; this list is parallel to res-proj-vars (so use res-indices to find the right ones) - ;; but it contains #fs in places where we don't need the indy projections (because the corresponding - ;; result is not dependened on by anything) - [indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary - (and (free-identifier-mapping-get used-indy-vars - (arg/res-var x) - (λ () #f)) - (arg/res-var x)))) - (or (istx-ress an-istx) '())))]) - - (define (arg/res-to-indy-var var) - (let loop ([iargs (append indy-arg-vars indy-res-vars)] - [args (append (map arg/res-var ordered-args) (map arg/res-var ordered-ress))]) - (cond - [(null? args) - (error '->i "internal error; did not find a matching var for ~s" var)] - [else - (let ([arg (car args)] - [iarg (car iargs)]) - (cond - [(free-identifier=? var arg) iarg] - [else (loop (cdr iargs) (cdr args))]))]))) - - (define this-param (and (syntax-parameter-value #'making-a-method) - (car (generate-temporaries '(this))))) - - #`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc - - ;; the pre- and post-condition procs - #,@(for/list ([pres (istx-pre an-istx)] - [i (in-naturals)]) - (string->symbol (format "pre-proc~a" i))) - #,@(for/list ([pres (istx-post an-istx)] - [i (in-naturals)]) - (string->symbol (format "post-proc~a" i))) - - ;; first the non-dependent arg projections - #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var)) - args+rst - (vector->list arg-proj-vars))) - ;; then the dependent arg projections - #,@(filter values (map (λ (arg/res arg-proj-var) (and (arg/res-vars arg/res) arg-proj-var)) - args+rst - (vector->list arg-proj-vars))) - ;; then the non-dependent indy arg projections - #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var)) - args+rst - (vector->list indy-arg-proj-vars))) - - - ;; then the non-dependent res projections - #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var)) - (or (istx-ress an-istx) '()) - (vector->list res-proj-vars))) - ;; then the dependent res projections - #,@(filter values (map (λ (arg/res res-proj-var) (and (arg/res-vars arg/res) res-proj-var)) - (or (istx-ress an-istx) '()) - (vector->list res-proj-vars))) - ;; then the non-dependent indy res projections - #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var)) - (or (istx-ress an-istx) '()) - (vector->list indy-res-proj-vars)))) - (λ (val) - (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) - (let ([arg-checker - (λ #,(args/vars->arglist an-istx wrapper-args this-param) - #,(add-wrapper-let - (add-pre-cond - an-istx - arg/res-to-indy-var - (add-eres-lets - an-istx - res-proj-vars - arg/res-to-indy-var - (args/vars->arg-checker - (result-checkers - an-istx - ordered-ress res-indices - res-proj-vars indy-res-proj-vars - wrapper-ress indy-res-vars - arg/res-to-indy-var) - (istx-args an-istx) - (istx-rst an-istx) - wrapper-args - this-param))) - #t - ordered-args arg-indices - arg-proj-vars indy-arg-proj-vars - wrapper-args indy-arg-vars - arg/res-to-indy-var))]) - (impersonate-procedure - val - (make-keyword-procedure - (λ (kwds kwd-args . args) - (keyword-apply arg-checker kwds kwd-args args)) - (λ args (apply arg-checker args))) - impersonator-prop:contracted ctc)))))))) +(define-for-syntax (mk-wrapper-func/blame-id-info an-istx used-indy-vars) + (define args+rst (append (istx-args an-istx) + (if (istx-rst an-istx) + (list (istx-rst an-istx)) + '()))) + (define-values (ordered-args arg-indices) (find-ordering args+rst)) + (define-values (ordered-ress res-indices) (if (istx-ress an-istx) + (find-ordering (istx-ress an-istx)) + (values '() '()))) + + (define wrapper-args (list->vector + (append (generate-temporaries (map arg/res-var (istx-args an-istx))) + (if (istx-rst an-istx) + (list #'rest-args) + '())))) + (define indy-arg-vars (generate-temporaries (map arg/res-var ordered-args))) + (define arg-proj-vars (list->vector (generate-temporaries (map arg/res-var args+rst)))) + + ;; this list is parallel to arg-proj-vars (so use arg-indices to find the right ones) + ;; but it contains #fs in places where we don't need the indy projections (because the corresponding + ;; argument is not dependened on by anything) + (define indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary + (and (free-identifier-mapping-get used-indy-vars + (arg/res-var x) + (λ () #f)) + (arg/res-var x)))) + args+rst))) + + + (define wrapper-ress (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))) + (define indy-res-vars (generate-temporaries (map arg/res-var ordered-ress))) + (define res-proj-vars (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))) + + ;; this list is parallel to res-proj-vars (so use res-indices to find the right ones) + ;; but it contains #fs in places where we don't need the indy projections (because the corresponding + ;; result is not dependened on by anything) + (define indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary + (and (free-identifier-mapping-get used-indy-vars + (arg/res-var x) + (λ () #f)) + (arg/res-var x)))) + (or (istx-ress an-istx) '())))) + + (define (arg/res-to-indy-var var) + (let loop ([iargs (append indy-arg-vars indy-res-vars)] + [args (append (map arg/res-var ordered-args) (map arg/res-var ordered-ress))]) + (cond + [(null? args) + (error '->i "internal error; did not find a matching var for ~s" var)] + [else + (let ([arg (car args)] + [iarg (car iargs)]) + (cond + [(free-identifier=? var arg) iarg] + [else (loop (cdr iargs) (cdr args))]))]))) + + (define this-param (and (syntax-parameter-value #'making-a-method) + (car (generate-temporaries '(this))))) + + (define blame-var-table (make-free-identifier-mapping)) + + (define wrapper-body + (add-wrapper-let + (add-pre-cond + an-istx + arg/res-to-indy-var + (add-eres-lets + an-istx + res-proj-vars + arg/res-to-indy-var + (args/vars->arg-checker + (build-result-checkers + an-istx + ordered-ress res-indices + res-proj-vars indy-res-proj-vars + wrapper-ress indy-res-vars + arg/res-to-indy-var + blame-var-table) + (istx-args an-istx) + (istx-rst an-istx) + wrapper-args + this-param))) + #t + ordered-args arg-indices + arg-proj-vars indy-arg-proj-vars + wrapper-args indy-arg-vars + arg/res-to-indy-var + blame-var-table)) + + (define blame-ids '()) + (free-identifier-mapping-for-each + blame-var-table + (λ (id prs) + (for ([pr (in-list prs)]) + (define indy? (list-ref pr 0)) + (define dom? (list-ref pr 1)) + (set! blame-ids (cons (cons (build-blame-identifier indy? dom? id) + (vector (syntax-e id) indy? dom?)) + blame-ids))))) + (set! blame-ids (sort blame-ids string<=? #:key (λ (x) (symbol->string (syntax-e (car x)))))) + + (values + (map cdr blame-ids) + #`(λ (chk ctc blame swapped-blame #,@(map car blame-ids) + + ;; the pre- and post-condition procs + #,@(for/list ([pres (istx-pre an-istx)] + [i (in-naturals)]) + (string->symbol (format "pre-proc~a" i))) + #,@(for/list ([pres (istx-post an-istx)] + [i (in-naturals)]) + (string->symbol (format "post-proc~a" i))) + + ;; first the non-dependent arg projections + #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var)) + args+rst + (vector->list arg-proj-vars))) + ;; then the dependent arg projections + #,@(filter values (map (λ (arg/res arg-proj-var) (and (arg/res-vars arg/res) arg-proj-var)) + args+rst + (vector->list arg-proj-vars))) + ;; then the non-dependent indy arg projections + #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var)) + args+rst + (vector->list indy-arg-proj-vars))) + + ;; then the non-dependent res projections + #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var)) + (or (istx-ress an-istx) '()) + (vector->list res-proj-vars))) + ;; then the dependent res projections + #,@(filter values (map (λ (arg/res res-proj-var) (and (arg/res-vars arg/res) res-proj-var)) + (or (istx-ress an-istx) '()) + (vector->list res-proj-vars))) + ;; then the non-dependent indy res projections + #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var)) + (or (istx-ress an-istx) '()) + (vector->list indy-res-proj-vars)))) + + (λ (val) + (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) + (let ([arg-checker + (λ #,(args/vars->arglist an-istx wrapper-args this-param) + #,wrapper-body)]) + (impersonate-procedure + val + (make-keyword-procedure + (λ (kwds kwd-args . args) + (keyword-apply arg-checker kwds kwd-args args)) + (λ args (apply arg-checker args))) + impersonator-prop:contracted ctc)))))) (begin-encourage-inline (define (un-dep ctc obj blame) @@ -665,173 +733,179 @@ vars)) (define-syntax (->i/m stx) - (let* ([an-istx (parse-->i stx)] - [used-indy-vars (mk-used-indy-vars an-istx)] - [wrapper-func (mk-wrapper-func an-istx used-indy-vars)] - [args+rst (append (istx-args an-istx) + (define an-istx (parse-->i stx)) + (define used-indy-vars (mk-used-indy-vars an-istx)) + (define-values (blame-ids-info wrapper-func) (mk-wrapper-func/blame-id-info an-istx used-indy-vars)) + (define args+rst (append (istx-args an-istx) (if (istx-rst an-istx) (list (istx-rst an-istx)) - '()))] - [this->i (gensym 'this->i)]) - (with-syntax ([(arg-exp-xs ...) - (generate-temporaries (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-var arg))) - args+rst)))] - [(arg-exps ...) - (filter values (map (λ (arg) (and (not (arg/res-vars arg)) + '()))) + (define this->i (gensym 'this->i)) + (with-syntax ([(arg-exp-xs ...) + (generate-temporaries (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-var arg))) + args+rst)))] + [((arg-names arg-exps) ...) + (filter values (map (λ (arg) (and (not (arg/res-vars arg)) + (list + (arg/res-var arg) + (syntax-property (syntax-property - (syntax-property - (arg/res-ctc arg) - 'racket/contract:negative-position - this->i) - 'racket/contract:contract-on-boundary - (gensym '->i-indy-boundary)))) - args+rst))] - - [(res-exp-xs ...) - (if (istx-ress an-istx) - (generate-temporaries (filter values (map (λ (res) (and (not (arg/res-vars res)) (arg/res-var res))) - (istx-ress an-istx)))) - '())] - [(res-exps ...) - (if (istx-ress an-istx) - (filter values (map (λ (res) (and (not (arg/res-vars res)) - (syntax-property - (syntax-property - (arg/res-ctc res) - 'racket/contract:positive-position - this->i) - 'racket/contract:contract-on-boundary - (gensym '->i-indy-boundary)))) - (istx-ress an-istx))) - '())]) - - #`(let ([arg-exp-xs arg-exps] ... - [res-exp-xs res-exps] ...) - #,(syntax-property - #`(->i - ;; all of the non-dependent argument contracts - (list arg-exp-xs ...) - ;; all of the dependent argument contracts - (list #,@(filter values (map (λ (arg) - (and (arg/res-vars arg) - #`(λ (#,@(arg/res-vars arg) val blame) - ;; this used to use opt/direct, but opt/direct duplicates code (bad!) - (un-dep #,(syntax-property - (syntax-property - (arg/res-ctc arg) - 'racket/contract:negative-position - this->i) - 'racket/contract:contract-on-boundary - (gensym '->i-indy-boundary)) - val blame)))) - args+rst))) - ;; then the non-dependent argument contracts that are themselves dependend on - (list #,@(filter values - (map (λ (arg/res indy-id) - (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) - indy-id)) - (filter (λ (arg/res) (not (arg/res-vars arg/res))) args+rst) - (syntax->list #'(arg-exp-xs ...))))) + (arg/res-ctc arg) + 'racket/contract:negative-position + this->i) + 'racket/contract:contract-on-boundary + (gensym '->i-indy-boundary))))) + args+rst))] - - #,(if (istx-ress an-istx) - #`(list res-exp-xs ...) - #''()) - #,(if (istx-ress an-istx) - #`(list #,@(filter values (map (λ (arg) - (and (arg/res-vars arg) - (if (eres? arg) - #`(λ #,(arg/res-vars arg) - (opt/c #,(syntax-property - (syntax-property - (arg/res-ctc arg) - 'racket/contract:positive-position - this->i) - 'racket/contract:contract-on-boundary - (gensym '->i-indy-boundary)))) - #`(λ (#,@(arg/res-vars arg) val blame) - ;; this used to use opt/direct, but opt/direct duplicates code (bad!) - (un-dep #,(syntax-property - (syntax-property - (arg/res-ctc arg) - 'racket/contract:positive-position - this->i) - 'racket/contract:contract-on-boundary - (gensym '->i-indy-boundary)) - val blame))))) - (istx-ress an-istx)))) - #''()) - #,(if (istx-ress an-istx) - #`(list #,@(filter values - (map (λ (arg/res indy-id) - (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) - indy-id)) - (filter (λ (arg/res) (not (arg/res-vars arg/res))) (istx-ress an-istx)) - (syntax->list #'(res-exp-xs ...))))) - #''()) - - #,(let ([func (λ (pre/post) #`(λ #,(pre/post-vars pre/post) #,(pre/post-exp pre/post)))]) - #`(list #,@(for/list ([pre (in-list (istx-pre an-istx))]) - (func pre)) - #,@(for/list ([post (in-list (istx-post an-istx))]) - (func post)))) - - #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg)))) - (istx-args an-istx)))) - #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (arg-optional? arg))) - (istx-args an-istx)))) - '#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) (arg-kwd arg) (syntax-e (arg-kwd arg)))) - (istx-args an-istx))) - keywordlist stx))]) - (and (eq? (syntax-e x) kwd) - x))) - (define pre (find-kwd '#:pre)) - (define post (find-kwd '#:post)) - (define orig (list (car (syntax-e stx)))) - (vector this->i - ;; the ->i in the original input to this guy - (if post (cons post orig) orig) - (if pre (list pre) '())))))))) + [(res-exp-xs ...) + (if (istx-ress an-istx) + (generate-temporaries (filter values (map (λ (res) (and (not (arg/res-vars res)) (arg/res-var res))) + (istx-ress an-istx)))) + '())] + [((res-names res-exps) ...) + (if (istx-ress an-istx) + (filter values (map (λ (res) (and (not (arg/res-vars res)) + (list + (arg/res-var res) + (syntax-property + (syntax-property + (arg/res-ctc res) + 'racket/contract:positive-position + this->i) + 'racket/contract:contract-on-boundary + (gensym '->i-indy-boundary))))) + (istx-ress an-istx))) + '())]) + + #`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ... + [res-exp-xs (coerce-contract '->i res-exps)] ...) + #,(syntax-property + #`(->i + ;; the information needed to make the blame records and their new contexts + '#,blame-ids-info + ;; all of the non-dependent argument contracts + (list (cons 'arg-names arg-exp-xs) ...) + ;; all of the dependent argument contracts + (list #,@(filter values (map (λ (arg) + (and (arg/res-vars arg) + #`(λ (#,@(arg/res-vars arg) val blame) + ;; this used to use opt/direct, but opt/direct duplicates code (bad!) + (un-dep #,(syntax-property + (syntax-property + (arg/res-ctc arg) + 'racket/contract:negative-position + this->i) + 'racket/contract:contract-on-boundary + (gensym '->i-indy-boundary)) + val blame)))) + args+rst))) + ;; then the non-dependent argument contracts that are themselves dependend on + (list #,@(filter values + (map (λ (arg/res indy-id) + (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) + #`(cons '#,(arg/res-var arg/res) #,indy-id))) + (filter (λ (arg/res) (not (arg/res-vars arg/res))) args+rst) + (syntax->list #'(arg-exp-xs ...))))) + + + #,(if (istx-ress an-istx) + #`(list (cons 'res-names res-exp-xs) ...) + #''()) + #,(if (istx-ress an-istx) + #`(list #,@(filter values (map (λ (arg) + (and (arg/res-vars arg) + (if (eres? arg) + #`(λ #,(arg/res-vars arg) + (opt/c #,(syntax-property + (syntax-property + (arg/res-ctc arg) + 'racket/contract:positive-position + this->i) + 'racket/contract:contract-on-boundary + (gensym '->i-indy-boundary)))) + #`(λ (#,@(arg/res-vars arg) val blame) + ;; this used to use opt/direct, but opt/direct duplicates code (bad!) + (un-dep #,(syntax-property + (syntax-property + (arg/res-ctc arg) + 'racket/contract:positive-position + this->i) + 'racket/contract:contract-on-boundary + (gensym '->i-indy-boundary)) + val blame))))) + (istx-ress an-istx)))) + #''()) + #,(if (istx-ress an-istx) + #`(list #,@(filter values + (map (λ (arg/res indy-id) + (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) + #`(cons '#,(arg/res-var arg/res) #,indy-id))) + (filter (λ (arg/res) (not (arg/res-vars arg/res))) (istx-ress an-istx)) + (syntax->list #'(res-exp-xs ...))))) + #''()) + + #,(let ([func (λ (pre/post) #`(λ #,(pre/post-vars pre/post) #,(pre/post-exp pre/post)))]) + #`(list #,@(for/list ([pre (in-list (istx-pre an-istx))]) + (func pre)) + #,@(for/list ([post (in-list (istx-post an-istx))]) + (func post)))) + + #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg)))) + (istx-args an-istx)))) + #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (arg-optional? arg))) + (istx-args an-istx)))) + '#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) (arg-kwd arg) (syntax-e (arg-kwd arg)))) + (istx-args an-istx))) + keywordlist stx))]) + (and (eq? (syntax-e x) kwd) + x))) + (define pre (find-kwd '#:pre)) + (define post (find-kwd '#:post)) + (define orig (list (car (syntax-e stx)))) + (vector this->i + ;; the ->i in the original input to this guy + (if post (cons post orig) orig) + (if pre (list pre) '()))))))) diff --git a/collects/racket/contract/private/arrow.rkt b/collects/racket/contract/private/arrow.rkt index 912d5880ae..82708c2760 100644 --- a/collects/racket/contract/private/arrow.rkt +++ b/collects/racket/contract/private/arrow.rkt @@ -330,14 +330,14 @@ v4 todo: #`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) (let ([basic-lambda-name basic-lambda]) (arity-checking-wrapper val blame - basic-lambda-name - void - #,min-method-arity - #,max-method-arity - #,min-arity - #,(if dom-rest #f max-arity) - '(req-kwd ...) - '(opt-kwd ...))))] + basic-lambda-name + void + #,min-method-arity + #,max-method-arity + #,min-arity + #,(if dom-rest #f max-arity) + '(req-kwd ...) + '(opt-kwd ...))))] [(pair? req-keywords) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) (let ([kwd-lambda-name kwd-lambda]) @@ -471,23 +471,34 @@ v4 todo: [mtd? (base->-mtd? ctc)]) (λ (orig-blame) (define rng-blame (blame-add-context orig-blame "the range of")) - (define swapped (blame-swap orig-blame)) - (define swapped-domain (blame-add-context swapped "the domain of")) + (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t)) (define partial-doms (for/list ([dom (in-list doms-proj)] [n (in-naturals 1)]) - (dom (blame-add-context swapped + (dom (blame-add-context orig-blame (format "the ~a argument of" - (n->th n)))))) + (n->th n)) + #:swap? #t)))) (define partial-optional-doms (for/list ([dom (in-list doms-optional-proj)] [n (in-naturals (+ 1 (length doms-proj)))]) - (dom (blame-add-context swapped + (dom (blame-add-context orig-blame (format "the ~a argument of" - (n->th n)))))) + (n->th n)) + #:swap? #t)))) (define partial-ranges (map (λ (rng) (rng rng-blame)) rngs-proj)) - (define partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)) - (define partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)) + (define partial-mandatory-kwds + (for/list ([kwd-proj (in-list mandatory-kwds-proj)] + [kwd (in-list mandatory-keywords)]) + (kwd-proj (blame-add-context orig-blame + (format "the ~a argument of" kwd) + #:swap? #t)))) + (define partial-optional-kwds + (for/list ([kwd-proj (in-list optional-kwds-proj)] + [kwd (in-list optional-keywords)]) + (kwd-proj (blame-add-context orig-blame + (format "the ~a argument of" kwd) + #:swap? #t)))) (define the-args (append partial-doms partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges)) @@ -1192,7 +1203,6 @@ v4 todo: [else (cons (+ mandatory-count i) (loop (+ i 1)))]))])]) (λ (blame) - (let ([blame (blame-add-context blame "the domain of")]) (λ (val) (if (base-->d-rest-ctc ->d-stct) (check-procedure/more val @@ -1274,7 +1284,8 @@ v4 todo: (invoke-dep-ctc (car result-contracts) (if rng-underscore? #f dep-post-args) (car results) - blame) + blame + #f) (loop (cdr results) (cdr result-contracts)))])))))) null)) @@ -1287,7 +1298,7 @@ v4 todo: [(or (null? building-kwd-args) (null? all-kwds)) '()] [else (if (eq? (car all-kwds) (car building-kwd-args)) - (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame)) + (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) blame #t) (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))]) (if (null? kwd-res) null (list kwd-res))) @@ -1305,20 +1316,20 @@ v4 todo: (cond [(null? args) (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame)) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() blame #t) '())] [(null? non-kwd-ctcs) (if (base-->d-rest-ctc ->d-stct) - (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame)) + (invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args blame #t) ;; ran out of arguments, but don't have a rest parameter. ;; procedure-reduce-arity (or whatever the new thing is ;; going to be called) should ensure this doesn't happen. (error 'shouldnt\ happen))] - [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) + [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) blame #t) (loop (cdr args) (cdr non-kwd-ctcs)))]))))))) - impersonator-prop:contracted ->d-stct)))))) + impersonator-prop:contracted ->d-stct))))) (define (build-values-string desc dep-pre-args) (cond @@ -1335,11 +1346,16 @@ v4 todo: (loop (cdr lst)))])))])) ;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst -(define (invoke-dep-ctc dep-ctc dep-args val blame) +(define (invoke-dep-ctc dep-ctc dep-args val blame dom?) (let ([ctc (coerce-contract '->d (if dep-args (apply dep-ctc dep-args) dep-ctc))]) - (((contract-projection ctc) blame) val))) + (((contract-projection ctc) + (blame-add-context + blame + (if dom? "the domain of" "the range of") + #:swap? dom?)) + val))) ;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any) (define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args) @@ -1627,35 +1643,34 @@ v4 todo: (define (case->-proj wrapper) (λ (ctc) - (let* ([dom-ctcs (map contract-projection (get-case->-dom-ctcs ctc))] - [rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)]) - (and rngs (map contract-projection (get-case->-rng-ctcs ctc))))] - [rst-ctcs (base-case->-rst-ctcs ctc)] - [specs (base-case->-specs ctc)]) - (λ (blame) - (define dom-blame (blame-add-context (blame-swap blame) "the domain of")) - (define rng-blame (blame-add-context blame "the range of")) - (let ([projs (append (map (λ (f) (f dom-blame)) dom-ctcs) - (map (λ (f) (f rng-blame)) rng-ctcs))] - [chk - (λ (val mtd?) - (cond - [(null? specs) - (unless (procedure? val) - (raise-blame-error blame val "expected a procedure"))] - [else - (for-each - (λ (dom-length has-rest?) - (if has-rest? - (check-procedure/more val mtd? dom-length '() '() blame) - (check-procedure val mtd? dom-length 0 '() '() blame))) - specs rst-ctcs)]))]) - (apply (base-case->-wrapper ctc) - chk - wrapper - blame - ctc - projs)))))) + (define dom-ctcs (map contract-projection (get-case->-dom-ctcs ctc))) + (define rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)]) + (and rngs (map contract-projection (get-case->-rng-ctcs ctc))))) + (define rst-ctcs (base-case->-rst-ctcs ctc)) + (define specs (base-case->-specs ctc)) + (λ (blame) + (define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) + (define rng-blame (blame-add-context blame "the range of")) + (define projs (append (map (λ (f) (f dom-blame)) dom-ctcs) + (map (λ (f) (f rng-blame)) rng-ctcs))) + (define (chk val mtd?) + (cond + [(null? specs) + (unless (procedure? val) + (raise-blame-error blame val "expected a procedure"))] + [else + (for-each + (λ (dom-length has-rest?) + (if has-rest? + (check-procedure/more val mtd? dom-length '() '() blame) + (check-procedure val mtd? dom-length 0 '() '() blame))) + specs rst-ctcs)])) + (apply (base-case->-wrapper ctc) + chk + wrapper + blame + ctc + projs)))) (define (case->-name ctc) (apply diff --git a/collects/racket/contract/private/blame.rkt b/collects/racket/contract/private/blame.rkt index a576c14221..1c1b62259d 100644 --- a/collects/racket/contract/private/blame.rkt +++ b/collects/racket/contract/private/blame.rkt @@ -13,6 +13,7 @@ blame-swap blame-replace-negative ;; used for indy blame blame-add-context + blame-add-unknown-context blame-context raise-blame-error @@ -36,20 +37,35 @@ (hash/recur (blame-original? b)))) (define-struct blame - [source value build-name positive negative original? context] + [source value build-name positive negative original? context top-known? important] #:property prop:equal+hash (list blame=? blame-hash blame-hash)) (define -make-blame (let ([make-blame (λ (source value build-name positive negative original?) - (make-blame source value build-name positive negative original? '()))]) + (make-blame source value build-name positive negative original? '() #t #f))]) make-blame)) -(define (blame-add-context b s) +;; s : (or/c string? #f) +(define (blame-add-context b s #:important [important #f] #:swap? [swap? #f]) (struct-copy blame b - [context (cons s (blame-context b))])) + [original? (if swap? (not (blame-original? b)) (blame-original? b))] + [positive (if swap? (blame-negative b) (blame-positive b))] + [negative (if swap? (blame-positive b) (blame-negative b))] + [important (or important (blame-important b))] + [context (if s (cons s (blame-context b)) (blame-context b))] + [top-known? #t])) + +(define (blame-add-unknown-context b) + (define old (blame-context b)) + (struct-copy + blame b + [top-known? #f] + [context (if (blame-top-known? b) + (blame-context b) + (cons "..." (blame-context b)))])) (define (blame-contract b) ((blame-build-name b))) @@ -76,90 +92,82 @@ (current-continuation-marks) b))) -(define (default-blame-format b x custom-message) - (let* ([source-message (source-location->string (blame-source b))] - [positive-message (show/display (convert-blame-party (blame-positive b)))] - - [context-message (apply string-append - (for/list ([context (in-list (blame-context b))] - [n (in-naturals)]) - (format (if (zero? n) - " in: ~a\n" - " ~a\n") - context)))] - [the-contract-str (show/write (blame-contract b))] - [contract-message (string-append (if (regexp-match #rx"\n" the-contract-str) - (string-append (regexp-replace #rx"\n$" context-message "") - the-contract-str) - (string-append context-message - (format " ~a" the-contract-str))))] - [contract-message+at - (regexp-replace - #rx"^\n" - (if (regexp-match #rx"\n$" contract-message) - (string-append contract-message - (if (string=? source-message "") - "" - (format " at: ~a" source-message))) - (string-append contract-message - "\n" - (if (string=? source-message "") - "" - (format " at: ~a" source-message)))) - "")]) - ;; use (regexp-match #rx"\n" ...) to find out if show/display decided that this - ;; is a multiple-line message and adjust surrounding formatting accordingly +(define (default-blame-format blme x custom-message) + (define source-message (source-location->string (blame-source blme))) + (define positive-message (show/display (convert-blame-party (blame-positive blme)))) + + (define context (blame-context blme)) + (define context-lines (if (null? context) + #f + (apply string-append + (for/list ([context (in-list context)] + [n (in-naturals)]) + (format (if (zero? n) + " in: ~a\n" + " ~a\n") + context))))) + (define contract-line (show/write (blame-contract blme) #:alone? #t)) + (define at-line (if (string=? source-message "") + #f + (format " at: ~a" source-message))) + + (define self-or-not (if (blame-original? blme) + "self-contract violation" + "contract violation")) + + (define start-of-message (cond - [(blame-original? b) - (define start-of-message - (if (blame-value b) - (format "~a: self-contract violation," (blame-value b)) - "self-contract violation:")) - (string-append - (format "~a ~a\n" start-of-message custom-message) - (format " contract from: ~a~a blaming: ~a~a" - positive-message - (if (regexp-match #rx"\n" positive-message) - " " - ",") - positive-message - (if (regexp-match #rx"\n" positive-message) - "" - "\n")) - contract-message+at)] + [(blame-important blme) + (format "~a: ~a" (blame-important blme) self-or-not)] + [(blame-value blme) + (format "~a: ~a" (blame-value blme) self-or-not)] [else - (define negative-message (show/display (convert-blame-party (blame-negative b)))) - (define start-of-message - (if (blame-value b) - (format "~a: contract violation," (blame-value b)) - "contract violation:")) + (format "~a:" self-or-not)])) + + (define blaming-line (format " blaming: ~a" positive-message)) + + (define from-line + (if (blame-original? blme) + (format " contract from: ~a" positive-message) + (let ([negative-message (show/display (convert-blame-party (blame-negative blme)))]) + (format " contract from: ~a" negative-message)))) + + (combine-lines + start-of-message + (format " ~a" custom-message) + context-lines + (if context-lines + contract-line (string-append - (format "~a ~a\n" start-of-message custom-message) - (format " contract from: ~a~a blaming: ~a~a" - negative-message - (if (regexp-match #rx"\n" negative-message) - " " - ",") - positive-message - (if (regexp-match #rx"\n" positive-message) - "" - "\n")) - contract-message+at)]))) + " in:" + (substring contract-line 5 (string-length contract-line)))) + from-line + blaming-line + at-line)) -(define (add-newline str) - (if (regexp-match #rx"\n$" str) - str - (string-append str "\n"))) +;; combine-lines : (->* #:rest (listof (or/c string? #f))) string?) +;; combines each of 'lines' into a single message, dropping #fs, +;; and otherwise guaranteeing that each string is on its own line. +(define (combine-lines . lines) + (apply + string-append + (for/list ([line (in-list lines)] + #:when (string? line)) + (if (regexp-match #rx"\n$" line) + line + (string-append line "\n"))))) -(define ((show f) v) +(define ((show f) v #:alone? [alone? #f]) (let* ([line (parameterize ([pretty-print-columns 'infinity]) (f v))]) (if (< (string-length line) 30) - line - (parameterize ([pretty-print-print-line show-line-break] - [pretty-print-columns 50]) - (f v))))) + (cond + [alone? (string-append spacer line)] + [else line]) + (parameterize ([pretty-print-print-line (show-line-break alone?)] + [pretty-print-columns 50]) + (f v))))) (define (pretty-format/display v [columns (pretty-print-columns)]) (let ([port (open-output-string)]) @@ -179,11 +187,16 @@ (define show/display (show pretty-format/display)) (define show/write (show pretty-format/write)) -(define (show-line-break line port len cols) - (newline port) + +(define ((show-line-break alone?) line port len cols) + (if alone? + (unless (equal? line 0) (newline port)) + (newline port)) (if line - (begin (display " " port) 6) - 0)) + (begin (display spacer port) 6) + 0)) + +(define spacer " ") (define current-blame-format (make-parameter default-blame-format)) diff --git a/collects/racket/contract/private/prop.rkt b/collects/racket/contract/private/prop.rkt index 096e410631..48a098c118 100644 --- a/collects/racket/contract/private/prop.rkt +++ b/collects/racket/contract/private/prop.rkt @@ -1,7 +1,8 @@ #lang racket/base (require "blame.rkt" - "generate-base.rkt") + "generate-base.rkt" + racket/performance-hint) (provide prop:contract contract-struct? @@ -11,7 +12,7 @@ contract-struct-stronger? contract-struct-generate contract-struct-exercise - + prop:flat-contract flat-contract-struct? @@ -196,9 +197,11 @@ [get-first-order (or get-first-order get-any?)] [get-projection (cond - [get-projection (if (skip-projection-wrapper?) - get-projection - (projection-wrapper get-projection))] + [get-projection + (blame-context-projection-wrapper + (if (skip-projection-wrapper?) + get-projection + (projection-wrapper get-projection)))] [else (get-first-order-projection get-name get-first-order)])] [stronger (or stronger weakest)]) @@ -233,6 +236,12 @@ (error 'prop:chaperone-contract (format "expected a chaperone of ~v, got ~v" v v*))) v*))))))) +(define (blame-context-projection-wrapper proj) + (λ (ctc) + (define c-proj (proj ctc)) + (λ (blame) + (c-proj (blame-add-unknown-context blame))))) + (define build-chaperone-contract-property (build-property (compose make-chaperone-contract-property make-contract-property) 'anonymous-chaperone-contract @@ -246,12 +255,13 @@ (define ((get-first-order-projection get-name get-first-order) c) (first-order-projection (get-name c) (get-first-order c))) -(define (first-order-projection name first-order) - (λ (b) - (λ (x) - (if (first-order x) - x - (raise-blame-error b x "expected: ~s, given: ~e" name x))))) +(begin-encourage-inline + (define (first-order-projection name first-order) + (λ (b) + (λ (x) + (if (first-order x) + x + (raise-blame-error b x "expected: ~s, given: ~e" name x)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index df14645752..ea09040c6e 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -2969,7 +2969,10 @@ [name ;; the procedure name of a method has ' method in ...' in it; trim that away (define method-name (regexp-replace #rx" method in .*%.?$" (symbol->string name) "")) - (blame-add-context blame (format "the ~a method in" method-name))] + (blame-add-context blame + (format "the ~a method in" method-name) + #:important + name)] [else (blame-add-context blame "an unnamed method in")])) diff --git a/collects/scribblings/guide/contracts-intro.scrbl b/collects/scribblings/guide/contracts-intro.scrbl index ac3f541f1f..663f223b27 100644 --- a/collects/scribblings/guide/contracts-intro.scrbl +++ b/collects/scribblings/guide/contracts-intro.scrbl @@ -204,32 +204,23 @@ parties in a contract, examples involve multiple modules. To experiment with multiple modules within a single module or within DrRacket's @tech{definitions area}, use the -@racketmodname[racket/load] language. The contents of such a module -can be other modules (and @racket[require] statements), using the -longhand parenthesized syntax for a module (see -@secref["module-syntax"]). For example, try the example earlier in -this section as follows: +Racket's submodules. For example, try the example earlier in +this section like this: @racketmod[ -racket/load +racket -(module m racket +(module+ server (provide (contract-out [amount (and/c number? positive?)])) (define amount 150)) - -(module n racket - (require 'm) + +(module+ main + (require (submod ".." server)) (+ amount 10)) - -(require 'n)] +] Each of the modules and their contracts are wrapped in parentheses -with the @racket[module] keyword at the front. The first form after +with the @racket[module+] keyword at the front. The first form after @racket[module] is the name of the module to be used in a subsequent @racket[require] statement (where each reference through a -@racket[require] prefixes the name with a quote). The second form -after @racket[module] is the language, and the remaining forms are the -body of the module. After all of the modules, a @racket[require] -starts one of the modules plus anything that is @racket[require]s. - - +@racket[require] prefixes the name with @racket[".."]). diff --git a/collects/scribblings/guide/contracts-simple-function.scrbl b/collects/scribblings/guide/contracts-simple-function.scrbl index 49d4fda414..e32ac32b1b 100644 --- a/collects/scribblings/guide/contracts-simple-function.scrbl +++ b/collects/scribblings/guide/contracts-simple-function.scrbl @@ -335,28 +335,28 @@ on a value other than an integer, then the server is to blame. You wrote your module. You added contracts. You put them into the interface so that client programmers have all the information from interfaces. It's a piece of art: -@racketmod[ -racket - -(provide - (contract-out - [deposit (-> (lambda (x) - (and (number? x) (integer? x) (>= x 0))) - any)])) - -(define this 0) -(define (deposit a) ...) -] +@interaction[#:eval + contract-eval + (module bank-server racket + (provide + (contract-out + [deposit (-> (λ (x) + (and (number? x) (integer? x) (>= x 0))) + any)])) + + (define total 0) + (define (deposit a) (set! total (+ a total))))] Several clients used your module. Others used their modules in turn. And all of a sudden one of them sees this error message: -@inset-flow{@racketerror{bank-client broke the contract (-> ??? any) -it had with myaccount on deposit; expected , given: -10}} +@interaction[#:eval + contract-eval + (require 'bank-server) + (deposit -10)] -Clearly, @racket[bank-client] is a module that uses @racket[myaccount] -but what is the @racketerror{???} doing there? Wouldn't it be nice if +What is the @racketerror{???} doing there? Wouldn't it be nice if we had a name for this class of data much like we have string, number, and so on? @@ -368,21 +368,20 @@ by a predicate that consumes all Racket values and produces a boolean. The ``named'' part says what we want to do, which is to name the contract so that error messages become intelligible: -@racketmod[ -racket - -(define (amount? x) (and (number? x) (integer? x) (>= x 0))) -(define amount (flat-named-contract 'amount amount?)) +@interaction[#:eval + contract-eval + (module improved-bank-server racket + (define (amount? x) (and (number? x) (integer? x) (>= x 0))) + (define amount (flat-named-contract 'amount amount?)) -(provide (contract-out [deposit (amount . -> . any)])) + (provide (contract-out [deposit (amount . -> . any)])) -(define this 0) -(define (deposit a) ...) -] + (define total 0) + (define (deposit a) (set! total (+ a total))))] -With this little change, the error message becomes all of the -sudden quite readable: - -@inset-flow{@racketerror{bank-client broke the contract (-> amount -any) it had with myaccount on deposit; expected , given: -10}} +With this little change, the error message becomes quite readable: +@interaction[#:eval + contract-eval + (require 'improved-bank-server) + (deposit -10)] diff --git a/collects/scribblings/guide/contracts-utils.rkt b/collects/scribblings/guide/contracts-utils.rkt index a610852cd2..e1fca63fb9 100644 --- a/collects/scribblings/guide/contracts-utils.rkt +++ b/collects/scribblings/guide/contracts-utils.rkt @@ -3,13 +3,15 @@ (require scribble/basic (for-syntax racket/port) racket/include + scribble/eval (except-in scribble/manual link)) (provide ctc-section ctc-link exercise solution - external-file) + external-file + contract-eval) (define (ctc-section #:tag [tag #f] . rest) (keyword-apply section @@ -69,3 +71,6 @@ [(_ filename) #`(include/reader #,(format "contracts-examples/~a.rkt" (syntax-e #'filename)) comment-racketmod-reader)])) + +(define contract-eval (make-base-eval)) +(contract-eval '(require racket/contract)) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index b923fdd5bb..e673e49078 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -1355,11 +1355,15 @@ We can use this insight to generalize the function contracts and build a function that accepts any two contracts and returns a contract for functions between them. +This projection also goes further and uses +@racket[blame-add-context] to improve the error messages +when a contract violation is detected. + @racketblock[ (define (make-simple-function-contract dom-proj range-proj) (lambda (blame) - (let ([dom (dom-proj (blame-swap blame))] - [rng (range-proj blame)]) + (let ([dom (dom-proj (blame-add-context blame "the argument of" #:swap? #t))] + [rng (range-proj (blame-add-context blame "the range of"))]) (lambda (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) @@ -1542,6 +1546,53 @@ contracts. The error messages assume that the function named by This predicate recognizes @tech{blame objects}. } +@defproc[(blame-add-context [blame blame?] + [context (or/c string? #f)] + [#:important important (or/c string? #f) #f] + [#:swap? swap? boolean? #f]) + blame?]{ + Adds some context information to blame error messages + that explicates which portion of the contract failed + (and that gets rendered by @racket[raise-blame-error]). + + The @racket[context] argument describes one layer of the + portion of the contract, typically of the form @racket["the 1st argument of"] + (in the case of a function contract) + or @racket["a conjunct of"] (in the case of an @racket[and/c] contract). + + For example, consider this contract violation: + @interaction[#:eval (contract-eval) +(define/contract f + (list/c (-> integer? integer?)) + (list (λ (x) x))) + +((car f) #f) +] +It shows that the portion of the contract being violated is the first +occurrence of @racket[integer?], because the @racket[->] and +the @racket[list/c] combinators each internally called +@racket[blame-add-context] to add the two lines following +``in'' in the error message. + +The @racket[important] argument is used to build the beginning part +of the contract violation. The last @racket[important] argument that +gets added to a blame object is used. The @racket[class/c] contract +adds an important argument, as does the @racket[->] contract (when +@racket[->] knows the name of the function getting the contract). + +The @racket[swap?] argument has the effect of calling @racket[blame-swap] +while adding the layer of context, but without creating an extra +blame object. + +The context information recorded in blame structs keeps track of +combinators that do not add information, and add the string @racket["..."] +for them, so programmers at least see that there was some context +they are missing in the error messages. Accordingly, since there are +combinators that should not add any context (e.g., @racket[recursive-contract]), +passing @racket[#f] as the context string argument avoids adding the +@racket["..."] string. +} + @deftogether[( @defproc[(blame-positive [b blame?]) any/c] @defproc[(blame-negative [b blame?]) any/c] @@ -1568,6 +1619,7 @@ source location was provided, all fields of the structure will contain @defproc[(blame-swap [b blame?]) blame?]{ This function swaps the positive and negative parties of a @tech{blame object}. +(See also @racket[blame-add-context].) } @deftogether[( diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 061cfe3b4a..1629de8a99 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -143,10 +143,15 @@ (define (has-proper-blame? msg) (define reg (cond - [(eq? blame 'pos) #rx"self-contract violation[:,].*blaming: pos"] + [(eq? blame 'pos) #rx"self-contract violation[\n:,].*blaming: pos"] [(eq? blame 'neg) #rx"blaming: neg"] [(string? blame) (string-append "blaming: " (regexp-quote blame))] [else #f])) + + (when reg + (unless (regexp-match? reg msg) + (eprintf "ACK!! ~s ~s\n" blame msg) + (custodian-shutdown-all (current-custodian)))) (and reg (regexp-match? reg msg))) (printf "testing: ~s\n" name) (contract-eval @@ -3041,7 +3046,7 @@ ;; test to make sure the values are in the error messages (contract-error-test - 'contract-error-test1 + '->i-contract-error-test1 #'((contract (->i ([x number?]) #:pre (x) #f any) (λ (x) x) 'pos @@ -3051,7 +3056,7 @@ (and (exn:fail:contract:blame? x) (regexp-match #rx"x: 123456789" (exn-message x))))) (contract-error-test - 'contract-error-test2 + '->i-contract-error-test2 #'((contract (->i ([|x y| number?]) #:pre (|x y|) #f any) (λ (x) x) 'pos @@ -3063,12 +3068,23 @@ ;; test to make sure the collects directories are appropriately prefixed (contract-error-test - 'contract-error-test3 + '->i-contract-error-test3 #'(contract symbol? "not a symbol" 'pos 'neg 'not-a-symbol #'here) (lambda (x) (and (exn:fail:contract:blame? x) (regexp-match? #px"" (exn-message x))))) + + ;; make sure that ->i checks its arguments + (contract-error-test + '->i-contract-error-test4 + #'(->i ([x (λ (x y z) #f)]) any) + exn:fail?) + + (contract-error-test + '->i-contract-error-test5 + #'(->i () (values [x (λ (x y z) #f)][y 5])) + exn:fail?) (test/neg-blame '->i-protect-shared-state @@ -11299,18 +11315,38 @@ so that propagation occurs. ; ; - (contract-eval '(define (extract-context-lines thunk num) + (contract-eval '(define (extract-context-lines thunk) (define str (with-handlers ((exn:fail:contract:blame? exn-message)) (thunk) "didn't raise an exception")) - (define lines - (regexp-split - #rx"\n " - (regexp-replace #rx"(.*)\n in: " str ""))) - (for/list ([answer-count (in-range num)] - [msg-str (in-list lines)]) - msg-str))) + (define m (regexp-match #rx".*\n +in: (.*)$" str)) + (cond + [m + (define without-prefix (list-ref m 1)) + (define m2 (regexp-match #rx"(.*)\n *contract from:" without-prefix)) + (cond + [m2 + (define lines (regexp-split #rx"\n *" (list-ref m2 1))) + ;; drop the lines with the contract (keep lines beginning with an article) + (let loop ([lines (regexp-split #rx"\n *" (list-ref m2 1))]) + (cond + [(null? lines) '()] + [else + (define line (car lines)) + (cond + [(or (regexp-match #rx"^the " line) + (regexp-match #rx"^an " line) + (regexp-match #rx"^a " line)) + (cons line (loop (cdr lines)))] + [else + (loop (cdr lines))])]))] + [else + (string-append "did not find ``contract from:'', so no context in msg: " + str)])] + [else + (string-append "did not find ``in:'', so no context in msg: " + str)]))) (ctest '("the cdr of" "the 1st argument of") extract-context-lines @@ -11318,8 +11354,7 @@ so that propagation occurs. (λ (x y) x) 'pos 'neg) - (cons 1 2) 1)) - 2) + (cons 1 2) 1))) (ctest '("the 3rd element of" "the 2nd argument of") extract-context-lines @@ -11327,8 +11362,7 @@ so that propagation occurs. (λ (x y) x) 'pos 'neg) - 1 (list 1 2 3))) - 2) + 1 (list 1 2 3)))) (ctest '("the range of" "the 4th element of") extract-context-lines @@ -11336,16 +11370,14 @@ so that propagation occurs. (list 1 2 #f (λ (x) #f)) 'pos 'neg)) - 1)) - 2) + 1))) (ctest '("a disjunct of") extract-context-lines (λ () (contract (or/c 1 (-> number? number?)) 3 'pos - 'neg)) - 1) + 'neg))) (ctest '("the range of" "a disjunct of") extract-context-lines @@ -11353,49 +11385,235 @@ so that propagation occurs. (λ (x) #f) 'pos 'neg) - 1)) - 2) + 1))) (ctest '("the 2nd conjunct of") extract-context-lines (λ () (contract (and/c procedure? (-> integer? integer?)) (λ (x y) 1) 'pos - 'neg)) - 1) + 'neg))) (ctest '("an element of") extract-context-lines (λ () (contract (listof number?) (list #f) 'pos - 'neg)) - 1) + 'neg))) (ctest '("the promise from") extract-context-lines (λ () (force (contract (promise/c number?) (delay #f) 'pos - 'neg))) - 1) + 'neg)))) (ctest '("the parameter of") extract-context-lines (λ () ((contract (parameter/c number?) (make-parameter #f) 'pos - 'neg))) - 1) + 'neg)))) (ctest '("the parameter of") extract-context-lines (λ () ((contract (parameter/c number?) (make-parameter 1) 'pos 'neg) - #f)) - 1) + #f))) + (ctest '("the #:x argument of") + extract-context-lines + (λ () ((contract (-> #:x number? #:a char? #:w boolean? any) + (λ (#:x x #:a a #:w w) x) + 'pos + 'neg) + #:a #\a #:w #f #:x 'two))) + (ctest '("the #:a argument of") + extract-context-lines + (λ () ((contract (-> #:x number? #:a char? #:w boolean? any) + (λ (#:x x #:a a #:w w) x) + 'pos + 'neg) + #:a #f #:w #f #:x 2))) + + (ctest '("the #:w argument of") + extract-context-lines + (λ () ((contract (-> #:x number? #:a char? #:w boolean? any) + (λ (#:x x #:a a #:w w) x) + 'pos + 'neg) + #:a #\a #:w 'false #:x 2))) + + (ctest '("the #:x argument of") + extract-context-lines + (λ () ((contract (->* () (#:x number?) any) + (λ (#:x [x 1]) x) + 'pos + 'neg) + #:x #f))) + + (ctest '("the #:x argument of") + extract-context-lines + (λ () ((contract (->* () (#:x number? #:a char? #:w boolean?) any) + (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) + 'pos + 'neg) + #:a #\a #:w #f #:x 'two))) + + (ctest '("the #:a argument of") + extract-context-lines + (λ () ((contract (->* () (#:x number? #:a char? #:w boolean?) any) + (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) + 'pos + 'neg) + #:a #f #:w #f #:x 2))) + + (ctest '("the #:w argument of") + extract-context-lines + (λ () ((contract (->* () (#:x number? #:a char? #:w boolean?) any) + (λ (#:x [x 1] #:a [a #\a] #:w [w #f]) x) + 'pos + 'neg) + #:a #\a #:w 'false #:x 2))) + + (ctest '("the x argument of") + extract-context-lines + (λ () ((contract (->i ([w integer?] [x boolean?] [a char?]) any) + (λ (w x a) x) + 'pos + 'neg) + 1 'true #\a))) + + (ctest '("the x argument of") + extract-context-lines + (λ () ((contract (->i ([w integer?]) ([x boolean?] [a char?]) any) + (λ (w [x #t] [a #\a]) x) + 'pos + 'neg) + 1 'true #\a))) + + (ctest '("the y result of") + extract-context-lines + (λ () ((contract (->i () (values [x integer?] [y integer?])) + (λ () (values 1 #f)) + 'pos + 'neg)))) + + (ctest '("the x result of") + extract-context-lines + (λ () ((contract (->i () (values [x integer?] [y integer?])) + (λ () (values #f 1)) + 'pos + 'neg)))) + + (ctest '("the a argument of") + extract-context-lines + (λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 'one #:b 2 3 #:d 4))) + + (ctest '("the b argument of") + extract-context-lines + (λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 1 #:b 'two 3 #:d 4))) + + (ctest '("the c argument of") + extract-context-lines + (λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 1 #:b 2 'three #:d 4))) + + (ctest '("the d argument of") + extract-context-lines + (λ () ((contract (->i ([a integer?] #:b [b integer?]) ([c integer?] #:d [d integer?]) any) + (λ (a #:b b [c 1] #:d [d 1]) 1) + 'pos + 'neg) + 1 #:b 2 3 #:d 'four))) + + ;; indy + (ctest '("the 2nd argument of" "the x argument of") + extract-context-lines + (λ () ((contract (->i ([x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))]) any) + (λ (x a) x) + 'pos + 'neg) + (λ (x y) 1) 11))) + + (ctest '("the 2nd argument of" "the x result of") + extract-context-lines + (λ () ((contract (->i () (values [x (-> number? boolean? integer?)] [a (x) (>=/c (x 11 'true))])) + (λ () (values (λ (x y) x) 1)) + 'pos + 'neg)))) + + (ctest '("the x argument of") + extract-context-lines + (λ () ((contract (->i ([x () integer?]) any) + (λ (x) x) + 'pos + 'neg) + #f))) + + (ctest '("the a argument of") + extract-context-lines + (λ () ((contract (->i ([a integer?] [x (a) integer?]) any) + (λ (a x) x) + 'pos + 'neg) + #f 1))) + + (ctest '("the 1st result of") + extract-context-lines + (λ () ((contract (->i () (values [_ integer?] [_ integer?])) + (λ () (values #f 1)) + 'pos + 'neg)))) + + (ctest '("the result of") + extract-context-lines + (λ () ((contract (->i () [_ integer?]) + (λ () (values #f)) + 'pos + 'neg)))) + + (ctest '("the domain of") + extract-context-lines + (λ () ((contract (->d ([x integer?]) [y integer?]) + (λ (x) #f) + 'pos + 'neg) + #f))) + + (ctest '("the range of") + extract-context-lines + (λ () ((contract (->d ([x integer?]) [y integer?]) + (λ (x) #f) + 'pos + 'neg) + 1))) + + (ctest '("the range of") + extract-context-lines + (λ () (letrec ([ctc (-> integer? (recursive-contract ctc))]) + (letrec ([f (λ (x) 'not-f)]) + ((contract ctc f 'pos 'neg) 1))))) + + #; + (ctest '("an element of" "the 3rd element of") + extract-context-lines + (λ () (contract (vector/c (vectorof real?) (vectorof number?) (vectorof boolean?)) + (vector (vector 1) (vector 1) (vector 1)) + 'pos + 'neg))) ; ;