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

Separate out vector-related contract combinators into a new file.

Browse Source
This commit is contained in:
Stevie Strickland 2010-05-14 18:34:53 -04:00
parent 089e99fac6
commit c8737d5615
5 changed files with 159 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/contract.rkt
View File

@ -37,6 +37,7 @@
;;
(require racket/contract/private/base
racket/contract/private/vector
racket/contract/private/misc
racket/contract/private/provide
racket/contract/private/guts
@ -51,6 +52,7 @@
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

2
collects/racket/contract/base.rkt
View File

@ -8,6 +8,7 @@
"private/base.rkt"
"private/box.rkt"
"private/hash.rkt"
"private/vector.rkt"
"private/misc.rkt"
"private/provide.rkt"
"private/guts.rkt"
@ -29,6 +30,7 @@
(all-from-out "private/arr-i.rkt")
(all-from-out "private/box.rkt")
(all-from-out "private/hash.rkt")
(all-from-out "private/vector.rkt")
(except-out (all-from-out "private/misc.rkt")
check-between/c
check-unary-between/c)

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

@ -21,7 +21,6 @@
printable/c
symbols one-of/c
listof non-empty-listof cons/c list/c
vectorof vector-immutableof vector/c vector-immutable/c
promise/c
struct/c
syntax/c
@ -761,38 +760,6 @@
(*-immutableof non-empty-list? for-each map andmap non-empty-list non-empty-listof))
(define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a))
(define/final-prop (immutable-vector? val) (and (immutable? val) (vector? val)))
(define vector-immutableof
(*-immutableof immutable-vector?
(λ (f v) (for ([e (in-vector v)]) (f e)))
(λ (f v) (apply vector-immutable (for/list ([e (in-vector v)]) (f e))))
(λ (f v) (for/and ([e (in-vector v)]) (f e)))
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/c . args)
(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)))))))
;;
;; cons/c opter
;;
@ -972,12 +939,6 @@
(define cons/c-main-function (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b))
(define vector-immutable/c (*-immutable/c vector?
vector-immutable
(#t (λ (v i) (vector-ref v i)))
(λ (n v) (= n (vector-length v)))
immutable-vector
vector-immutable/c))
;;
;; cons/c opter

154
collects/racket/contract/private/vector.rkt Normal file
View File

@ -0,0 +1,154 @@
#lang racket/base
(require (for-syntax racket/base)
"guts.ss")
(provide vector/c vectorof vector-immutable/c vector-immutableof)
(define-syntax (*-immutableof 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?)))))))]))
(define/final-prop (immutable-vector? val) (and (immutable? val) (vector? val)))
(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/c . args)
(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)
(syntax-case stx ()
[(_ predicate? constructor (arb? selectors ...) type-name name)
#'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)]
[(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?)
(and (eq? #f (syntax->datum (syntax arb?)))
(boolean? (syntax->datum #'test-immutable?)))
(let ([test-immutable? (syntax->datum #'test-immutable?)])
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
[(procs ...) (generate-temporaries (syntax (selectors ...)))]
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
#`(let ([predicate?-name predicate?]
[constructor-name constructor]
[selector-names selectors] ...)
(λ (params ...)
(let ([ctc-x (coerce-contract 'name params)] ...)
(if (and (flat-contract? ctc-x) ...)
(let ([p-apps (flat-contract-predicate ctc-x)] ...)
(build-flat-contract
`(name ,(contract-name ctc-x) ...)
(lambda (x)
(and (predicate?-name x)
(p-apps (selector-names x))
...))))
(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
[(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?
vector-immutable
(#t (λ (v i) (vector-ref v i)))
(λ (n v) (= n (vector-length v)))
immutable-vector
vector-immutable/c))

1
collects/scribblings/reference/contracts.scrbl
View File

@ -22,6 +22,7 @@ constraints.
racket/contract/private/guts
racket/contract/private/box
racket/contract/private/hash
racket/contract/private/vector
racket/contract/private/misc
racket/contract/private/provide)]