From c8737d5615db678b93784794ec6f55109b9d46d5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 14 May 2010 18:34:53 -0400 Subject: [PATCH] Separate out vector-related contract combinators into a new file. --- collects/mzlib/contract.rkt | 2 + collects/racket/contract/base.rkt | 2 + collects/racket/contract/private/misc.rkt | 39 ----- collects/racket/contract/private/vector.rkt | 154 ++++++++++++++++++ .../scribblings/reference/contracts.scrbl | 1 + 5 files changed, 159 insertions(+), 39 deletions(-) create mode 100644 collects/racket/contract/private/vector.rkt diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index 1ced3d7025..68296b6b36 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -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 diff --git a/collects/racket/contract/base.rkt b/collects/racket/contract/base.rkt index b6d492b7e8..6f06480b44 100644 --- a/collects/racket/contract/base.rkt +++ b/collects/racket/contract/base.rkt @@ -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) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 2fc58e279d..53051ac25c 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -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 diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt new file mode 100644 index 0000000000..1adbb694f2 --- /dev/null +++ b/collects/racket/contract/private/vector.rkt @@ -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)) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 8464987491..36ed4c1f67 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -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)]