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

Now migrate vector/c and vector-immutable/c.

Browse Source 
Also add old-style vector/c to mzlib/contract.
This commit is contained in:
Stevie Strickland 2010-05-17 13:52:01 -04:00
parent 3028f2d142
commit b416b7e5bb
4 changed files with 202 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/mzlib/private/contract-mutable.rkt
View File

@ -2,7 +2,7 @@
(require (only-in racket/contract/private/box box-immutable/c) (require (only-in racket/contract/private/box box-immutable/c)
(only-in racket/contract/private/vector (only-in racket/contract/private/vector
vector/c vector-immutableof vector-immutable/c) vector-immutableof vector-immutable/c)
racket/contract/private/blame racket/contract/private/blame
racket/contract/private/guts) racket/contract/private/guts)
@ -44,3 +44,30 @@
(for ([v (in-vector val)]) (for ([v (in-vector val)])
(proj v)) (proj v))
val)))))) val))))))
(define/subexpression-pos-prop (vector/c . ctcs)
(let ([ctcs (for/list ([ctc (in-list ctcs)])
(coerce-flat-contract 'vector/c ctc))])
(make-flat-contract
#:name (apply build-compound-type-name 'vector/c ctcs)
#:first-order
(λ (val)
(and (vector? val)
(= (vector-length val) (length ctcs))
(for/and ([v (in-vector val)]
[c (in-list ctcs)])
(contract-first-order-passes? c v))))
#:projection
(λ (blame)
(λ (val)
(let ([projs (for/list ([ctc (in-list ctcs)])
((contract-projection ctc) blame))])
(unless (vector? val)
(raise-blame-error blame val "not a vector"))
(unless (= (vector-length val) (length ctcs))
(raise-blame-error blame val "expected vector of length ~a, got length ~a"
(length ctcs) (vector-length val)))
(for ([v (in-vector val)]
[p (in-list projs)])
(p v))
val))))))

11
collects/mzlib/scribblings/contract.scrbl
View File

@ -85,8 +85,7 @@ from @schememodname[scheme/contract]:
symbols symbols
syntax/c syntax/c
vector-immutable/c vector-immutable/c
vector-immutableof vector-immutableof]
vector/c]
It also provides the old version of the following forms: It also provides the old version of the following forms:
@ -117,3 +116,11 @@ must match @racket[c].}
Accepts a flat contract and returns a flat contract Accepts a flat contract and returns a flat contract
that checks for vectors whose elements match the original contract.} that checks for vectors whose elements match the original contract.}
@defproc[(vector/c [c flat-contract?] ...) flat-contract?]{
Accepts any number of flat contracts and returns a
flat contract that recognizes vectors. The number of elements in the
vector must match the number of arguments supplied to
@racket[vector/c], and each element of the vector must match the
corresponding flat contract.}

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

@ -3,7 +3,8 @@
(require (for-syntax racket/base) (require (for-syntax racket/base)
"guts.ss") "guts.ss")
(provide vector/c (rename-out [wrap-vectorof vectorof]) (provide (rename-out [wrap-vectorof vectorof]
[wrap-vector/c vector/c])
vector-immutable/c vector-immutableof) vector-immutable/c vector-immutableof)
(define-struct vectorof (elem immutable)) (define-struct vectorof (elem immutable))
@ -150,102 +151,154 @@
(define/subexpression-pos-prop (vector-immutableof c) (define/subexpression-pos-prop (vector-immutableof c)
(build-vectorof c #:immutable #t)) (build-vectorof c #:immutable #t))
(define/subexpression-pos-prop (vector/c . args) (define-struct vector/c (elems immutable))
(let* ([ctcs (coerce-flat-contracts 'vector/c args)]
[largs (length args)]
[procs (map flat-contract-predicate ctcs)])
(build-flat-contract
(apply build-compound-type-name 'vector/c ctcs)
(λ (v)
(and (vector? v)
(= (vector-length v) largs)
(andmap (λ (p? x) (p? x))
procs
(vector->list v)))))))
(define-syntax (*-immutable/c stx) (define (vector/c-name c)
(syntax-case stx () (let ([immutable (vector/c-immutable c)])
[(_ predicate? constructor (arb? selectors ...) type-name name) (apply build-compound-type-name 'vector/c
#'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)] (append
[(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?) (map contract-name (vector/c-elems c))
(and (eq? #f (syntax->datum (syntax arb?))) (if (and (flat-vector/c? c)
(boolean? (syntax->datum #'test-immutable?))) (not (eq? immutable #t)))
(let ([test-immutable? (syntax->datum #'test-immutable?)]) (list '#:flat? #t)
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] null)
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))] (if (not (eq? immutable 'dont-care))
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))] (list '#:immutable immutable)
[(procs ...) (generate-temporaries (syntax (selectors ...)))] null)))))
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
#`(let ([predicate?-name predicate?] (define (vector/c-first-order c)
[constructor-name constructor] (let ([elem-ctcs (vector/c-elems c)]
[selector-names selectors] ...) [immutable (vector/c-immutable c)]
(λ (params ...) [flat? (flat-vector/c? c)])
(let ([ctc-x (coerce-contract 'name params)] ...) (λ (val #:blame [blame #f])
(if (and (flat-contract? ctc-x) ...) (let/ec return
(let ([p-apps (flat-contract-predicate ctc-x)] ...) (define (fail . args)
(build-flat-contract (if blame
`(name ,(contract-name ctc-x) ...) (apply raise-blame-error blame val args)
(lambda (x) (return #f)))
(and (predicate?-name x) (unless (vector? val)
(p-apps (selector-names x)) (fail "expected a vector, got ~a" val))
...))))
(let ([procs (contract-projection ctc-x)] ...)
(make-contract
#:name (build-compound-type-name 'name ctc-x ...)
#:projection
(λ (blame)
(let ([p-apps (procs blame)] ...)
(λ (v)
(if #,(if test-immutable?
#'(and (predicate?-name v)
(immutable? v))
#'(predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...)
(raise-blame-error
blame
v
#,(if test-immutable?
"expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e")
'type-name
v)))))))))))))]
[(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax->datum (syntax arb?)))
(syntax
(let ([predicate?-name predicate?]
[constructor-name constructor]
[selector-name selector])
(λ params
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([procs (map contract-projection ctcs)])
(make-contract
#:name (apply build-compound-type-name 'name ctcs)
#:projection
(λ (blame)
(let ([p-apps (map (λ (proc) (proc blame)) procs)]
[count (length params)])
(λ (v)
(if (and (immutable? v)
(predicate?-name v)
(correct-size count v))
(apply constructor-name
(let loop ([p-apps p-apps]
[i 0])
(cond (cond
[(null? p-apps) null] [(eq? immutable #t)
[else (let ([p-app (car p-apps)]) (unless (immutable? val)
(cons (p-app (selector-name v i)) (fail "expected an immutable vector, got ~a" val))]
(loop (cdr p-apps) (+ i 1))))]))) [(eq? immutable #f)
(raise-blame-error (when (immutable? val)
blame (fail "expected an mutable vector, got ~a" val))]
v [else (void)])
"expected <~a>, given: ~e" (let ([elem-count (length elem-ctcs)])
'type-name (unless (= (vector-length val) elem-count)
v)))))))))))])) (fail "expected a vector of ~a element~a, got ~a"
elem-count (if (= elem-count 1) "" "s") val)))
(when (or flat? (and (immutable? val) (not blame)))
(if blame
(for ([e (in-vector val)]
[c (in-list elem-ctcs)])
(((contract-projection c) blame) e))
(for ([e (in-vector val)]
[c (in-list elem-ctcs)])
(unless (contract-first-order-passes? c e)
(fail)))))
#t))))
(define vector-immutable/c (*-immutable/c vector? (define-struct (flat-vector/c vector/c) ()
vector-immutable #:property prop:flat-contract
(#t (λ (v i) (vector-ref v i))) (build-flat-contract-property
(λ (n v) (= n (vector-length v))) #:name vector/c-name
immutable-vector #:first-order vector/c-first-order
vector-immutable/c)) #:projection
(λ (ctc)
(λ (blame)
(λ (val)
((vector/c-first-order ctc) val #:blame blame)
val)))))
(define (vector/c-ho-projection vector-wrapper)
(λ (ctc)
(let ([elem-ctcs (vector/c-elems ctc)]
[immutable (vector/c-immutable ctc)])
(λ (blame)
(let ([elem-pos-projs (apply vector-immutable
(map (λ (c) ((contract-projection c) blame)) elem-ctcs))]
[elem-neg-projs (apply vector-immutable
(map (λ (c) ((contract-projection c) (blame-swap blame))) elem-ctcs))])
(λ (val)
((vector/c-first-order ctc) val #:blame blame)
(if (immutable? val)
(apply vector-immutable
(for/list ([e (in-vector val)]
[i (in-naturals)])
((vector-ref elem-pos-projs i) e)))
(vector-wrapper
val
(λ (vec i val)
((vector-ref elem-pos-projs i) val))
(λ (vec i val)
((vector-ref elem-neg-projs i) val))))))))))
(define-struct (chaperone-vector/c vector/c) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name vector/c-name
#:first-order vector/c-first-order
#:projection (vector/c-ho-projection chaperone-vector)))
(define-struct (proxy-vector/c vector/c) ()
#:property prop:contract
(build-contract-property
#:name vector/c-name
#:first-order vector/c-first-order
#:projection (vector/c-ho-projection proxy-vector)))
(define-syntax (wrap-vector/c stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
(syntax/loc stx build-vector/c)
'racket/contract:contract
(vector (gensym 'ctc) (list #'x) null))]
[(vec/c arg ...)
(let ([args (syntax->list #'(arg ...))]
[this-one (gensym 'ctc)])
(define (convert-args args)
(let loop ([args args]
[new-args null])
(cond
[(null? args) (reverse new-args)]
[(keyword? (syntax-e (car args)))
(if (null? (cdr args))
(reverse (cons (car args) new-args))
(loop (cddr args)
(list* (cadr args) (car args) new-args)))]
[else
(loop (cdr args)
(cons (syntax-property
(car args)
'racket/contract:positive-position
this-one)
new-args))])))
(with-syntax ([(new-arg ...) (convert-args args)]
[app (datum->syntax stx '#%app)])
(syntax-property
(syntax/loc stx
(app build-vector/c new-arg ...))
'racket/contract:contract
(vector this-one (list #'vec/c) null))))]))
(define (build-vector/c #:immutable [immutable 'dont-care] #:flat? [flat? #f] . cs)
(let ([ctcs (if flat?
(map (λ (c) (coerce-flat-contract 'vector/c c)) cs)
(map (λ (c) (coerce-contract 'vector/c c)) cs))])
(cond
[(or flat?
(and (eq? immutable #t)
(andmap flat-contract? ctcs)))
(make-flat-vector/c ctcs immutable)]
[(andmap chaperone-contract? ctcs)
(make-chaperone-vector/c ctcs immutable)]
[else
(make-proxy-vector/c ctcs immutable)])))
(define/subexpression-pos-prop (vector-immutable/c . args)
(apply build-vector/c args #:immutable #t))

17
collects/tests/racket/contract-test.rktl
View File

@ -8990,8 +8990,11 @@ so that propagation occurs.
(test-flat-contract '(vector-immutableof boolean?) (vector-immutable #t #f) (vector-immutable #f 3 #t)) (test-flat-contract '(vector-immutableof boolean?) (vector-immutable #t #f) (vector-immutable #f 3 #t))
(test-flat-contract '(vector-immutableof any/c) (vector-immutable #t #f) 3) (test-flat-contract '(vector-immutableof any/c) (vector-immutable #t #f) 3)
(test-flat-contract '(vector/c boolean? (flat-contract integer?)) (vector #t 1) (vector 1 #f)) (test-flat-contract '(vector/c boolean? (flat-contract integer?) #:flat? #t) (vector #t 1) (vector 1 #f))
(test-flat-contract '(vector/c boolean? (flat-contract integer?)) (vector #t 1) #f) (test-flat-contract '(vector/c boolean? (flat-contract integer?) #:flat? #t) (vector #t 1) #f)
(test-flat-contract '(vector-immutable/c boolean? (flat-contract integer?))
(vector-immutable #t 1) (vector-immutable 1 #f))
(test-flat-contract '(vector-immutable/c boolean? (flat-contract integer?)) (vector-immutable #t 1) #f)
(test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) (cons 1 #f)) (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) (cons 1 #f))
(test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) #f) (test-flat-contract '(cons/c boolean? (flat-contract integer?)) (cons #t 1) #f)
@ -10033,6 +10036,16 @@ so that propagation occurs.
(test-obligations '(vector-immutableof a) (test-obligations '(vector-immutableof a)
'((racket/contract:contract (vector-immutableof) ()) '((racket/contract:contract (vector-immutableof) ())
(racket/contract:positive-position a))) (racket/contract:positive-position a)))
(test-obligations '(vector/c a b c)
'((racket/contract:contract (vector/c) ())
(racket/contract:positive-position a)
(racket/contract:positive-position b)
(racket/contract:positive-position c)))
(test-obligations '(vector-immutable/c a b c)
'((racket/contract:contract (vector-immutable/c) ())
(racket/contract:positive-position a)
(racket/contract:positive-position b)
(racket/contract:positive-position c)))
; ;