From 81cd1e3404c27bafb55247c8b1edcb82d1c5ef6c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 23 May 2014 10:15:00 -0500 Subject: [PATCH] vectorof contract: add some tests and make flat variant subscribe to the val-first protocol --- .../tests/racket/contract/context.rkt | 5 ++ .../tests/racket/contract/vector.rkt | 50 ++++++++++- .../racket/contract/private/vector.rkt | 90 ++++++++++++++----- 3 files changed, 123 insertions(+), 22 deletions(-) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt index 4422a93b9a..7657ab852e 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/context.rkt @@ -465,6 +465,11 @@ 'pos 'neg)) + (context-test '("an element of") + '(contract (vectorof integer? #:flat? #t) + (vector-immutable #f) + 'pos 'neg)) + (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/vector.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/vector.rkt index 4b2dabd1f4..b1971d94c2 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/vector.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/vector.rkt @@ -44,6 +44,48 @@ 0 #f))) + (test/pos-blame + 'vectorof7 + '(contract (vectorof integer? #:immutable #t) + (vector-immutable #f) + 'pos 'neg)) + + (test/pos-blame + 'vectorof8 + '(contract (vectorof integer? #:immutable #t) + 11 + 'pos 'neg)) + + (test/pos-blame + 'vectorof9 + '(contract (vectorof integer? #:immutable #t) + (vector 11) + 'pos 'neg)) + + (test/spec-passed + 'vectorof10 + '(contract (vectorof integer? #:flat? #t) + (vector 11) + 'pos 'neg)) + + (test/pos-blame + 'vectorof10 + '(contract (vectorof integer? #:flat? #t) + (vector #f) + 'pos 'neg)) + + (test/pos-blame + 'vectorof11 + '(contract (vectorof integer? #:flat? #t) + (vector-immutable #f) + 'pos 'neg)) + + (test/spec-passed + 'vectorof12 + '(contract (vectorof integer? #:flat? #t) + (vector-immutable 11) + 'pos 'neg)) + (test/spec-passed 'vector/c1 '(let ([v (chaperone-vector (vector-immutable 1) @@ -82,4 +124,10 @@ (λ (vec i v) v) (λ (vec i v) v))]) (vector-set! (contract (vector/c integer?) v 'pos 'neg) - 0 #f)))) + 0 #f))) + + (test/pos-blame + 'vector/c6 + '(contract (vector/c integer? #:immutable #t) + (vector-immutable #f) + 'pos 'neg))) diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index 8a21e7d445..eb41878f4f 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -68,6 +68,34 @@ (fail val '(expected: "~s for element ~s" given: "~e") (contract-name elem-ctc) n e)))) #t))) +(define (check-val-first-vectorof c) + (define immutable (base-vectorof-immutable c)) + (λ (val blame) + (cond + [(vector? val) + (cond + [(eq? immutable #t) + (cond + [(immutable? val) #f] + [else + (λ (neg-party) + (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)))] + [else #f])] + [else #f])] + [else + (λ (neg-party) + (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)]) (λ (val) @@ -80,6 +108,18 @@ (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))))) #:projection (λ (ctc) (define check (check-vectorof ctc)) @@ -94,16 +134,20 @@ (p e))) val))))) +(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) (λ (ctc) (define elem-ctc (base-vectorof-elem ctc)) (define immutable (base-vectorof-immutable ctc)) (define check (check-vectorof ctc)) (λ (blame) - (define pos-blame (blame-add-context blame "an element of")) - (define neg-blame (blame-add-context blame "an element of" #:swap? #t)) - (define elem-pos-proj ((get/build-val-first-projection elem-ctc) pos-blame)) - (define elem-neg-proj ((get/build-val-first-projection elem-ctc) neg-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 elem-pos-proj (vfp pos-blame)) + (define elem-neg-proj (vfp neg-blame)) (define checked-ref (λ (neg-party) (λ (vec i val) (with-continuation-mark @@ -144,8 +188,10 @@ [immutable (base-vectorof-immutable ctc)] [check (check-vectorof ctc)]) (λ (blame) - (let ([elem-pos-proj ((contract-projection elem-ctc) (blame-add-context blame "an element of"))] - [elem-neg-proj ((contract-projection elem-ctc) (blame-add-context blame "an element of" #:swap? #t))]) + (let ([elem-pos-proj ((contract-projection elem-ctc) + (blame-add-element-of-context blame))] + [elem-neg-proj ((contract-projection elem-ctc) + (blame-add-element-of-context blame #:swap? #t))]) (define checked-ref (λ (vec i val) (with-continuation-mark contract-continuation-mark-key blame @@ -204,19 +250,20 @@ 'racket/contract:contract (vector this-one (list #'vecof) null))))])) -(define (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f]) - (let ([ctc (if flat? - (coerce-flat-contract 'vectorof c) - (coerce-contract 'vectorof c))]) - (cond - [(or flat? - (and (eq? immutable #t) - (flat-contract? ctc))) - (make-flat-vectorof ctc immutable)] - [(chaperone-contract? ctc) - (make-chaperone-vectorof ctc immutable)] - [else - (make-impersonator-vectorof ctc immutable)]))) +(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f]) + (define ctc + (if flat? + (coerce-flat-contract 'vectorof c) + (coerce-contract 'vectorof c))) + (cond + [(or flat? + (and (equal? immutable #t) + (flat-contract? ctc))) + (make-flat-vectorof ctc immutable)] + [(chaperone-contract? ctc) + (make-chaperone-vectorof ctc immutable)] + [else + (make-impersonator-vectorof ctc immutable)])) (define/subexpression-pos-prop (vector-immutableof c) (vectorof c #:immutable #t)) @@ -283,7 +330,7 @@ #:projection (λ (ctc) (λ (blame) - (define blame+ctxt (blame-add-context blame "an element of")) + (define blame+ctxt (blame-add-element-of-context blame)) (λ (val) (with-continuation-mark contract-continuation-mark-key blame @@ -308,7 +355,8 @@ ([c (in-list elem-ctcs)] [i (in-naturals)]) ((contract-projection c) - (blame-add-context blame (format "the ~a element of" (n->th i)) #:swap? #t)))]) + (blame-add-context blame (format "the ~a element of" (n->th i)) + #:swap? #t)))]) (λ (val) (check-vector/c ctc val blame) (if (and (immutable? val) (not (chaperone? val)))