racket/collects/racket/contract/private/vector.rkt
Robby Findler 21cbd9ad81 added the racket/contract/combinator library,
and documented and adjusted these libraries:
     racket/contract/base
     racket/contract/exists
     racket/contract/parametric (renamed from exists)
     racket/contract/region
2011-04-25 11:51:44 -05:00

295 lines
10 KiB
Racket

#lang racket/base
(require (for-syntax racket/base)
"guts.ss"
"prop.rkt"
"blame.rkt"
"misc.rkt")
(provide (rename-out [wrap-vectorof vectorof]
[wrap-vector/c vector/c])
vector-immutable/c vector-immutableof)
(define-struct base-vectorof (elem immutable))
(define-for-syntax (convert-args args this-one)
(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))])))
(define (vectorof-name c)
(let ([immutable (base-vectorof-immutable c)])
(apply build-compound-type-name 'vectorof
(contract-name (base-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 (check-vectorof c)
(let ([elem-ctc (base-vectorof-elem c)]
[immutable (base-vectorof-immutable c)]
[flat? (flat-vectorof? c)])
(λ (val fail [first-order? #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 first-order?
(for ([e (in-vector val)]
[n (in-naturals)])
(unless (contract-first-order-passes? elem-ctc e)
(fail "expected <~s> for element ~v, got ~v" (contract-name elem-ctc) n e))))
#t)))
(define (vectorof-first-order ctc)
(let ([check (check-vectorof ctc)])
(λ (val)
(let/ec return
(check val (λ _ (return #f)) #t)))))
(define-struct (flat-vectorof base-vectorof) ()
#:property prop:flat-contract
(build-flat-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:projection
(λ (ctc)
(λ (blame)
(λ (val)
((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args)))
(let* ([elem-ctc (base-vectorof-elem ctc)]
[p ((contract-projection elem-ctc) blame)])
(for ([e (in-vector val)])
(p e)))
val)))))
(define (vectorof-ho-projection vector-wrapper)
(λ (ctc)
(let ([elem-ctc (base-vectorof-elem ctc)]
[immutable (base-vectorof-immutable ctc)])
(λ (blame)
(let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
[elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
(λ (val)
((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args)))
(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))
impersonator-prop:contracted ctc))))))))
(define-struct (chaperone-vectorof base-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 (impersonator-vectorof base-vectorof) ()
#:property prop:contract
(build-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:projection (vectorof-ho-projection impersonate-vector)))
(define-syntax (wrap-vectorof stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
(syntax/loc stx vectorof)
'racket/contract:contract
(vector (gensym 'ctc) (list #'x) null))]
[(vecof arg ...)
(let ([args (syntax->list #'(arg ...))]
[this-one (gensym 'vectorof-ctc)])
(with-syntax ([(new-arg ...) (convert-args args this-one)])
(syntax-property
(syntax/loc stx
(vectorof new-arg ...))
'racket/contract:contract
(vector this-one (list #'vecof) null))))]))
(define (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-impersonator-vectorof ctc immutable)])))
(define/subexpression-pos-prop (vector-immutableof c)
(vectorof c #:immutable #t))
(define-struct base-vector/c (elems immutable))
(define (vector/c-name c)
(let ([immutable (base-vector/c-immutable c)])
(apply build-compound-type-name 'vector/c
(append
(map contract-name (base-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 (check-vector/c c)
(let ([elem-ctcs (base-vector/c-elems c)]
[immutable (base-vector/c-immutable c)]
[flat? (flat-vector/c? c)])
(λ (val fail [first-order? #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 first-order?
(for ([e (in-vector val)]
[n (in-naturals)]
[c (in-list elem-ctcs)])
(unless (contract-first-order-passes? c e)
(fail "expected <~s> for element ~v, got ~v" (contract-name c) n val))))
#t)))
(define (vector/c-first-order ctc)
(let ([check (check-vector/c ctc)])
(λ (val)
(let/ec return
(check val (λ _ (return #f)) #t)))))
(define-struct (flat-vector/c base-vector/c) ()
#:property prop:flat-contract
(build-flat-contract-property
#:name vector/c-name
#:first-order vector/c-first-order
#:projection
(λ (ctc)
(λ (blame)
(λ (val)
((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
(for ([e (in-vector val)]
[c (in-list (base-vector/c-elems ctc))])
(((contract-projection c) blame) e))
val)))))
(define (vector/c-ho-projection vector-wrapper)
(λ (ctc)
(let ([elem-ctcs (base-vector/c-elems ctc)]
[immutable (base-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)
((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
(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))
impersonator-prop:contracted ctc))))))))
(define-struct (chaperone-vector/c base-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 (impersonator-vector/c base-vector/c) ()
#:property prop:contract
(build-contract-property
#:name vector/c-name
#:first-order vector/c-first-order
#:projection (vector/c-ho-projection impersonate-vector)))
(define-syntax (wrap-vector/c stx)
(syntax-case stx ()
[x
(identifier? #'x)
(syntax-property
(syntax/loc stx vector/c)
'racket/contract:contract
(vector (gensym 'ctc) (list #'x) null))]
[(vec/c arg ...)
(let ([args (syntax->list #'(arg ...))]
[this-one (gensym 'vector/c-ctc)])
(with-syntax ([(new-arg ...) (convert-args args this-one)])
(syntax-property
(syntax/loc stx
(vector/c new-arg ...))
'racket/contract:contract
(vector this-one (list #'vec/c) null))))]))
(define (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-impersonator-vector/c ctcs immutable)])))
(define/subexpression-pos-prop (vector-immutable/c . args)
(apply vector/c args #:immutable #t))