Rework the naming conventions in {box,vector,hash}.rkt.
Fixing it so that errors aren't generated with "build-<foo>/c".
This commit is contained in:
Stevie Strickland
parent
277d9d199d
commit
859ea63faa
|
|
@ -7,13 +7,13 @@
|
|||
(rename-out [wrap-box/c box/c]))
|
||||
|
||||
(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)
|
||||
(let ([elem-ctc (box/c-content ctc)]
|
||||
[immutable (box/c-immutable ctc)]
|
||||
(let ([elem-ctc (base-box/c-content ctc)]
|
||||
[immutable (base-box/c-immutable ctc)]
|
||||
[flat? (flat-box/c? ctc)])
|
||||
(λ (val fail [first-order? #f])
|
||||
(unless (box? val)
|
||||
|
|
@ -38,8 +38,8 @@
|
|||
(check val (λ _ (return #f)) #t)))))
|
||||
|
||||
(define (box/c-name ctc)
|
||||
(let ([elem-name (contract-name (box/c-content ctc))]
|
||||
[immutable (box/c-immutable ctc)]
|
||||
(let ([elem-name (contract-name (base-box/c-content ctc))]
|
||||
[immutable (base-box/c-immutable ctc)]
|
||||
[flat? (flat-box/c? ctc)])
|
||||
(apply build-compound-type-name
|
||||
'box/c
|
||||
|
|
@ -54,7 +54,7 @@
|
|||
(list '#:flat? #t)
|
||||
null))))))
|
||||
|
||||
(define-struct (flat-box/c box/c) ()
|
||||
(define-struct (flat-box/c base-box/c) ()
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name box/c-name
|
||||
|
|
@ -64,13 +64,13 @@
|
|||
(λ (blame)
|
||||
(λ (val)
|
||||
((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)))))
|
||||
|
||||
(define (ho-projection box-wrapper)
|
||||
(λ (ctc)
|
||||
(let ([elem-ctc (box/c-content ctc)]
|
||||
[immutable (box/c-immutable ctc)])
|
||||
(let ([elem-ctc (base-box/c-content ctc)]
|
||||
[immutable (base-box/c-immutable ctc)])
|
||||
(λ (blame)
|
||||
(let ([pos-elem-proj ((contract-projection elem-ctc) blame)]
|
||||
[neg-elem-proj ((contract-projection elem-ctc) (blame-swap blame))])
|
||||
|
|
@ -83,14 +83,14 @@
|
|||
(λ (b v) (neg-elem-proj v))
|
||||
proxy-prop:contracted ctc))))))))
|
||||
|
||||
(define-struct (chaperone-box/c box/c) ()
|
||||
(define-struct (chaperone-box/c base-box/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name box/c-name
|
||||
#:first-order box/c-first-order
|
||||
#:projection (ho-projection chaperone-box)))
|
||||
|
||||
(define-struct (proxy-box/c box/c) ()
|
||||
(define-struct (proxy-box/c base-box/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name box/c-name
|
||||
|
|
@ -102,7 +102,7 @@
|
|||
[x
|
||||
(identifier? #'x)
|
||||
(syntax-property
|
||||
(syntax/loc stx build-box/c)
|
||||
(syntax/loc stx box/c)
|
||||
'racket/contract:contract
|
||||
(vector (gensym 'ctc) (list #'x) null))]
|
||||
[(b/c arg ...)
|
||||
|
|
@ -128,11 +128,11 @@
|
|||
[app (datum->syntax stx '#%app)])
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(app build-box/c new-arg ...))
|
||||
(app box/c new-arg ...))
|
||||
'racket/contract:contract
|
||||
(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?
|
||||
(coerce-flat-contract 'box/c elem)
|
||||
(coerce-contract 'box/c elem))])
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@
|
|||
[x
|
||||
(identifier? #'x)
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
build-hash/c)
|
||||
(syntax/loc stx hash/c)
|
||||
'racket/contract:contract
|
||||
(vector (gensym 'ctc) (list stx) null))]
|
||||
[(h/c arg ...)
|
||||
|
|
@ -48,11 +47,11 @@
|
|||
[app (datum->syntax stx '#%app)])
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(app build-hash/c new-arg ...))
|
||||
(app hash/c new-arg ...))
|
||||
'racket/contract:contract
|
||||
(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))
|
||||
(error 'hash/c "expected #:immutable argument to be either #t, #f, or 'dont-care, got ~s" immutable))
|
||||
(let ([dom-ctc (if flat?
|
||||
|
|
@ -75,9 +74,9 @@
|
|||
(make-proxy-hash/c dom-ctc rng-ctc immutable)])))
|
||||
|
||||
(define (check-hash/c ctc)
|
||||
(let ([dom-ctc (hash/c-dom ctc)]
|
||||
[rng-ctc (hash/c-rng ctc)]
|
||||
[immutable (hash/c-immutable ctc)]
|
||||
(let ([dom-ctc (base-hash/c-dom ctc)]
|
||||
[rng-ctc (base-hash/c-rng ctc)]
|
||||
[immutable (base-hash/c-immutable ctc)]
|
||||
[flat? (flat-hash/c? ctc)])
|
||||
(λ (val fail [first-order? #f])
|
||||
(unless (hash? val)
|
||||
|
|
@ -111,22 +110,22 @@
|
|||
(define (hash/c-name ctc)
|
||||
(apply
|
||||
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
|
||||
(if (and (flat-hash/c? ctc)
|
||||
(not (eq? (hash/c-immutable ctc) #t)))
|
||||
(not (eq? (base-hash/c-immutable ctc) #t)))
|
||||
(list '#:flat? #t)
|
||||
null)
|
||||
(case (hash/c-immutable ctc)
|
||||
(case (base-hash/c-immutable ctc)
|
||||
[(dont-care) null]
|
||||
[(#t)
|
||||
(list '#:immutable #t)]
|
||||
[(#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
|
||||
|
||||
#:property prop:flat-contract
|
||||
|
|
@ -138,8 +137,8 @@
|
|||
(λ (blame)
|
||||
(λ (val)
|
||||
((check-hash/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
(let ([dom-proj ((contract-projection (hash/c-dom ctc)) blame)]
|
||||
[rng-proj ((contract-projection (hash/c-rng ctc)) blame)])
|
||||
(let ([dom-proj ((contract-projection (base-hash/c-dom ctc)) blame)]
|
||||
[rng-proj ((contract-projection (base-hash/c-rng ctc)) blame)])
|
||||
(for ([(k v) (in-hash val)])
|
||||
(dom-proj k)
|
||||
(rng-proj v)))
|
||||
|
|
@ -147,9 +146,9 @@
|
|||
|
||||
(define (ho-projection hash-wrapper)
|
||||
(λ (ctc)
|
||||
(let ([dom-proc (contract-projection (hash/c-dom ctc))]
|
||||
[rng-proc (contract-projection (hash/c-rng ctc))]
|
||||
[immutable (hash/c-immutable ctc)])
|
||||
(let ([dom-proc (contract-projection (base-hash/c-dom ctc))]
|
||||
[rng-proc (contract-projection (base-hash/c-rng ctc))]
|
||||
[immutable (base-hash/c-immutable ctc)])
|
||||
(λ (blame)
|
||||
(let ([pos-dom-proj (dom-proc blame)]
|
||||
[neg-dom-proj (dom-proc (blame-swap blame))]
|
||||
|
|
@ -183,7 +182,7 @@
|
|||
(pos-dom-proj k))
|
||||
proxy-prop:contracted ctc))))))))
|
||||
|
||||
(define-struct (chaperone-hash/c hash/c) ()
|
||||
(define-struct (chaperone-hash/c base-hash/c) ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
|
|
@ -191,7 +190,7 @@
|
|||
#:first-order hash/c-first-order
|
||||
#:projection (ho-projection chaperone-hash)))
|
||||
|
||||
(define-struct (proxy-hash/c hash/c) ()
|
||||
(define-struct (proxy-hash/c base-hash/c) ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
|
|
|
|||
|
|
@ -7,12 +7,12 @@
|
|||
[wrap-vector/c vector/c])
|
||||
vector-immutable/c vector-immutableof)
|
||||
|
||||
(define-struct vectorof (elem immutable))
|
||||
(define-struct base-vectorof (elem immutable))
|
||||
|
||||
(define (vectorof-name c)
|
||||
(let ([immutable (vectorof-immutable c)])
|
||||
(let ([immutable (base-vectorof-immutable c)])
|
||||
(apply build-compound-type-name 'vectorof
|
||||
(contract-name (vectorof-elem c))
|
||||
(contract-name (base-vectorof-elem c))
|
||||
(append
|
||||
(if (and (flat-vectorof? c)
|
||||
(not (eq? immutable #t)))
|
||||
|
|
@ -23,8 +23,8 @@
|
|||
null)))))
|
||||
|
||||
(define (check-vectorof c)
|
||||
(let ([elem-ctc (vectorof-elem c)]
|
||||
[immutable (vectorof-immutable 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)
|
||||
|
|
@ -50,7 +50,7 @@
|
|||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
|
||||
(define-struct (flat-vectorof vectorof) ()
|
||||
(define-struct (flat-vectorof base-vectorof) ()
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name vectorof-name
|
||||
|
|
@ -60,7 +60,7 @@
|
|||
(λ (blame)
|
||||
(λ (val)
|
||||
((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)])
|
||||
(for ([e (in-vector val)])
|
||||
(p e)))
|
||||
|
|
@ -68,8 +68,8 @@
|
|||
|
||||
(define (vectorof-ho-projection vector-wrapper)
|
||||
(λ (ctc)
|
||||
(let ([elem-ctc (vectorof-elem ctc)]
|
||||
[immutable (vectorof-immutable 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))])
|
||||
|
|
@ -87,14 +87,14 @@
|
|||
(elem-neg-proj val))
|
||||
proxy-prop:contracted ctc))))))))
|
||||
|
||||
(define-struct (chaperone-vectorof vectorof) ()
|
||||
(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 (proxy-vectorof vectorof) ()
|
||||
(define-struct (proxy-vectorof base-vectorof) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name vectorof-name
|
||||
|
|
@ -106,7 +106,7 @@
|
|||
[x
|
||||
(identifier? #'x)
|
||||
(syntax-property
|
||||
(syntax/loc stx build-vectorof)
|
||||
(syntax/loc stx vectorof)
|
||||
'racket/contract:contract
|
||||
(vector (gensym 'ctc) (list #'x) null))]
|
||||
[(vecof arg ...)
|
||||
|
|
@ -133,11 +133,11 @@
|
|||
[app (datum->syntax stx '#%app)])
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(app build-vectorof new-arg ...))
|
||||
(app vectorof new-arg ...))
|
||||
'racket/contract:contract
|
||||
(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?
|
||||
(coerce-flat-contract 'vectorof c)
|
||||
(coerce-contract 'vectorof c))])
|
||||
|
|
@ -152,15 +152,15 @@
|
|||
(make-proxy-vectorof ctc immutable)])))
|
||||
|
||||
(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)
|
||||
(let ([immutable (vector/c-immutable c)])
|
||||
(let ([immutable (base-vector/c-immutable c)])
|
||||
(apply build-compound-type-name 'vector/c
|
||||
(append
|
||||
(map contract-name (vector/c-elems c))
|
||||
(map contract-name (base-vector/c-elems c))
|
||||
(if (and (flat-vector/c? c)
|
||||
(not (eq? immutable #t)))
|
||||
(list '#:flat? #t)
|
||||
|
|
@ -170,8 +170,8 @@
|
|||
null)))))
|
||||
|
||||
(define (check-vector/c c)
|
||||
(let ([elem-ctcs (vector/c-elems c)]
|
||||
[immutable (vector/c-immutable 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)
|
||||
|
|
@ -202,7 +202,7 @@
|
|||
(let/ec return
|
||||
(check val (λ _ (return #f)) #t)))))
|
||||
|
||||
(define-struct (flat-vector/c vector/c) ()
|
||||
(define-struct (flat-vector/c base-vector/c) ()
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name vector/c-name
|
||||
|
|
@ -213,14 +213,14 @@
|
|||
(λ (val)
|
||||
((check-vector/c ctc) val (λ args (apply raise-blame-error blame val args)))
|
||||
(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))
|
||||
val)))))
|
||||
|
||||
(define (vector/c-ho-projection vector-wrapper)
|
||||
(λ (ctc)
|
||||
(let ([elem-ctcs (vector/c-elems ctc)]
|
||||
[immutable (vector/c-immutable 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))]
|
||||
|
|
@ -241,14 +241,14 @@
|
|||
((vector-ref elem-neg-projs i) val))
|
||||
proxy-prop:contracted ctc))))))))
|
||||
|
||||
(define-struct (chaperone-vector/c vector/c) ()
|
||||
(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 (proxy-vector/c vector/c) ()
|
||||
(define-struct (proxy-vector/c base-vector/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name vector/c-name
|
||||
|
|
@ -260,7 +260,7 @@
|
|||
[x
|
||||
(identifier? #'x)
|
||||
(syntax-property
|
||||
(syntax/loc stx build-vector/c)
|
||||
(syntax/loc stx vector/c)
|
||||
'racket/contract:contract
|
||||
(vector (gensym 'ctc) (list #'x) null))]
|
||||
[(vec/c arg ...)
|
||||
|
|
@ -287,11 +287,11 @@
|
|||
[app (datum->syntax stx '#%app)])
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(app build-vector/c new-arg ...))
|
||||
(app vector/c new-arg ...))
|
||||
'racket/contract:contract
|
||||
(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?
|
||||
(map (λ (c) (coerce-flat-contract 'vector/c c)) cs)
|
||||
(map (λ (c) (coerce-contract 'vector/c c)) cs))])
|
||||
|
|
@ -306,4 +306,4 @@
|
|||
(make-proxy-vector/c ctcs immutable)])))
|
||||
|
||||
(define/subexpression-pos-prop (vector-immutable/c . args)
|
||||
(apply build-vector/c args #:immutable #t))
|
||||
(apply vector/c args #:immutable #t))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user