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

add the ability to make chaperone contracts to ->i

Browse Source
This commit is contained in:
Robby Findler 2015-12-18 20:41:31 -06:00
parent 962a72dfda
commit 506c9be0cd
3 changed files with 247 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
pkgs/racket-test/tests/racket/contract/arrow-i.rkt
View File

@ -2,7 +2,7 @@
(require "test-util.rkt") (require "test-util.rkt")
(parameterize ([current-contract-namespace (parameterize ([current-contract-namespace
(make-basic-contract-namespace)]) (make-basic-contract-namespace 'racket/contract/parametric)])
(define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?)) (define exn:fail:contract:blame? (contract-eval 'exn:fail:contract:blame?))
(test/no-error '(->i ([x integer?]) ([y integer?]) any)) (test/no-error '(->i ([x integer?]) ([y integer?]) any))
@ -1397,4 +1397,31 @@
1)) 1))
;; this used to cause a runtime error in the code that parses ->i ;; this used to cause a runtime error in the code that parses ->i
(test/no-error '(->i ([x () any/c] [y (x) any/c]) any))) (test/no-error '(->i ([x () any/c] [y (x) any/c]) any))
(test/spec-passed/result
'really-chaperones.1
'(let ([f (λ () 1)])
(chaperone-of?
(contract (->i #:chaperone () any) f 'pos 'neg)
f))
#t)
(test/spec-passed/result
'really-chaperones.2
'(let ([f (λ () 1)])
(chaperone-of?
(contract (->i () [_ (new-∀/c)]) f 'pos 'neg)
f))
#f)
(test/spec-passed/result
'really-chaperones.3
'(with-handlers ([exn:fail?
(λ (x)
(regexp-match? #rx"^->i:.*chaperone" (exn-message x)))])
((contract (->i #:chaperone ([x integer?] [y (x) (new-∀/c)]) any)
(λ (x y) x)
'pos 'neg) 1 2)
"didn't raise an error")
#t))

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

@ -20,12 +20,13 @@ code does the parsing and validation of the syntax.
|# |#
;; istx-is-chaperone-contract? : boolean?
;; args : (listof arg?) ;; args : (listof arg?)
;; rst : (or/c #f arg/res?) ;; rst : (or/c #f arg/res?)
;; pre : (listof pre/post?) ;; pre : (listof pre/post?)
;; ress : (or/c #f (listof eres?) (listof lres?)) ;; ress : (or/c #f (listof eres?) (listof lres?))
;; post : (listof pre/post?) ;; post : (listof pre/post?)
(struct istx (args rst pre ress post) #:transparent) (struct istx (is-chaperone-contract? args rst pre ress post) #:transparent)
;; NOTE: the ress field may contain a mixture of eres and lres structs ;; NOTE: the ress field may contain a mixture of eres and lres structs
;; but only temporarily; in that case, a syntax error ;; but only temporarily; in that case, a syntax error
;; is signaled and the istx struct is not used afterwards ;; is signaled and the istx struct is not used afterwards
@ -59,11 +60,13 @@ code does the parsing and validation of the syntax.
(define (parse-->i stx) (define (parse-->i stx)
(if (identifier? stx) (if (identifier? stx)
(raise-syntax-error #f "expected ->i to follow an open parenthesis" stx) (raise-syntax-error #f "expected ->i to follow an open parenthesis" stx)
(let-values ([(raw-mandatory-doms raw-optional-doms (let-values ([(is-chaperone-contract?
raw-mandatory-doms raw-optional-doms
id/rest-id pre-cond range post-cond) id/rest-id pre-cond range post-cond)
(pull-out-pieces stx)]) (pull-out-pieces stx)])
(let ([candidate (let ([candidate
(istx (append (parse-doms stx #f raw-mandatory-doms) (istx is-chaperone-contract?
(append (parse-doms stx #f raw-mandatory-doms)
(parse-doms stx #t raw-optional-doms)) (parse-doms stx #t raw-optional-doms))
id/rest-id id/rest-id
pre-cond pre-cond
@ -393,12 +396,26 @@ code does the parsing and validation of the syntax.
;; pull-out-pieces : ;; pull-out-pieces :
;; stx -> (values raw-mandatory-doms raw-optional-doms id/rest-id pre-cond range post-cond) ;; stx -> (values raw-mandatory-doms raw-optional-doms id/rest-id pre-cond range post-cond)
(define (pull-out-pieces stx) (define (pull-out-pieces stx)
(let*-values ([(raw-mandatory-doms leftover) (let*-values ([(is-chaperone-contract? leftover)
(syntax-case stx () (syntax-case stx ()
[(_ (raw-mandatory-doms ...) . leftover) [(_ #:chaperone . leftover)
(values #t #'leftover)]
[(_ . leftover)
(let ([lst (syntax->list stx)])
(when (null? (cdr lst))
(raise-syntax-error #f "expected a sequence of mandatory domain elements"
stx))
(when (keyword? (syntax-e (cadr lst)))
(raise-syntax-error #f "unknown keyword"
stx
(cadr lst)))
(values #f #'leftover))])]
[(raw-mandatory-doms leftover)
(syntax-case leftover ()
[((raw-mandatory-doms ...) . leftover)
(values (syntax->list #'(raw-mandatory-doms ...)) (values (syntax->list #'(raw-mandatory-doms ...))
#'leftover)] #'leftover)]
[(_ a . leftover) [(a . leftover)
(raise-syntax-error #f (raise-syntax-error #f
"expected a sequence of mandatory domain elements" "expected a sequence of mandatory domain elements"
stx #'a)] stx #'a)]
@ -604,7 +621,9 @@ code does the parsing and validation of the syntax.
(values (reverse post-conds) leftover)]))]) (values (reverse post-conds) leftover)]))])
(syntax-case leftover () (syntax-case leftover ()
[() [()
(values raw-mandatory-doms raw-optional-doms id/rest-id pre-conds range post-conds)] (values is-chaperone-contract?
raw-mandatory-doms raw-optional-doms id/rest-id pre-conds
range post-conds)]
[(a . b) [(a . b)
(raise-syntax-error #f "bad syntax" stx #'a)] (raise-syntax-error #f "bad syntax" stx #'a)]
[_ [_

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

@ -27,7 +27,7 @@
(provide (rename-out [->i/m ->i])) (provide (rename-out [->i/m ->i]))
(define (build-??-args ctc blame) (define (build-??-args c-or-i-procedure ctc blame)
(define arg-ctc-projs (map (λ (x) (contract-projection (->i-arg-contract x))) (->i-arg-ctcs ctc))) (define arg-ctc-projs (map (λ (x) (contract-projection (->i-arg-contract x))) (->i-arg-ctcs ctc)))
(define indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x))) (define indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x)))
(->i-indy-arg-ctcs ctc))) (->i-indy-arg-ctcs ctc)))
@ -81,7 +81,8 @@
[rng-pr (in-list (->i-indy-rng-ctcs ctc))]) [rng-pr (in-list (->i-indy-rng-ctcs ctc))])
(rng-proj (blame-add-context indy-rng-blame (format "the ~a result of" (rng-proj (blame-add-context indy-rng-blame (format "the ~a result of"
(car rng-pr)))))) (car rng-pr))))))
(list* (λ (val mtd?) (list* c-or-i-procedure
(λ (val mtd?)
(if has-rest (if has-rest
(check-procedure/more val mtd? (check-procedure/more val mtd?
(->i-mandatory-args ctc) (->i-mandatory-args ctc)
@ -104,10 +105,10 @@
partial-indy-rngs))) partial-indy-rngs)))
(define arr->i-proj (define arr->i-proj
(λ (ctc) (λ (ctc c-or-i-procedure)
(define func (->i-mk-wrapper ctc)) (define func (->i-mk-wrapper ctc))
(λ (blame) (λ (blame)
(define ???-args (build-??-args ctc blame)) (define ???-args (build-??-args c-or-i-procedure ctc blame))
(apply func ???-args)))) (apply func ???-args))))
@ -183,12 +184,14 @@
pre/post-procs pre/post-procs
mandatory-args opt-args mandatory-kwds opt-kwds rest mandatory-args opt-args mandatory-kwds opt-kwds rest
mtd? here mk-wrapper mk-val-first-wrapper name-info) mtd? here mk-wrapper mk-val-first-wrapper name-info)
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc)
#:property prop:contract
(build-contract-property (define (mk-prop chaperone?)
(define c-or-i-procedure (if chaperone? chaperone-procedure impersonate-procedure))
((if chaperone? build-chaperone-contract-property build-contract-property)
#:val-first-projection #:val-first-projection
(λ (ctc) (λ (ctc)
(define blame-accepting-proj (arr->i-proj ctc)) (define blame-accepting-proj (arr->i-proj ctc c-or-i-procedure))
(λ (blame) (λ (blame)
(λ (val) (λ (val)
(wrapped-extra-arg-arrow (wrapped-extra-arg-arrow
@ -197,11 +200,11 @@
(->i-mk-val-first-wrapper ctc))))) (->i-mk-val-first-wrapper ctc)))))
#:late-neg-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define blame-accepting-proj (arr->i-proj ctc)) (define blame-accepting-proj (arr->i-proj ctc c-or-i-procedure))
(λ (blame) (λ (blame)
(λ (val neg-party) (λ (val neg-party)
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val)))) ((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))))
#:projection arr->i-proj #:projection (λ (ctc) (arr->i-proj ctc c-or-i-procedure))
#: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]
@ -318,6 +321,24 @@
#:exercise exercise->i #:exercise exercise->i
#:stronger (λ (this that) (eq? this that)))) ;; WRONG #:stronger (λ (this that) (eq? this that)))) ;; WRONG
(struct chaperone->i ->i () #:property prop:chaperone-contract (mk-prop #t))
(struct impersonator->i ->i () #:property prop:contract (mk-prop #f))
(define (make-->i is-chaperone-contract? 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 mk-val-first-wrapper name-info)
(define maker (if is-chaperone-contract? chaperone->i impersonator->i))
(maker 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 mk-val-first-wrapper name-info))
;; find-ordering : (listof arg) -> (values (listof arg) (listof number)) ;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
;; sorts the arguments according to the dependency order. ;; sorts the arguments according to the dependency order.
;; returns them in the reverse of that order, ie expressions that need ;; returns them in the reverse of that order, ie expressions that need
@ -655,7 +676,7 @@ evaluted left-to-right.)
;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values, ;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values,
;; with 'body' in the body of the let also handles adding code to check to see if unsupplied ;; with 'body' in the body of the let also handles adding code to check to see if unsupplied
;; args are present (skipping the contract check, if so) ;; args are present (skipping the contract check, if so)
(define-for-syntax (add-wrapper-let body swapped-blame? neg-calls? (define-for-syntax (add-wrapper-let body is-chaperone-contract? swapped-blame? neg-calls?
ordered-arg/reses indicies ordered-arg/reses indicies
arg/res-proj-vars indy-arg/res-proj-vars arg/res-proj-vars indy-arg/res-proj-vars
wrapper-arg/ress indy-arg/res-vars wrapper-arg/ress indy-arg/res-vars
@ -706,7 +727,8 @@ evaluted left-to-right.)
wrapper-arg wrapper-arg
(cond (cond
[(and (eres? an-arg/res) (arg/res-vars an-arg/res)) [(and (eres? an-arg/res) (arg/res-vars an-arg/res))
#`(un-dep #,(eres-eid an-arg/res) #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
#,(eres-eid an-arg/res)
#,wrapper-arg #,wrapper-arg
#,(build-blame-identifier #f #,(build-blame-identifier #f
swapped-blame? swapped-blame?
@ -789,6 +811,7 @@ evaluted left-to-right.)
#,(add-wrapper-let #,(add-wrapper-let
(add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress
#`(values #,@(vector->list wrapper-ress))) #`(values #,@(vector->list wrapper-ress)))
(istx-is-chaperone-contract? an-istx)
#f #f #f #f
ordered-ress res-indices ordered-ress res-indices
res-proj-vars indy-res-proj-vars res-proj-vars indy-res-proj-vars
@ -868,6 +891,7 @@ evaluted left-to-right.)
(istx-rst an-istx) (istx-rst an-istx)
wrapper-args wrapper-args
this-param))) this-param)))
(istx-is-chaperone-contract? an-istx)
#t #f #t #f
ordered-args arg-indices ordered-args arg-indices
arg-proj-vars indy-arg-proj-vars arg-proj-vars indy-arg-proj-vars
@ -879,7 +903,7 @@ evaluted left-to-right.)
#`(λ #,wrapper-proc-arglist #`(λ #,wrapper-proc-arglist
(λ (val) (λ (val)
(chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(impersonate-procedure (c-or-i-procedure
val val
(let ([arg-checker (let ([arg-checker
(λ #,(args/vars->arglist an-istx wrapper-args this-param) (λ #,(args/vars->arglist an-istx wrapper-args this-param)
@ -954,7 +978,7 @@ evaluted left-to-right.)
'())))) '()))))
(define wrapper-proc-arglist (define wrapper-proc-arglist
#`(chk ctc blame swapped-blame #,@(map car blame-ids) #`(c-or-i-procedure chk ctc blame swapped-blame #,@(map car blame-ids)
;; the pre- and post-condition procs ;; the pre- and post-condition procs
#,@(for/list ([pres (istx-pre an-istx)] #,@(for/list ([pres (istx-pre an-istx)]
@ -1037,6 +1061,7 @@ evaluted left-to-right.)
(istx-rst an-istx) (istx-rst an-istx)
wrapper-args wrapper-args
this-param) this-param)
(istx-is-chaperone-contract? an-istx)
#t #t #t #t
ordered-args arg-indices ordered-args arg-indices
arg-proj-vars indy-arg-proj-vars arg-proj-vars indy-arg-proj-vars
@ -1059,8 +1084,17 @@ evaluted left-to-right.)
#`(f #,@argument-list))) #`(f #,@argument-list)))
(begin-encourage-inline (begin-encourage-inline
(define (un-dep ctc obj blame) (define (un-dep/chaperone orig-ctc obj blame)
(let ([ctc (coerce-contract '->i ctc)]) (let ([ctc (coerce-contract '->i orig-ctc)])
(unless (chaperone-contract? ctc)
(raise-argument-error '->i
"chaperone-contract?"
orig-ctc))
(((contract-projection ctc) blame) obj))))
(begin-encourage-inline
(define (un-dep orig-ctc obj blame)
(let ([ctc (coerce-contract '->i orig-ctc)])
(((contract-projection ctc) blame) obj)))) (((contract-projection ctc) blame) obj))))
(define-for-syntax (mk-used-indy-vars an-istx) (define-for-syntax (mk-used-indy-vars an-istx)
@ -1161,10 +1195,13 @@ evaluted left-to-right.)
an-id arg/ress-to-look-in)) an-id arg/ress-to-look-in))
ans)) ans))
(define is-chaperone-contract? (istx-is-chaperone-contract? an-istx))
#`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ... #`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ...
[res-exp-xs (coerce-contract '->i res-exps)] ...) [res-exp-xs (coerce-contract '->i res-exps)] ...)
#,(syntax-property #,(syntax-property
#`(->i #`(make-->i
#,is-chaperone-contract?
;; the information needed to make the blame records and their new contexts ;; the information needed to make the blame records and their new contexts
'#,blame-ids '#,blame-ids
;; all of the non-dependent argument contracts ;; all of the non-dependent argument contracts
@ -1185,7 +1222,8 @@ evaluted left-to-right.)
#,@(arg/res-vars arg) #,@(arg/res-vars arg)
;; this used to use opt/direct, but ;; this used to use opt/direct, but
;; opt/direct duplicates code (bad!) ;; opt/direct duplicates code (bad!)
(un-dep #,ctc-stx val blame)))) (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
#,ctc-stx val blame))))
;; then the non-dependent argument contracts that are themselves dependend on ;; then the non-dependent argument contracts that are themselves dependend on
(list #,@(filter values (list #,@(filter values
(map (λ (arg/res indy-id) (map (λ (arg/res indy-id)
@ -1225,7 +1263,8 @@ evaluted left-to-right.)
;; this used to use opt/direct, but ;; this used to use opt/direct, but
;; opt/direct duplicates code (bad!) ;; opt/direct duplicates code (bad!)
#,@(arg/res-vars arg) #,@(arg/res-vars arg)
(un-dep #,arg-stx val blame))))) (#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep)
#,arg-stx val blame)))))
#''()) #''())
#,(if (istx-ress an-istx) #,(if (istx-ress an-istx)
#`(list #,@(filter values #`(list #,@(filter values