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

Rework the naming conventions in {box,vector,hash}.rkt.

Browse Source 
Fixing it so that errors aren't generated with "build-<foo>/c".
This commit is contained in:
Stevie Strickland 2010-09-20 18:19:48 -04:00
parent 277d9d199d
commit 859ea63faa
3 changed files with 63 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/racket/contract/private/box.rkt
View File

@ -7,13 +7,13 @@
(rename-out [wrap-box/c box/c])) (rename-out [wrap-box/c box/c]))
(define/subexpression-pos-prop (box-immutable/c elem) (define/subexpression-pos-prop (box-immutable/c elem)
(build-box/c elem #:immutable #t)) (box/c elem #:immutable #t))
(define-struct box/c (content immutable)) (define-struct base-box/c (content immutable))
(define (check-box/c ctc) (define (check-box/c ctc)
(let ([elem-ctc (box/c-content ctc)] (let ([elem-ctc (base-box/c-content ctc)]
[immutable (box/c-immutable ctc)] [immutable (base-box/c-immutable ctc)]
[flat? (flat-box/c? ctc)]) [flat? (flat-box/c? ctc)])
(λ (val fail [first-order? #f]) (λ (val fail [first-order? #f])
(unless (box? val) (unless (box? val)
@ -38,8 +38,8 @@
(check val (λ _ (return #f)) #t))))) (check val (λ _ (return #f)) #t)))))
(define (box/c-name ctc) (define (box/c-name ctc)
(let ([elem-name (contract-name (box/c-content ctc))] (let ([elem-name (contract-name (base-box/c-content ctc))]
[immutable (box/c-immutable ctc)] [immutable (base-box/c-immutable ctc)]
[flat? (flat-box/c? ctc)]) [flat? (flat-box/c? ctc)])
(apply build-compound-type-name (apply build-compound-type-name
'box/c 'box/c
@ -54,7 +54,7 @@
(list '#:flat? #t) (list '#:flat? #t)
null)))))) null))))))
(define-struct (flat-box/c box/c) () (define-struct (flat-box/c base-box/c) ()
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:name box/c-name #:name box/c-name
@ -64,13 +64,13 @@
(λ (blame) (λ (blame)
(λ (val) (λ (val)
((check-box/c ctc) val (λ args (apply raise-blame-error blame val args))) ((check-box/c ctc) val (λ args (apply raise-blame-error blame val args)))
(((contract-projection (box/c-content ctc)) blame) (unbox val)) (((contract-projection (base-box/c-content ctc)) blame) (unbox val))
val))))) val)))))
(define (ho-projection box-wrapper) (define (ho-projection box-wrapper)
(λ (ctc) (λ (ctc)
(let ([elem-ctc (box/c-content ctc)] (let ([elem-ctc (base-box/c-content ctc)]
[immutable (box/c-immutable ctc)]) [immutable (base-box/c-immutable ctc)])
(λ (blame) (λ (blame)
(let ([pos-elem-proj ((contract-projection elem-ctc) blame)] (let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
[neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))]) [neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
@ -83,14 +83,14 @@
(λ (b v) (neg-elem-proj v)) (λ (b v) (neg-elem-proj v))
proxy-prop:contracted ctc)))))))) proxy-prop:contracted ctc))))))))
(define-struct (chaperone-box/c box/c) () (define-struct (chaperone-box/c base-box/c) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:projection (ho-projection chaperone-box))) #:projection (ho-projection chaperone-box)))
(define-struct (proxy-box/c box/c) () (define-struct (proxy-box/c base-box/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name box/c-name #:name box/c-name
@ -102,7 +102,7 @@
[x [x
(identifier? #'x) (identifier? #'x)
(syntax-property (syntax-property
(syntax/loc stx build-box/c) (syntax/loc stx box/c)
'racket/contract:contract 'racket/contract:contract
(vector (gensym 'ctc) (list #'x) null))] (vector (gensym 'ctc) (list #'x) null))]
[(b/c arg ...) [(b/c arg ...)
@ -128,11 +128,11 @@
[app (datum->syntax stx '#%app)]) [app (datum->syntax stx '#%app)])
(syntax-property (syntax-property
(syntax/loc stx (syntax/loc stx
(app build-box/c new-arg ...)) (app box/c new-arg ...))
'racket/contract:contract 'racket/contract:contract
(vector this-one (list #'b/c) null))))])) (vector this-one (list #'b/c) null))))]))
(define (build-box/c elem #:immutable [immutable 'dont-care] #:flat? [flat? #f]) (define (box/c elem #:immutable [immutable 'dont-care] #:flat? [flat? #f])
(let ([ctc (if flat? (let ([ctc (if flat?
(coerce-flat-contract 'box/c elem) (coerce-flat-contract 'box/c elem)
(coerce-contract 'box/c elem))]) (coerce-contract 'box/c elem))])

37
collects/racket/contract/private/hash.rkt
View File

@ -10,8 +10,7 @@
[x [x
(identifier? #'x) (identifier? #'x)
(syntax-property (syntax-property
(syntax/loc stx (syntax/loc stx hash/c)
build-hash/c)
'racket/contract:contract 'racket/contract:contract
(vector (gensym 'ctc) (list stx) null))] (vector (gensym 'ctc) (list stx) null))]
[(h/c arg ...) [(h/c arg ...)
@ -48,11 +47,11 @@
[app (datum->syntax stx '#%app)]) [app (datum->syntax stx '#%app)])
(syntax-property (syntax-property
(syntax/loc stx (syntax/loc stx
(app build-hash/c new-arg ...)) (app hash/c new-arg ...))
'racket/contract:contract 'racket/contract:contract
(vector this-one (list #'h/c) null))))])) (vector this-one (list #'h/c) null))))]))
(define (build-hash/c dom rng #:immutable [immutable 'dont-care] #:flat? [flat? #f]) (define (hash/c dom rng #:immutable [immutable 'dont-care] #:flat? [flat? #f])
(unless (memq immutable '(#t #f dont-care)) (unless (memq immutable '(#t #f dont-care))
(error 'hash/c "expected #:immutable argument to be either #t, #f, or 'dont-care, got ~s" immutable)) (error 'hash/c "expected #:immutable argument to be either #t, #f, or 'dont-care, got ~s" immutable))
(let ([dom-ctc (if flat? (let ([dom-ctc (if flat?
@ -75,9 +74,9 @@
(make-proxy-hash/c dom-ctc rng-ctc immutable)]))) (make-proxy-hash/c dom-ctc rng-ctc immutable)])))
(define (check-hash/c ctc) (define (check-hash/c ctc)
(let ([dom-ctc (hash/c-dom ctc)] (let ([dom-ctc (base-hash/c-dom ctc)]
[rng-ctc (hash/c-rng ctc)] [rng-ctc (base-hash/c-rng ctc)]
[immutable (hash/c-immutable ctc)] [immutable (base-hash/c-immutable ctc)]
[flat? (flat-hash/c? ctc)]) [flat? (flat-hash/c? ctc)])
(λ (val fail [first-order? #f]) (λ (val fail [first-order? #f])
(unless (hash? val) (unless (hash? val)
@ -111,22 +110,22 @@
(define (hash/c-name ctc) (define (hash/c-name ctc)
(apply (apply
build-compound-type-name build-compound-type-name
'hash/c (hash/c-dom ctc) (hash/c-rng ctc) 'hash/c (base-hash/c-dom ctc) (base-hash/c-rng ctc)
(append (append
(if (and (flat-hash/c? ctc) (if (and (flat-hash/c? ctc)
(not (eq? (hash/c-immutable ctc) #t))) (not (eq? (base-hash/c-immutable ctc) #t)))
(list '#:flat? #t) (list '#:flat? #t)
null) null)
(case (hash/c-immutable ctc) (case (base-hash/c-immutable ctc)
[(dont-care) null] [(dont-care) null]
[(#t) [(#t)
(list '#:immutable #t)] (list '#:immutable #t)]
[(#f) [(#f)
(list '#:immutable #f)])))) (list '#:immutable #f)]))))
(define-struct hash/c (dom rng immutable)) (define-struct base-hash/c (dom rng immutable))
(define-struct (flat-hash/c hash/c) () (define-struct (flat-hash/c base-hash/c) ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:flat-contract #:property prop:flat-contract
@ -138,8 +137,8 @@
(λ (blame) (λ (blame)
(λ (val) (λ (val)
((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args))) ((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
(let ([dom-proj ((contract-projection (hash/c-dom ctc)) blame)] (let ([dom-proj ((contract-projection (base-hash/c-dom ctc)) blame)]
[rng-proj ((contract-projection (hash/c-rng ctc)) blame)]) [rng-proj ((contract-projection (base-hash/c-rng ctc)) blame)])
(for ([(k v) (in-hash val)]) (for ([(k v) (in-hash val)])
(dom-proj k) (dom-proj k)
(rng-proj v))) (rng-proj v)))
@ -147,9 +146,9 @@
(define (ho-projection hash-wrapper) (define (ho-projection hash-wrapper)
(λ (ctc) (λ (ctc)
(let ([dom-proc (contract-projection (hash/c-dom ctc))] (let ([dom-proc (contract-projection (base-hash/c-dom ctc))]
[rng-proc (contract-projection (hash/c-rng ctc))] [rng-proc (contract-projection (base-hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)]) [immutable (base-hash/c-immutable ctc)])
(λ (blame) (λ (blame)
(let ([pos-dom-proj (dom-proc blame)] (let ([pos-dom-proj (dom-proc blame)]
[neg-dom-proj (dom-proc (blame-swap blame))] [neg-dom-proj (dom-proc (blame-swap blame))]
@ -183,7 +182,7 @@
(pos-dom-proj k)) (pos-dom-proj k))
proxy-prop:contracted ctc)))))))) proxy-prop:contracted ctc))))))))
(define-struct (chaperone-hash/c hash/c) () (define-struct (chaperone-hash/c base-hash/c) ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
@ -191,7 +190,7 @@
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:projection (ho-projection chaperone-hash))) #:projection (ho-projection chaperone-hash)))
(define-struct (proxy-hash/c hash/c) () (define-struct (proxy-hash/c base-hash/c) ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property

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

@ -7,12 +7,12 @@
[wrap-vector/c vector/c]) [wrap-vector/c vector/c])
vector-immutable/c vector-immutableof) vector-immutable/c vector-immutableof)
(define-struct vectorof (elem immutable)) (define-struct base-vectorof (elem immutable))
(define (vectorof-name c) (define (vectorof-name c)
(let ([immutable (vectorof-immutable c)]) (let ([immutable (base-vectorof-immutable c)])
(apply build-compound-type-name 'vectorof (apply build-compound-type-name 'vectorof
(contract-name (vectorof-elem c)) (contract-name (base-vectorof-elem c))
(append (append
(if (and (flat-vectorof? c) (if (and (flat-vectorof? c)
(not (eq? immutable #t))) (not (eq? immutable #t)))
@ -23,8 +23,8 @@
null))))) null)))))
(define (check-vectorof c) (define (check-vectorof c)
(let ([elem-ctc (vectorof-elem c)] (let ([elem-ctc (base-vectorof-elem c)]
[immutable (vectorof-immutable c)] [immutable (base-vectorof-immutable c)]
[flat? (flat-vectorof? c)]) [flat? (flat-vectorof? c)])
(λ (val fail [first-order? #f]) (λ (val fail [first-order? #f])
(unless (vector? val) (unless (vector? val)
@ -50,7 +50,7 @@
(let/ec return (let/ec return
(check val (λ _ (return #f)) #t))))) (check val (λ _ (return #f)) #t)))))
(define-struct (flat-vectorof vectorof) () (define-struct (flat-vectorof base-vectorof) ()
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:name vectorof-name #:name vectorof-name
@ -60,7 +60,7 @@
(λ (blame) (λ (blame)
(λ (val) (λ (val)
((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args))) ((check-vectorof ctc) val (λ args (apply raise-blame-error blame val args)))
(let* ([elem-ctc (vectorof-elem ctc)] (let* ([elem-ctc (base-vectorof-elem ctc)]
[p ((contract-projection elem-ctc) blame)]) [p ((contract-projection elem-ctc) blame)])
(for ([e (in-vector val)]) (for ([e (in-vector val)])
(p e))) (p e)))
@ -68,8 +68,8 @@
(define (vectorof-ho-projection vector-wrapper) (define (vectorof-ho-projection vector-wrapper)
(λ (ctc) (λ (ctc)
(let ([elem-ctc (vectorof-elem ctc)] (let ([elem-ctc (base-vectorof-elem ctc)]
[immutable (vectorof-immutable ctc)]) [immutable (base-vectorof-immutable ctc)])
(λ (blame) (λ (blame)
(let ([elem-pos-proj ((contract-projection elem-ctc) blame)] (let ([elem-pos-proj ((contract-projection elem-ctc) blame)]
[elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))]) [elem-neg-proj ((contract-projection elem-ctc) (blame-swap blame))])
@ -87,14 +87,14 @@
(elem-neg-proj val)) (elem-neg-proj val))
proxy-prop:contracted ctc)))))))) proxy-prop:contracted ctc))))))))
(define-struct (chaperone-vectorof vectorof) () (define-struct (chaperone-vectorof base-vectorof) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:projection (vectorof-ho-projection chaperone-vector))) #:projection (vectorof-ho-projection chaperone-vector)))
(define-struct (proxy-vectorof vectorof) () (define-struct (proxy-vectorof base-vectorof) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name vectorof-name #:name vectorof-name
@ -106,7 +106,7 @@
[x [x
(identifier? #'x) (identifier? #'x)
(syntax-property (syntax-property
(syntax/loc stx build-vectorof) (syntax/loc stx vectorof)
'racket/contract:contract 'racket/contract:contract
(vector (gensym 'ctc) (list #'x) null))] (vector (gensym 'ctc) (list #'x) null))]
[(vecof arg ...) [(vecof arg ...)
@ -133,11 +133,11 @@
[app (datum->syntax stx '#%app)]) [app (datum->syntax stx '#%app)])
(syntax-property (syntax-property
(syntax/loc stx (syntax/loc stx
(app build-vectorof new-arg ...)) (app vectorof new-arg ...))
'racket/contract:contract 'racket/contract:contract
(vector this-one (list #'vecof) null))))])) (vector this-one (list #'vecof) null))))]))
(define (build-vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f]) (define (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f])
(let ([ctc (if flat? (let ([ctc (if flat?
(coerce-flat-contract 'vectorof c) (coerce-flat-contract 'vectorof c)
(coerce-contract 'vectorof c))]) (coerce-contract 'vectorof c))])
@ -152,15 +152,15 @@
(make-proxy-vectorof ctc immutable)]))) (make-proxy-vectorof ctc immutable)])))
(define/subexpression-pos-prop (vector-immutableof c) (define/subexpression-pos-prop (vector-immutableof c)
(build-vectorof c #:immutable #t)) (vectorof c #:immutable #t))
(define-struct vector/c (elems immutable)) (define-struct base-vector/c (elems immutable))
(define (vector/c-name c) (define (vector/c-name c)
(let ([immutable (vector/c-immutable c)]) (let ([immutable (base-vector/c-immutable c)])
(apply build-compound-type-name 'vector/c (apply build-compound-type-name 'vector/c
(append (append
(map contract-name (vector/c-elems c)) (map contract-name (base-vector/c-elems c))
(if (and (flat-vector/c? c) (if (and (flat-vector/c? c)
(not (eq? immutable #t))) (not (eq? immutable #t)))
(list '#:flat? #t) (list '#:flat? #t)
@ -170,8 +170,8 @@
null))))) null)))))
(define (check-vector/c c) (define (check-vector/c c)
(let ([elem-ctcs (vector/c-elems c)] (let ([elem-ctcs (base-vector/c-elems c)]
[immutable (vector/c-immutable c)] [immutable (base-vector/c-immutable c)]
[flat? (flat-vector/c? c)]) [flat? (flat-vector/c? c)])
(λ (val fail [first-order? #f]) (λ (val fail [first-order? #f])
(unless (vector? val) (unless (vector? val)
@ -202,7 +202,7 @@
(let/ec return (let/ec return
(check val (λ _ (return #f)) #t))))) (check val (λ _ (return #f)) #t)))))
(define-struct (flat-vector/c vector/c) () (define-struct (flat-vector/c base-vector/c) ()
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:name vector/c-name #:name vector/c-name
@ -213,14 +213,14 @@
(λ (val) (λ (val)
((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args))) ((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
(for ([e (in-vector val)] (for ([e (in-vector val)]
[c (in-list (vector/c-elems ctc))]) [c (in-list (base-vector/c-elems ctc))])
(((contract-projection c) blame) e)) (((contract-projection c) blame) e))
val))))) val)))))
(define (vector/c-ho-projection vector-wrapper) (define (vector/c-ho-projection vector-wrapper)
(λ (ctc) (λ (ctc)
(let ([elem-ctcs (vector/c-elems ctc)] (let ([elem-ctcs (base-vector/c-elems ctc)]
[immutable (vector/c-immutable ctc)]) [immutable (base-vector/c-immutable ctc)])
(λ (blame) (λ (blame)
(let ([elem-pos-projs (apply vector-immutable (let ([elem-pos-projs (apply vector-immutable
(map (λ (c) ((contract-projection c) blame)) elem-ctcs))] (map (λ (c) ((contract-projection c) blame)) elem-ctcs))]
@ -241,14 +241,14 @@
((vector-ref elem-neg-projs i) val)) ((vector-ref elem-neg-projs i) val))
proxy-prop:contracted ctc)))))))) proxy-prop:contracted ctc))))))))
(define-struct (chaperone-vector/c vector/c) () (define-struct (chaperone-vector/c base-vector/c) ()
#:property prop:chaperone-contract #:property prop:chaperone-contract
(build-chaperone-contract-property (build-chaperone-contract-property
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:projection (vector/c-ho-projection chaperone-vector))) #:projection (vector/c-ho-projection chaperone-vector)))
(define-struct (proxy-vector/c vector/c) () (define-struct (proxy-vector/c base-vector/c) ()
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name vector/c-name #:name vector/c-name
@ -260,7 +260,7 @@
[x [x
(identifier? #'x) (identifier? #'x)
(syntax-property (syntax-property
(syntax/loc stx build-vector/c) (syntax/loc stx vector/c)
'racket/contract:contract 'racket/contract:contract
(vector (gensym 'ctc) (list #'x) null))] (vector (gensym 'ctc) (list #'x) null))]
[(vec/c arg ...) [(vec/c arg ...)
@ -287,11 +287,11 @@
[app (datum->syntax stx '#%app)]) [app (datum->syntax stx '#%app)])
(syntax-property (syntax-property
(syntax/loc stx (syntax/loc stx
(app build-vector/c new-arg ...)) (app vector/c new-arg ...))
'racket/contract:contract 'racket/contract:contract
(vector this-one (list #'vec/c) null))))])) (vector this-one (list #'vec/c) null))))]))
(define (build-vector/c #:immutable [immutable 'dont-care] #:flat? [flat? #f] . cs) (define (vector/c #:immutable [immutable 'dont-care] #:flat? [flat? #f] . cs)
(let ([ctcs (if flat? (let ([ctcs (if flat?
(map (λ (c) (coerce-flat-contract 'vector/c c)) cs) (map (λ (c) (coerce-flat-contract 'vector/c c)) cs)
(map (λ (c) (coerce-contract 'vector/c c)) cs))]) (map (λ (c) (coerce-contract 'vector/c c)) cs))])
@ -306,4 +306,4 @@
(make-proxy-vector/c ctcs immutable)]))) (make-proxy-vector/c ctcs immutable)])))
(define/subexpression-pos-prop (vector-immutable/c . args) (define/subexpression-pos-prop (vector-immutable/c . args)
(apply build-vector/c args #:immutable #t)) (apply vector/c args #:immutable #t))