add the ability to make chaperone contracts to ->i
This commit is contained in:
Robby Findler
parent
962a72dfda
commit
506c9be0cd
|
|
@ -2,7 +2,7 @@
|
|||
(require "test-util.rkt")
|
||||
|
||||
(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?))
|
||||
|
||||
(test/no-error '(->i ([x integer?]) ([y integer?]) any))
|
||||
|
|
@ -1397,4 +1397,31 @@
|
|||
1))
|
||||
|
||||
;; 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))
|
||||
|
|
|
|||
|
|
@ -20,12 +20,13 @@ code does the parsing and validation of the syntax.
|
|||
|
||||
|#
|
||||
|
||||
;; istx-is-chaperone-contract? : boolean?
|
||||
;; args : (listof arg?)
|
||||
;; rst : (or/c #f arg/res?)
|
||||
;; pre : (listof pre/post?)
|
||||
;; ress : (or/c #f (listof eres?) (listof lres?))
|
||||
;; 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
|
||||
;; but only temporarily; in that case, a syntax error
|
||||
;; 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)
|
||||
(if (identifier? 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)
|
||||
(pull-out-pieces stx)])
|
||||
(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))
|
||||
id/rest-id
|
||||
pre-cond
|
||||
|
|
@ -393,12 +396,26 @@ code does the parsing and validation of the syntax.
|
|||
;; pull-out-pieces :
|
||||
;; stx -> (values raw-mandatory-doms raw-optional-doms id/rest-id pre-cond range post-cond)
|
||||
(define (pull-out-pieces stx)
|
||||
(let*-values ([(raw-mandatory-doms leftover)
|
||||
(let*-values ([(is-chaperone-contract? leftover)
|
||||
(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 ...))
|
||||
#'leftover)]
|
||||
[(_ a . leftover)
|
||||
[(a . leftover)
|
||||
(raise-syntax-error #f
|
||||
"expected a sequence of mandatory domain elements"
|
||||
stx #'a)]
|
||||
|
|
@ -604,7 +621,9 @@ code does the parsing and validation of the syntax.
|
|||
(values (reverse post-conds) 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)
|
||||
(raise-syntax-error #f "bad syntax" stx #'a)]
|
||||
[_
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
|
||||
(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 indy-arg-ctc-projs (map (λ (x) (contract-projection (cdr x)))
|
||||
(->i-indy-arg-ctcs ctc)))
|
||||
|
|
@ -81,7 +81,8 @@
|
|||
[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))))))
|
||||
(list* (λ (val mtd?)
|
||||
(list* c-or-i-procedure
|
||||
(λ (val mtd?)
|
||||
(if has-rest
|
||||
(check-procedure/more val mtd?
|
||||
(->i-mandatory-args ctc)
|
||||
|
|
@ -104,10 +105,10 @@
|
|||
partial-indy-rngs)))
|
||||
|
||||
(define arr->i-proj
|
||||
(λ (ctc)
|
||||
(λ (ctc c-or-i-procedure)
|
||||
(define func (->i-mk-wrapper ctc))
|
||||
(λ (blame)
|
||||
(define ???-args (build-??-args ctc blame))
|
||||
(define ???-args (build-??-args c-or-i-procedure ctc blame))
|
||||
(apply func ???-args))))
|
||||
|
||||
|
||||
|
|
@ -183,12 +184,14 @@
|
|||
pre/post-procs
|
||||
mandatory-args opt-args mandatory-kwds opt-kwds rest
|
||||
mtd? here mk-wrapper mk-val-first-wrapper name-info)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:property prop:custom-write custom-write-property-proc)
|
||||
|
||||
(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
|
||||
(λ (ctc)
|
||||
(define blame-accepting-proj (arr->i-proj ctc))
|
||||
(define blame-accepting-proj (arr->i-proj ctc c-or-i-procedure))
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(wrapped-extra-arg-arrow
|
||||
|
|
@ -197,11 +200,11 @@
|
|||
(->i-mk-val-first-wrapper ctc)))))
|
||||
#:late-neg-projection
|
||||
(λ (ctc)
|
||||
(define blame-accepting-proj (arr->i-proj ctc))
|
||||
(define blame-accepting-proj (arr->i-proj ctc c-or-i-procedure))
|
||||
(λ (blame)
|
||||
(λ (val neg-party)
|
||||
((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)
|
||||
(define (arg/ress->spec infos ctcs dep-ctcs skip?)
|
||||
(let loop ([infos infos]
|
||||
|
|
@ -318,6 +321,24 @@
|
|||
#:exercise exercise->i
|
||||
#: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))
|
||||
;; sorts the arguments according to the dependency order.
|
||||
;; 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,
|
||||
;; 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)
|
||||
(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
|
||||
arg/res-proj-vars indy-arg/res-proj-vars
|
||||
wrapper-arg/ress indy-arg/res-vars
|
||||
|
|
@ -706,7 +727,8 @@ evaluted left-to-right.)
|
|||
wrapper-arg
|
||||
(cond
|
||||
[(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
|
||||
#,(build-blame-identifier #f
|
||||
swapped-blame?
|
||||
|
|
@ -789,6 +811,7 @@ evaluted left-to-right.)
|
|||
#,(add-wrapper-let
|
||||
(add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress
|
||||
#`(values #,@(vector->list wrapper-ress)))
|
||||
(istx-is-chaperone-contract? an-istx)
|
||||
#f #f
|
||||
ordered-ress res-indices
|
||||
res-proj-vars indy-res-proj-vars
|
||||
|
|
@ -868,6 +891,7 @@ evaluted left-to-right.)
|
|||
(istx-rst an-istx)
|
||||
wrapper-args
|
||||
this-param)))
|
||||
(istx-is-chaperone-contract? an-istx)
|
||||
#t #f
|
||||
ordered-args arg-indices
|
||||
arg-proj-vars indy-arg-proj-vars
|
||||
|
|
@ -879,7 +903,7 @@ evaluted left-to-right.)
|
|||
#`(λ #,wrapper-proc-arglist
|
||||
(λ (val)
|
||||
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
|
||||
(impersonate-procedure
|
||||
(c-or-i-procedure
|
||||
val
|
||||
(let ([arg-checker
|
||||
(λ #,(args/vars->arglist an-istx wrapper-args this-param)
|
||||
|
|
@ -954,7 +978,7 @@ evaluted left-to-right.)
|
|||
'()))))
|
||||
|
||||
(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
|
||||
#,@(for/list ([pres (istx-pre an-istx)]
|
||||
|
|
@ -1037,6 +1061,7 @@ evaluted left-to-right.)
|
|||
(istx-rst an-istx)
|
||||
wrapper-args
|
||||
this-param)
|
||||
(istx-is-chaperone-contract? an-istx)
|
||||
#t #t
|
||||
ordered-args arg-indices
|
||||
arg-proj-vars indy-arg-proj-vars
|
||||
|
|
@ -1059,8 +1084,17 @@ evaluted left-to-right.)
|
|||
#`(f #,@argument-list)))
|
||||
|
||||
(begin-encourage-inline
|
||||
(define (un-dep ctc obj blame)
|
||||
(let ([ctc (coerce-contract '->i ctc)])
|
||||
(define (un-dep/chaperone orig-ctc obj blame)
|
||||
(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))))
|
||||
|
||||
(define-for-syntax (mk-used-indy-vars an-istx)
|
||||
|
|
@ -1161,10 +1195,13 @@ evaluted left-to-right.)
|
|||
an-id arg/ress-to-look-in))
|
||||
ans))
|
||||
|
||||
(define is-chaperone-contract? (istx-is-chaperone-contract? an-istx))
|
||||
|
||||
#`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ...
|
||||
[res-exp-xs (coerce-contract '->i res-exps)] ...)
|
||||
#,(syntax-property
|
||||
#`(->i
|
||||
#`(make-->i
|
||||
#,is-chaperone-contract?
|
||||
;; the information needed to make the blame records and their new contexts
|
||||
'#,blame-ids
|
||||
;; all of the non-dependent argument contracts
|
||||
|
|
@ -1185,7 +1222,8 @@ evaluted left-to-right.)
|
|||
#,@(arg/res-vars arg)
|
||||
;; this used to use opt/direct, but
|
||||
;; 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
|
||||
(list #,@(filter values
|
||||
(map (λ (arg/res indy-id)
|
||||
|
|
@ -1225,7 +1263,8 @@ evaluted left-to-right.)
|
|||
;; this used to use opt/direct, but
|
||||
;; opt/direct duplicates code (bad!)
|
||||
#,@(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)
|
||||
#`(list #,@(filter values
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user