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
[#:name name any/c 'anonymous-contract]
[#: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
(or/c #f (-> blame? (-> any/c (-> any/c any/c))))
#f]
@ -1852,6 +1856,10 @@ accepted by the third argument to @racket[datum->syntax].
@defproc[(make-chaperone-contract
[#:name name any/c 'anonymous-chaperone-contract]
[#: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-proj
(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
[#:name name any/c 'anonymous-flat-contract]
[#: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-proj
(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?]
)]{
@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,
respectively. They both take the same set of three optional arguments: a name,
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
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
object, and the second accepts a value to protect with the contract. The
projection must either produce the value, suitably wrapped to enforce any
higher-order aspects of the contract, or signal a contract violation using
@racket[raise-blame-error]. The default projection produces an error when the
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
@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
(-> contract? (-> any/c boolean?))
(λ (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-proj
(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
(-> contract? (-> any/c boolean?))
(λ (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-proj
(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
(-> contract? (-> any/c boolean?))
(λ (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-proj
(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)
((blame-accepting-proj (blame-add-missing-party blame neg-party)) val))
(->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
#:name (λ (ctc)
(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
(with-syntax ([rng-len (length rngs)])
(with-syntax ([rng-results
#'(values ((rng-ctc rng-x) neg-party)
#'(values (rng-ctc rng-x neg-party)
...)])
#'(case-lambda
[(rng-x ...)
@ -185,7 +185,7 @@
[opt-keywords (map (λ (p) (syntax-e (car p))) opt-kwds)]
[need-apply-values? (or dom-rest (not (null? opt-doms)))]
[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
(cond
[dom-rest
@ -197,10 +197,10 @@
[else
#'(this-param ... dom-x ... [opt-dom-x arrow:unspecified-dom] ...)])]
[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
(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 ...))))])
#`(let ([r #,i])
(if (eq? arrow:unspecified-dom #,opt-dom-x) r (cons #,o r))))]
@ -214,7 +214,7 @@
[kwd-stx
(let* ([req-stxs
(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
(map (λ (x c) (λ (r) #`(maybe-cons-kwd #,c #,x #,r neg-party)))
(syntax->list #'(opt-kwd-x ...))
@ -348,40 +348,42 @@
(define (maybe-cons-kwd c x r neg-party)
(if (eq? arrow:unspecified-dom x)
r
(cons ((c x) neg-party) r)))
(cons (c x neg-party) r)))
(define (->-proj chaperone-or-impersonate-procedure ctc
;; fields of the 'ctc' struct
min-arity doms kwd-infos rest pre? rngs post?
plus-one-arity-function chaperone-constructor)
(define doms-proj (map get/build-val-first-projection doms))
(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))))
plus-one-arity-function chaperone-constructor
late-neg?)
(define optionals-length (- (length doms) min-arity))
(define mtd? #f) ;; not yet supported for the new contracts
(λ (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 partial-doms
(for/list ([dom (in-list doms-proj)]
(define partial-doms
(for/list ([dom (in-list doms)]
[n (in-naturals 1)])
(dom (blame-add-context orig-blame
(format "the ~a argument of" (n->th n))
#:swap? #t))))
(define partial-rest (and rest-proj
(rest-proj
((get/build-late-neg-projection dom)
(blame-add-context orig-blame
(format "the ~a argument of" (n->th n))
#:swap? #t))))
(define partial-rest (and rest
((get/build-late-neg-projection rest)
(blame-add-context orig-blame "the rest argument of"
#: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
(for/list ([kwd-proj (in-list kwds-proj)]
(for/list ([kwd-info (in-list kwd-infos)]
[kwd (in-list kwd-infos)])
(kwd-proj (blame-add-context orig-blame
(format "the ~a argument of" (kwd-info-kwd kwd))
#:swap? #t))))
((get/build-late-neg-projection (kwd-info-ctc kwd-info))
(blame-add-context orig-blame
(format "the ~a argument of" (kwd-info-kwd kwd))
#:swap? #t))))
(define man-then-opt-partial-kwds
(append (for/list ([partial-kwd (in-list partial-kwds)]
[kwd-info (in-list kwd-infos)]
@ -401,27 +403,42 @@
man-then-opt-partial-kwds
partial-ranges
(if partial-rest (list partial-rest) '())))
(λ (val)
(wrapped-extra-arg-arrow
(cond
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
=>
values]
[else
(λ (neg-party)
(define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args))
(if post?
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party))
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
impersonator-prop:application-mark (cons arrow:contract-key
;; is this right?
partial-ranges))))])
(apply plus-one-arity-function orig-blame val plus-one-constructor-args)))))
(define (successfully-got-the-right-kind-of-function val neg-party)
(define chap/imp-func (apply chaperone-constructor orig-blame val neg-party the-args))
(if post?
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party))
(chaperone-or-impersonate-procedure
val
chap/imp-func
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
impersonator-prop:application-mark (cons arrow:contract-key
;; is this right?
partial-ranges))))
(cond
[late-neg?
(λ (val neg-party)
(cond
[(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
=>
(λ (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 '()))]
[(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 base-arg-vars normal-arg-vars)
@ -190,7 +190,7 @@
append
(map (λ (kwd kwd-arg-x kb)
(set! base-arg-expressions
(cons #`((#,kb #,kwd-arg-x) neg-party)
(cons #`(#,kb #,kwd-arg-x neg-party)
base-arg-expressions))
(set! base-arg-vars (cons (car (generate-temporaries (list kwd-arg-x)))
base-arg-vars))
@ -228,7 +228,7 @@
#,@(for/list ([ob (in-list (reverse ob))]
[optional-arg (in-list (reverse optional-args))])
(set! args-expressions
(cons #`((#,ob #,optional-arg) neg-party)
(cons #`(#,ob #,optional-arg neg-party)
args-expressions))
(set! args-vars
(cons (car (generate-temporaries (list optional-arg)))
@ -237,7 +237,7 @@
(define full-call
(cond
[(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)))
args-vars))
#`(apply #,@no-rest-call #,(car args-vars))]
@ -281,7 +281,9 @@
#'(res-x ...))))]
[else
post-check ...
(values ((rb res-x) neg-party) ...)])))]
(values
(rb res-x neg-party)
...)])))]
#`[#,the-args
pre-check ...
(let ([blame+neg-party (cons blame neg-party)])
@ -340,7 +342,7 @@
(cond
[(and (pair? mandatory-kwds)
(equal? (car mandatory-kwds) kwd))
(cons (((car kbs) kwd-arg) neg-party)
(cons ((car kbs) kwd-arg neg-party)
(loop (cdr kwds)
(cdr kwd-args)
(cdr mandatory-kwds)
@ -349,7 +351,7 @@
okbs))]
[(and (pair? optional-kwds)
(equal? (car optional-kwds) kwd))
(cons (((car okbs) kwd-arg) neg-party)
(cons ((car okbs) kwd-arg neg-party)
(loop (cdr kwds)
(cdr kwd-args)
mandatory-kwds
@ -368,9 +370,9 @@
[rbs rbs])
(cond
[(null? regular-args) '()]
[(null? rbs) ((rest-ctc regular-args) neg-party)]
[(null? rbs) (rest-ctc regular-args neg-party)]
[else
(cons (((car rbs) (car regular-args)) neg-party)
(cons ((car rbs) (car regular-args) neg-party)
(loop (cdr regular-args) (cdr rbs)))]))))
(define complete-blame (blame-add-missing-party blame neg-party))
(when pre (check-pre-cond pre blame neg-party f))
@ -385,7 +387,7 @@
values
(for/list ([result (in-list results)]
[rng (in-list rngs)])
((rng result) neg-party)))]
(rng result neg-party)))]
[else
(mk-call)]))))
@ -908,16 +910,16 @@
(define kwd-results
(for/list ([kwd (in-list kwds)]
[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
(let loop ([args args]
[projs mandatory+optional-dom-projs])
(cond
[(and (null? projs) (null? args)) '()]
[(null? projs)
((rest-proj args) neg-party)]
(rest-proj args neg-party)]
[(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)))])))
(define (result-checker . results)
(unless (= rng-len (length results))
@ -926,7 +928,7 @@
values
(for/list ([res (in-list results)]
[neg-party-proj (in-list rng-projs)])
((neg-party-proj res) neg-party))))
(neg-party-proj res neg-party))))
(define args-dealt-with
(if (null? kwds)
regular-arg-results
@ -1132,7 +1134,7 @@
#t))
(define (make-property build-X-property chaperone-or-impersonate-procedure)
(define proj
(define val-first-proj
(λ (->stct)
(->-proj chaperone-or-impersonate-procedure ->stct
(base->-min-arity ->stct)
@ -1143,14 +1145,28 @@
(base->-rngs ->stct)
(base->-post? ->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])
(build-X-property
#:name base->-name
#:first-order ->-first-order
#:projection
(λ (this)
(define cthis (proj this))
(define cthis (val-first-proj this))
(λ (blame)
(define cblame (cthis blame))
(λ (val)
@ -1180,7 +1196,8 @@
(not (base->-post? that))))
#:generate ->-generate
#:exercise ->-exercise
#:val-first-projection proj)))
#:val-first-projection val-first-proj
#:late-neg-projection late-neg-proj)))
(define-struct (-> base->) ()
#:property
@ -1207,11 +1224,11 @@
(λ () (f))
(case-lambda
[(rng)
(unless (void? rng)
(raise-blame-error blame #:missing-party neg-party rng
'(expected: "void?" given: "~e")
rng))
rng]
(if (void? rng)
rng
(raise-blame-error blame #:missing-party neg-party rng
'(expected: "void?" given: "~e")
rng))]
[args
(wrong-number-of-results-blame blame neg-party f args 1)]))))
(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)
(let ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc)
(define cvfp (contract-val-first-projection c))
(define clnp (contract-late-neg-projection c))
(define blame
(make-blame (build-source-location loc)
name
@ -65,10 +65,10 @@
;; instead of changing the library around.
(or pos "false")
(if cvfp #f neg)
(if clnp #f neg)
#t))
(cond
[cvfp (((cvfp blame) v) neg)]
[clnp ((clnp blame) v neg)]
[else (((contract-projection c) blame) v)])))
(define-syntax (invariant-assertion stx)

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

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

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

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

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

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

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

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

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

@ -68,15 +68,15 @@
[(pred val) val]
[else (partial-contract val)])))))
(define (single-or/c-val-first-projection ctc)
(define c-proj (get/build-val-first-projection (single-or/c-ho-ctc ctc)))
(define (single-or/c-late-neg-projection ctc)
(define c-proj (get/build-late-neg-projection (single-or/c-ho-ctc ctc)))
(define pred (single-or/c-pred ctc))
(λ (blame)
(define p-app (c-proj (blame-add-or-context blame)))
(λ (val)
(λ (val neg-party)
(if (pred val)
(λ (neg-party) val)
(p-app val)))))
val
(p-app val neg-party)))))
(define (blame-add-or-context blame)
(blame-add-context blame "a part of the or/c of"))
@ -200,7 +200,7 @@
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#: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
#:first-order single-or/c-first-order
#:stronger single-or/c-stronger?
@ -215,7 +215,7 @@
#:property prop:contract
(build-contract-property
#: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
#:first-order single-or/c-first-order
#:stronger single-or/c-stronger?
@ -273,21 +273,22 @@
candidate-proc
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 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 predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc)))
(λ (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
[(for/or ([pred (in-list predicates)])
(pred val))
(λ (neg-party) val)]
val]
[else
(let loop ([checks first-order-checks]
[c-projs c-projs]
[c-projs c-projs+blame]
[contracts ho-contracts]
[candidate-c-proj #f]
[candidate-contract #f])
@ -295,22 +296,20 @@
[(null? checks)
(cond
[candidate-c-proj
((candidate-c-proj blame-w-context) val)]
(candidate-c-proj val neg-party)]
[else
(λ (neg-party)
(raise-blame-error blame val #:missing-party neg-party
'("none of the branches of the or/c matched" given: "~e")
val))])]
(raise-blame-error blame val #:missing-party neg-party
'("none of the branches of the or/c matched" given: "~e")
val)])]
[((car checks) val)
(if candidate-c-proj
(λ (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"
given:
"~e")
(contract-name candidate-contract)
(contract-name (car contracts))
val))
(raise-blame-error blame val #:missing-party neg-party
'("two of the clauses in the or/c might both match: ~s and ~s"
given:
"~e")
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(loop (cdr checks)
(cdr c-projs)
(cdr contracts)
@ -359,7 +358,7 @@
(parameterize ([skip-projection-wrapper? #t])
(build-chaperone-contract-property
#: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
#:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger?
@ -374,7 +373,7 @@
#:property prop:contract
(build-contract-property
#: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
#:first-order multi-or/c-first-order
#: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-projection
contract-struct-val-first-projection
contract-struct-late-neg-projection
contract-struct-stronger?
contract-struct-generate
contract-struct-exercise
@ -66,6 +67,7 @@
generate
exercise
val-first-projection
late-neg-projection
list-contract? ]
#:omit-define-syntaxes)
@ -106,6 +108,12 @@
(and get-projection
(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 (contract-struct-stronger? a b)
(define prop (contract-struct-property a))
@ -255,6 +263,7 @@
#:first-order [get-first-order #f]
#:projection [get-projection #f]
#:val-first-projection [get-val-first-projection #f]
#:late-neg-projection [get-late-neg-projection #f]
#:stronger [stronger #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
@ -289,7 +298,8 @@
(mk get-name get-first-order
get-projection stronger
generate exercise
get-val-first-projection
get-val-first-projection
get-late-neg-projection
list-contract?)))
(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? ]
#:omit-define-syntaxes
#:property prop:custom-write
@ -386,12 +397,14 @@
#:first-order (lambda (c) (make-contract-first-order c))
#:projection (lambda (c) (make-contract-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))
#:generate (lambda (c) (make-contract-generate c))
#:exercise (lambda (c) (make-contract-exercise 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? ]
#:omit-define-syntaxes
#:property prop:custom-write
@ -405,12 +418,14 @@
#:first-order (lambda (c) (make-chaperone-contract-first-order c))
#:projection (lambda (c) (make-chaperone-contract-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))
#:generate (lambda (c) (make-chaperone-contract-generate c))
#:exercise (lambda (c) (make-chaperone-contract-exercise 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? ]
#:omit-define-syntaxes
#:property prop:custom-write
@ -423,6 +438,7 @@
#:name (lambda (c) (make-flat-contract-name c))
#:first-order (lambda (c) (make-flat-contract-first-order 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))
#:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
#:generate (lambda (c) (make-flat-contract-generate c))
@ -434,6 +450,7 @@
#:first-order [first-order #f]
#:projection [projection #f]
#:val-first-projection [val-first-projection #f]
#:late-neg-projection [late-neg-projection #f]
#:stronger [stronger #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
@ -448,7 +465,7 @@
[stronger (or stronger as-strong?)])
(mk name first-order
projection val-first-projection
projection val-first-projection late-neg-projection
stronger
generate exercise
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))))
#t)))
(define (check-val-first-vectorof c)
(define (check-late-neg-vectorof c)
(define immutable (base-vectorof-immutable c))
(λ (val blame)
(λ (val blame neg-party)
(cond
[(vector? val)
(cond
@ -78,23 +78,20 @@
(cond
[(immutable? val) #f]
[else
(λ (neg-party)
(raise-blame-error blame #:missing-party neg-party
val '(expected "an immutable vector" given: "~e") val))])]
(raise-blame-error blame #:missing-party neg-party
val '(expected "an immutable vector" given: "~e") val)])]
[(eq? immutable #f)
(cond
[(immutable? val)
(λ (neg-party)
(raise-blame-error blame #:missing-party neg-party
val '(expected "an mutable vector" given: "~e" val)))]
(raise-blame-error blame #:missing-party neg-party
val '(expected "an mutable vector" given: "~e" val))]
[else #f])]
[else #f])]
[else
(λ (neg-party)
(raise-blame-error blame #:missing-party neg-party
val
'(expected "a vector," given: "~e")
val))])))
(raise-blame-error blame #:missing-party neg-party
val
'(expected "a vector," given: "~e")
val)])))
(define (vectorof-first-order ctc)
(let ([check (check-vectorof ctc)])
@ -126,29 +123,28 @@
(build-flat-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:val-first-projection (λ (ctc)
(define check (check-val-first-vectorof ctc))
(define vfp (get/build-val-first-projection (base-vectorof-elem ctc)))
(λ (blame)
(define ele-blame (blame-add-element-of-context blame))
(define vfp+blame (vfp ele-blame))
(λ (val)
(or (check val blame)
(λ (neg-party)
(for ([x (in-vector val)])
((vfp+blame x) neg-party))
val)))))
#:late-neg-projection (λ (ctc)
(define check (check-late-neg-vectorof ctc))
(define vfp (get/build-late-neg-projection (base-vectorof-elem ctc)))
(λ (blame)
(define ele-blame (blame-add-element-of-context blame))
(define vfp+blame (vfp ele-blame))
(λ (val neg-party)
(check val blame neg-party)
(for ([x (in-vector val)])
(vfp+blame x neg-party))
val)))
#:stronger vectorof-stronger
#:projection
(λ (ctc)
(define check (check-vectorof ctc))
(λ (blame)
(define raise-blame (λ (val . args)
(apply raise-blame-error blame val args)))
(define raise-blame (λ (val . args) (apply raise-blame-error blame val args)))
(define ele-blame (blame-add-element-of-context blame))
(λ (val)
(check val raise-blame #f)
(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)])
(p e)))
val)))))
@ -156,7 +152,7 @@
(define (blame-add-element-of-context blame #:swap? [swap? #f])
(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)
(define elem-ctc (base-vectorof-elem ctc))
(define immutable (base-vectorof-immutable ctc))
@ -164,40 +160,34 @@
(λ (blame)
(define pos-blame (blame-add-element-of-context blame))
(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-neg-proj (vfp neg-blame))
(define checked-ref (λ (neg-party)
(λ (vec i val)
(with-continuation-mark
contract-continuation-mark-key
(cons pos-blame neg-party)
((elem-pos-proj val) neg-party)))))
(with-continuation-mark contract-continuation-mark-key
(cons pos-blame neg-party)
(elem-pos-proj val neg-party)))))
(define checked-set (λ (neg-party)
(λ (vec i val)
(with-continuation-mark
contract-continuation-mark-key
(cons neg-blame neg-party)
((elem-neg-proj val) neg-party)))))
(with-continuation-mark contract-continuation-mark-key
(cons neg-blame neg-party)
(elem-neg-proj val neg-party)))))
(λ (val)
(let/ec k
(define (raise-blame val . args)
(k
(λ (neg-party)
(apply raise-blame-error blame #:missing-party neg-party val args))))
(check val raise-blame #f)
(λ (neg-party)
(if (and (immutable? val) (not (chaperone? val)))
(apply vector-immutable
(for/list ([e (in-vector val)])
((elem-pos-proj e) neg-party)))
(chaperone-or-impersonate-vector
val
(checked-ref neg-party)
(checked-set neg-party)
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))))))))
(λ (val neg-party)
(define (raise-blame val . args)
(apply raise-blame-error blame #:missing-party neg-party val args))
(check val raise-blame #f)
(if (and (immutable? val) (not (chaperone? val)))
(apply vector-immutable
(for/list ([e (in-vector val)])
(elem-pos-proj e neg-party)))
(chaperone-or-impersonate-vector
val
(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)
(make-impersonator-property 'prop:neg-blame-party))
@ -242,7 +232,7 @@
#:name vectorof-name
#:first-order vectorof-first-order
#: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)))
(define-struct (impersonator-vectorof base-vectorof) ()
@ -252,7 +242,7 @@
#:name vectorof-name
#:first-order vectorof-first-order
#: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)))
(define-syntax (wrap-vectorof stx)