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

add and use late-neg projections to the contract system

Browse Source 
These avoid one layer of currying and are more efficient, getting
about a 1.3x speed up on this program:

 #lang racket/base
(module server racket/base
  (require racket/contract/base)
  (provide
   (contract-out
    [f (-> integer? boolean? char? void?)]))
  (define (f i b c) (void)))

(require (submod "." server))

(time
  (for ([x (in-range 10000000)])
    (f 1 #t #\x)))
This commit is contained in:
Robby Findler 2015-08-31 20:30:17 -05:00
parent f09c78b5f4
commit 13964c4141
12 changed files with 570 additions and 507 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -1831,7 +1831,11 @@ accepted by the third argument to @racket[datum->syntax].
@defproc[(make-contract @defproc[(make-contract
[#:name name any/c 'anonymous-contract] [#:name name any/c 'anonymous-contract]
[#:first-order test (-> any/c any/c) (λ (x) #t)] [#:first-order test (-> any/c any/c) (λ (x) #t)]
[#:val-first-projection [#:late-neg-projection
late-neg-proj
(or/c #f (-> blame? (-> any/c any/c any/c)))
#f]
[#:val-first-projection
val-first-proj val-first-proj
(or/c #f (-> blame? (-> any/c (-> any/c any/c)))) (or/c #f (-> blame? (-> any/c (-> any/c any/c))))
#f] #f]
@ -1852,6 +1856,10 @@ accepted by the third argument to @racket[datum->syntax].
@defproc[(make-chaperone-contract @defproc[(make-chaperone-contract
[#:name name any/c 'anonymous-chaperone-contract] [#:name name any/c 'anonymous-chaperone-contract]
[#:first-order test (-> any/c any/c) (λ (x) #t)] [#:first-order test (-> any/c any/c) (λ (x) #t)]
[#:late-neg-projection
late-neg-proj
(or/c #f (-> blame? (-> any/c any/c any/c)))
#f]
[#:val-first-projection [#:val-first-projection
val-first-proj val-first-proj
(or/c #f (-> blame? (-> any/c (-> any/c any/c)))) (or/c #f (-> blame? (-> any/c (-> any/c any/c))))
@ -1873,6 +1881,10 @@ accepted by the third argument to @racket[datum->syntax].
@defproc[(make-flat-contract @defproc[(make-flat-contract
[#:name name any/c 'anonymous-flat-contract] [#:name name any/c 'anonymous-flat-contract]
[#:first-order test (-> any/c any/c) (λ (x) #t)] [#:first-order test (-> any/c any/c) (λ (x) #t)]
[#:late-neg-projection
late-neg-proj
(or/c #f (-> blame? (-> any/c any/c any/c)))
#f]
[#:val-first-projection [#:val-first-projection
val-first-proj val-first-proj
(or/c #f (-> blame? (-> any/c (-> any/c any/c)))) (or/c #f (-> blame? (-> any/c (-> any/c any/c))))
@ -1893,12 +1905,6 @@ accepted by the third argument to @racket[datum->syntax].
flat-contract?] flat-contract?]
)]{ )]{
@italic{The precise details of the
@racket[val-first-projection] argument
are subject to change. (Probably
also the default values of the @racket[project]
arguments will change.}
These functions build simple higher-order contracts, chaperone contracts, and flat contracts, These functions build simple higher-order contracts, chaperone contracts, and flat contracts,
respectively. They both take the same set of three optional arguments: a name, respectively. They both take the same set of three optional arguments: a name,
a first-order predicate, and a blame-tracking projection. a first-order predicate, and a blame-tracking projection.
@ -1916,13 +1922,25 @@ by @racket[contract-first-order-passes?], and indirectly by @racket[or/c] to
determine which of multiple higher-order contracts to wrap a value with. The determine which of multiple higher-order contracts to wrap a value with. The
default test accepts any value. default test accepts any value.
The projection @racket[proj] defines the behavior of applying the contract. It The @racket[late-neg-proj] defines the behavior of applying the contract. If it is
supplied, it accepts a blame object that does not have a value for
the @racket[blame-negative] field. Then it must return a function that accepts
both the value that is getting the contract and the name of the blame party, in
that order. The result must either be the value (perhaps suitably wrapped
with a @tech{chaperone} or @tech{impersonator} to enforce the contract), or
signal a contract violation using @racket[raise-blame-error]. The default is
@racket[#f].
The projection @racket[proj] and @racket[val-first-proj] are older mechanisms for
defining the behavior of applying the contract. The @racket[proj] argument
is a curried function of two arguments: the first application accepts a blame is a curried function of two arguments: the first application accepts a blame
object, and the second accepts a value to protect with the contract. The object, and the second accepts a value to protect with the contract. The
projection must either produce the value, suitably wrapped to enforce any projection must either produce the value, suitably wrapped to enforce any
higher-order aspects of the contract, or signal a contract violation using higher-order aspects of the contract, or signal a contract violation using
@racket[raise-blame-error]. The default projection produces an error when the @racket[raise-blame-error]. The default projection produces an error when the
first-order test fails, and produces the value unchanged otherwise. first-order test fails, and produces the value unchanged otherwise.
The @racket[val-first-proj] is like @racket[late-neg-proj], except with
an extra layer of currying.
Projections for chaperone contracts must produce a value that passes Projections for chaperone contracts must produce a value that passes
@racket[chaperone-of?] when compared with the original, uncontracted value. @racket[chaperone-of?] when compared with the original, uncontracted value.
@ -2274,6 +2292,10 @@ is expected to be the blame record for the contract on the value).
get-first-order get-first-order
(-> contract? (-> any/c boolean?)) (-> contract? (-> any/c boolean?))
(λ (c) (λ (x) #t))] (λ (c) (λ (x) #t))]
[#:late-neg-projection
late-neg-proj
(or/c #f (-> contract? (-> blame? (-> any/c any/c any/c))))
#f]
[#:val-first-projection [#:val-first-projection
val-first-proj val-first-proj
(or/c #f (-> contract? blame? (-> any/c (-> any/c any/c)))) (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
@ -2323,6 +2345,10 @@ is expected to be the blame record for the contract on the value).
get-first-order get-first-order
(-> contract? (-> any/c boolean?)) (-> contract? (-> any/c boolean?))
(λ (c) (λ (x) #t))] (λ (c) (λ (x) #t))]
[#:late-neg-projection
late-neg-proj
(or/c #f (-> contract? blame? (-> any/c any/c any/c)))
#f]
[#:val-first-projection [#:val-first-projection
val-first-proj val-first-proj
(or/c #f (-> contract? blame? (-> any/c (-> any/c any/c)))) (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))
@ -2372,6 +2398,10 @@ is expected to be the blame record for the contract on the value).
get-first-order get-first-order
(-> contract? (-> any/c boolean?)) (-> contract? (-> any/c boolean?))
(λ (c) (λ (x) #t))] (λ (c) (λ (x) #t))]
[#:late-neg-projection
late-neg-proj
(or/c #f (-> contract? blame? (-> any/c any/c any/c)))
#f]
[#:val-first-projection [#:val-first-projection
val-first-proj val-first-proj
(or/c #f (-> contract? blame? (-> any/c (-> any/c any/c)))) (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c))))

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

@ -195,6 +195,12 @@
(λ (neg-party) (λ (neg-party)
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val)) ((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))
(->i-mk-val-first-wrapper ctc))))) (->i-mk-val-first-wrapper ctc)))))
#:late-neg-projection
(λ (ctc)
(define blame-accepting-proj (arr->i-proj ctc))
(λ (blame)
(λ (val neg-party)
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))))
#:projection arr->i-proj #:projection arr->i-proj
#:name (λ (ctc) #:name (λ (ctc)
(define (arg/ress->spec infos ctcs dep-ctcs skip?) (define (arg/ress->spec infos ctcs dep-ctcs skip?)

115
racket/collects/racket/contract/private/arrow-higher-order.rkt
View File

@ -163,7 +163,7 @@
(list (list
(with-syntax ([rng-len (length rngs)]) (with-syntax ([rng-len (length rngs)])
(with-syntax ([rng-results (with-syntax ([rng-results
#'(values ((rng-ctc rng-x) neg-party) #'(values (rng-ctc rng-x neg-party)
...)]) ...)])
#'(case-lambda #'(case-lambda
[(rng-x ...) [(rng-x ...)
@ -185,7 +185,7 @@
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)] [opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
[need-apply-values? (or dom-rest (not (null? opt-doms)))] [need-apply-values? (or dom-rest (not (null? opt-doms)))]
[no-rng-checking? (not rngs)]) [no-rng-checking? (not rngs)])
(with-syntax ([(dom-projd-args ...) #'(((dom-ctc dom-x) neg-party) ...)] (with-syntax ([(dom-projd-args ...) #'((dom-ctc dom-x neg-party) ...)]
[basic-params [basic-params
(cond (cond
[dom-rest [dom-rest
@ -197,10 +197,10 @@
[else [else
#'(this-param ... dom-x ... [opt-dom-x arrow:unspecified-dom] ...)])] #'(this-param ... dom-x ... [opt-dom-x arrow:unspecified-dom] ...)])]
[opt+rest-uses [opt+rest-uses
(for/fold ([i (if dom-rest #'((rest-ctc rest-x) neg-party) #'null)]) (for/fold ([i (if dom-rest #'(rest-ctc rest-x neg-party) #'null)])
([o (in-list (reverse ([o (in-list (reverse
(syntax->list (syntax->list
#'(((opt-dom-ctc opt-dom-x) neg-party) ...))))] #'((opt-dom-ctc opt-dom-x neg-party) ...))))]
[opt-dom-x (in-list (reverse (syntax->list #'(opt-dom-x ...))))]) [opt-dom-x (in-list (reverse (syntax->list #'(opt-dom-x ...))))])
#`(let ([r #,i]) #`(let ([r #,i])
(if (eq? arrow:unspecified-dom #,opt-dom-x) r (cons #,o r))))] (if (eq? arrow:unspecified-dom #,opt-dom-x) r (cons #,o r))))]
@ -214,7 +214,7 @@
[kwd-stx [kwd-stx
(let* ([req-stxs (let* ([req-stxs
(map (λ (s) (λ (r) #`(cons #,s #,r))) (map (λ (s) (λ (r) #`(cons #,s #,r)))
(syntax->list #'(((req-kwd-ctc req-kwd-x) neg-party) ...)))] (syntax->list #'((req-kwd-ctc req-kwd-x neg-party) ...)))]
[opt-stxs [opt-stxs
(map (λ (x c) (λ (r) #`(maybe-cons-kwd #,c #,x #,r neg-party))) (map (λ (x c) (λ (r) #`(maybe-cons-kwd #,c #,x #,r neg-party)))
(syntax->list #'(opt-kwd-x ...)) (syntax->list #'(opt-kwd-x ...))
@ -348,40 +348,42 @@
(define (maybe-cons-kwd c x r neg-party) (define (maybe-cons-kwd c x r neg-party)
(if (eq? arrow:unspecified-dom x) (if (eq? arrow:unspecified-dom x)
r r
(cons ((c x) neg-party) r))) (cons (c x neg-party) r)))
(define (->-proj chaperone-or-impersonate-procedure ctc (define (->-proj chaperone-or-impersonate-procedure ctc
;; fields of the 'ctc' struct ;; fields of the 'ctc' struct
min-arity doms kwd-infos rest pre? rngs post? min-arity doms kwd-infos rest pre? rngs post?
plus-one-arity-function chaperone-constructor) plus-one-arity-function chaperone-constructor
(define doms-proj (map get/build-val-first-projection doms)) late-neg?)
(define rest-proj (and rest (get/build-val-first-projection rest)))
(define rngs-proj (if rngs (map get/build-val-first-projection rngs) '()))
(define kwds-proj
(for/list ([kwd-info (in-list kwd-infos)])
(get/build-val-first-projection (kwd-info-ctc kwd-info))))
(define optionals-length (- (length doms) min-arity)) (define optionals-length (- (length doms) min-arity))
(define mtd? #f) ;; not yet supported for the new contracts (define mtd? #f) ;; not yet supported for the new contracts
(λ (orig-blame) (λ (orig-blame)
(define rng-blame (arrow:blame-add-range-context orig-blame)) (define rng-blame (arrow:blame-add-range-context orig-blame))
(define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t)) (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
(define partial-doms
(for/list ([dom (in-list doms-proj)] (define partial-doms
(for/list ([dom (in-list doms)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(dom (blame-add-context orig-blame ((get/build-late-neg-projection dom)
(format "the ~a argument of" (n->th n)) (blame-add-context orig-blame
#:swap? #t)))) (format "the ~a argument of" (n->th n))
(define partial-rest (and rest-proj #:swap? #t))))
(rest-proj (define partial-rest (and rest
((get/build-late-neg-projection rest)
(blame-add-context orig-blame "the rest argument of" (blame-add-context orig-blame "the rest argument of"
#:swap? #t)))) #:swap? #t))))
(define partial-ranges (map (λ (rng) (rng rng-blame)) rngs-proj)) (define partial-ranges
(if rngs
(for/list ([rng (in-list rngs)])
((get/build-late-neg-projection rng) rng-blame))
'()))
(define partial-kwds (define partial-kwds
(for/list ([kwd-proj (in-list kwds-proj)] (for/list ([kwd-info (in-list kwd-infos)]
[kwd (in-list kwd-infos)]) [kwd (in-list kwd-infos)])
(kwd-proj (blame-add-context orig-blame ((get/build-late-neg-projection (kwd-info-ctc kwd-info))
(format "the ~a argument of" (kwd-info-kwd kwd)) (blame-add-context orig-blame
#:swap? #t)))) (format "the ~a argument of" (kwd-info-kwd kwd))
#:swap? #t))))
(define man-then-opt-partial-kwds (define man-then-opt-partial-kwds
(append (for/list ([partial-kwd (in-list partial-kwds)] (append (for/list ([partial-kwd (in-list partial-kwds)]
[kwd-info (in-list kwd-infos)] [kwd-info (in-list kwd-infos)]
@ -401,27 +403,42 @@
man-then-opt-partial-kwds man-then-opt-partial-kwds
partial-ranges partial-ranges
(if partial-rest (list partial-rest) '()))) (if partial-rest (list partial-rest) '())))
(λ (val)
(wrapped-extra-arg-arrow (define (successfully-got-the-right-kind-of-function val neg-party)
(cond (define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args))
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos) (if post?
=> (chaperone-or-impersonate-procedure
values] val
[else chap/imp-func
(λ (neg-party) impersonator-prop:contracted ctc
(define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args)) impersonator-prop:blame (blame-add-missing-party orig-blame neg-party))
(if post? (chaperone-or-impersonate-procedure
(chaperone-or-impersonate-procedure val
val chap/imp-func
chap/imp-func impersonator-prop:contracted ctc
impersonator-prop:contracted ctc impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)) impersonator-prop:application-mark (cons arrow:contract-key
(chaperone-or-impersonate-procedure ;; is this right?
val partial-ranges))))
chap/imp-func
impersonator-prop:contracted ctc (cond
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party) [late-neg?
impersonator-prop:application-mark (cons arrow:contract-key (λ (val neg-party)
;; is this right? (cond
partial-ranges))))]) [(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
(apply plus-one-arity-function orig-blame val plus-one-constructor-args))))) =>
(λ (f)
(f neg-party))]
[else
(successfully-got-the-right-kind-of-function val neg-party)]))]
[else
(λ (val)
(wrapped-extra-arg-arrow
(cond
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
=>
values]
[else
(λ (neg-party)
(successfully-got-the-right-kind-of-function val neg-party))])
(apply plus-one-arity-function orig-blame val plus-one-constructor-args)))])))

63
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -179,7 +179,7 @@
[(res-x ...) (generate-temporaries (or rngs '()))] [(res-x ...) (generate-temporaries (or rngs '()))]
[(kwd-arg-x ...) (generate-temporaries mandatory-kwds)]) [(kwd-arg-x ...) (generate-temporaries mandatory-kwds)])
(define base-arg-expressions (reverse (syntax->list #'(((regb arg-x) neg-party) ...)))) (define base-arg-expressions (reverse (syntax->list #'((regb arg-x neg-party) ...))))
(define normal-arg-vars (generate-temporaries #'(arg-x ...))) (define normal-arg-vars (generate-temporaries #'(arg-x ...)))
(define base-arg-vars normal-arg-vars) (define base-arg-vars normal-arg-vars)
@ -190,7 +190,7 @@
append append
(map (λ (kwd kwd-arg-x kb) (map (λ (kwd kwd-arg-x kb)
(set! base-arg-expressions (set! base-arg-expressions
(cons #`((#,kb #,kwd-arg-x) neg-party) (cons #`(#,kb #,kwd-arg-x neg-party)
base-arg-expressions)) base-arg-expressions))
(set! base-arg-vars (cons (car (generate-temporaries (list kwd-arg-x))) (set! base-arg-vars (cons (car (generate-temporaries (list kwd-arg-x)))
base-arg-vars)) base-arg-vars))
@ -228,7 +228,7 @@
#,@(for/list ([ob (in-list (reverse ob))] #,@(for/list ([ob (in-list (reverse ob))]
[optional-arg (in-list (reverse optional-args))]) [optional-arg (in-list (reverse optional-args))])
(set! args-expressions (set! args-expressions
(cons #`((#,ob #,optional-arg) neg-party) (cons #`(#,ob #,optional-arg neg-party)
args-expressions)) args-expressions))
(set! args-vars (set! args-vars
(cons (car (generate-temporaries (list optional-arg))) (cons (car (generate-temporaries (list optional-arg)))
@ -237,7 +237,7 @@
(define full-call (define full-call
(cond (cond
[(and first? rest) [(and first? rest)
(set! args-expressions (cons #'((restb rest-arg) neg-party) args-expressions)) (set! args-expressions (cons #'(restb rest-arg neg-party) args-expressions))
(set! args-vars (cons (car (generate-temporaries '(rest-args-arrow-contract))) (set! args-vars (cons (car (generate-temporaries '(rest-args-arrow-contract)))
args-vars)) args-vars))
#`(apply #,@no-rest-call #,(car args-vars))] #`(apply #,@no-rest-call #,(car args-vars))]
@ -281,7 +281,9 @@
#'(res-x ...))))] #'(res-x ...))))]
[else [else
post-check ... post-check ...
(values ((rb res-x) neg-party) ...)])))] (values
(rb res-x neg-party)
...)])))]
#`[#,the-args #`[#,the-args
pre-check ... pre-check ...
(let ([blame+neg-party (cons blame neg-party)]) (let ([blame+neg-party (cons blame neg-party)])
@ -340,7 +342,7 @@
(cond (cond
[(and (pair? mandatory-kwds) [(and (pair? mandatory-kwds)
(equal? (car mandatory-kwds) kwd)) (equal? (car mandatory-kwds) kwd))
(cons (((car kbs) kwd-arg) neg-party) (cons ((car kbs) kwd-arg neg-party)
(loop (cdr kwds) (loop (cdr kwds)
(cdr kwd-args) (cdr kwd-args)
(cdr mandatory-kwds) (cdr mandatory-kwds)
@ -349,7 +351,7 @@
okbs))] okbs))]
[(and (pair? optional-kwds) [(and (pair? optional-kwds)
(equal? (car optional-kwds) kwd)) (equal? (car optional-kwds) kwd))
(cons (((car okbs) kwd-arg) neg-party) (cons ((car okbs) kwd-arg neg-party)
(loop (cdr kwds) (loop (cdr kwds)
(cdr kwd-args) (cdr kwd-args)
mandatory-kwds mandatory-kwds
@ -368,9 +370,9 @@
[rbs rbs]) [rbs rbs])
(cond (cond
[(null? regular-args) '()] [(null? regular-args) '()]
[(null? rbs) ((rest-ctc regular-args) neg-party)] [(null? rbs) (rest-ctc regular-args neg-party)]
[else [else
(cons (((car rbs) (car regular-args)) neg-party) (cons ((car rbs) (car regular-args) neg-party)
(loop (cdr regular-args) (cdr rbs)))])))) (loop (cdr regular-args) (cdr rbs)))]))))
(define complete-blame (blame-add-missing-party blame neg-party)) (define complete-blame (blame-add-missing-party blame neg-party))
(when pre (check-pre-cond pre blame neg-party f)) (when pre (check-pre-cond pre blame neg-party f))
@ -385,7 +387,7 @@
values values
(for/list ([result (in-list results)] (for/list ([result (in-list results)]
[rng (in-list rngs)]) [rng (in-list rngs)])
((rng result) neg-party)))] (rng result neg-party)))]
[else [else
(mk-call)])))) (mk-call)]))))
@ -908,16 +910,16 @@
(define kwd-results (define kwd-results
(for/list ([kwd (in-list kwds)] (for/list ([kwd (in-list kwds)]
[kwd-arg (in-list kwd-args)]) [kwd-arg (in-list kwd-args)])
(((hash-ref kwd-table kwd) kwd-arg) neg-party))) ((hash-ref kwd-table kwd) kwd-arg neg-party)))
(define regular-arg-results (define regular-arg-results
(let loop ([args args] (let loop ([args args]
[projs mandatory+optional-dom-projs]) [projs mandatory+optional-dom-projs])
(cond (cond
[(and (null? projs) (null? args)) '()] [(and (null? projs) (null? args)) '()]
[(null? projs) [(null? projs)
((rest-proj args) neg-party)] (rest-proj args neg-party)]
[(null? args) (error 'cant-happen::dynamic->*)] [(null? args) (error 'cant-happen::dynamic->*)]
[else (cons (((car projs) (car args)) neg-party) [else (cons ((car projs) (car args) neg-party)
(loop (cdr args) (cdr projs)))]))) (loop (cdr args) (cdr projs)))])))
(define (result-checker . results) (define (result-checker . results)
(unless (= rng-len (length results)) (unless (= rng-len (length results))
@ -926,7 +928,7 @@
values values
(for/list ([res (in-list results)] (for/list ([res (in-list results)]
[neg-party-proj (in-list rng-projs)]) [neg-party-proj (in-list rng-projs)])
((neg-party-proj res) neg-party)))) (neg-party-proj res neg-party))))
(define args-dealt-with (define args-dealt-with
(if (null? kwds) (if (null? kwds)
regular-arg-results regular-arg-results
@ -1132,7 +1134,7 @@
#t)) #t))
(define (make-property build-X-property chaperone-or-impersonate-procedure) (define (make-property build-X-property chaperone-or-impersonate-procedure)
(define proj (define val-first-proj
(λ (->stct) (λ (->stct)
(->-proj chaperone-or-impersonate-procedure ->stct (->-proj chaperone-or-impersonate-procedure ->stct
(base->-min-arity ->stct) (base->-min-arity ->stct)
@ -1143,14 +1145,28 @@
(base->-rngs ->stct) (base->-rngs ->stct)
(base->-post? ->stct) (base->-post? ->stct)
(base->-plus-one-arity-function ->stct) (base->-plus-one-arity-function ->stct)
(base->-chaperone-constructor ->stct)))) (base->-chaperone-constructor ->stct)
#f)))
(define late-neg-proj
(λ (->stct)
(->-proj chaperone-or-impersonate-procedure ->stct
(base->-min-arity ->stct)
(base->-doms ->stct)
(base->-kwd-infos ->stct)
(base->-rest ->stct)
(base->-pre? ->stct)
(base->-rngs ->stct)
(base->-post? ->stct)
(base->-plus-one-arity-function ->stct)
(base->-chaperone-constructor ->stct)
#t)))
(parameterize ([skip-projection-wrapper? #t]) (parameterize ([skip-projection-wrapper? #t])
(build-X-property (build-X-property
#:name base->-name #:name base->-name
#:first-order ->-first-order #:first-order ->-first-order
#:projection #:projection
(λ (this) (λ (this)
(define cthis (proj this)) (define cthis (val-first-proj this))
(λ (blame) (λ (blame)
(define cblame (cthis blame)) (define cblame (cthis blame))
(λ (val) (λ (val)
@ -1180,7 +1196,8 @@
(not (base->-post? that)))) (not (base->-post? that))))
#:generate ->-generate #:generate ->-generate
#:exercise ->-exercise #:exercise ->-exercise
#:val-first-projection proj))) #:val-first-projection val-first-proj
#:late-neg-projection late-neg-proj)))
(define-struct (-> base->) () (define-struct (-> base->) ()
#:property #:property
@ -1207,11 +1224,11 @@
(λ () (f)) (λ () (f))
(case-lambda (case-lambda
[(rng) [(rng)
(unless (void? rng) (if (void? rng)
(raise-blame-error blame #:missing-party neg-party rng rng
'(expected: "void?" given: "~e") (raise-blame-error blame #:missing-party neg-party rng
rng)) '(expected: "void?" given: "~e")
rng] rng))]
[args [args
(wrong-number-of-results-blame blame neg-party f args 1)])))) (wrong-number-of-results-blame blame neg-party f args 1)]))))
(get-chaperone-constructor)))) (get-chaperone-constructor))))

6
racket/collects/racket/contract/private/base.rkt
View File

@ -51,7 +51,7 @@
(define (apply-contract c v pos neg name loc) (define (apply-contract c v pos neg name loc)
(let ([c (coerce-contract 'contract c)]) (let ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc) (check-source-location! 'contract loc)
(define cvfp (contract-val-first-projection c)) (define clnp (contract-late-neg-projection c))
(define blame (define blame
(make-blame (build-source-location loc) (make-blame (build-source-location loc)
name name
@ -65,10 +65,10 @@
;; instead of changing the library around. ;; instead of changing the library around.
(or pos "false") (or pos "false")
(if cvfp #f neg) (if clnp #f neg)
#t)) #t))
(cond (cond
[cvfp (((cvfp blame) v) neg)] [clnp ((clnp blame) v neg)]
[else (((contract-projection c) blame) v)]))) [else (((contract-projection c) blame) v)])))
(define-syntax (invariant-assertion stx) (define-syntax (invariant-assertion stx)

52
racket/collects/racket/contract/private/box.rkt
View File

@ -111,18 +111,19 @@
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:stronger box/c-stronger #:stronger box/c-stronger
#:val-first-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define content-ctc (get/build-val-first-projection (base-box/c-content ctc))) (define content-ctc (get/build-late-neg-projection (base-box/c-content ctc)))
(λ (blame) (λ (blame)
(define box-blame (add-box-context blame)) (define box-blame (add-box-context blame))
(define val-first-proj (content-ctc box-blame)) (define late-neg-proj (content-ctc box-blame))
(λ (val) (λ (val neg-party)
(define fail-proc (check-box/c-np ctc val blame)) (define fail-proc (check-box/c-np ctc val box-blame))
(or fail-proc (cond
(λ (neg-party) [fail-proc (fail-proc neg-party)]
((val-first-proj (unbox val)) neg-party) [else
val))))) (late-neg-proj (unbox val) neg-party)
val]))))
#:projection #:projection
(λ (ctc) (λ (ctc)
(λ (blame) (λ (blame)
@ -148,26 +149,29 @@
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))))))) impersonator-prop:blame blame))))))))
(define (ho-val-first-projection chaperone/impersonate-box) (define (ho-late-neg-projection chaperone/impersonate-box)
(λ (ctc) (λ (ctc)
(define elem-ctc (base-box/c-content ctc)) (define elem-ctc (base-box/c-content ctc))
(define immutable (base-box/c-immutable ctc)) (define immutable (base-box/c-immutable ctc))
(define vfp (get/build-val-first-projection elem-ctc)) (define vfp (get/build-late-neg-projection elem-ctc))
(λ (blame) (λ (blame)
(define box-blame (add-box-context blame)) (define box-blame (add-box-context blame))
(define pos-elem-proj (vfp box-blame)) (define pos-elem-proj (vfp box-blame))
(define neg-elem-proj (vfp (blame-swap box-blame))) (define neg-elem-proj (vfp (blame-swap box-blame)))
(λ (val) (λ (val neg-party)
(or (check-box/c-np ctc val blame) (cond
(if (and (immutable? val) (not (chaperone? val))) [(check-box/c-np ctc val blame)
(λ (neg-party) (box-immutable ((pos-elem-proj (unbox val)) neg-party))) =>
(λ (neg-party) (λ (f) (f neg-party))]
(chaperone/impersonate-box [else
val (if (and (immutable? val) (not (chaperone? val)))
(λ (b v) ((pos-elem-proj v) neg-party)) (box-immutable (pos-elem-proj (unbox val) neg-party))
(λ (b v) ((neg-elem-proj v) neg-party)) (chaperone/impersonate-box
impersonator-prop:contracted ctc val
impersonator-prop:blame (blame-add-missing-party blame neg-party))))))))) (λ (b v) (pos-elem-proj v neg-party))
(λ (b v) (neg-elem-proj v neg-party))
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))))
(define-struct (chaperone-box/c base-box/c) () (define-struct (chaperone-box/c base-box/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -176,7 +180,7 @@
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:stronger box/c-stronger #:stronger box/c-stronger
#:val-first-projection (ho-val-first-projection chaperone-box) #:late-neg-projection (ho-late-neg-projection chaperone-box)
#:projection (ho-projection chaperone-box))) #:projection (ho-projection chaperone-box)))
(define-struct (impersonator-box/c base-box/c) () (define-struct (impersonator-box/c base-box/c) ()
@ -186,7 +190,7 @@
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:stronger box/c-stronger #:stronger box/c-stronger
#:val-first-projection (ho-val-first-projection impersonate-box) #:late-neg-projection (ho-late-neg-projection impersonate-box)
#:projection (ho-projection impersonate-box))) #:projection (ho-projection impersonate-box)))
(define-syntax (wrap-box/c stx) (define-syntax (wrap-box/c stx)

20
racket/collects/racket/contract/private/guts.rkt
View File

@ -544,22 +544,18 @@
(predicate-contract-pred that)))) (predicate-contract-pred that))))
#:name (λ (ctc) (predicate-contract-name ctc)) #:name (λ (ctc) (predicate-contract-name ctc))
#:first-order (λ (ctc) (predicate-contract-pred ctc)) #:first-order (λ (ctc) (predicate-contract-pred ctc))
#:val-first-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define p? (predicate-contract-pred ctc)) (define p? (predicate-contract-pred ctc))
(define name (predicate-contract-name ctc)) (define name (predicate-contract-name ctc))
(λ (blame) (λ (blame)
(let ([predicate-contract-proj (λ (v neg-party)
(λ (v) (if (p? v)
(if (p? v) v
(λ (neg-party) (raise-blame-error blame v #:missing-party neg-party
v) '(expected: "~s" given: "~e")
(λ (neg-party) name
(raise-blame-error blame v #:missing-party neg-party v)))))
'(expected: "~s" given: "~e")
name
v))))])
predicate-contract-proj)))
#:generate (λ (ctc) #:generate (λ (ctc)
(let ([generate (predicate-contract-generate ctc)]) (let ([generate (predicate-contract-generate ctc)])
(cond (cond

93
racket/collects/racket/contract/private/hash.rkt
View File

@ -188,7 +188,7 @@
#:name hash/c-name #:name hash/c-name
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:stronger hash/c-stronger #:stronger hash/c-stronger
#:val-first-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define dom-ctc (base-hash/c-dom ctc)) (define dom-ctc (base-hash/c-dom ctc))
(define immutable (base-hash/c-immutable ctc)) (define immutable (base-hash/c-immutable ctc))
@ -198,38 +198,36 @@
(blame-add-key-context blame #f))) (blame-add-key-context blame #f)))
(define rng-proj ((contract-projection (base-hash/c-rng ctc)) (define rng-proj ((contract-projection (base-hash/c-rng ctc))
(blame-add-value-context blame #f))) (blame-add-value-context blame #f)))
(λ (val) (λ (val neg-party)
(λ (neg-party) (cond
(cond [(check-hash/c dom-ctc immutable flat? val blame neg-party)
[(check-hash/c dom-ctc immutable flat? val blame neg-party) val]
val] [else
[else (for ([(k v) (in-hash val)])
(for ([(k v) (in-hash val)]) (dom-proj k)
(dom-proj k) (rng-proj v))
(rng-proj v)) val]))))))
val])))))))
(define (ho-projection chaperone-or-impersonate-hash) (define (ho-projection chaperone-or-impersonate-hash)
(λ (ctc) (λ (ctc)
(define immutable (base-hash/c-immutable ctc)) (define immutable (base-hash/c-immutable ctc))
(define dom-ctc (base-hash/c-dom ctc)) (define dom-ctc (base-hash/c-dom ctc))
(define flat? (flat-hash/c? ctc)) (define flat? (flat-hash/c? ctc))
(define dom-proc (get/build-val-first-projection dom-ctc)) (define dom-proc (get/build-late-neg-projection dom-ctc))
(define rng-proc (get/build-val-first-projection (base-hash/c-rng ctc))) (define rng-proc (get/build-late-neg-projection (base-hash/c-rng ctc)))
(λ (blame) (λ (blame)
(define pos-dom-proj (dom-proc (blame-add-key-context blame #f))) (define pos-dom-proj (dom-proc (blame-add-key-context blame #f)))
(define neg-dom-proj (dom-proc (blame-add-key-context blame #t))) (define neg-dom-proj (dom-proc (blame-add-key-context blame #t)))
(define pos-rng-proj (rng-proc (blame-add-value-context blame #f))) (define pos-rng-proj (rng-proc (blame-add-value-context blame #f)))
(define neg-rng-proj (rng-proc (blame-add-value-context blame #t))) (define neg-rng-proj (rng-proc (blame-add-value-context blame #t)))
(λ (val) (λ (val neg-party)
(λ (neg-party) (cond
(cond [(check-hash/c dom-ctc immutable flat? val blame neg-party)
[(check-hash/c dom-ctc immutable flat? val blame neg-party) val]
val] [else
[else (handle-the-hash val neg-party
(handle-the-hash val neg-party pos-dom-proj neg-dom-proj (λ (v) pos-rng-proj) (λ (v) neg-rng-proj)
pos-dom-proj neg-dom-proj (λ (v) pos-rng-proj) (λ (v) neg-rng-proj) chaperone-or-impersonate-hash ctc blame)])))))
chaperone-or-impersonate-hash ctc blame)]))))))
(define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?)) (define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?))
(define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?)) (define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?))
@ -240,21 +238,21 @@
(if (immutable? val) (if (immutable? val)
(for/fold ([h val]) ([(k v) (in-hash val)]) (for/fold ([h val]) ([(k v) (in-hash val)])
(hash-set h (hash-set h
((pos-dom-proj k) neg-party) (pos-dom-proj k neg-party)
(((mk-pos-rng-proj k) v) neg-party))) ((mk-pos-rng-proj k) v neg-party)))
(chaperone-or-impersonate-hash (chaperone-or-impersonate-hash
val val
(λ (h k) (λ (h k)
(values ((neg-dom-proj k) neg-party) (values (neg-dom-proj k neg-party)
(λ (h k v) (λ (h k v)
(((mk-pos-rng-proj k) v) neg-party)))) ((mk-pos-rng-proj k) v neg-party))))
(λ (h k v) (λ (h k v)
(values ((neg-dom-proj k) neg-party) (values (neg-dom-proj k neg-party)
(((mk-neg-rng-proj k) v) neg-party))) ((mk-neg-rng-proj k) v neg-party)))
(λ (h k) (λ (h k)
((neg-dom-proj k) neg-party)) (neg-dom-proj k neg-party))
(λ (h k) (λ (h k)
((pos-dom-proj k) neg-party)) (pos-dom-proj k neg-party))
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame))) impersonator-prop:blame blame)))
@ -266,7 +264,7 @@
#:name hash/c-name #:name hash/c-name
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:stronger hash/c-stronger #:stronger hash/c-stronger
#:val-first-projection (ho-projection chaperone-hash))) #:late-neg-projection (ho-projection chaperone-hash)))
(define-struct (impersonator-hash/c base-hash/c) () (define-struct (impersonator-hash/c base-hash/c) ()
#:omit-define-syntaxes #:omit-define-syntaxes
@ -276,7 +274,7 @@
#:name hash/c-name #:name hash/c-name
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:stronger hash/c-stronger #:stronger hash/c-stronger
#:val-first-projection (ho-projection impersonate-hash))) #:late-neg-projection (ho-projection impersonate-hash)))
(define (hash/dc-name a-hash-dc) (define (hash/dc-name a-hash-dc)
@ -305,11 +303,11 @@
(define (hash/dc-stronger this that) #f) (define (hash/dc-stronger this that) #f)
(define ((hash/dc-val-first-projection chaperone-or-impersonate-hash) ctc) (define ((hash/dc-late-neg-projection chaperone-or-impersonate-hash) ctc)
(define dom-ctc (base-hash/dc-dom ctc)) (define dom-ctc (base-hash/dc-dom ctc))
(define immutable (base-hash/dc-immutable ctc)) (define immutable (base-hash/dc-immutable ctc))
(define flat? (flat-hash/dc? ctc)) (define flat? (flat-hash/dc? ctc))
(define dom-proc (get/build-val-first-projection dom-ctc)) (define dom-proc (get/build-late-neg-projection dom-ctc))
(define dep-rng-proc (base-hash/dc-dep-rng ctc)) (define dep-rng-proc (base-hash/dc-dep-rng ctc))
(λ (blame) (λ (blame)
(define pos-dom-proj (dom-proc (blame-add-key-context blame #f))) (define pos-dom-proj (dom-proc (blame-add-key-context blame #f)))
@ -319,18 +317,17 @@
(base-hash/dc-here ctc)))) (base-hash/dc-here ctc))))
(define pos-value-blame (blame-add-value-context blame #f)) (define pos-value-blame (blame-add-value-context blame #f))
(define neg-value-blame (blame-add-value-context blame #t)) (define neg-value-blame (blame-add-value-context blame #t))
(λ (val) (λ (val neg-party)
(λ (neg-party) (cond
(cond [(check-hash/c dom-ctc immutable flat? val blame neg-party) val]
[(check-hash/c dom-ctc immutable flat? val blame neg-party) val] [else
[else (define ((mk-rng-proj x-value-blame) key)
(define ((mk-rng-proj x-value-blame) key) ((get/build-late-neg-projection (dep-rng-proc (indy-dom-proj key neg-party)))
((get/build-val-first-projection (dep-rng-proc ((indy-dom-proj key) neg-party))) x-value-blame))
x-value-blame)) (handle-the-hash val neg-party
(handle-the-hash val neg-party pos-dom-proj neg-dom-proj
pos-dom-proj neg-dom-proj (mk-rng-proj pos-value-blame) (mk-rng-proj neg-value-blame)
(mk-rng-proj pos-value-blame) (mk-rng-proj neg-value-blame) chaperone-or-impersonate-hash ctc blame)]))))
chaperone-or-impersonate-hash ctc blame)])))))
(struct base-hash/dc (dom dep-rng here name-info immutable)) (struct base-hash/dc (dom dep-rng here name-info immutable))
(struct flat-hash/dc base-hash/dc () (struct flat-hash/dc base-hash/dc ()
@ -348,7 +345,7 @@
#:name hash/dc-name #:name hash/dc-name
#:first-order hash/dc-first-order #:first-order hash/dc-first-order
#:stronger hash/dc-stronger #:stronger hash/dc-stronger
#:val-first-projection (hash/dc-val-first-projection chaperone-hash))) #:late-neg-projection (hash/dc-late-neg-projection chaperone-hash)))
(struct impersonator-hash/dc base-hash/dc () (struct impersonator-hash/dc base-hash/dc ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
@ -356,7 +353,7 @@
#:name hash/dc-name #:name hash/dc-name
#:first-order hash/dc-first-order #:first-order hash/dc-first-order
#:stronger hash/dc-stronger #:stronger hash/dc-stronger
#:val-first-projection (hash/dc-val-first-projection impersonate-hash))) #:late-neg-projection (hash/dc-late-neg-projection impersonate-hash)))
(define (build-hash/dc dom dep-rng here name-info immutable kind) (define (build-hash/dc dom dep-rng here name-info immutable kind)
(unless (member kind '(flat chaperone impersonator)) (unless (member kind '(flat chaperone impersonator))

490
racket/collects/racket/contract/private/misc.rkt
View File

@ -54,7 +54,9 @@
contract-projection contract-projection
contract-val-first-projection ;; might return #f (if none) contract-val-first-projection ;; might return #f (if none)
contract-late-neg-projection ;; might return #f (if none)
get/build-val-first-projection ;; builds one if necc., using contract-projection get/build-val-first-projection ;; builds one if necc., using contract-projection
get/build-late-neg-projection
contract-name contract-name
n->th n->th
@ -113,22 +115,21 @@
([p (in-list (cdr projs))]) ([p (in-list (cdr projs))])
(λ (v) (p (proj v))))))) (λ (v) (p (proj v)))))))
(define (val-first-and-proj ctc) (define (late-neg-and-proj ctc)
(define mk-pos-projs (map get/build-val-first-projection (base-and/c-ctcs ctc))) (define mk-pos-projs (map get/build-late-neg-projection (base-and/c-ctcs ctc)))
(λ (blame) (λ (blame)
(define projs (define projs
(for/list ([c (in-list mk-pos-projs)] (for/list ([c (in-list mk-pos-projs)]
[n (in-naturals 1)]) [n (in-naturals 1)])
(c (blame-add-context blame (format "the ~a conjunct of" (n->th n)))))) (c (blame-add-context blame (format "the ~a conjunct of" (n->th n))))))
(λ (val) (λ (val neg-party)
(λ (neg-party) (let loop ([projs (cdr projs)]
(let loop ([projs (cdr projs)] [val ((car projs) val neg-party)])
[val (((car projs) val) neg-party)]) (cond
(cond [(null? projs) val]
[(null? projs) val] [else
[else (loop (cdr projs)
(loop (cdr projs) ((car projs) val neg-party))])))))
(((car projs) val) neg-party))]))))))
(define (first-order-and-proj ctc) (define (first-order-and-proj ctc)
(λ (blame) (λ (blame)
@ -146,23 +147,23 @@
(define new-blame (blame-add-context blame "an and/c case of")) (define new-blame (blame-add-context blame "an and/c case of"))
((ctc1-proj new-blame) val)])]))))) ((ctc1-proj new-blame) val)])])))))
(define (first-order-val-first-and-proj ctc) (define (first-order-late-neg-and-proj ctc)
(define predicates (first-order-and/c-predicates ctc)) (define predicates (first-order-and/c-predicates ctc))
(define ctcs (base-and/c-ctcs ctc)) (define blame-accepters (map get/build-late-neg-projection (base-and/c-ctcs ctc)))
(λ (blame) (λ (blame)
(λ (val) (define new-blame (blame-add-context blame "an and/c case of"))
(define projs (map (λ (f) (f new-blame)) blame-accepters))
(λ (val neg-party)
(let loop ([predicates predicates] (let loop ([predicates predicates]
[ctcs ctcs]) [projs projs])
(cond (cond
[(null? predicates) (λ (neg-party) val)] [(null? predicates) val]
[else [else
(cond (cond
[((car predicates) val) [((car predicates) val)
(loop (cdr predicates) (cdr ctcs))] (loop (cdr predicates) (cdr projs))]
[else [else
(define ctc1-val-first-proj (get/build-val-first-projection (car ctcs))) ((car projs) val neg-party)])])))))
(define new-blame (blame-add-context blame "an and/c case of"))
((ctc1-val-first-proj new-blame) val)])])))))
(define (and-stronger? this that) (define (and-stronger? this that)
(and (base-and/c? that) (and (base-and/c? that)
@ -264,7 +265,7 @@
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:projection first-order-and-proj #:projection first-order-and-proj
#:val-first-projection first-order-val-first-and-proj #:late-neg-projection first-order-late-neg-and-proj
#:name and-name #:name and-name
#:first-order and-first-order #:first-order and-first-order
#:stronger and-stronger? #:stronger and-stronger?
@ -275,7 +276,7 @@
(parameterize ([skip-projection-wrapper? #t]) (parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property (build-chaperone-contract-property
#:projection and-proj #:projection and-proj
#:val-first-projection val-first-and-proj #:late-neg-projection late-neg-and-proj
#:name and-name #:name and-name
#:first-order and-first-order #:first-order and-first-order
#:stronger and-stronger? #:stronger and-stronger?
@ -285,7 +286,7 @@
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection and-proj #:projection and-proj
#:val-first-projection val-first-and-proj #:late-neg-projection late-neg-and-proj
#:name and-name #:name and-name
#:first-order and-first-order #:first-order and-first-order
#:stronger and-stronger? #:stronger and-stronger?
@ -708,8 +709,8 @@
(elem-proj+blame x)) (elem-proj+blame x))
(raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))]))) (raise-listof-blame-error blame val (pe-listof-ctc? ctc) #f))))])))
(define (listof-val-first-projection ctc) (define (listof-late-neg-projection ctc)
(define elem-proj (get/build-val-first-projection (listof-ctc-elem-c ctc))) (define elem-proj (get/build-late-neg-projection (listof-ctc-elem-c ctc)))
(define pred? (if (pe-listof-ctc? ctc) (define pred? (if (pe-listof-ctc? ctc)
list? list?
non-empty-list?)) non-empty-list?))
@ -718,49 +719,45 @@
(cond (cond
[(flat-listof-ctc? ctc) [(flat-listof-ctc? ctc)
(if (im-listof-ctc? ctc) (if (im-listof-ctc? ctc)
(λ (val) (λ (val neg-party)
(λ (neg-party) (let loop ([val val])
(let loop ([val val]) (cond
(cond [(pair? val)
[(pair? val) (elem-proj+blame (car val) neg-party)
((elem-proj+blame (car val)) neg-party) (loop (cdr val))]
(loop (cdr val))] [else
[else (elem-proj+blame val neg-party)]))
((elem-proj+blame val) neg-party)])) val)
val)) (λ (val neg-party)
(λ (val) (cond
(if (pred? val) [(pred? val)
(λ (neg-party) (for ([x (in-list val)])
(for ([x (in-list val)]) (elem-proj+blame x neg-party))
((elem-proj+blame x) neg-party)) val]
val) [else
(λ (neg-party) (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)])))]
(raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)))))]
[else [else
(if (im-listof-ctc? ctc) (if (im-listof-ctc? ctc)
(λ (val) (λ (val neg-party)
(λ (neg-party) (let loop ([val val])
(let loop ([val val]) (cond
(cond [(pair? val)
[(pair? val) (cons (elem-proj+blame (car val) neg-party)
(cons ((elem-proj+blame (car val)) neg-party) (loop (cdr val)))]
(loop (cdr val)))] [else
[else (elem-proj+blame val neg-party)])))
((elem-proj+blame val) neg-party)])))) (λ (val neg-party)
(λ (val) (if (pred? val)
(if (pred? val) (for/list ([x (in-list val)])
(λ (neg-party) (elem-proj+blame x neg-party))
(for/list ([x (in-list val)]) (raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party))))])))
((elem-proj+blame x) neg-party)))
(λ (neg-party)
(raise-listof-blame-error blame val (pe-listof-ctc? ctc) neg-party)))))])))
(define flat-prop (define flat-prop
(build-flat-contract-property (build-flat-contract-property
#:name list-name #:name list-name
#:first-order list-fo-check #:first-order list-fo-check
#:projection listof-projection #:projection listof-projection
#:val-first-projection listof-val-first-projection #:late-neg-projection listof-late-neg-projection
#:generate listof-generate #:generate listof-generate
#:exercise listof-exercise #:exercise listof-exercise
#:stronger listof-stronger #:stronger listof-stronger
@ -770,7 +767,7 @@
#:name list-name #:name list-name
#:first-order list-fo-check #:first-order list-fo-check
#:projection listof-projection #:projection listof-projection
#:val-first-projection listof-val-first-projection #:late-neg-projection listof-late-neg-projection
#:generate listof-generate #:generate listof-generate
#:exercise listof-exercise #:exercise listof-exercise
#:stronger listof-stronger #:stronger listof-stronger
@ -780,7 +777,7 @@
#:name list-name #:name list-name
#:first-order list-fo-check #:first-order list-fo-check
#:projection listof-projection #:projection listof-projection
#:val-first-projection listof-val-first-projection #:late-neg-projection listof-late-neg-projection
#:generate listof-generate #:generate listof-generate
#:exercise listof-exercise #:exercise listof-exercise
#:stronger listof-stronger #:stronger listof-stronger
@ -875,21 +872,20 @@
(define (blame-add-cdr-context blame) (blame-add-context blame "the cdr of")) (define (blame-add-cdr-context blame) (blame-add-context blame "the cdr of"))
(define ((cons/c-val-first-ho-check combine) ctc) (define ((cons/c-late-neg-ho-check combine) ctc)
(define ctc-car (the-cons/c-hd-ctc ctc)) (define ctc-car (the-cons/c-hd-ctc ctc))
(define ctc-cdr (the-cons/c-tl-ctc ctc)) (define ctc-cdr (the-cons/c-tl-ctc ctc))
(define car-val-first-proj (get/build-val-first-projection ctc-car)) (define car-late-neg-proj (get/build-late-neg-projection ctc-car))
(define cdr-val-first-proj (get/build-val-first-projection ctc-cdr)) (define cdr-late-neg-proj (get/build-late-neg-projection ctc-cdr))
(λ (blame) (λ (blame)
(define car-p (car-val-first-proj (blame-add-car-context blame))) (define car-p (car-late-neg-proj (blame-add-car-context blame)))
(define cdr-p (cdr-val-first-proj (blame-add-cdr-context blame))) (define cdr-p (cdr-late-neg-proj (blame-add-cdr-context blame)))
(λ (v) (λ (v neg-party)
(λ (neg-party) (unless (pair? v)
(unless (pair? v) (raise-not-cons-blame-error blame #:missing-party neg-party v))
(raise-not-cons-blame-error blame #:missing-party neg-party v)) (combine v
(combine v (car-p (car v) neg-party)
((car-p (car v)) neg-party) (cdr-p (cdr v) neg-party)))))
((cdr-p (cdr v)) neg-party))))))
(define ((cons/c-ho-check combine) ctc) (define ((cons/c-ho-check combine) ctc)
(define ctc-car (the-cons/c-hd-ctc ctc)) (define ctc-car (the-cons/c-hd-ctc ctc))
@ -959,7 +955,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:val-first-projection (cons/c-val-first-ho-check (λ (v a d) v)) #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) v))
#:projection (cons/c-ho-check (λ (v a d) v)) #:projection (cons/c-ho-check (λ (v a d) v))
#:name cons/c-name #:name cons/c-name
#:first-order cons/c-first-order #:first-order cons/c-first-order
@ -971,7 +967,7 @@
#:property prop:chaperone-contract #:property prop:chaperone-contract
(parameterize ([skip-projection-wrapper? #t]) (parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property (build-chaperone-contract-property
#:val-first-projection (cons/c-val-first-ho-check (λ (v a d) (cons a d))) #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d)))
#:projection (cons/c-ho-check (λ (v a d) (cons a d))) #:projection (cons/c-ho-check (λ (v a d) (cons a d)))
#:name cons/c-name #:name cons/c-name
#:first-order cons/c-first-order #:first-order cons/c-first-order
@ -982,7 +978,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:val-first-projection (cons/c-val-first-ho-check (λ (v a d) (cons a d))) #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d)))
#:projection (cons/c-ho-check (λ (v a d) (cons a d))) #:projection (cons/c-ho-check (λ (v a d) (cons a d)))
#:name cons/c-name #:name cons/c-name
#:first-order cons/c-first-order #:first-order cons/c-first-order
@ -1001,8 +997,8 @@
[else [else
(impersonator-cons/c ctc-car ctc-cdr)])) (impersonator-cons/c ctc-car ctc-cdr)]))
(define (cons/dc-val-first-projection ctc) (define (cons/dc-late-neg-projection ctc)
(define undep-proj (get/build-val-first-projection (the-cons/dc-undep ctc))) (define undep-proj (get/build-late-neg-projection (the-cons/dc-undep ctc)))
(define dep-proc (the-cons/dc-dep ctc)) (define dep-proc (the-cons/dc-dep ctc))
(define forwards? (the-cons/dc-forwards? ctc)) (define forwards? (the-cons/dc-forwards? ctc))
(λ (blame) (λ (blame)
@ -1013,28 +1009,26 @@
(undep-proj (blame-replace-negative (undep-proj (blame-replace-negative
(if forwards? cdr-blame car-blame) (if forwards? cdr-blame car-blame)
(the-cons/dc-here ctc)))) (the-cons/dc-here ctc))))
(λ (val) (λ (val neg-party)
(cond (cond
[(pair? val) [(pair? val)
(λ (neg-party) (define-values (orig-undep orig-dep)
(define-values (orig-undep orig-dep)
(if forwards?
(values (car val) (cdr val))
(values (cdr val) (car val))))
(define new-undep ((undep-proj+blame orig-undep) neg-party))
(define new-dep-ctc (coerce-contract
'cons/dc
(dep-proc ((undep-proj+indy-blame orig-undep) neg-party))))
(define new-dep ((((get/build-val-first-projection new-dep-ctc)
(if forwards? cdr-blame car-blame))
orig-dep)
neg-party))
(if forwards? (if forwards?
(cons new-undep new-dep) (values (car val) (cdr val))
(cons new-dep new-undep)))] (values (cdr val) (car val))))
(define new-undep (undep-proj+blame orig-undep neg-party))
(define new-dep-ctc (coerce-contract
'cons/dc
(dep-proc (undep-proj+indy-blame orig-undep neg-party))))
(define new-dep (((get/build-late-neg-projection new-dep-ctc)
(if forwards? cdr-blame car-blame))
orig-dep
neg-party))
(if forwards?
(cons new-undep new-dep)
(cons new-dep new-undep))]
[else [else
(λ (neg-party) (raise-not-cons-blame-error blame val #:missing-party neg-party)]))))
(raise-not-cons-blame-error blame val #:missing-party neg-party))]))))
(define (cons/dc-name ctc) (define (cons/dc-name ctc)
(define info (the-cons/dc-name-info ctc)) (define info (the-cons/dc-name-info ctc))
@ -1079,7 +1073,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:val-first-projection cons/dc-val-first-projection #:late-neg-projection cons/dc-late-neg-projection
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger? #:stronger cons/dc-stronger?
@ -1089,7 +1083,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:val-first-projection cons/dc-val-first-projection #:late-neg-projection cons/dc-late-neg-projection
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger? #:stronger cons/dc-stronger?
@ -1099,7 +1093,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:val-first-projection cons/dc-val-first-projection #:late-neg-projection cons/dc-late-neg-projection
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger? #:stronger cons/dc-stronger?
@ -1240,37 +1234,34 @@
#:generate list/c-generate #:generate list/c-generate
#:exercise list/c-exercise #:exercise list/c-exercise
#:stronger list/c-stronger #:stronger list/c-stronger
#:val-first-projection #:late-neg-projection
(λ (c) (λ (c)
(λ (blame) (λ (blame)
(define projs (define projs
(for/list ([ctc (in-list (generic-list/c-args c))] (for/list ([ctc (in-list (generic-list/c-args c))]
[i (in-naturals 1)]) [i (in-naturals 1)])
((get/build-val-first-projection ctc) ((get/build-late-neg-projection ctc)
(add-list-context blame i)))) (add-list-context blame i))))
(define expected-length (length (generic-list/c-args c))) (define args (generic-list/c-args c))
(λ (val) (define expected-length (length args))
(λ (val neg-party)
(cond (cond
[(list? val) [(list? val)
(define args (generic-list/c-args c))
(define actual-length (length val)) (define actual-length (length val))
(cond (cond
[(= actual-length expected-length) [(= actual-length expected-length)
(λ (neg-party) (for ([proj (in-list projs)]
(for ([proj (in-list projs)] [ele (in-list val)])
[ele (in-list val)]) (proj ele neg-party))
((proj ele) neg-party)) val]
val)]
[else [else
(λ (neg-party) (expected-a-list-of-len val actual-length expected-length blame
(expected-a-list-of-len val actual-length expected-length blame #:missing-party neg-party)])]
#:missing-party neg-party))])]
[else [else
(λ (neg-party) (raise-blame-error blame #:missing-party neg-party
(raise-blame-error blame #:missing-party neg-party val
val '(expected "a list" given: "~e")
'(expected "a list" given: "~e") val)]))))
val))]))))
#:projection #:projection
(lambda (c) (lambda (c)
(lambda (blame) (lambda (blame)
@ -1327,30 +1318,27 @@
(if (= actual 1) "" "s") (if (= actual 1) "" "s")
x)]))) x)])))
(define (list/c-chaperone/other-val-first-projection c) (define (list/c-chaperone/other-late-neg-projection c)
(define projs (map get/build-val-first-projection (generic-list/c-args c))) (define projs (map get/build-late-neg-projection (generic-list/c-args c)))
(define expected (length projs)) (define expected (length projs))
(λ (blame) (λ (blame)
(define p-apps (for/list ([proj (in-list projs)] (define p-apps (for/list ([proj (in-list projs)]
[i (in-naturals 1)]) [i (in-naturals 1)])
(proj (add-list-context blame i)))) (proj (add-list-context blame i))))
(λ (val) (λ (val neg-party)
(cond (cond
[(list? val) [(list? val)
(define actual (length val)) (define actual (length val))
(cond (cond
[(= actual expected) [(= actual expected)
(λ (neg-party) (for/list ([item (in-list val)]
(for/list ([item (in-list val)] [p-app (in-list p-apps)])
[p-app (in-list p-apps)]) (p-app item neg-party))]
((p-app item) neg-party)))]
[else [else
(λ (neg-party) (expected-a-list-of-len val actual expected blame
(expected-a-list-of-len val actual expected blame #:missing-party neg-party)])]
#:missing-party neg-party))])]
[else [else
(λ (neg-party) (expected-a-list val blame #:missing-party neg-party)]))))
(expected-a-list val blame #:missing-party neg-party))]))))
(define (add-list-context blame i) (define (add-list-context blame i)
(blame-add-context blame (format "the ~a~a element of" (blame-add-context blame (format "the ~a~a element of"
@ -1372,7 +1360,7 @@
#:exercise list/c-exercise #:exercise list/c-exercise
#:stronger list/c-stronger #:stronger list/c-stronger
#:projection list/c-chaperone/other-projection #:projection list/c-chaperone/other-projection
#:val-first-projection list/c-chaperone/other-val-first-projection #:late-neg-projection list/c-chaperone/other-late-neg-projection
#:list-contract? (λ (c) #t)))) #:list-contract? (λ (c) #t))))
(struct higher-order-list/c generic-list/c () (struct higher-order-list/c generic-list/c ()
@ -1385,7 +1373,7 @@
#:exercise list/c-exercise #:exercise list/c-exercise
#:stronger list/c-stronger #:stronger list/c-stronger
#:projection list/c-chaperone/other-projection #:projection list/c-chaperone/other-projection
#:val-first-projection list/c-chaperone/other-val-first-projection #:late-neg-projection list/c-chaperone/other-late-neg-projection
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
(struct syntax-ctc (ctc) (struct syntax-ctc (ctc)
@ -1416,30 +1404,28 @@
[else [else
(promise-ctc ctc)]))) (promise-ctc ctc)])))
(define (promise-contract-val-first-proj ctc) (define (promise-contract-late-neg-proj ctc)
(define chap? (chaperone-promise-ctc? ctc)) (define chap? (chaperone-promise-ctc? ctc))
(define c/i-struct (if chap? chaperone-struct impersonate-struct)) (define c/i-struct (if chap? chaperone-struct impersonate-struct))
(define c/i-procedure (if chap? chaperone-procedure impersonate-procedure)) (define c/i-procedure (if chap? chaperone-procedure impersonate-procedure))
(define ctc-proc (get/build-val-first-projection (promise-base-ctc-ctc ctc))) (define ctc-proc (get/build-late-neg-projection (promise-base-ctc-ctc ctc)))
(λ (blame) (λ (blame)
(define p-app (ctc-proc (blame-add-context blame "the promise from"))) (define p-app (ctc-proc (blame-add-context blame "the promise from")))
(λ (val) (λ (val neg-party)
(if (promise? val) (if (promise? val)
(λ (neg-party) (c/i-struct
(c/i-struct val
val promise-forcer
promise-forcer (λ (_ proc)
(λ (_ proc) (c/i-procedure
(c/i-procedure proc
proc (λ (promise)
(λ (promise) (values (λ (val) (p-app val neg-party)) promise)))))
(values (λ (val) ((p-app val) neg-party)) promise)))))) (raise-blame-error
(λ (neg-party) blame #:missing-party neg-party
(raise-blame-error val
blame #:missing-party neg-party '(expected: "<promise>" given: "~e")
val val)))))
'(expected: "<promise>" given: "~e")
val))))))
(define (promise-contract-name ctc) (define (promise-contract-name ctc)
(build-compound-type-name 'promise/c (promise-base-ctc-ctc ctc))) (build-compound-type-name 'promise/c (promise-base-ctc-ctc ctc)))
@ -1455,7 +1441,7 @@
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:name promise-contract-name #:name promise-contract-name
#:val-first-projection promise-contract-val-first-proj #:late-neg-projection promise-contract-late-neg-proj
#:stronger promise-ctc-stronger? #:stronger promise-ctc-stronger?
#:first-order (λ (ctc) promise?))) #:first-order (λ (ctc) promise?)))
(struct promise-ctc promise-base-ctc () (struct promise-ctc promise-base-ctc ()
@ -1463,7 +1449,7 @@
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name promise-contract-name #:name promise-contract-name
#:val-first-projection promise-contract-val-first-proj #:late-neg-projection promise-contract-late-neg-proj
#:stronger promise-ctc-stronger? #:stronger promise-ctc-stronger?
#:first-order (λ (ctc) promise?))) #:first-order (λ (ctc) promise?)))
@ -1509,31 +1495,29 @@
partial-pos-contract)] partial-pos-contract)]
[else [else
(raise-blame-error blame val '(expected "a parameter"))]))))) (raise-blame-error blame val '(expected "a parameter"))])))))
#:val-first-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define in-proc (contract-projection (parameter/c-in ctc))) (define in-proc (get/build-late-neg-projection (parameter/c-in ctc)))
(define out-proc (contract-projection (parameter/c-out ctc))) (define out-proc (get/build-late-neg-projection (parameter/c-out ctc)))
(λ (blame) (λ (blame)
(define blame/c (blame-add-context blame "the parameter of")) (define blame/c (blame-add-context blame "the parameter of"))
(define swapped (blame-swap blame/c)) (define in-proj (in-proc (blame-swap blame/c)))
(λ (val) (define out-proj (out-proc blame/c))
(λ (val neg-party)
(cond (cond
[(parameter? val) [(parameter? val)
(λ (neg-party) (define (add-profiling f)
(define (add-profiling f) (λ (x)
(λ (x) (with-continuation-mark contract-continuation-mark-key
(with-continuation-mark contract-continuation-mark-key (cons blame/c neg-party)
(cons blame neg-party) (f x neg-party))))
(f x)))) (make-derived-parameter
(make-derived-parameter val
val (add-profiling in-proj)
;; unfortunately expensive (add-profiling out-proj))]
(add-profiling (in-proc (blame-add-missing-party swapped neg-party)))
(add-profiling (out-proc (blame-add-missing-party blame/c neg-party)))))]
[else [else
(λ (neg-party) (raise-blame-error blame #:missing-party neg-party
(raise-blame-error blame #:missing-party neg-party val '(expected "a parameter"))]))))
val '(expected "a parameter")))]))))
#:name #:name
(λ (ctc) (apply build-compound-type-name (λ (ctc) (apply build-compound-type-name
@ -1584,7 +1568,7 @@
(define (get-any? c) any?) (define (get-any? c) any?)
(define (any? x) #t) (define (any? x) #t)
(define any/c-neg-party-fn (λ (val) (λ (neg-party) val))) (define any/c-neg-party-fn (λ (val neg-party) val))
(define (random-any/c env fuel) (define (random-any/c env fuel)
(define env-hash (contract-random-generate-env-hash env)) (define env-hash (contract-random-generate-env-hash env))
@ -1624,7 +1608,7 @@
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:projection get-any-projection #:projection get-any-projection
#:val-first-projection (λ (ctc) (λ (blame) any/c-neg-party-fn)) #:late-neg-projection (λ (ctc) (λ (blame) any/c-neg-party-fn))
#:stronger (λ (this that) (any/c? that)) #:stronger (λ (this that) (any/c? that))
#:name (λ (ctc) 'any/c) #:name (λ (ctc) 'any/c)
#:generate (λ (ctc) #:generate (λ (ctc)
@ -1648,7 +1632,7 @@
(none/c-name ctc) (none/c-name ctc)
val)))) val))))
(define ((((none-curried-val-first-proj ctc) blame) val) neg-party) (define (((none-curried-late-neg-proj ctc) blame) val neg-party)
(raise-blame-error (raise-blame-error
blame #:missing-party neg-party blame #:missing-party neg-party
val val
@ -1662,7 +1646,7 @@
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:projection none-curried-proj #:projection none-curried-proj
#:val-first-projection none-curried-val-first-proj #:late-neg-projection none-curried-late-neg-proj
#:stronger (λ (this that) #t) #:stronger (λ (this that) #t)
#:name (λ (ctc) (none/c-name ctc)) #:name (λ (ctc) (none/c-name ctc))
#:first-order (λ (ctc) (λ (val) #f)))) #:first-order (λ (ctc) (λ (val) #f))))
@ -1731,52 +1715,51 @@
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))) impersonator-prop:blame blame))))
(define ((prompt-tag/c-val-first-proj chaperone?) ctc) (define ((prompt-tag/c-late-neg-proj chaperone?) ctc)
(define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag)) (define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag))
(define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure)) (define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure))
(define ho-projs (define ho-projs
(map get/build-val-first-projection (base-prompt-tag/c-ctcs ctc))) (map get/build-late-neg-projection (base-prompt-tag/c-ctcs ctc)))
(define call/cc-projs (define call/cc-projs
(map get/build-val-first-projection (base-prompt-tag/c-call/ccs ctc))) (map get/build-late-neg-projection (base-prompt-tag/c-call/ccs ctc)))
(λ (blame) (λ (blame)
(define swapped (blame-swap blame)) (define swapped (blame-swap blame))
(define ho-neg-projs (for/list ([proj (in-list ho-projs)]) (proj swapped))) (define ho-neg-projs (for/list ([proj (in-list ho-projs)]) (proj swapped)))
(define ho-pos-projs (for/list ([proj (in-list ho-projs)]) (proj blame))) (define ho-pos-projs (for/list ([proj (in-list ho-projs)]) (proj blame)))
(define cc-neg-projs (for/list ([proj (in-list call/cc-projs)]) (proj swapped))) (define cc-neg-projs (for/list ([proj (in-list call/cc-projs)]) (proj swapped)))
(define cc-pos-projs (for/list ([proj (in-list call/cc-projs)]) (proj blame))) (define cc-pos-projs (for/list ([proj (in-list call/cc-projs)]) (proj blame)))
(λ (val) (define (make-proj projs neg-party)
(define (make-proj projs neg-party) (λ vs
(λ vs (apply values
(define vs2 (for/list ([proj projs] [v vs]) (for/list ([proj (in-list projs)]
((proj v) neg-party))) [v (in-list vs)])
(apply values vs2))) (proj v neg-party)))))
(λ (val neg-party)
;; now do the actual wrapping ;; now do the actual wrapping
(cond (cond
[(continuation-prompt-tag? val) [(continuation-prompt-tag? val)
(λ (neg-party) ;; prompt/abort projections
;; prompt/abort projections (define proj1 (make-proj ho-pos-projs neg-party))
(define proj1 (make-proj ho-pos-projs neg-party)) (define proj2 (make-proj ho-neg-projs neg-party))
(define proj2 (make-proj ho-neg-projs neg-party)) ;; call/cc projections
;; call/cc projections (define call/cc-guard (make-proj cc-pos-projs neg-party))
(define call/cc-guard (make-proj cc-pos-projs neg-party)) (define call/cc-proxy
(define call/cc-proxy (λ (f)
(λ (f) (proc-proxy
(proc-proxy f
f (λ args
(λ args (apply values (make-proj cc-neg-projs neg-party) args)))))
(apply values (make-proj cc-neg-projs neg-party) args))))) (proxy val
(proxy val proj1 proj2
proj1 proj2 call/cc-guard call/cc-proxy
call/cc-guard call/cc-proxy impersonator-prop:contracted ctc
impersonator-prop:contracted ctc impersonator-prop:blame (blame-add-missing-party blame neg-party))]
impersonator-prop:blame (blame-add-missing-party blame neg-party)))]
[else [else
(λ (neg-party) (raise-blame-error
(raise-blame-error blame #:missing-party neg-party val
blame #:missing-party neg-party val '(expected: "~s" given: "~e")
'(expected: "~s" given: "~e") (contract-name ctc)
(contract-name ctc) val)]))))
val))]))))
(define (prompt-tag/c-stronger? this that) (define (prompt-tag/c-stronger? this that)
(and (base-prompt-tag/c? that) (and (base-prompt-tag/c? that)
@ -1794,7 +1777,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:val-first-projection (prompt-tag/c-val-first-proj #t) #:late-neg-projection (prompt-tag/c-late-neg-proj #t)
#:projection (prompt-tag/c-proj #t) #:projection (prompt-tag/c-proj #t)
#:first-order (λ (ctc) continuation-prompt-tag?) #:first-order (λ (ctc) continuation-prompt-tag?)
#:stronger prompt-tag/c-stronger? #:stronger prompt-tag/c-stronger?
@ -1804,7 +1787,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:val-first-projection (prompt-tag/c-val-first-proj #f) #:late-neg-projection (prompt-tag/c-late-neg-proj #f)
#:projection (prompt-tag/c-proj #f) #:projection (prompt-tag/c-proj #f)
#:first-order (λ (ctc) continuation-prompt-tag?) #:first-order (λ (ctc) continuation-prompt-tag?)
#:stronger prompt-tag/c-stronger? #:stronger prompt-tag/c-stronger?
@ -1841,31 +1824,29 @@
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))) impersonator-prop:blame blame))))
(define ((continuation-mark-key/c-val-first-proj proxy) ctc) (define ((continuation-mark-key/c-late-neg-proj proxy) ctc)
(define ho-proj (define ho-proj
(get/build-val-first-projection (base-continuation-mark-key/c-ctc ctc))) (get/build-late-neg-projection (base-continuation-mark-key/c-ctc ctc)))
(λ (blame) (λ (blame)
(define swapped (blame-swap blame)) (define swapped (blame-swap blame))
(define proj1 (ho-proj blame)) (define proj1 (ho-proj blame))
(define proj2 (ho-proj (blame-swap blame))) (define proj2 (ho-proj (blame-swap blame)))
(λ (val) (λ (val neg-party)
(cond (cond
[(continuation-mark-key? val) [(continuation-mark-key? val)
(λ (neg-party) (proxy val
(proxy val (λ (v) (proj1 v neg-party))
(λ (v) ((proj1 v) neg-party)) (λ (v) (proj2 v neg-party))
(λ (v) ((proj2 v) neg-party)) impersonator-prop:contracted ctc
impersonator-prop:contracted ctc impersonator-prop:blame blame)]
impersonator-prop:blame blame))]
[else [else
(λ (neg-party) (unless (contract-first-order-passes? ctc val)
(unless (contract-first-order-passes? ctc val) (raise-blame-error
(raise-blame-error blame #:missing-party neg-party
blame #:missing-party neg-party val
val '(expected: "~s" given: "~e")
'(expected: "~s" given: "~e") (contract-name ctc)
(contract-name ctc) val))]))))
val)))]))))
(define (continuation-mark-key/c-stronger? this that) (define (continuation-mark-key/c-stronger? this that)
(and (base-continuation-mark-key/c? that) (and (base-continuation-mark-key/c? that)
@ -1881,7 +1862,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:val-first-projection (continuation-mark-key/c-val-first-proj chaperone-continuation-mark-key) #:late-neg-projection (continuation-mark-key/c-late-neg-proj chaperone-continuation-mark-key)
#:projection (continuation-mark-key/c-proj chaperone-continuation-mark-key) #:projection (continuation-mark-key/c-proj chaperone-continuation-mark-key)
#:first-order (λ (ctc) continuation-mark-key?) #:first-order (λ (ctc) continuation-mark-key?)
#:stronger continuation-mark-key/c-stronger? #:stronger continuation-mark-key/c-stronger?
@ -1893,7 +1874,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:val-first-projection (continuation-mark-key/c-val-first-proj impersonate-continuation-mark-key) #:late-neg-projection (continuation-mark-key/c-late-neg-proj impersonate-continuation-mark-key)
#:projection (continuation-mark-key/c-proj impersonate-continuation-mark-key) #:projection (continuation-mark-key/c-proj impersonate-continuation-mark-key)
#:first-order (λ (ctc) continuation-mark-key?) #:first-order (λ (ctc) continuation-mark-key?)
#:stronger continuation-mark-key/c-stronger? #:stronger continuation-mark-key/c-stronger?
@ -1995,30 +1976,28 @@
impersonator-prop:contracted ctc impersonator-prop:contracted ctc
impersonator-prop:blame blame)))) impersonator-prop:blame blame))))
(define ((channel/c-val-first-proj proxy) ctc) (define ((channel/c-late-neg-proj proxy) ctc)
(define ho-proj (define ho-proj
(get/build-val-first-projection (base-channel/c-ctc ctc))) (get/build-late-neg-projection (base-channel/c-ctc ctc)))
(λ (blame) (λ (blame)
(define pos-proj (ho-proj blame)) (define pos-proj (ho-proj blame))
(define neg-proj (ho-proj (blame-swap blame))) (define neg-proj (ho-proj (blame-swap blame)))
(define (proj1 neg-party) (λ (ch) (values ch (λ (v) ((pos-proj v) neg-party))))) (define (proj1 neg-party) (λ (ch) (values ch (λ (v) (pos-proj v neg-party)))))
(define (proj2 neg-party) (λ (ch v) ((neg-proj v) neg-party))) (define (proj2 neg-party) (λ (ch v) (neg-proj v neg-party)))
(λ (val) (λ (val neg-party)
(cond (cond
[(channel? val) [(channel? val)
(λ (neg-party) (proxy val
(proxy val (proj1 neg-party)
(proj1 neg-party) (proj2 neg-party)
(proj2 neg-party) impersonator-prop:contracted ctc
impersonator-prop:contracted ctc impersonator-prop:blame blame)]
impersonator-prop:blame blame))]
[else [else
(λ (neg-party) (raise-blame-error
(raise-blame-error blame #:missing-party neg-party
blame #:missing-party neg-party val '(expected: "~s" given: "~e")
val '(expected: "~s" given: "~e") (contract-name ctc)
(contract-name ctc) val)]))))
val))]))))
(define (channel/c-first-order ctc) channel?) (define (channel/c-first-order ctc) channel?)
@ -2035,7 +2014,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:val-first-projection (channel/c-val-first-proj chaperone-channel) #:late-neg-projection (channel/c-late-neg-proj chaperone-channel)
#:projection (channel/c-proj chaperone-channel) #:projection (channel/c-proj chaperone-channel)
#:first-order channel/c-first-order #:first-order channel/c-first-order
#:stronger channel/c-stronger? #:stronger channel/c-stronger?
@ -2046,7 +2025,7 @@
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:val-first-projection (channel/c-val-first-proj impersonate-channel) #:late-neg-projection (channel/c-late-neg-proj impersonate-channel)
#:projection (channel/c-proj impersonate-channel) #:projection (channel/c-proj impersonate-channel)
#:first-order channel/c-first-order #:first-order channel/c-first-order
#:stronger channel/c-stronger? #:stronger channel/c-stronger?
@ -2086,6 +2065,9 @@
(define (contract-val-first-projection ctc) (define (contract-val-first-projection ctc)
(contract-struct-val-first-projection (contract-struct-val-first-projection
(coerce-contract 'contract-projection ctc))) (coerce-contract 'contract-projection ctc)))
(define (contract-late-neg-projection ctc)
(contract-struct-late-neg-projection
(coerce-contract 'contract-projection ctc)))
(define (get/build-val-first-projection ctc) (define (get/build-val-first-projection ctc)
(or (contract-struct-val-first-projection ctc) (or (contract-struct-val-first-projection ctc)
@ -2097,6 +2079,14 @@
((p (blame-add-missing-party blme neg-party)) val))) ((p (blame-add-missing-party blme neg-party)) val)))
(string->symbol (format "val-first: ~s" (contract-name ctc)))))))) (string->symbol (format "val-first: ~s" (contract-name ctc))))))))
(define (get/build-late-neg-projection ctc)
(or (contract-struct-late-neg-projection ctc)
(let ([p (contract-projection ctc)])
(λ (blme)
(procedure-rename
(λ (val neg-party)
((p (blame-add-missing-party blme neg-party)) val))
(string->symbol (format "late-neg: ~s" (contract-name ctc))))))))
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-named-contract name pre-contract [generate #f]) (define (flat-named-contract name pre-contract [generate #f])

53
racket/collects/racket/contract/private/orc.rkt
View File

@ -68,15 +68,15 @@
[(pred val) val] [(pred val) val]
[else (partial-contract val)]))))) [else (partial-contract val)])))))
(define (single-or/c-val-first-projection ctc) (define (single-or/c-late-neg-projection ctc)
(define c-proj (get/build-val-first-projection (single-or/c-ho-ctc ctc))) (define c-proj (get/build-late-neg-projection (single-or/c-ho-ctc ctc)))
(define pred (single-or/c-pred ctc)) (define pred (single-or/c-pred ctc))
(λ (blame) (λ (blame)
(define p-app (c-proj (blame-add-or-context blame))) (define p-app (c-proj (blame-add-or-context blame)))
(λ (val) (λ (val neg-party)
(if (pred val) (if (pred val)
(λ (neg-party) val) val
(p-app val))))) (p-app val neg-party)))))
(define (blame-add-or-context blame) (define (blame-add-or-context blame)
(blame-add-context blame "a part of the or/c of")) (blame-add-context blame "a part of the or/c of"))
@ -200,7 +200,7 @@
(parameterize ([skip-projection-wrapper? #t]) (parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property (build-chaperone-contract-property
#:projection single-or/c-projection #:projection single-or/c-projection
#:val-first-projection single-or/c-val-first-projection #:late-neg-projection single-or/c-late-neg-projection
#:name single-or/c-name #:name single-or/c-name
#:first-order single-or/c-first-order #:first-order single-or/c-first-order
#:stronger single-or/c-stronger? #:stronger single-or/c-stronger?
@ -215,7 +215,7 @@
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection single-or/c-projection #:projection single-or/c-projection
#:val-first-projection single-or/c-val-first-projection #:late-neg-projection single-or/c-late-neg-projection
#:name single-or/c-name #:name single-or/c-name
#:first-order single-or/c-first-order #:first-order single-or/c-first-order
#:stronger single-or/c-stronger? #:stronger single-or/c-stronger?
@ -273,21 +273,22 @@
candidate-proc candidate-proc
candidate-contract)]))]))))) candidate-contract)]))])))))
(define (multi-or/c-val-first-proj ctc) (define (multi-or/c-late-neg-proj ctc)
(define ho-contracts (multi-or/c-ho-ctcs ctc)) (define ho-contracts (multi-or/c-ho-ctcs ctc))
(define c-projs (map get/build-val-first-projection ho-contracts)) (define c-projs (map get/build-late-neg-projection ho-contracts))
(define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)) (define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts))
(define predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))) (define predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc)))
(λ (blame) (λ (blame)
(define blame-w-context (blame-add-or-context blame)) (define blame-w-context (blame-add-or-context blame))
(λ (val) (define c-projs+blame (map (λ (c-proj) (c-proj blame-w-context)) c-projs))
(λ (val neg-party)
(cond (cond
[(for/or ([pred (in-list predicates)]) [(for/or ([pred (in-list predicates)])
(pred val)) (pred val))
(λ (neg-party) val)] val]
[else [else
(let loop ([checks first-order-checks] (let loop ([checks first-order-checks]
[c-projs c-projs] [c-projs c-projs+blame]
[contracts ho-contracts] [contracts ho-contracts]
[candidate-c-proj #f] [candidate-c-proj #f]
[candidate-contract #f]) [candidate-contract #f])
@ -295,22 +296,20 @@
[(null? checks) [(null? checks)
(cond (cond
[candidate-c-proj [candidate-c-proj
((candidate-c-proj blame-w-context) val)] (candidate-c-proj val neg-party)]
[else [else
(λ (neg-party) (raise-blame-error blame val #:missing-party neg-party
(raise-blame-error blame val #:missing-party neg-party '("none of the branches of the or/c matched" given: "~e")
'("none of the branches of the or/c matched" given: "~e") val)])]
val))])]
[((car checks) val) [((car checks) val)
(if candidate-c-proj (if candidate-c-proj
(λ (neg-party) (raise-blame-error blame val #:missing-party neg-party
(raise-blame-error blame val #:missing-party neg-party '("two of the clauses in the or/c might both match: ~s and ~s"
'("two of the clauses in the or/c might both match: ~s and ~s" given:
given: "~e")
"~e") (contract-name candidate-contract)
(contract-name candidate-contract) (contract-name (car contracts))
(contract-name (car contracts)) val)
val))
(loop (cdr checks) (loop (cdr checks)
(cdr c-projs) (cdr c-projs)
(cdr contracts) (cdr contracts)
@ -359,7 +358,7 @@
(parameterize ([skip-projection-wrapper? #t]) (parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property (build-chaperone-contract-property
#:projection multi-or/c-proj #:projection multi-or/c-proj
#:val-first-projection multi-or/c-val-first-proj #:late-neg-projection multi-or/c-late-neg-proj
#:name multi-or/c-name #:name multi-or/c-name
#:first-order multi-or/c-first-order #:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger? #:stronger multi-or/c-stronger?
@ -374,7 +373,7 @@
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection multi-or/c-proj #:projection multi-or/c-proj
#:val-first-projection multi-or/c-val-first-proj #:late-neg-projection multi-or/c-late-neg-proj
#:name multi-or/c-name #:name multi-or/c-name
#:first-order multi-or/c-first-order #:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger? #:stronger multi-or/c-stronger?

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

@ -10,6 +10,7 @@
contract-struct-first-order contract-struct-first-order
contract-struct-projection contract-struct-projection
contract-struct-val-first-projection contract-struct-val-first-projection
contract-struct-late-neg-projection
contract-struct-stronger? contract-struct-stronger?
contract-struct-generate contract-struct-generate
contract-struct-exercise contract-struct-exercise
@ -66,6 +67,7 @@
generate generate
exercise exercise
val-first-projection val-first-projection
late-neg-projection
list-contract? ] list-contract? ]
#:omit-define-syntaxes) #:omit-define-syntaxes)
@ -106,6 +108,12 @@
(and get-projection (and get-projection
(get-projection c))) (get-projection c)))
(define (contract-struct-late-neg-projection c)
(define prop (contract-struct-property c))
(define get-projection (contract-property-late-neg-projection prop))
(and get-projection
(get-projection c)))
(define trail (make-parameter #f)) (define trail (make-parameter #f))
(define (contract-struct-stronger? a b) (define (contract-struct-stronger? a b)
(define prop (contract-struct-property a)) (define prop (contract-struct-property a))
@ -255,6 +263,7 @@
#:first-order [get-first-order #f] #:first-order [get-first-order #f]
#:projection [get-projection #f] #:projection [get-projection #f]
#:val-first-projection [get-val-first-projection #f] #:val-first-projection [get-val-first-projection #f]
#:late-neg-projection [get-late-neg-projection #f]
#:stronger [stronger #f] #:stronger [stronger #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))] #:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
@ -289,7 +298,8 @@
(mk get-name get-first-order (mk get-name get-first-order
get-projection stronger get-projection stronger
generate exercise generate exercise
get-val-first-projection get-val-first-projection
get-late-neg-projection
list-contract?))) list-contract?)))
(define build-contract-property (define build-contract-property
@ -372,7 +382,8 @@
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct make-contract [ name first-order projection val-first-projection (define-struct make-contract [ name first-order projection
val-first-projection late-neg-projection
stronger generate exercise list-contract? ] stronger generate exercise list-contract? ]
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write #:property prop:custom-write
@ -386,12 +397,14 @@
#:first-order (lambda (c) (make-contract-first-order c)) #:first-order (lambda (c) (make-contract-first-order c))
#:projection (lambda (c) (make-contract-projection c)) #:projection (lambda (c) (make-contract-projection c))
#:val-first-projection (lambda (c) (make-contract-val-first-projection c)) #:val-first-projection (lambda (c) (make-contract-val-first-projection c))
#:late-neg-projection (lambda (c) (make-contract-late-neg-projection c))
#:stronger (lambda (a b) ((make-contract-stronger a) a b)) #:stronger (lambda (a b) ((make-contract-stronger a) a b))
#:generate (lambda (c) (make-contract-generate c)) #:generate (lambda (c) (make-contract-generate c))
#:exercise (lambda (c) (make-contract-exercise c)) #:exercise (lambda (c) (make-contract-exercise c))
#:list-contract? (λ (c) (make-contract-list-contract? c)))) #:list-contract? (λ (c) (make-contract-list-contract? c))))
(define-struct make-chaperone-contract [ name first-order projection val-first-projection (define-struct make-chaperone-contract [ name first-order projection
val-first-projection late-neg-projection
stronger generate exercise list-contract? ] stronger generate exercise list-contract? ]
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write #:property prop:custom-write
@ -405,12 +418,14 @@
#:first-order (lambda (c) (make-chaperone-contract-first-order c)) #:first-order (lambda (c) (make-chaperone-contract-first-order c))
#:projection (lambda (c) (make-chaperone-contract-projection c)) #:projection (lambda (c) (make-chaperone-contract-projection c))
#:val-first-projection (lambda (c) (make-chaperone-contract-val-first-projection c)) #:val-first-projection (lambda (c) (make-chaperone-contract-val-first-projection c))
#:late-neg-projection (lambda (c) (make-chaperone-contract-late-neg-projection c))
#:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b)) #:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
#:generate (lambda (c) (make-chaperone-contract-generate c)) #:generate (lambda (c) (make-chaperone-contract-generate c))
#:exercise (lambda (c) (make-chaperone-contract-exercise c)) #:exercise (lambda (c) (make-chaperone-contract-exercise c))
#:list-contract? (λ (c) (make-chaperone-contract-list-contract? c)))) #:list-contract? (λ (c) (make-chaperone-contract-list-contract? c))))
(define-struct make-flat-contract [ name first-order projection val-first-projection (define-struct make-flat-contract [ name first-order projection
val-first-projection late-neg-projection
stronger generate exercise list-contract? ] stronger generate exercise list-contract? ]
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write #:property prop:custom-write
@ -423,6 +438,7 @@
#:name (lambda (c) (make-flat-contract-name c)) #:name (lambda (c) (make-flat-contract-name c))
#:first-order (lambda (c) (make-flat-contract-first-order c)) #:first-order (lambda (c) (make-flat-contract-first-order c))
#:val-first-projection (λ (c) (make-flat-contract-val-first-projection c)) #:val-first-projection (λ (c) (make-flat-contract-val-first-projection c))
#:late-neg-projection (λ (c) (make-flat-contract-late-neg-projection c))
#:projection (lambda (c) (make-flat-contract-projection c)) #:projection (lambda (c) (make-flat-contract-projection c))
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b)) #:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
#:generate (lambda (c) (make-flat-contract-generate c)) #:generate (lambda (c) (make-flat-contract-generate c))
@ -434,6 +450,7 @@
#:first-order [first-order #f] #:first-order [first-order #f]
#:projection [projection #f] #:projection [projection #f]
#:val-first-projection [val-first-projection #f] #:val-first-projection [val-first-projection #f]
#:late-neg-projection [late-neg-projection #f]
#:stronger [stronger #f] #:stronger [stronger #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))] #:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
@ -448,7 +465,7 @@
[stronger (or stronger as-strong?)]) [stronger (or stronger as-strong?)])
(mk name first-order (mk name first-order
projection val-first-projection projection val-first-projection late-neg-projection
stronger stronger
generate exercise generate exercise
list-contract?))) list-contract?)))

106
racket/collects/racket/contract/private/vector.rkt
View File

@ -68,9 +68,9 @@
(fail val '(expected: "~s for element ~s" given: "~e") (contract-name elem-ctc) n e)))) (fail val '(expected: "~s for element ~s" given: "~e") (contract-name elem-ctc) n e))))
#t))) #t)))
(define (check-val-first-vectorof c) (define (check-late-neg-vectorof c)
(define immutable (base-vectorof-immutable c)) (define immutable (base-vectorof-immutable c))
(λ (val blame) (λ (val blame neg-party)
(cond (cond
[(vector? val) [(vector? val)
(cond (cond
@ -78,23 +78,20 @@
(cond (cond
[(immutable? val) #f] [(immutable? val) #f]
[else [else
(λ (neg-party) (raise-blame-error blame #:missing-party neg-party
(raise-blame-error blame #:missing-party neg-party val '(expected "an immutable vector" given: "~e") val)])]
val '(expected "an immutable vector" given: "~e") val))])]
[(eq? immutable #f) [(eq? immutable #f)
(cond (cond
[(immutable? val) [(immutable? val)
(λ (neg-party) (raise-blame-error blame #:missing-party neg-party
(raise-blame-error blame #:missing-party neg-party val '(expected "an mutable vector" given: "~e" val))]
val '(expected "an mutable vector" given: "~e" val)))]
[else #f])] [else #f])]
[else #f])] [else #f])]
[else [else
(λ (neg-party) (raise-blame-error blame #:missing-party neg-party
(raise-blame-error blame #:missing-party neg-party val
val '(expected "a vector," given: "~e")
'(expected "a vector," given: "~e") val)])))
val))])))
(define (vectorof-first-order ctc) (define (vectorof-first-order ctc)
(let ([check (check-vectorof ctc)]) (let ([check (check-vectorof ctc)])
@ -126,29 +123,28 @@
(build-flat-contract-property (build-flat-contract-property
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:val-first-projection (λ (ctc) #:late-neg-projection (λ (ctc)
(define check (check-val-first-vectorof ctc)) (define check (check-late-neg-vectorof ctc))
(define vfp (get/build-val-first-projection (base-vectorof-elem ctc))) (define vfp (get/build-late-neg-projection (base-vectorof-elem ctc)))
(λ (blame) (λ (blame)
(define ele-blame (blame-add-element-of-context blame)) (define ele-blame (blame-add-element-of-context blame))
(define vfp+blame (vfp ele-blame)) (define vfp+blame (vfp ele-blame))
(λ (val) (λ (val neg-party)
(or (check val blame) (check val blame neg-party)
(λ (neg-party) (for ([x (in-vector val)])
(for ([x (in-vector val)]) (vfp+blame x neg-party))
((vfp+blame x) neg-party)) val)))
val)))))
#:stronger vectorof-stronger #:stronger vectorof-stronger
#:projection #:projection
(λ (ctc) (λ (ctc)
(define check (check-vectorof ctc)) (define check (check-vectorof ctc))
(λ (blame) (λ (blame)
(define raise-blame (λ (val . args) (define raise-blame (λ (val . args) (apply raise-blame-error blame val args)))
(apply raise-blame-error blame val args))) (define ele-blame (blame-add-element-of-context blame))
(λ (val) (λ (val)
(check val raise-blame #f) (check val raise-blame #f)
(let* ([elem-ctc (base-vectorof-elem ctc)] (let* ([elem-ctc (base-vectorof-elem ctc)]
[p ((contract-projection elem-ctc) blame)]) [p ((contract-projection elem-ctc) ele-blame)])
(for ([e (in-vector val)]) (for ([e (in-vector val)])
(p e))) (p e)))
val))))) val)))))
@ -156,7 +152,7 @@
(define (blame-add-element-of-context blame #:swap? [swap? #f]) (define (blame-add-element-of-context blame #:swap? [swap? #f])
(blame-add-context blame "an element of" #:swap? swap?)) (blame-add-context blame "an element of" #:swap? swap?))
(define (vectorof-val-first-ho-projection chaperone-or-impersonate-vector) (define (vectorof-late-neg-ho-projection chaperone-or-impersonate-vector)
(λ (ctc) (λ (ctc)
(define elem-ctc (base-vectorof-elem ctc)) (define elem-ctc (base-vectorof-elem ctc))
(define immutable (base-vectorof-immutable ctc)) (define immutable (base-vectorof-immutable ctc))
@ -164,40 +160,34 @@
(λ (blame) (λ (blame)
(define pos-blame (blame-add-element-of-context blame)) (define pos-blame (blame-add-element-of-context blame))
(define neg-blame (blame-add-element-of-context blame #:swap? #t)) (define neg-blame (blame-add-element-of-context blame #:swap? #t))
(define vfp (get/build-val-first-projection elem-ctc)) (define vfp (get/build-late-neg-projection elem-ctc))
(define elem-pos-proj (vfp pos-blame)) (define elem-pos-proj (vfp pos-blame))
(define elem-neg-proj (vfp neg-blame)) (define elem-neg-proj (vfp neg-blame))
(define checked-ref (λ (neg-party) (define checked-ref (λ (neg-party)
(λ (vec i val) (λ (vec i val)
(with-continuation-mark (with-continuation-mark contract-continuation-mark-key
contract-continuation-mark-key (cons pos-blame neg-party)
(cons pos-blame neg-party) (elem-pos-proj val neg-party)))))
((elem-pos-proj val) neg-party)))))
(define checked-set (λ (neg-party) (define checked-set (λ (neg-party)
(λ (vec i val) (λ (vec i val)
(with-continuation-mark (with-continuation-mark contract-continuation-mark-key
contract-continuation-mark-key (cons neg-blame neg-party)
(cons neg-blame neg-party) (elem-neg-proj val neg-party)))))
((elem-neg-proj val) neg-party)))))
(λ (val) (λ (val neg-party)
(let/ec k (define (raise-blame val . args)
(define (raise-blame val . args) (apply raise-blame-error blame #:missing-party neg-party val args))
(k (check val raise-blame #f)
(λ (neg-party) (if (and (immutable? val) (not (chaperone? val)))
(apply raise-blame-error blame #:missing-party neg-party val args)))) (apply vector-immutable
(check val raise-blame #f) (for/list ([e (in-vector val)])
(λ (neg-party) (elem-pos-proj e neg-party)))
(if (and (immutable? val) (not (chaperone? val))) (chaperone-or-impersonate-vector
(apply vector-immutable val
(for/list ([e (in-vector val)]) (checked-ref neg-party)
((elem-pos-proj e) neg-party))) (checked-set neg-party)
(chaperone-or-impersonate-vector impersonator-prop:contracted ctc
val impersonator-prop:blame (blame-add-missing-party blame neg-party)))))))
(checked-ref neg-party)
(checked-set neg-party)
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))))))))
(define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get) (define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
(make-impersonator-property 'prop:neg-blame-party)) (make-impersonator-property 'prop:neg-blame-party))
@ -242,7 +232,7 @@
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:stronger vectorof-stronger #:stronger vectorof-stronger
#:val-first-projection (vectorof-val-first-ho-projection chaperone-vector) #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)
#:projection (vectorof-ho-projection chaperone-vector))) #:projection (vectorof-ho-projection chaperone-vector)))
(define-struct (impersonator-vectorof base-vectorof) () (define-struct (impersonator-vectorof base-vectorof) ()
@ -252,7 +242,7 @@
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:stronger vectorof-stronger #:stronger vectorof-stronger
#:val-first-projection (vectorof-val-first-ho-projection chaperone-vector) #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)
#:projection (vectorof-ho-projection impersonate-vector))) #:projection (vectorof-ho-projection impersonate-vector)))
(define-syntax (wrap-vectorof stx) (define-syntax (wrap-vectorof stx)