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)
(let ([immutable (vector/c-immutable c)])
(apply build-compound-type-name 'vector/c
(append
(map contract-name (vector/c-elems c))
(if (and (flat-vector/c? c)
(not (eq? immutable #t)))
(list '#:flat? #t)
null)
(if (not (eq? immutable 'dont-care))
(list '#:immutable immutable)
null)))))
(define (vector/c-first-order c)
(let ([elem-ctcs (vector/c-elems c)]
[immutable (vector/c-immutable c)]
[flat? (flat-vector/c? c)])
(λ (val #:blame [blame #f])
(let/ec return
(define (fail . args)
(if blame
(apply raise-blame-error blame val args)
(return #f)))
(unless (vector? val)
(fail "expected a vector, got ~a" val))
(cond
[(eq? immutable #t)
(unless (immutable? val)
(fail "expected an immutable vector, got ~a" val))]
[(eq? immutable #f)
(when (immutable? val)
(fail "expected an mutable vector, got ~a" val))]
[else (void)])
(let ([elem-count (length elem-ctcs)])
(unless (= (vector-length val) elem-count)
(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-struct (flat-vector/c vector/c) ()
#:property prop:flat-contract
(build-flat-contract-property
#:name vector/c-name
#:first-order vector/c-first-order
#: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 () (syntax-case stx ()
[(_ predicate? constructor (arb? selectors ...) type-name name) [x
#'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)] (identifier? #'x)
[(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?) (syntax-property
(and (eq? #f (syntax->datum (syntax arb?))) (syntax/loc stx build-vector/c)
(boolean? (syntax->datum #'test-immutable?))) 'racket/contract:contract
(let ([test-immutable? (syntax->datum #'test-immutable?)]) (vector (gensym 'ctc) (list #'x) null))]
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] [(vec/c arg ...)
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))] (let ([args (syntax->list #'(arg ...))]
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))] [this-one (gensym 'ctc)])
[(procs ...) (generate-temporaries (syntax (selectors ...)))] (define (convert-args args)
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))]) (let loop ([args args]
#`(let ([predicate?-name predicate?] [new-args null])
[constructor-name constructor] (cond
[selector-names selectors] ...) [(null? args) (reverse new-args)]
(λ (params ...) [(keyword? (syntax-e (car args)))
(let ([ctc-x (coerce-contract 'name params)] ...) (if (null? (cdr args))
(if (and (flat-contract? ctc-x) ...) (reverse (cons (car args) new-args))
(let ([p-apps (flat-contract-predicate ctc-x)] ...) (loop (cddr args)
(build-flat-contract (list* (cadr args) (car args) new-args)))]
`(name ,(contract-name ctc-x) ...) [else
(lambda (x) (loop (cdr args)
(and (predicate?-name x) (cons (syntax-property
(p-apps (selector-names x)) (car args)
...)))) 'racket/contract:positive-position
(let ([procs (contract-projection ctc-x)] ...) this-one)
(make-contract new-args))])))
#:name (build-compound-type-name 'name ctc-x ...) (with-syntax ([(new-arg ...) (convert-args args)]
#:projection [app (datum->syntax stx '#%app)])
(λ (blame) (syntax-property
(let ([p-apps (procs blame)] ...) (syntax/loc stx
(λ (v) (app build-vector/c new-arg ...))
(if #,(if test-immutable? 'racket/contract:contract
#'(and (predicate?-name v) (vector this-one (list #'vec/c) null))))]))
(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
[(null? p-apps) null]
[else (let ([p-app (car p-apps)])
(cons (p-app (selector-name v i))
(loop (cdr p-apps) (+ i 1))))])))
(raise-blame-error
blame
v
"expected <~a>, given: ~e"
'type-name
v)))))))))))]))
(define vector-immutable/c (*-immutable/c vector? (define (build-vector/c #:immutable [immutable 'dont-care] #:flat? [flat? #f] . cs)
vector-immutable (let ([ctcs (if flat?
(#t (λ (v i) (vector-ref v i))) (map (λ (c) (coerce-flat-contract 'vector/c c)) cs)
(λ (n v) (= n (vector-length v))) (map (λ (c) (coerce-contract 'vector/c c)) cs))])
immutable-vector (cond
vector-immutable/c)) [(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)))
; ;