suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve the contract error messages:

Browse Source 
- add context information, so we can see which part of the contract failed
 - re-arrange some of the information in the contracts
This commit is contained in:
Robby Findler 2012-04-18 15:19:29 -05:00
parent 32a2339d04
commit 17a723a63e
11 changed files with 988 additions and 602 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/racket/contract/private/arr-i-parse.rkt
View File

@ -289,7 +289,7 @@ code does the parsing and validation of the syntax.
(syntax->list #'(ctc-pr ...)))] (syntax->list #'(ctc-pr ...)))]
[any #f] [any #f]
[[_ ctc] [[_ ctc]
(list (eres #'id #f #'ctc (car (generate-temporaries '(eres)))))] (list (eres #'_ #f #'ctc (car (generate-temporaries '(eres)))))]
[[id ctc] [[id ctc]
(begin (begin
(check-id stx #'id) (check-id stx #'id)
@ -370,7 +370,10 @@ code does the parsing and validation of the syntax.
(syntax-case #'pre-leftover () (syntax-case #'pre-leftover ()
[() (raise-syntax-error [() (raise-syntax-error
#f #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 stx
(car (syntax->list leftover)))] (car (syntax->list leftover)))]
[x (void)]) [x (void)])
@ -387,7 +390,10 @@ code does the parsing and validation of the syntax.
(syntax-case #'pre-leftover () (syntax-case #'pre-leftover ()
[() (raise-syntax-error [() (raise-syntax-error
#f #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 stx
(car (syntax->list leftover)))] (car (syntax->list leftover)))]
[x (void)]) [x (void)])

764
collects/racket/contract/private/arr-i.rkt
View File

@ -23,62 +23,95 @@
(provide (rename-out [->i/m ->i])) (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)) ;; arg-dep-ctcs : (-> ??? (listof contract))
;; indy-arg-ctcs : (listof contract) ;; indy-arg-ctcs : (listof (cons symbol? contract))
;; rng-ctcs : (listof contract) ;; rng-ctcs : (listof (cons symbol? contract))
;; rng-dep-ctcs : (-> ??? (listof contract)) ;; rng-dep-ctcs : (-> ??? (listof contract))
;; indy-rng-ctcs : (listof contract) ;; indy-rng-ctcs : (listof (cons symbol? contract))
;; mandatory-args, opt-args : number ;; mandatory-args, opt-args : number
;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keyword<? ;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keyword<?
;; rest? : boolean ;; rest : (or/c symbol? #f)
;; here : quoted-spec for use in assigning indy blame ;; here : quoted-spec for use in assigning indy blame
;; mk-wrapper : creates the a wrapper function that implements the contract checking ;; mk-wrapper : creates the a wrapper function that implements the contract checking
(struct ->i (arg-ctcs arg-dep-ctcs indy-arg-ctcs (struct ->i (blame-info
rng-ctcs rng-dep-ctcs indy-rng-ctcs arg-ctcs arg-dep-ctcs indy-arg-ctcs
pre/post-procs rng-ctcs rng-dep-ctcs indy-rng-ctcs
mandatory-args opt-args mandatory-kwds opt-kwds rest? mtd? pre/post-procs
here mandatory-args opt-args mandatory-kwds opt-kwds rest
mk-wrapper mtd? here mk-wrapper name-info)
name-info)
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection #:projection
(λ (ctc) (λ (ctc)
(let ([arg-ctc-projs (map contract-projection (->i-arg-ctcs ctc))] (define arg-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-arg-ctcs ctc)))
[indy-arg-ctc-projs (map contract-projection (->i-indy-arg-ctcs ctc))] (define indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-indy-arg-ctcs ctc)))
[rng-ctc-projs (map contract-projection (->i-rng-ctcs ctc))] (define rng-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-rng-ctcs ctc)))
[indy-rng-ctc-projs (map contract-projection (->i-indy-rng-ctcs ctc))] (define indy-rng-ctc-projs (map (λ (x) (contract-projection (cdr x))) (->i-indy-rng-ctcs ctc)))
[func (->i-mk-wrapper ctc)] (define func (->i-mk-wrapper ctc))
[has-rest? (->i-rest? ctc)] (define has-rest (->i-rest ctc))
[here (->i-here ctc)]) (define here (->i-here ctc))
(λ (blame) (λ (blame)
(let* ([swapped-blame (blame-swap blame)] (define blames (for/list ([blame-info (->i-blame-info ctc)])
[indy-dom-blame (blame-replace-negative swapped-blame here)] (define name (vector-ref blame-info 0))
[indy-rng-blame (blame-replace-negative blame here)] (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))
[partial-doms (map (λ (dom) (dom swapped-blame)) arg-ctc-projs)] (define partial-doms
[partial-indy-doms (map (λ (dom) (dom indy-dom-blame)) indy-arg-ctc-projs)] (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))))))
[partial-rngs (map (λ (rng) (rng blame)) rng-ctc-projs)] (define partial-rngs
[partial-indy-rngs (map (λ (rng) (rng indy-rng-blame)) indy-rng-ctc-projs)]) (for/list ([rng-proj (in-list rng-ctc-projs)]
(apply func [pr (in-list (->i-rng-ctcs ctc))]
blame [n (in-naturals 1)])
swapped-blame (define name (car pr))
indy-dom-blame (rng-proj (blame-add-context blame
indy-rng-blame (if (eq? '_ name)
(λ (val mtd?) (if (null? (cdr rng-ctc-projs))
(if has-rest? "the result of"
(check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame) (format "the ~a result of" (n->th n)))
(check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame))) (format "the ~a result of" name))))))
ctc (define partial-indy-rngs
(append (->i-pre/post-procs ctc) (for/list ([rng-proj (in-list indy-rng-ctc-projs)]
partial-doms [rng-pr (in-list (->i-indy-rng-ctcs ctc))])
(->i-arg-dep-ctcs ctc) (rng-proj (blame-add-context indy-rng-blame (format "the ~a result of" (car rng-pr))))))
partial-indy-doms (apply func
partial-rngs (λ (val mtd?)
(->i-rng-dep-ctcs ctc) (if has-rest
partial-indy-rngs)))))) (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) #:name (λ (ctc)
(define (arg/ress->spec infos ctcs dep-ctcs skip?) (define (arg/ress->spec infos ctcs dep-ctcs skip?)
(let loop ([infos infos] (let loop ([infos infos]
@ -118,11 +151,11 @@
[rng-info (vector-ref name-info 3)] [rng-info (vector-ref name-info 3)]
[post-infos (vector-ref name-info 4)]) [post-infos (vector-ref name-info 4)])
`(->i ,(arg/ress->spec args-info `(->i ,(arg/ress->spec args-info
(->i-arg-ctcs ctc) (map cdr (->i-arg-ctcs ctc))
(->i-arg-dep-ctcs ctc) (->i-arg-dep-ctcs ctc)
(λ (x) (list-ref x 4))) (λ (x) (list-ref x 4)))
,@(let ([rests (arg/ress->spec args-info ,@(let ([rests (arg/ress->spec args-info
(->i-arg-ctcs ctc) (map cdr (->i-arg-ctcs ctc))
(->i-arg-dep-ctcs ctc) (->i-arg-dep-ctcs ctc)
(λ (x) (not (list-ref x 4))))]) (λ (x) (not (list-ref x 4))))])
(if (null? rests) (if (null? rests)
@ -130,7 +163,7 @@
(list rests))) (list rests)))
,@(if rest-info ,@(if rest-info
(case (car 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) ...])]) [(dep) `(#:rest [,(list-ref rest-info 1) ,(list-ref rest-info 2) ...])])
'()) '())
,@(apply ,@(apply
@ -144,7 +177,7 @@
'any] 'any]
[else [else
(let ([infos (arg/ress->spec rng-info (let ([infos (arg/ress->spec rng-info
(->i-rng-ctcs ctc) (map cdr (->i-rng-ctcs ctc))
(->i-rng-dep-ctcs ctc) (->i-rng-dep-ctcs ctc)
(λ (x) #f))]) (λ (x) #f))])
(cond (cond
@ -160,14 +193,14 @@
`(#:post ,(car post-info) ...))))))) `(#:post ,(car post-info) ...)))))))
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(let ([has-rest? (->i-rest? ctc)] (let ([has-rest (->i-rest ctc)]
[mtd? (->i-mtd? ctc)] [mtd? (->i-mtd? ctc)]
[mand-args (->i-mandatory-args ctc)] [mand-args (->i-mandatory-args ctc)]
[opt-args (->i-opt-args ctc)] [opt-args (->i-opt-args ctc)]
[mand-kwds (->i-mandatory-kwds ctc)] [mand-kwds (->i-mandatory-kwds ctc)]
[opt-kwds (->i-opt-kwds ctc)]) [opt-kwds (->i-opt-kwds ctc)])
(λ (val) (λ (val)
(if has-rest? (if has-rest
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f) (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))))) (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f)))))
#:stronger (λ (this that) (eq? this that)))) ;; WRONG #:stronger (λ (this that) (eq? this that)))) ;; WRONG
@ -392,14 +425,17 @@
;; -- the generated lets rebind these variables to their projected counterparts, with normal blame ;; -- 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 ;; (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 ;; (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 ;; 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" ;; WRONG: need to rename the variables in this function from "arg" to "arg/res"
(define-for-syntax (add-wrapper-let body swapped-blame? (define-for-syntax (add-wrapper-let body swapped-blame?
ordered-args arg-indices ordered-args arg-indices
arg-proj-vars indy-arg-proj-vars arg-proj-vars indy-arg-proj-vars
wrapper-args indy-arg-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) (define (add-unsupplied-check arg wrapper-arg stx)
(if (and (arg? arg) (if (and (arg? arg)
@ -409,6 +445,14 @@
#,stx) #,stx)
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]) (for/fold ([body body])
([indy-arg-var (in-list indy-arg-vars)] ([indy-arg-var (in-list indy-arg-vars)]
[arg (in-list ordered-args)] [arg (in-list ordered-args)]
@ -430,9 +474,7 @@
(if (arg/res-vars arg) (if (arg/res-vars arg)
#`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg)) #`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))
#,wrapper-arg #,wrapper-arg
#,(if swapped-blame? #,(add-blame-var #t swapped-blame? (arg/res-var arg)))
#'indy-dom-blame
#'indy-rng-blame))
#`(#,indy-arg-proj-var #,wrapper-arg)))]) #`(#,indy-arg-proj-var #,wrapper-arg)))])
(list))]) (list))])
#`(let (#,@indy-binding #`(let (#,@indy-binding
@ -444,27 +486,32 @@
[(and (eres? arg) (arg/res-vars arg)) [(and (eres? arg) (arg/res-vars arg))
#`(un-dep #,(eres-eid arg) #`(un-dep #,(eres-eid arg)
#,wrapper-arg #,wrapper-arg
#,(if swapped-blame? #,(add-blame-var #f swapped-blame? (arg/res-var arg)))]
#'swapped-blame
#'blame))]
[(arg/res-vars arg) [(arg/res-vars arg)
#`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg)) #`(#,arg-proj-var #,@(map arg/res-to-indy-var (arg/res-vars arg))
#,wrapper-arg #,wrapper-arg
#,(if swapped-blame? #,(add-blame-var #f swapped-blame? (arg/res-var arg)))]
#'swapped-blame
#'blame))]
[else [else
#`(#,arg-proj-var #,wrapper-arg)]))]) #`(#,arg-proj-var #,wrapper-arg)]))])
#,body))))) #,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 ;; 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 ;; which should be a function from results to projection-applied versions of the same
;; if there are result contracts. ;; if there are result contracts.
(define-for-syntax (result-checkers an-istx (define-for-syntax (build-result-checkers an-istx
ordered-ress res-indices ordered-ress res-indices
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars wrapper-ress indy-res-vars
arg/res-to-indy-var) arg/res-to-indy-var
blame-var-table)
(cond (cond
[(istx-ress an-istx) [(istx-ress an-istx)
(list (list
@ -475,7 +522,8 @@
ordered-ress res-indices ordered-ress res-indices
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
wrapper-ress indy-res-vars wrapper-ress indy-res-vars
arg/res-to-indy-var)))] arg/res-to-indy-var
blame-var-table)))]
[else [else
null])) null]))
@ -492,137 +540,157 @@
body))] body))]
[else stx])) [else stx]))
(define-for-syntax (mk-wrapper-func an-istx used-indy-vars) (define-for-syntax (mk-wrapper-func/blame-id-info an-istx used-indy-vars)
(let ([args+rst (append (istx-args an-istx) (define args+rst (append (istx-args an-istx)
(if (istx-rst an-istx) (if (istx-rst an-istx)
(list (istx-rst an-istx)) (list (istx-rst an-istx))
'()))]) '())))
(let-values ([(ordered-args arg-indices) (find-ordering args+rst)] (define-values (ordered-args arg-indices) (find-ordering args+rst))
[(ordered-ress res-indices) (if (istx-ress an-istx) (define-values (ordered-ress res-indices) (if (istx-ress an-istx)
(find-ordering (istx-ress an-istx)) (find-ordering (istx-ress an-istx))
(values '() '()))]) (values '() '())))
(let ([wrapper-args (list->vector (define wrapper-args (list->vector
(append (generate-temporaries (map arg/res-var (istx-args an-istx))) (append (generate-temporaries (map arg/res-var (istx-args an-istx)))
(if (istx-rst an-istx) (if (istx-rst an-istx)
(list #'rest-args) (list #'rest-args)
'())))] '()))))
[indy-arg-vars (generate-temporaries (map arg/res-var ordered-args))] (define indy-arg-vars (generate-temporaries (map arg/res-var ordered-args)))
[arg-proj-vars (list->vector (generate-temporaries (map arg/res-var args+rst)))] (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) ;; 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 ;; but it contains #fs in places where we don't need the indy projections (because the corresponding
;; argument is not dependened on by anything) ;; argument is not dependened on by anything)
[indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary (define indy-arg-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and (free-identifier-mapping-get used-indy-vars (and (free-identifier-mapping-get used-indy-vars
(arg/res-var x) (arg/res-var x)
(λ () #f)) (λ () #f))
(arg/res-var x)))) (arg/res-var x))))
args+rst))] args+rst)))
[wrapper-ress (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))] (define 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))] (define 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) '()))))] (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) ;; 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 ;; but it contains #fs in places where we don't need the indy projections (because the corresponding
;; result is not dependened on by anything) ;; result is not dependened on by anything)
[indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary (define indy-res-proj-vars (list->vector (map (λ (x) (maybe-generate-temporary
(and (free-identifier-mapping-get used-indy-vars (and (free-identifier-mapping-get used-indy-vars
(arg/res-var x) (arg/res-var x)
(λ () #f)) (λ () #f))
(arg/res-var x)))) (arg/res-var x))))
(or (istx-ress an-istx) '())))]) (or (istx-ress an-istx) '()))))
(define (arg/res-to-indy-var var) (define (arg/res-to-indy-var var)
(let loop ([iargs (append indy-arg-vars indy-res-vars)] (let loop ([iargs (append indy-arg-vars indy-res-vars)]
[args (append (map arg/res-var ordered-args) (map arg/res-var ordered-ress))]) [args (append (map arg/res-var ordered-args) (map arg/res-var ordered-ress))])
(cond (cond
[(null? args) [(null? args)
(error '->i "internal error; did not find a matching var for ~s" var)] (error '->i "internal error; did not find a matching var for ~s" var)]
[else [else
(let ([arg (car args)] (let ([arg (car args)]
[iarg (car iargs)]) [iarg (car iargs)])
(cond (cond
[(free-identifier=? var arg) iarg] [(free-identifier=? var arg) iarg]
[else (loop (cdr iargs) (cdr args))]))]))) [else (loop (cdr iargs) (cdr args))]))])))
(define this-param (and (syntax-parameter-value #'making-a-method) (define this-param (and (syntax-parameter-value #'making-a-method)
(car (generate-temporaries '(this))))) (car (generate-temporaries '(this)))))
#`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc (define blame-var-table (make-free-identifier-mapping))
;; the pre- and post-condition procs (define wrapper-body
#,@(for/list ([pres (istx-pre an-istx)] (add-wrapper-let
[i (in-naturals)]) (add-pre-cond
(string->symbol (format "pre-proc~a" i))) an-istx
#,@(for/list ([pres (istx-post an-istx)] arg/res-to-indy-var
[i (in-naturals)]) (add-eres-lets
(string->symbol (format "post-proc~a" i))) 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))
;; first the non-dependent arg projections (define blame-ids '())
#,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var)) (free-identifier-mapping-for-each
args+rst blame-var-table
(vector->list arg-proj-vars))) (λ (id prs)
;; then the dependent arg projections (for ([pr (in-list prs)])
#,@(filter values (map (λ (arg/res arg-proj-var) (and (arg/res-vars arg/res) arg-proj-var)) (define indy? (list-ref pr 0))
args+rst (define dom? (list-ref pr 1))
(vector->list arg-proj-vars))) (set! blame-ids (cons (cons (build-blame-identifier indy? dom? id)
;; then the non-dependent indy arg projections (vector (syntax-e id) indy? dom?))
#,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var)) blame-ids)))))
args+rst (set! blame-ids (sort blame-ids string<=? #:key (λ (x) (symbol->string (syntax-e (car x))))))
(vector->list indy-arg-proj-vars)))
(values
(map cdr blame-ids)
#`(λ (chk ctc blame swapped-blame #,@(map car blame-ids)
;; then the non-dependent res projections ;; the pre- and post-condition procs
#,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var)) #,@(for/list ([pres (istx-pre an-istx)]
(or (istx-ress an-istx) '()) [i (in-naturals)])
(vector->list res-proj-vars))) (string->symbol (format "pre-proc~a" i)))
;; then the dependent res projections #,@(for/list ([pres (istx-post an-istx)]
#,@(filter values (map (λ (arg/res res-proj-var) (and (arg/res-vars arg/res) res-proj-var)) [i (in-naturals)])
(or (istx-ress an-istx) '()) (string->symbol (format "post-proc~a" i)))
(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) ;; first the non-dependent arg projections
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var))
(let ([arg-checker args+rst
(λ #,(args/vars->arglist an-istx wrapper-args this-param) (vector->list arg-proj-vars)))
#,(add-wrapper-let ;; then the dependent arg projections
(add-pre-cond #,@(filter values (map (λ (arg/res arg-proj-var) (and (arg/res-vars arg/res) arg-proj-var))
an-istx args+rst
arg/res-to-indy-var (vector->list arg-proj-vars)))
(add-eres-lets ;; then the non-dependent indy arg projections
an-istx #,@(filter values (map (λ (arg/res arg-proj-var) (and (not (arg/res-vars arg/res)) arg-proj-var))
res-proj-vars args+rst
arg/res-to-indy-var (vector->list indy-arg-proj-vars)))
(args/vars->arg-checker
(result-checkers ;; then the non-dependent res projections
an-istx #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var))
ordered-ress res-indices (or (istx-ress an-istx) '())
res-proj-vars indy-res-proj-vars (vector->list res-proj-vars)))
wrapper-ress indy-res-vars ;; then the dependent res projections
arg/res-to-indy-var) #,@(filter values (map (λ (arg/res res-proj-var) (and (arg/res-vars arg/res) res-proj-var))
(istx-args an-istx) (or (istx-ress an-istx) '())
(istx-rst an-istx) (vector->list res-proj-vars)))
wrapper-args ;; then the non-dependent indy res projections
this-param))) #,@(filter values (map (λ (arg/res res-proj-var) (and (not (arg/res-vars arg/res)) res-proj-var))
#t (or (istx-ress an-istx) '())
ordered-args arg-indices (vector->list indy-res-proj-vars))))
arg-proj-vars indy-arg-proj-vars
wrapper-args indy-arg-vars (λ (val)
arg/res-to-indy-var))]) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(impersonate-procedure (let ([arg-checker
val (λ #,(args/vars->arglist an-istx wrapper-args this-param)
(make-keyword-procedure #,wrapper-body)])
(λ (kwds kwd-args . args) (impersonate-procedure
(keyword-apply arg-checker kwds kwd-args args)) val
(λ args (apply arg-checker args))) (make-keyword-procedure
impersonator-prop:contracted ctc)))))))) (λ (kwds kwd-args . args)
(keyword-apply arg-checker kwds kwd-args args))
(λ args (apply arg-checker args)))
impersonator-prop:contracted ctc))))))
(begin-encourage-inline (begin-encourage-inline
(define (un-dep ctc obj blame) (define (un-dep ctc obj blame)
@ -665,173 +733,179 @@
vars)) vars))
(define-syntax (->i/m stx) (define-syntax (->i/m stx)
(let* ([an-istx (parse-->i stx)] (define an-istx (parse-->i stx))
[used-indy-vars (mk-used-indy-vars an-istx)] (define used-indy-vars (mk-used-indy-vars an-istx))
[wrapper-func (mk-wrapper-func an-istx used-indy-vars)] (define-values (blame-ids-info wrapper-func) (mk-wrapper-func/blame-id-info an-istx used-indy-vars))
[args+rst (append (istx-args an-istx) (define args+rst (append (istx-args an-istx)
(if (istx-rst an-istx) (if (istx-rst an-istx)
(list (istx-rst an-istx)) (list (istx-rst an-istx))
'()))] '())))
[this->i (gensym 'this->i)]) (define this->i (gensym 'this->i))
(with-syntax ([(arg-exp-xs ...) (with-syntax ([(arg-exp-xs ...)
(generate-temporaries (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-var arg))) (generate-temporaries (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-var arg)))
args+rst)))] args+rst)))]
[(arg-exps ...) [((arg-names arg-exps) ...)
(filter values (map (λ (arg) (and (not (arg/res-vars arg)) (filter values (map (λ (arg) (and (not (arg/res-vars arg))
(list
(arg/res-var arg)
(syntax-property
(syntax-property (syntax-property
(syntax-property (arg/res-ctc arg)
(arg/res-ctc arg) 'racket/contract:negative-position
'racket/contract:negative-position this->i)
this->i) 'racket/contract:contract-on-boundary
'racket/contract:contract-on-boundary (gensym '->i-indy-boundary)))))
(gensym '->i-indy-boundary)))) args+rst))]
args+rst))]
[(res-exp-xs ...) [(res-exp-xs ...)
(if (istx-ress an-istx) (if (istx-ress an-istx)
(generate-temporaries (filter values (map (λ (res) (and (not (arg/res-vars res)) (arg/res-var res))) (generate-temporaries (filter values (map (λ (res) (and (not (arg/res-vars res)) (arg/res-var res)))
(istx-ress an-istx)))) (istx-ress an-istx))))
'())] '())]
[(res-exps ...) [((res-names res-exps) ...)
(if (istx-ress an-istx) (if (istx-ress an-istx)
(filter values (map (λ (res) (and (not (arg/res-vars res)) (filter values (map (λ (res) (and (not (arg/res-vars res))
(list
(arg/res-var res)
(syntax-property
(syntax-property (syntax-property
(syntax-property (arg/res-ctc res)
(arg/res-ctc res) 'racket/contract:positive-position
'racket/contract:positive-position this->i)
this->i) 'racket/contract:contract-on-boundary
'racket/contract:contract-on-boundary (gensym '->i-indy-boundary)))))
(gensym '->i-indy-boundary)))) (istx-ress an-istx)))
(istx-ress an-istx))) '())])
'())])
#`(let ([arg-exp-xs arg-exps] ... #`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ...
[res-exp-xs res-exps] ...) [res-exp-xs (coerce-contract '->i res-exps)] ...)
#,(syntax-property #,(syntax-property
#`(->i #`(->i
;; all of the non-dependent argument contracts ;; the information needed to make the blame records and their new contexts
(list arg-exp-xs ...) '#,blame-ids-info
;; all of the dependent argument contracts ;; all of the non-dependent argument contracts
(list #,@(filter values (map (λ (arg) (list (cons 'arg-names arg-exp-xs) ...)
(and (arg/res-vars arg) ;; all of the dependent argument contracts
#`(λ (#,@(arg/res-vars arg) val blame) (list #,@(filter values (map (λ (arg)
;; this used to use opt/direct, but opt/direct duplicates code (bad!) (and (arg/res-vars arg)
(un-dep #,(syntax-property #`(λ (#,@(arg/res-vars arg) val blame)
(syntax-property ;; this used to use opt/direct, but opt/direct duplicates code (bad!)
(arg/res-ctc arg) (un-dep #,(syntax-property
'racket/contract:negative-position (syntax-property
this->i) (arg/res-ctc arg)
'racket/contract:contract-on-boundary 'racket/contract:negative-position
(gensym '->i-indy-boundary)) this->i)
val blame)))) 'racket/contract:contract-on-boundary
args+rst))) (gensym '->i-indy-boundary))
;; then the non-dependent argument contracts that are themselves dependend on val blame))))
(list #,@(filter values args+rst)))
(map (λ (arg/res indy-id) ;; then the non-dependent argument contracts that are themselves dependend on
(and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) (list #,@(filter values
indy-id)) (map (λ (arg/res indy-id)
(filter (λ (arg/res) (not (arg/res-vars arg/res))) args+rst) (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f))
(syntax->list #'(arg-exp-xs ...))))) #`(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) #,(if (istx-ress an-istx)
#`(list res-exp-xs ...) #`(list (cons 'res-names res-exp-xs) ...)
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) #`(list #,@(filter values (map (λ (arg)
(and (arg/res-vars arg) (and (arg/res-vars arg)
(if (eres? arg) (if (eres? arg)
#`(λ #,(arg/res-vars arg) #`(λ #,(arg/res-vars arg)
(opt/c #,(syntax-property (opt/c #,(syntax-property
(syntax-property (syntax-property
(arg/res-ctc arg) (arg/res-ctc arg)
'racket/contract:positive-position 'racket/contract:positive-position
this->i) this->i)
'racket/contract:contract-on-boundary 'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary)))) (gensym '->i-indy-boundary))))
#`(λ (#,@(arg/res-vars arg) val blame) #`(λ (#,@(arg/res-vars arg) val blame)
;; this used to use opt/direct, but opt/direct duplicates code (bad!) ;; this used to use opt/direct, but opt/direct duplicates code (bad!)
(un-dep #,(syntax-property (un-dep #,(syntax-property
(syntax-property (syntax-property
(arg/res-ctc arg) (arg/res-ctc arg)
'racket/contract:positive-position 'racket/contract:positive-position
this->i) this->i)
'racket/contract:contract-on-boundary 'racket/contract:contract-on-boundary
(gensym '->i-indy-boundary)) (gensym '->i-indy-boundary))
val blame))))) val blame)))))
(istx-ress an-istx)))) (istx-ress an-istx))))
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values #`(list #,@(filter values
(map (λ (arg/res indy-id) (map (λ (arg/res indy-id)
(and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f))
indy-id)) #`(cons '#,(arg/res-var arg/res) #,indy-id)))
(filter (λ (arg/res) (not (arg/res-vars arg/res))) (istx-ress an-istx)) (filter (λ (arg/res) (not (arg/res-vars arg/res))) (istx-ress an-istx))
(syntax->list #'(res-exp-xs ...))))) (syntax->list #'(res-exp-xs ...)))))
#''()) #''())
#,(let ([func (λ (pre/post) #`(λ #,(pre/post-vars pre/post) #,(pre/post-exp pre/post)))]) #,(let ([func (λ (pre/post) #`(λ #,(pre/post-vars pre/post) #,(pre/post-exp pre/post)))])
#`(list #,@(for/list ([pre (in-list (istx-pre an-istx))]) #`(list #,@(for/list ([pre (in-list (istx-pre an-istx))])
(func pre)) (func pre))
#,@(for/list ([post (in-list (istx-post an-istx))]) #,@(for/list ([post (in-list (istx-post an-istx))])
(func post)))) (func post))))
#,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg)))) #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg))))
(istx-args an-istx)))) (istx-args an-istx))))
#,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (arg-optional? arg))) #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (arg-optional? arg)))
(istx-args an-istx)))) (istx-args an-istx))))
'#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) (arg-kwd arg) (syntax-e (arg-kwd arg)))) '#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) (arg-kwd arg) (syntax-e (arg-kwd arg))))
(istx-args an-istx))) (istx-args an-istx)))
keyword<?) keyword<?)
'#,(sort (filter values (map (λ (arg) (and (arg-optional? arg) (arg-kwd arg) (syntax-e (arg-kwd arg)))) '#,(sort (filter values (map (λ (arg) (and (arg-optional? arg) (arg-kwd arg) (syntax-e (arg-kwd arg))))
(istx-args an-istx))) (istx-args an-istx)))
keyword<?) keyword<?)
#,(and (istx-rst an-istx) #t) '#,(and (istx-rst an-istx) (arg/res-var (istx-rst an-istx)))
#,(and (syntax-parameter-value #'making-a-method) #t) #,(and (syntax-parameter-value #'making-a-method) #t)
(quote-module-name) (quote-module-name)
#,wrapper-func #,wrapper-func
'#(#,(for/list ([an-arg (in-list (istx-args an-istx))]) '#(#,(for/list ([an-arg (in-list (istx-args an-istx))])
`(,(if (arg/res-vars an-arg) 'dep 'nodep) `(,(if (arg/res-vars an-arg) 'dep 'nodep)
,(syntax-e (arg/res-var an-arg)) ,(syntax-e (arg/res-var an-arg))
,(if (arg/res-vars an-arg) ,(if (arg/res-vars an-arg)
(map syntax-e (arg/res-vars an-arg)) (map syntax-e (arg/res-vars an-arg))
'()) '())
,(and (arg-kwd an-arg) ,(and (arg-kwd an-arg)
(syntax-e (arg-kwd an-arg))) (syntax-e (arg-kwd an-arg)))
,(arg-optional? an-arg))) ,(arg-optional? an-arg)))
#,(if (istx-rst an-istx) #,(if (istx-rst an-istx)
(if (arg/res-vars (istx-rst an-istx)) (if (arg/res-vars (istx-rst an-istx))
`(dep ,(syntax-e (arg/res-var (istx-rst an-istx))) `(dep ,(syntax-e (arg/res-var (istx-rst an-istx)))
,(map syntax-e (arg/res-vars (istx-rst an-istx)))) ,(map syntax-e (arg/res-vars (istx-rst an-istx))))
`(nodep ,(syntax-e (arg/res-var (istx-rst an-istx))))) `(nodep ,(syntax-e (arg/res-var (istx-rst an-istx)))))
#f) #f)
#,(for/list ([pre (in-list (istx-pre an-istx))]) #,(for/list ([pre (in-list (istx-pre an-istx))])
(list (map syntax-e (pre/post-vars pre)) (list (map syntax-e (pre/post-vars pre))
(pre/post-str pre))) (pre/post-str pre)))
#,(and (istx-ress an-istx) #,(and (istx-ress an-istx)
(for/list ([a-res (in-list (istx-ress an-istx))]) (for/list ([a-res (in-list (istx-ress an-istx))])
`(,(if (arg/res-vars a-res) 'dep 'nodep) `(,(if (arg/res-vars a-res) 'dep 'nodep)
,(if (eres? a-res) ,(if (eres? a-res)
'_ '_
(syntax-e (arg/res-var a-res))) (syntax-e (arg/res-var a-res)))
,(if (arg/res-vars a-res) ,(if (arg/res-vars a-res)
(map syntax-e (arg/res-vars a-res)) (map syntax-e (arg/res-vars a-res))
'()) '())
#f #f
#f))) #f)))
#,(for/list ([post (in-list (istx-post an-istx))]) #,(for/list ([post (in-list (istx-post an-istx))])
(list (map syntax-e (pre/post-vars post)) (list (map syntax-e (pre/post-vars post))
(pre/post-str post))))) (pre/post-str post)))))
'racket/contract:contract 'racket/contract:contract
(let () (let ()
(define (find-kwd kwd) (define (find-kwd kwd)
(for/or ([x (in-list (syntax->list stx))]) (for/or ([x (in-list (syntax->list stx))])
(and (eq? (syntax-e x) kwd) (and (eq? (syntax-e x) kwd)
x))) x)))
(define pre (find-kwd '#:pre)) (define pre (find-kwd '#:pre))
(define post (find-kwd '#:post)) (define post (find-kwd '#:post))
(define orig (list (car (syntax-e stx)))) (define orig (list (car (syntax-e stx))))
(vector this->i (vector this->i
;; the ->i in the original input to this guy ;; the ->i in the original input to this guy
(if post (cons post orig) orig) (if post (cons post orig) orig)
(if pre (list pre) '())))))))) (if pre (list pre) '())))))))

123
collects/racket/contract/private/arrow.rkt
View File

@ -330,14 +330,14 @@ v4 todo:
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([basic-lambda-name basic-lambda]) (let ([basic-lambda-name basic-lambda])
(arity-checking-wrapper val blame (arity-checking-wrapper val blame
basic-lambda-name basic-lambda-name
void void
#,min-method-arity #,min-method-arity
#,max-method-arity #,max-method-arity
#,min-arity #,min-arity
#,(if dom-rest #f max-arity) #,(if dom-rest #f max-arity)
'(req-kwd ...) '(req-kwd ...)
'(opt-kwd ...))))] '(opt-kwd ...))))]
[(pair? req-keywords) [(pair? req-keywords)
#`(let-values ([(rng-checker-name ...) (values rng-checker ...)]) #`(let-values ([(rng-checker-name ...) (values rng-checker ...)])
(let ([kwd-lambda-name kwd-lambda]) (let ([kwd-lambda-name kwd-lambda])
@ -471,23 +471,34 @@ v4 todo:
[mtd? (base->-mtd? ctc)]) [mtd? (base->-mtd? ctc)])
(λ (orig-blame) (λ (orig-blame)
(define rng-blame (blame-add-context orig-blame "the range of")) (define rng-blame (blame-add-context orig-blame "the range of"))
(define swapped (blame-swap orig-blame)) (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
(define swapped-domain (blame-add-context swapped "the domain of"))
(define partial-doms (define partial-doms
(for/list ([dom (in-list doms-proj)] (for/list ([dom (in-list doms-proj)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(dom (blame-add-context swapped (dom (blame-add-context orig-blame
(format "the ~a argument of" (format "the ~a argument of"
(n->th n)))))) (n->th n))
#:swap? #t))))
(define partial-optional-doms (define partial-optional-doms
(for/list ([dom (in-list doms-optional-proj)] (for/list ([dom (in-list doms-optional-proj)]
[n (in-naturals (+ 1 (length doms-proj)))]) [n (in-naturals (+ 1 (length doms-proj)))])
(dom (blame-add-context swapped (dom (blame-add-context orig-blame
(format "the ~a argument of" (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-ranges (map (λ (rng) (rng rng-blame)) rngs-proj))
(define partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)) (define partial-mandatory-kwds
(define partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)) (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 (define the-args (append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds partial-mandatory-kwds partial-optional-kwds
partial-ranges)) partial-ranges))
@ -1192,7 +1203,6 @@ v4 todo:
[else [else
(cons (+ mandatory-count i) (loop (+ i 1)))]))])]) (cons (+ mandatory-count i) (loop (+ i 1)))]))])])
(λ (blame) (λ (blame)
(let ([blame (blame-add-context blame "the domain of")])
(λ (val) (λ (val)
(if (base-->d-rest-ctc ->d-stct) (if (base-->d-rest-ctc ->d-stct)
(check-procedure/more val (check-procedure/more val
@ -1274,7 +1284,8 @@ v4 todo:
(invoke-dep-ctc (car result-contracts) (invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args) (if rng-underscore? #f dep-post-args)
(car results) (car results)
blame) blame
#f)
(loop (cdr results) (cdr result-contracts)))])))))) (loop (cdr results) (cdr result-contracts)))]))))))
null)) null))
@ -1287,7 +1298,7 @@ v4 todo:
[(or (null? building-kwd-args) (null? all-kwds)) '()] [(or (null? building-kwd-args) (null? all-kwds)) '()]
[else (if (eq? (car all-kwds) [else (if (eq? (car all-kwds)
(car building-kwd-args)) (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) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args 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))) (if (null? kwd-res) null (list kwd-res)))
@ -1305,20 +1316,20 @@ v4 todo:
(cond (cond
[(null? args) [(null? args)
(if (base-->d-rest-ctc ->d-stct) (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) [(null? non-kwd-ctcs)
(if (base-->d-rest-ctc ->d-stct) (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. ;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is ;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen. ;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ 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) (loop (cdr args)
(cdr non-kwd-ctcs)))]))))))) (cdr non-kwd-ctcs)))])))))))
impersonator-prop:contracted ->d-stct)))))) impersonator-prop:contracted ->d-stct)))))
(define (build-values-string desc dep-pre-args) (define (build-values-string desc dep-pre-args)
(cond (cond
@ -1335,11 +1346,16 @@ v4 todo:
(loop (cdr lst)))])))])) (loop (cdr lst)))])))]))
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst ;; 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 (let ([ctc (coerce-contract '->d (if dep-args
(apply dep-ctc dep-args) (apply dep-ctc dep-args)
dep-ctc))]) 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) ;; 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) (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) (define (case->-proj wrapper)
(λ (ctc) (λ (ctc)
(let* ([dom-ctcs (map contract-projection (get-case->-dom-ctcs ctc))] (define dom-ctcs (map contract-projection (get-case->-dom-ctcs ctc)))
[rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)]) (define rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)])
(and rngs (map contract-projection (get-case->-rng-ctcs ctc))))] (and rngs (map contract-projection (get-case->-rng-ctcs ctc)))))
[rst-ctcs (base-case->-rst-ctcs ctc)] (define rst-ctcs (base-case->-rst-ctcs ctc))
[specs (base-case->-specs ctc)]) (define specs (base-case->-specs ctc))
(λ (blame) (λ (blame)
(define dom-blame (blame-add-context (blame-swap blame) "the domain of")) (define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
(define rng-blame (blame-add-context blame "the range of")) (define rng-blame (blame-add-context blame "the range of"))
(let ([projs (append (map (λ (f) (f dom-blame)) dom-ctcs) (define projs (append (map (λ (f) (f dom-blame)) dom-ctcs)
(map (λ (f) (f rng-blame)) rng-ctcs))] (map (λ (f) (f rng-blame)) rng-ctcs)))
[chk (define (chk val mtd?)
(λ (val mtd?) (cond
(cond [(null? specs)
[(null? specs) (unless (procedure? val)
(unless (procedure? val) (raise-blame-error blame val "expected a procedure"))]
(raise-blame-error blame val "expected a procedure"))] [else
[else (for-each
(for-each (λ (dom-length has-rest?)
(λ (dom-length has-rest?) (if has-rest?
(if has-rest? (check-procedure/more val mtd? dom-length '() '() blame)
(check-procedure/more val mtd? dom-length '() '() blame) (check-procedure val mtd? dom-length 0 '() '() blame)))
(check-procedure val mtd? dom-length 0 '() '() blame))) specs rst-ctcs)]))
specs rst-ctcs)]))]) (apply (base-case->-wrapper ctc)
(apply (base-case->-wrapper ctc) chk
chk wrapper
wrapper blame
blame ctc
ctc projs))))
projs))))))
(define (case->-name ctc) (define (case->-name ctc)
(apply (apply

177
collects/racket/contract/private/blame.rkt
View File

@ -13,6 +13,7 @@
blame-swap blame-swap
blame-replace-negative ;; used for indy blame blame-replace-negative ;; used for indy blame
blame-add-context blame-add-context
blame-add-unknown-context
blame-context blame-context
raise-blame-error raise-blame-error
@ -36,20 +37,35 @@
(hash/recur (blame-original? b)))) (hash/recur (blame-original? b))))
(define-struct blame (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 #:property prop:equal+hash
(list blame=? blame-hash blame-hash)) (list blame=? blame-hash blame-hash))
(define -make-blame (define -make-blame
(let ([make-blame (let ([make-blame
(λ (source value build-name positive negative original?) (λ (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)) 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 (struct-copy
blame b 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))) (define (blame-contract b) ((blame-build-name b)))
@ -76,90 +92,82 @@
(current-continuation-marks) (current-continuation-marks)
b))) b)))
(define (default-blame-format b x custom-message) (define (default-blame-format blme x custom-message)
(let* ([source-message (source-location->string (blame-source b))] (define source-message (source-location->string (blame-source blme)))
[positive-message (show/display (convert-blame-party (blame-positive b)))] (define positive-message (show/display (convert-blame-party (blame-positive blme))))
[context-message (apply string-append (define context (blame-context blme))
(for/list ([context (in-list (blame-context b))] (define context-lines (if (null? context)
[n (in-naturals)]) #f
(format (if (zero? n) (apply string-append
" in: ~a\n" (for/list ([context (in-list context)]
" ~a\n") [n (in-naturals)])
context)))] (format (if (zero? n)
[the-contract-str (show/write (blame-contract b))] " in: ~a\n"
[contract-message (string-append (if (regexp-match #rx"\n" the-contract-str) " ~a\n")
(string-append (regexp-replace #rx"\n$" context-message "") context)))))
the-contract-str) (define contract-line (show/write (blame-contract blme) #:alone? #t))
(string-append context-message (define at-line (if (string=? source-message "")
(format " ~a" the-contract-str))))] #f
[contract-message+at (format " at: ~a" source-message)))
(regexp-replace
#rx"^\n" (define self-or-not (if (blame-original? blme)
(if (regexp-match #rx"\n$" contract-message) "self-contract violation"
(string-append contract-message "contract violation"))
(if (string=? source-message "")
"" (define start-of-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
(cond (cond
[(blame-original? b) [(blame-important blme)
(define start-of-message (format "~a: ~a" (blame-important blme) self-or-not)]
(if (blame-value b) [(blame-value blme)
(format "~a: self-contract violation," (blame-value b)) (format "~a: ~a" (blame-value blme) self-or-not)]
"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)]
[else [else
(define negative-message (show/display (convert-blame-party (blame-negative b)))) (format "~a:" self-or-not)]))
(define start-of-message
(if (blame-value b) (define blaming-line (format " blaming: ~a" positive-message))
(format "~a: contract violation," (blame-value b))
"contract violation:")) (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 (string-append
(format "~a ~a\n" start-of-message custom-message) " in:"
(format " contract from: ~a~a blaming: ~a~a" (substring contract-line 5 (string-length contract-line))))
negative-message from-line
(if (regexp-match #rx"\n" negative-message) blaming-line
" " at-line))
",")
positive-message
(if (regexp-match #rx"\n" positive-message)
""
"\n"))
contract-message+at)])))
(define (add-newline str) ;; combine-lines : (->* #:rest (listof (or/c string? #f))) string?)
(if (regexp-match #rx"\n$" str) ;; combines each of 'lines' into a single message, dropping #fs,
str ;; and otherwise guaranteeing that each string is on its own line.
(string-append str "\n"))) (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 (let* ([line
(parameterize ([pretty-print-columns 'infinity]) (parameterize ([pretty-print-columns 'infinity])
(f v))]) (f v))])
(if (< (string-length line) 30) (if (< (string-length line) 30)
line (cond
(parameterize ([pretty-print-print-line show-line-break] [alone? (string-append spacer line)]
[pretty-print-columns 50]) [else line])
(f v))))) (parameterize ([pretty-print-print-line (show-line-break alone?)]
[pretty-print-columns 50])
(f v)))))
(define (pretty-format/display v [columns (pretty-print-columns)]) (define (pretty-format/display v [columns (pretty-print-columns)])
(let ([port (open-output-string)]) (let ([port (open-output-string)])
@ -179,11 +187,16 @@
(define show/display (show pretty-format/display)) (define show/display (show pretty-format/display))
(define show/write (show pretty-format/write)) (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 (if line
(begin (display " " port) 6) (begin (display spacer port) 6)
0)) 0))
(define spacer " ")
(define current-blame-format (define current-blame-format
(make-parameter default-blame-format)) (make-parameter default-blame-format))

30
collects/racket/contract/private/prop.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(require "blame.rkt" (require "blame.rkt"
"generate-base.rkt") "generate-base.rkt"
racket/performance-hint)
(provide prop:contract (provide prop:contract
contract-struct? contract-struct?
@ -196,9 +197,11 @@
[get-first-order (or get-first-order get-any?)] [get-first-order (or get-first-order get-any?)]
[get-projection [get-projection
(cond (cond
[get-projection (if (skip-projection-wrapper?) [get-projection
get-projection (blame-context-projection-wrapper
(projection-wrapper get-projection))] (if (skip-projection-wrapper?)
get-projection
(projection-wrapper get-projection)))]
[else (get-first-order-projection [else (get-first-order-projection
get-name get-first-order)])] get-name get-first-order)])]
[stronger (or stronger weakest)]) [stronger (or stronger weakest)])
@ -233,6 +236,12 @@
(error 'prop:chaperone-contract (format "expected a chaperone of ~v, got ~v" v v*))) (error 'prop:chaperone-contract (format "expected a chaperone of ~v, got ~v" 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 (define build-chaperone-contract-property
(build-property (compose make-chaperone-contract-property make-contract-property) (build-property (compose make-chaperone-contract-property make-contract-property)
'anonymous-chaperone-contract 'anonymous-chaperone-contract
@ -246,12 +255,13 @@
(define ((get-first-order-projection get-name get-first-order) c) (define ((get-first-order-projection get-name get-first-order) c)
(first-order-projection (get-name c) (get-first-order c))) (first-order-projection (get-name c) (get-first-order c)))
(define (first-order-projection name first-order) (begin-encourage-inline
(λ (b) (define (first-order-projection name first-order)
(λ (x) (λ (b)
(if (first-order x) (λ (x)
x (if (first-order x)
(raise-blame-error b x "expected: ~s, given: ~e" name x))))) x
(raise-blame-error b x "expected: ~s, given: ~e" name x))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;

5
collects/racket/private/class-internal.rkt
View File

@ -2969,7 +2969,10 @@
[name [name
;; the procedure name of a method has ' method in ...' in it; trim that away ;; 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) "")) (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 [else
(blame-add-context blame "an unnamed method in")])) (blame-add-context blame "an unnamed method in")]))

27
collects/scribblings/guide/contracts-intro.scrbl
View File

@ -204,32 +204,23 @@ parties in a contract, examples involve multiple modules.
To experiment with multiple modules within a single module or within To experiment with multiple modules within a single module or within
DrRacket's @tech{definitions area}, use the DrRacket's @tech{definitions area}, use the
@racketmodname[racket/load] language. The contents of such a module Racket's submodules. For example, try the example earlier in
can be other modules (and @racket[require] statements), using the this section like this:
longhand parenthesized syntax for a module (see
@secref["module-syntax"]). For example, try the example earlier in
this section as follows:
@racketmod[ @racketmod[
racket/load racket
(module m racket (module+ server
(provide (contract-out [amount (and/c number? positive?)])) (provide (contract-out [amount (and/c number? positive?)]))
(define amount 150)) (define amount 150))
(module n racket (module+ main
(require 'm) (require (submod ".." server))
(+ amount 10)) (+ amount 10))
]
(require 'n)]
Each of the modules and their contracts are wrapped in parentheses 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[module] is the name of the module to be used in a subsequent
@racket[require] statement (where each reference through a @racket[require] statement (where each reference through a
@racket[require] prefixes the name with a quote). The second form @racket[require] prefixes the name with @racket[".."]).
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.

57
collects/scribblings/guide/contracts-simple-function.scrbl
View File

@ -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 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 so that client programmers have all the information from interfaces. It's a
piece of art: piece of art:
@racketmod[ @interaction[#:eval
racket contract-eval
(module bank-server racket
(provide
(contract-out
[deposit (-> (λ (x)
(and (number? x) (integer? x) (>= x 0)))
any)]))
(provide (define total 0)
(contract-out (define (deposit a) (set! total (+ a total))))]
[deposit (-> (lambda (x)
(and (number? x) (integer? x) (>= x 0)))
any)]))
(define this 0)
(define (deposit a) ...)
]
Several clients used your module. Others used their Several clients used your module. Others used their
modules in turn. And all of a sudden one of them sees this error modules in turn. And all of a sudden one of them sees this error
message: message:
@inset-flow{@racketerror{bank-client broke the contract (-> ??? any) @interaction[#:eval
it had with myaccount on deposit; expected <???>, given: -10}} contract-eval
(require 'bank-server)
(deposit -10)]
Clearly, @racket[bank-client] is a module that uses @racket[myaccount] What is the @racketerror{???} doing there? Wouldn't it be nice if
but 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, we had a name for this class of data much like we have string, number,
and so on? 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 boolean. The ``named'' part says what we want to do, which is to name
the contract so that error messages become intelligible: the contract so that error messages become intelligible:
@racketmod[ @interaction[#:eval
racket contract-eval
(module improved-bank-server racket
(define (amount? x) (and (number? x) (integer? x) (>= x 0)))
(define amount (flat-named-contract 'amount amount?))
(define (amount? x) (and (number? x) (integer? x) (>= x 0))) (provide (contract-out [deposit (amount . -> . any)]))
(define amount (flat-named-contract 'amount amount?))
(provide (contract-out [deposit (amount . -> . any)])) (define total 0)
(define (deposit a) (set! total (+ a total))))]
(define this 0) With this little change, the error message becomes quite readable:
(define (deposit a) ...)
]
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 <amount>, given: -10}}
@interaction[#:eval
contract-eval
(require 'improved-bank-server)
(deposit -10)]

7
collects/scribblings/guide/contracts-utils.rkt
View File

@ -3,13 +3,15 @@
(require scribble/basic (require scribble/basic
(for-syntax racket/port) (for-syntax racket/port)
racket/include racket/include
scribble/eval
(except-in scribble/manual link)) (except-in scribble/manual link))
(provide ctc-section (provide ctc-section
ctc-link ctc-link
exercise exercise
solution solution
external-file) external-file
contract-eval)
(define (ctc-section #:tag [tag #f] . rest) (define (ctc-section #:tag [tag #f] . rest)
(keyword-apply section (keyword-apply section
@ -69,3 +71,6 @@
[(_ filename) [(_ filename)
#`(include/reader #,(format "contracts-examples/~a.rkt" (syntax-e #'filename)) #`(include/reader #,(format "contracts-examples/~a.rkt" (syntax-e #'filename))
comment-racketmod-reader)])) comment-racketmod-reader)]))
(define contract-eval (make-base-eval))
(contract-eval '(require racket/contract))

56
collects/scribblings/reference/contracts.scrbl
View File

@ -1355,11 +1355,15 @@ We can use this insight to generalize the function contracts
and build a function that accepts any two contracts and and build a function that accepts any two contracts and
returns a contract for functions between them. 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[ @racketblock[
(define (make-simple-function-contract dom-proj range-proj) (define (make-simple-function-contract dom-proj range-proj)
(lambda (blame) (lambda (blame)
(let ([dom (dom-proj (blame-swap blame))] (let ([dom (dom-proj (blame-add-context blame "the argument of" #:swap? #t))]
[rng (range-proj blame)]) [rng (range-proj (blame-add-context blame "the range of"))])
(lambda (f) (lambda (f)
(if (and (procedure? f) (if (and (procedure? f)
(procedure-arity-includes? f 1)) (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}. 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[( @deftogether[(
@defproc[(blame-positive [b blame?]) any/c] @defproc[(blame-positive [b blame?]) any/c]
@defproc[(blame-negative [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?]{ @defproc[(blame-swap [b blame?]) blame?]{
This function swaps the positive and negative parties of a @tech{blame object}. This function swaps the positive and negative parties of a @tech{blame object}.
(See also @racket[blame-add-context].)
} }
@deftogether[( @deftogether[(

282
collects/tests/racket/contract-test.rktl
View File

@ -143,10 +143,15 @@
(define (has-proper-blame? msg) (define (has-proper-blame? msg)
(define reg (define reg
(cond (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"] [(eq? blame 'neg) #rx"blaming: neg"]
[(string? blame) (string-append "blaming: " (regexp-quote blame))] [(string? blame) (string-append "blaming: " (regexp-quote blame))]
[else #f])) [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))) (and reg (regexp-match? reg msg)))
(printf "testing: ~s\n" name) (printf "testing: ~s\n" name)
(contract-eval (contract-eval
@ -3041,7 +3046,7 @@
;; test to make sure the values are in the error messages ;; test to make sure the values are in the error messages
(contract-error-test (contract-error-test
'contract-error-test1 '->i-contract-error-test1
#'((contract (->i ([x number?]) #:pre (x) #f any) #'((contract (->i ([x number?]) #:pre (x) #f any)
(λ (x) x) (λ (x) x)
'pos 'pos
@ -3051,7 +3056,7 @@
(and (exn:fail:contract:blame? x) (and (exn:fail:contract:blame? x)
(regexp-match #rx"x: 123456789" (exn-message x))))) (regexp-match #rx"x: 123456789" (exn-message x)))))
(contract-error-test (contract-error-test
'contract-error-test2 '->i-contract-error-test2
#'((contract (->i ([|x y| number?]) #:pre (|x y|) #f any) #'((contract (->i ([|x y| number?]) #:pre (|x y|) #f any)
(λ (x) x) (λ (x) x)
'pos 'pos
@ -3063,13 +3068,24 @@
;; test to make sure the collects directories are appropriately prefixed ;; test to make sure the collects directories are appropriately prefixed
(contract-error-test (contract-error-test
'contract-error-test3 '->i-contract-error-test3
#'(contract symbol? "not a symbol" 'pos 'neg 'not-a-symbol #'here) #'(contract symbol? "not a symbol" 'pos 'neg 'not-a-symbol #'here)
(lambda (x) (lambda (x)
(and (exn:fail:contract:blame? x) (and (exn:fail:contract:blame? x)
(regexp-match? #px"<collects>" (regexp-match? #px"<collects>"
(exn-message x))))) (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 (test/neg-blame
'->i-protect-shared-state '->i-protect-shared-state
'(let ([x 1]) '(let ([x 1])
@ -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 (define str
(with-handlers ((exn:fail:contract:blame? exn-message)) (with-handlers ((exn:fail:contract:blame? exn-message))
(thunk) (thunk)
"didn't raise an exception")) "didn't raise an exception"))
(define lines (define m (regexp-match #rx".*\n +in: (.*)$" str))
(regexp-split (cond
#rx"\n " [m
(regexp-replace #rx"(.*)\n in: " str ""))) (define without-prefix (list-ref m 1))
(for/list ([answer-count (in-range num)] (define m2 (regexp-match #rx"(.*)\n *contract from:" without-prefix))
[msg-str (in-list lines)]) (cond
msg-str))) [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") (ctest '("the cdr of" "the 1st argument of")
extract-context-lines extract-context-lines
@ -11318,8 +11354,7 @@ so that propagation occurs.
(λ (x y) x) (λ (x y) x)
'pos 'pos
'neg) 'neg)
(cons 1 2) 1)) (cons 1 2) 1)))
2)
(ctest '("the 3rd element of" "the 2nd argument of") (ctest '("the 3rd element of" "the 2nd argument of")
extract-context-lines extract-context-lines
@ -11327,8 +11362,7 @@ so that propagation occurs.
(λ (x y) x) (λ (x y) x)
'pos 'pos
'neg) 'neg)
1 (list 1 2 3))) 1 (list 1 2 3))))
2)
(ctest '("the range of" "the 4th element of") (ctest '("the range of" "the 4th element of")
extract-context-lines extract-context-lines
@ -11336,16 +11370,14 @@ so that propagation occurs.
(list 1 2 #f (λ (x) #f)) (list 1 2 #f (λ (x) #f))
'pos 'pos
'neg)) 'neg))
1)) 1)))
2)
(ctest '("a disjunct of") (ctest '("a disjunct of")
extract-context-lines extract-context-lines
(λ () (contract (or/c 1 (-> number? number?)) (λ () (contract (or/c 1 (-> number? number?))
3 3
'pos 'pos
'neg)) 'neg)))
1)
(ctest '("the range of" "a disjunct of") (ctest '("the range of" "a disjunct of")
extract-context-lines extract-context-lines
@ -11353,49 +11385,235 @@ so that propagation occurs.
(λ (x) #f) (λ (x) #f)
'pos 'pos
'neg) 'neg)
1)) 1)))
2)
(ctest '("the 2nd conjunct of") (ctest '("the 2nd conjunct of")
extract-context-lines extract-context-lines
(λ () (contract (and/c procedure? (-> integer? integer?)) (λ () (contract (and/c procedure? (-> integer? integer?))
(λ (x y) 1) (λ (x y) 1)
'pos 'pos
'neg)) 'neg)))
1)
(ctest '("an element of") (ctest '("an element of")
extract-context-lines extract-context-lines
(λ () (contract (listof number?) (λ () (contract (listof number?)
(list #f) (list #f)
'pos 'pos
'neg)) 'neg)))
1)
(ctest '("the promise from") (ctest '("the promise from")
extract-context-lines extract-context-lines
(λ () (force (contract (promise/c number?) (λ () (force (contract (promise/c number?)
(delay #f) (delay #f)
'pos 'pos
'neg))) 'neg))))
1)
(ctest '("the parameter of") (ctest '("the parameter of")
extract-context-lines extract-context-lines
(λ () ((contract (parameter/c number?) (λ () ((contract (parameter/c number?)
(make-parameter #f) (make-parameter #f)
'pos 'pos
'neg))) 'neg))))
1)
(ctest '("the parameter of") (ctest '("the parameter of")
extract-context-lines extract-context-lines
(λ () ((contract (parameter/c number?) (λ () ((contract (parameter/c number?)
(make-parameter 1) (make-parameter 1)
'pos 'pos
'neg) 'neg)
#f)) #f)))
1) (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)))
; ;
; ;