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
This commit is contained in:
Robby Findler
parent
32a2339d04
commit
17a723a63e
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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 keyword<?
|
||||
;; rest? : boolean
|
||||
;; rest : (or/c symbol? #f)
|
||||
;; here : quoted-spec for use in assigning indy blame
|
||||
;; mk-wrapper : creates the a wrapper function that implements the contract checking
|
||||
(struct ->i (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)))
|
||||
keyword<?)
|
||||
'#,(sort (filter values (map (λ (arg) (and (arg-optional? arg) (arg-kwd arg) (syntax-e (arg-kwd arg))))
|
||||
(istx-args an-istx)))
|
||||
keyword<?)
|
||||
#,(and (istx-rst an-istx) #t)
|
||||
#,(and (syntax-parameter-value #'making-a-method) #t)
|
||||
(quote-module-name)
|
||||
#,wrapper-func
|
||||
'#(#,(for/list ([an-arg (in-list (istx-args an-istx))])
|
||||
`(,(if (arg/res-vars an-arg) 'dep 'nodep)
|
||||
,(syntax-e (arg/res-var an-arg))
|
||||
,(if (arg/res-vars an-arg)
|
||||
(map syntax-e (arg/res-vars an-arg))
|
||||
'())
|
||||
,(and (arg-kwd an-arg)
|
||||
(syntax-e (arg-kwd an-arg)))
|
||||
,(arg-optional? an-arg)))
|
||||
#,(if (istx-rst an-istx)
|
||||
(if (arg/res-vars (istx-rst an-istx))
|
||||
`(dep ,(syntax-e (arg/res-var (istx-rst an-istx)))
|
||||
,(map syntax-e (arg/res-vars (istx-rst an-istx))))
|
||||
`(nodep ,(syntax-e (arg/res-var (istx-rst an-istx)))))
|
||||
#f)
|
||||
#,(for/list ([pre (in-list (istx-pre an-istx))])
|
||||
(list (map syntax-e (pre/post-vars pre))
|
||||
(pre/post-str pre)))
|
||||
#,(and (istx-ress an-istx)
|
||||
(for/list ([a-res (in-list (istx-ress an-istx))])
|
||||
`(,(if (arg/res-vars a-res) 'dep 'nodep)
|
||||
,(if (eres? a-res)
|
||||
'_
|
||||
(syntax-e (arg/res-var a-res)))
|
||||
,(if (arg/res-vars a-res)
|
||||
(map syntax-e (arg/res-vars a-res))
|
||||
'())
|
||||
#f
|
||||
#f)))
|
||||
#,(for/list ([post (in-list (istx-post an-istx))])
|
||||
(list (map syntax-e (pre/post-vars post))
|
||||
(pre/post-str post)))))
|
||||
'racket/contract:contract
|
||||
(let ()
|
||||
(define (find-kwd kwd)
|
||||
(for/or ([x (in-list (syntax->list 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)))
|
||||
keyword<?)
|
||||
'#,(sort (filter values (map (λ (arg) (and (arg-optional? arg) (arg-kwd arg) (syntax-e (arg-kwd arg))))
|
||||
(istx-args an-istx)))
|
||||
keyword<?)
|
||||
'#,(and (istx-rst an-istx) (arg/res-var (istx-rst an-istx)))
|
||||
#,(and (syntax-parameter-value #'making-a-method) #t)
|
||||
(quote-module-name)
|
||||
#,wrapper-func
|
||||
'#(#,(for/list ([an-arg (in-list (istx-args an-istx))])
|
||||
`(,(if (arg/res-vars an-arg) 'dep 'nodep)
|
||||
,(syntax-e (arg/res-var an-arg))
|
||||
,(if (arg/res-vars an-arg)
|
||||
(map syntax-e (arg/res-vars an-arg))
|
||||
'())
|
||||
,(and (arg-kwd an-arg)
|
||||
(syntax-e (arg-kwd an-arg)))
|
||||
,(arg-optional? an-arg)))
|
||||
#,(if (istx-rst an-istx)
|
||||
(if (arg/res-vars (istx-rst an-istx))
|
||||
`(dep ,(syntax-e (arg/res-var (istx-rst an-istx)))
|
||||
,(map syntax-e (arg/res-vars (istx-rst an-istx))))
|
||||
`(nodep ,(syntax-e (arg/res-var (istx-rst an-istx)))))
|
||||
#f)
|
||||
#,(for/list ([pre (in-list (istx-pre an-istx))])
|
||||
(list (map syntax-e (pre/post-vars pre))
|
||||
(pre/post-str pre)))
|
||||
#,(and (istx-ress an-istx)
|
||||
(for/list ([a-res (in-list (istx-ress an-istx))])
|
||||
`(,(if (arg/res-vars a-res) 'dep 'nodep)
|
||||
,(if (eres? a-res)
|
||||
'_
|
||||
(syntax-e (arg/res-var a-res)))
|
||||
,(if (arg/res-vars a-res)
|
||||
(map syntax-e (arg/res-vars a-res))
|
||||
'())
|
||||
#f
|
||||
#f)))
|
||||
#,(for/list ([post (in-list (istx-post an-istx))])
|
||||
(list (map syntax-e (pre/post-vars post))
|
||||
(pre/post-str post)))))
|
||||
'racket/contract:contract
|
||||
(let ()
|
||||
(define (find-kwd kwd)
|
||||
(for/or ([x (in-list (syntax->list 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) '())))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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")]))
|
||||
|
||||
|
|
|
|||
|
|
@ -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[".."]).
|
||||
|
|
|
|||
|
|
@ -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 <amount>, given: -10}}
|
||||
With this little change, the error message becomes quite readable:
|
||||
|
||||
@interaction[#:eval
|
||||
contract-eval
|
||||
(require 'improved-bank-server)
|
||||
(deposit -10)]
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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[(
|
||||
|
|
|
|||
|
|
@ -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"<collects>"
|
||||
(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)))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user