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

Convert vectorof/vector-immutableof to the new regime.

Browse Source 
Also add old-style vectorof to mzlib/contract.
This commit is contained in:
Stevie Strickland 2010-05-17 13:11:10 -04:00
parent c8737d5615
commit 3028f2d142
6 changed files with 184 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/contract.rkt
View File

@ -37,7 +37,6 @@
;;
(require racket/contract/private/base
racket/contract/private/vector
racket/contract/private/misc
racket/contract/private/provide
racket/contract/private/guts
@ -52,7 +51,6 @@
contract-struct)
(all-from-out racket/contract/private/base)
(all-from-out racket/contract/private/vector)
(all-from-out racket/contract/private/provide)
(except-out (all-from-out racket/contract/private/misc)
check-between/c

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

@ -1,10 +1,13 @@
#lang racket/base
(require (only-in racket/contract/private/box box-immutable/c)
(only-in racket/contract/private/vector
vector/c vector-immutableof vector-immutable/c)
racket/contract/private/blame
racket/contract/private/guts)
(provide box/c box-immutable/c)
(provide box/c box-immutable/c
vector/c vectorof vector-immutableof vector-immutable/c)
(define/subexpression-pos-prop (box/c ctc)
(let ([ctc (coerce-flat-contract 'box/c ctc)])
@ -22,3 +25,22 @@
(raise-blame-error blame val "not a box"))
(proj (unbox val))
val))))))
(define/subexpression-pos-prop (vectorof ctc)
(let ([ctc (coerce-flat-contract 'vectorof ctc)])
(make-flat-contract
#:name (build-compound-type-name 'vectorof ctc)
#:first-order
(λ (val)
(and (vector? val)
(for/and ([v (in-vector val)])
(contract-first-order-passes? ctc v))))
#:projection
(λ (blame)
(λ (val)
(let ([proj ((contract-projection ctc) blame)])
(unless (vector? val)
(raise-blame-error blame val "not a vector"))
(for ([v (in-vector val)])
(proj v))
val))))))

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

@ -86,8 +86,7 @@ from @schememodname[scheme/contract]:
syntax/c
vector-immutable/c
vector-immutableof
vector/c
vectorof]
vector/c]
It also provides the old version of the following forms:
@ -113,3 +112,8 @@ that definition.}
Returns a flat contract that recognizes boxes. The content of the box
must match @racket[c].}
@defproc[(vectorof [c flat-contract?]) flat-contract?]{
Accepts a flat contract and returns a flat contract
that checks for vectors whose elements match the original contract.}

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

@ -3,55 +3,152 @@
(require (for-syntax racket/base)
"guts.ss")
(provide vector/c vectorof vector-immutable/c vector-immutableof)
(provide vector/c (rename-out [wrap-vectorof vectorof])
vector-immutable/c vector-immutableof)
(define-syntax (*-immutableof stx)
(define-struct vectorof (elem immutable))
(define (vectorof-name c)
(let ([immutable (vectorof-immutable c)])
(apply build-compound-type-name 'vectorof
(contract-name (vectorof-elem c))
(append
(if (and (flat-vectorof? c)
(not (eq? immutable #t)))
(list '#:flat? #t)
null)
(if (not (eq? immutable 'dont-care))
(list '#:immutable immutable)
null)))))
(define (vectorof-first-order c)
(let ([elem-ctc (vectorof-elem c)]
[immutable (vectorof-immutable c)]
[flat? (flat-vectorof? 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)])
(when (or flat? (and (immutable? val) (not blame)))
(if blame
(let ([elem-proj ((contract-projection elem-ctc) blame)])
(for ([e (in-vector val)])
(elem-proj e)))
(for ([e (in-vector val)])
(unless (contract-first-order-passes? elem-ctc e)
(fail)))))
#t))))
(define-struct (flat-vectorof vectorof) ()
#:property prop:flat-contract
(build-flat-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:projection
(λ (ctc)
(λ (blame)
(λ (val)
((vectorof-first-order ctc) val #:blame blame)
val)))))
(define (vectorof-ho-projection vector-wrapper)
(λ (ctc)
(let ([elem-ctc (vectorof-elem ctc)]
[immutable (vectorof-immutable ctc)])
(λ (blame)
(let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
[elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
(λ (val)
((vectorof-first-order ctc) val #:blame blame)
(if (immutable? val)
(apply vector-immutable
(for/list ([e (in-vector val)])
(elem-pos-proj e)))
(vector-wrapper
val
(λ (vec i val)
(elem-pos-proj val))
(λ (vec i val)
(elem-neg-proj val))))))))))
(define-struct (chaperone-vectorof vectorof) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:projection (vectorof-ho-projection chaperone-vector)))
(define-struct (proxy-vectorof vectorof) ()
#:property prop:contract
(build-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:projection (vectorof-ho-projection proxy-vector)))
(define-syntax (wrap-vectorof stx)
(syntax-case stx ()
[(_ predicate? fill testmap type-name name)
(identifier? (syntax predicate?))
(syntax
(let ([fill-name fill])
(λ (input)
(let ([ctc (coerce-contract 'name input)])
(if (flat-contract? ctc)
(let ([content-pred? (flat-contract-predicate ctc)])
(build-flat-contract
`(name ,(contract-name ctc))
(lambda (x) (and (predicate? x) (testmap content-pred? x)))))
(let ([proj (contract-projection ctc)])
(make-contract
#:name (build-compound-type-name 'name ctc)
#:projection
(λ (blame)
(let ([p-app (proj blame)])
(λ (val)
(unless (predicate? val)
(raise-blame-error
blame
val
"expected <~a>, given: ~e"
'type-name
val))
(fill-name p-app val))))
#:first-order predicate?)))))))]))
[x
(identifier? #'x)
(syntax-property
(syntax/loc stx build-vectorof)
'racket/contract:contract
(vector (gensym 'ctc) (list #'x) null))]
[(vecof 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
(append (reverse new-args)
(cons (syntax-property
(car args)
'racket/contract:positive-position
this-one)
(cdr args)))])))
(with-syntax ([(new-arg ...) (convert-args args)]
[app (datum->syntax stx '#%app)])
(syntax-property
(syntax/loc stx
(app build-vectorof new-arg ...))
'racket/contract:contract
(vector this-one (list #'vecof) null))))]))
(define/final-prop (immutable-vector? val) (and (immutable? val) (vector? val)))
(define (build-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-proxy-vectorof ctc immutable)])))
(define vector-immutableof
(*-immutableof immutable-vector?
(λ (f v) (apply vector-immutable (map f (vector->list v))))
(λ (f v) (andmap f (vector->list v)))
immutable-vector
vector-immutableof))
(define/subexpression-pos-prop (vectorof p)
(let* ([ctc (coerce-flat-contract 'vectorof p)]
[pred (flat-contract-predicate ctc)])
(build-flat-contract
(build-compound-type-name 'vectorof ctc)
(λ (v)
(and (vector? v)
(andmap pred (vector->list v)))))))
(define/subexpression-pos-prop (vector-immutableof c)
(build-vectorof c #:immutable #t))
(define/subexpression-pos-prop (vector/c . args)
(let* ([ctcs (coerce-flat-contracts 'vector/c args)]

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

@ -8985,8 +8985,10 @@ so that propagation occurs.
(test-flat-contract '(listof boolean?) (list #t #f) (list #f 3 #t))
(test-flat-contract '(listof any/c) (list #t #f) 3)
(test-flat-contract '(vectorof boolean?) (vector #t #f) (vector #f 3 #t))
(test-flat-contract '(vectorof any/c) (vector #t #f) 3)
(test-flat-contract '(vectorof boolean? #:flat? #t) (vector #t #f) (vector #f 3 #t))
(test-flat-contract '(vectorof any/c #:flat? #t) (vector #t #f) 3)
(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/c boolean? (flat-contract integer?)) (vector #t 1) (vector 1 #f))
(test-flat-contract '(vector/c boolean? (flat-contract integer?)) (vector #t 1) #f)
@ -10025,6 +10027,12 @@ so that propagation occurs.
(test-obligations '(box-immutable/c a)
'((racket/contract:contract (box-immutable/c) ())
(racket/contract:positive-position a)))
(test-obligations '(vectorof a)
'((racket/contract:contract (vectorof) ())
(racket/contract:positive-position a)))
(test-obligations '(vector-immutableof a)
'((racket/contract:contract (vector-immutableof) ())
(racket/contract:positive-position a)))
;

4
collects/typed-scheme/private/type-contract.rkt
View File

@ -132,7 +132,9 @@
#'(or/c . cnts)))]
[(and t (Function: _)) (t->c/fun t)]
[(Vector: t)
#`(vectorof #,(t->c t #:flat #t))]
(if flat?
#`(vectorof #,(t->c t #:flat #t) #:flat? #t)
#`(vectorof #,(t->c t)))]
[(Box: t)
(if flat?
#`(box/c #,(t->c t #:flat #t) #:flat? #t)