Add idtbl-chaperone and implement contracts on top of that.
This commit is contained in:
Eric Dobson
Ryan Culpepper
parent
54b82871ab
commit
8f8bc76e39
|
|
@ -2,6 +2,7 @@
|
|||
(require (for-syntax racket/base
|
||||
racket/syntax)
|
||||
racket/contract/base
|
||||
racket/contract/combinator
|
||||
racket/dict
|
||||
(rename-in (except-in "private/id-table.rkt"
|
||||
make-free-id-table
|
||||
|
|
@ -49,7 +50,9 @@
|
|||
[mutable-idtbl?
|
||||
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))]
|
||||
[immutable-idtbl?
|
||||
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))])
|
||||
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))]
|
||||
[chaperone-idtbl
|
||||
(format-id #'idtbl "chaperone-~a" (syntax-e #'idtbl))])
|
||||
(define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x))
|
||||
(with-syntax ([idtbl? (s '?)]
|
||||
[idtbl-hash (s '-hash)]
|
||||
|
|
@ -111,6 +114,131 @@
|
|||
idtbl-iterate-key
|
||||
idtbl-iterate-value))
|
||||
|
||||
(define-struct base-idtbl/c (dom rng immutable))
|
||||
|
||||
(define (idtbl/c-name ctc)
|
||||
(apply
|
||||
build-compound-type-name
|
||||
'idtbl/c (base-idtbl/c-dom ctc) (base-idtbl/c-rng ctc)
|
||||
(append
|
||||
(if (flat-idtbl/c? ctc)
|
||||
(list '#:flat? #t)
|
||||
null)
|
||||
(case (base-idtbl/c-immutable ctc)
|
||||
[(dont-care) null]
|
||||
[(#t)
|
||||
(list '#:immutable #t)]
|
||||
[(#f)
|
||||
(list '#:immutable #f)]))))
|
||||
|
||||
(define-values (idtbl/c-dom-pos-proj
|
||||
idtbl/c-dom-neg-proj
|
||||
idtbl/c-rng-pos-proj
|
||||
idtbl/c-rng-neg-proj)
|
||||
(let ()
|
||||
(define (proj acc location swap)
|
||||
(lambda (ctc blame)
|
||||
((contract-projection (acc ctc))
|
||||
(blame-add-context blame "the keys of" #:swap swap))))
|
||||
(values
|
||||
(proj base-idtbl/c-dom "the keys of" #f)
|
||||
(proj base-idtbl/c-dom "the keys of" #t)
|
||||
(proj base-idtbl/c-rng "the values of" #f)
|
||||
(proj base-idtbl/c-rng "the values of" #t))))
|
||||
|
||||
(define (idtbl/c-first-order ctc)
|
||||
(define dom-ctc (base-idtbl/c-dom ctc))
|
||||
(define rng-ctc (base-idtbl/c-rng ctc))
|
||||
(define immutable (base-idtbl/c-immutable ctc))
|
||||
(λ (val)
|
||||
(and (idtbl? val)
|
||||
(case immutable
|
||||
[(#t) (immutable? val)]
|
||||
[(#f) (not (immutable? val))]
|
||||
[else #t])
|
||||
(for/and ([(k v) (in-dict val)])
|
||||
(and (contract-first-order-passes? dom-ctc k)
|
||||
(contract-first-order-passes? rng-ctc v))))))
|
||||
|
||||
(define (check-idtbl/c ctc val blame)
|
||||
(define immutable (base-idtbl/c-immutable ctc))
|
||||
(unless (idtbl? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "a ~a," given: "~e") 'idtbl val))
|
||||
(case immutable
|
||||
[(#t)
|
||||
(unless (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
|
||||
[(#f)
|
||||
(when (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
|
||||
[(dont-care) (void)]))
|
||||
|
||||
(define ho-projection
|
||||
(lambda (ctc)
|
||||
(lambda (blame)
|
||||
(lambda (b)
|
||||
(define pos-dom-proj (idtbl/c-dom-pos-proj ctc blame))
|
||||
(define neg-dom-proj (idtbl/c-dom-pos-proj ctc blame))
|
||||
(define pos-rng-proj (idtbl/c-dom-pos-proj ctc blame))
|
||||
(define neg-rng-proj (idtbl/c-dom-pos-proj ctc blame))
|
||||
(lambda (tbl)
|
||||
(check-idtbl/c ctc tbl blame)
|
||||
(if (immutable? tbl)
|
||||
(error 'idtbl/c "Not Yet implemented")
|
||||
(chaperone-idtbl tbl
|
||||
(λ (t k)
|
||||
(values (neg-dom-proj k)
|
||||
(λ (h k v)
|
||||
(pos-rng-proj v))))
|
||||
(λ (t k v)
|
||||
(values (neg-dom-proj k)
|
||||
(neg-rng-proj v)))
|
||||
(λ (t k)
|
||||
(neg-dom-proj k))
|
||||
(λ (t k)
|
||||
(pos-dom-proj k))
|
||||
impersonator-prop:contracted ctc)))))))
|
||||
|
||||
|
||||
|
||||
(struct flat-idtbl/c base-idtbl/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(check-idtbl/c ctc val blame)
|
||||
(define dom-proj (idtbl/c-dom-pos-proj ctc))
|
||||
(define rng-proj (idtbl/c-rng-pos-proj ctc))
|
||||
(for ([(k v) (in-dict val)])
|
||||
(dom-proj k)
|
||||
(rng-proj v))
|
||||
val)))))
|
||||
|
||||
(struct chaperone-idtbl/c base-idtbl/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
(struct impersonator-idtbl/c base-idtbl/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name idtbl/c-name
|
||||
#:first-order idtbl/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
|
||||
(struct mutable-idtbl mutable-idtbl* ()
|
||||
#:property prop:dict/contract
|
||||
(list idtbl-mutable-methods
|
||||
|
|
@ -120,28 +248,18 @@
|
|||
(list idtbl-immutable-methods
|
||||
dict-contract-methods))
|
||||
|
||||
(define (mutable-idtbl/c value/c)
|
||||
(struct/c mutable-idtbl
|
||||
(hash/c any/c
|
||||
(listof (cons/c any/c value/c))
|
||||
#:immutable #f)
|
||||
any/c))
|
||||
|
||||
(define (immutable-idtbl/c value/c)
|
||||
(struct/c immutable-idtbl
|
||||
(hash/c any/c
|
||||
(listof (cons/c any/c value/c))
|
||||
#:immutable #t)
|
||||
any/c))
|
||||
|
||||
|
||||
(define (idtbl/c value/c #:immutable (immutable 'dont-care))
|
||||
(case immutable
|
||||
((dont-care) (or/c (mutable-idtbl/c value/c)
|
||||
(immutable-idtbl/c value/c)))
|
||||
((#t) (immutable-idtbl/c value/c))
|
||||
((#f) (mutable-idtbl/c value/c))))
|
||||
|
||||
(define (idtbl/c key/c value/c #:immutable (immutable 'dont-care))
|
||||
(define key/ctc (coerce-contract 'idtbl/c key/c))
|
||||
(define value/ctc (coerce-contract 'idtbl/c value/c))
|
||||
(cond
|
||||
((and (eq? immutable #t)
|
||||
(flat-contract? key/ctc)
|
||||
(flat-contract? value/ctc))
|
||||
(flat-idtbl/c key/ctc value/ctc immutable))
|
||||
((chaperone-contract? value/ctc)
|
||||
(chaperone-idtbl/c key/ctc value/ctc immutable))
|
||||
(else
|
||||
(impersonator-idtbl/c key/ctc value/ctc immutable))))
|
||||
|
||||
(provide/contract
|
||||
[make-idtbl
|
||||
|
|
@ -179,7 +297,7 @@
|
|||
[idtbl-for-each
|
||||
(-> idtbl? (-> identifier? any/c any) any)]
|
||||
[idtbl/c
|
||||
(->* (contract?)
|
||||
(->* (chaperone-contract? contract?)
|
||||
(#:immutable (or/c 'dont-care #t #f))
|
||||
contract?)]))))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,24 @@
|
|||
;; where hash maps symbol => (listof (cons identifier value))
|
||||
;; phase is a phase-level (integer or #f)
|
||||
|
||||
|
||||
(define-values (prop:id-table-impersonator
|
||||
id-table-impersonator?
|
||||
id-table-impersonator-value)
|
||||
(make-impersonator-property 'id-table-impersonator))
|
||||
|
||||
(define-values (id-table-imp-wrapped
|
||||
id-table-imp-ref-wrapper
|
||||
id-table-imp-set!-wrapper
|
||||
id-table-imp-remove!-wrapper
|
||||
id-table-imp-key-wrapper)
|
||||
(let ((extractor (lambda (i)
|
||||
(lambda (d)
|
||||
(vector-ref (id-table-impersonator-value d) i)))))
|
||||
(apply values (build-list 5 extractor))))
|
||||
|
||||
|
||||
|
||||
(define (make-id-table/constructor who init-dict phase make identifier->symbol identifier=?)
|
||||
(let ([t (make (make-hasheq) phase)])
|
||||
(for ([(k v) (in-dict init-dict)])
|
||||
|
|
@ -25,34 +43,47 @@
|
|||
(id-table-set/constructor who t k v make identifier->symbol identifier=?)))
|
||||
|
||||
(define (id-table-ref who d id default identifier->symbol identifier=?)
|
||||
(let ([phase (id-table-phase d)])
|
||||
(let ([i (for/first ([i (in-list (hash-ref (id-table-hash d)
|
||||
(identifier->symbol id phase)
|
||||
null))]
|
||||
#:when (identifier=? (car i) id phase))
|
||||
i)])
|
||||
(if i
|
||||
(cdr i)
|
||||
(cond [(eq? default not-given)
|
||||
(error who "no mapping for ~e" id)]
|
||||
[(procedure? default) (default)]
|
||||
[else default])))))
|
||||
(if (id-table-impersonator? d)
|
||||
(let-values (((new-id return-wrapper)
|
||||
((id-table-imp-ref-wrapper d) d id)))
|
||||
(return-wrapper
|
||||
(id-table-ref (id-table-imp-wrapped d) new-id default)))
|
||||
(let ([phase (id-table-phase d)])
|
||||
(let ([i (for/first ([i (in-list (hash-ref (id-table-hash d)
|
||||
(identifier->symbol id phase)
|
||||
null))]
|
||||
#:when (identifier=? (car i) id phase))
|
||||
i)])
|
||||
(if i
|
||||
(cdr i)
|
||||
(cond [(eq? default not-given)
|
||||
(error who "no mapping for ~e" id)]
|
||||
[(procedure? default) (default)]
|
||||
[else default]))))))
|
||||
|
||||
(define (id-table-set! who d id v identifier->symbol identifier=?)
|
||||
(let* ([phase (id-table-phase d)]
|
||||
[sym (identifier->symbol id phase)]
|
||||
[l (hash-ref (id-table-hash d) sym null)]
|
||||
[new-l (alist-set identifier=? phase l id v)])
|
||||
(hash-set! (id-table-hash d) sym new-l)))
|
||||
(if (id-table-impersonator? d)
|
||||
(let-values (((new-id new-v)
|
||||
((id-table-imp-set!-wrapper d) d id v)))
|
||||
(id-table-set! (id-table-imp-wrapped d) new-id new-v))
|
||||
(let* ([phase (id-table-phase d)]
|
||||
[sym (identifier->symbol id phase)]
|
||||
[l (hash-ref (id-table-hash d) sym null)]
|
||||
[new-l (alist-set identifier=? phase l id v)])
|
||||
(hash-set! (id-table-hash d) sym new-l))))
|
||||
|
||||
|
||||
(define (id-table-remove! who d id identifier->symbol identifier=?)
|
||||
(let* ([phase (id-table-phase d)]
|
||||
[sym (identifier->symbol id phase)]
|
||||
[l (hash-ref (id-table-hash d) sym null)]
|
||||
[newl (alist-remove identifier=? phase l id)])
|
||||
(if (pair? newl)
|
||||
(hash-set! (id-table-hash d) sym newl)
|
||||
(hash-remove! (id-table-hash d) sym))))
|
||||
(if (id-table-impersonator? d)
|
||||
(let ((new-id ((id-table-imp-remove!-wrapper d) d id)))
|
||||
(id-table-remove! (id-table-imp-wrapped d) new-id))
|
||||
(let* ([phase (id-table-phase d)]
|
||||
[sym (identifier->symbol id phase)]
|
||||
[l (hash-ref (id-table-hash d) sym null)]
|
||||
[newl (alist-remove identifier=? phase l id)])
|
||||
(if (pair? newl)
|
||||
(hash-set! (id-table-hash d) sym newl)
|
||||
(hash-remove! (id-table-hash d) sym)))))
|
||||
|
||||
(define (id-table-set/constructor who d id v constructor identifier->symbol identifier=?)
|
||||
(let* ([phase (id-table-phase d)]
|
||||
|
|
@ -120,12 +151,19 @@ Notes (FIXME?):
|
|||
(make-id-table-iter d a2 b2 b2))))))))
|
||||
|
||||
(define (id-table-iterate-key who d pos)
|
||||
(let-values ([(h a br b) (rebase-iter who d pos)])
|
||||
(caar b)))
|
||||
(if (id-table-impersonator? d)
|
||||
(let ((wrapper (id-table-imp-key-wrapper d)))
|
||||
(wrapper (id-table-iterate-key (id-table-imp-wrapped d) pos)))
|
||||
(let-values ([(h a br b) (rebase-iter who d pos)])
|
||||
(caar b))))
|
||||
|
||||
;; TODO figure out how to provide API compatibility with hashes with regards
|
||||
;; to iterate-key and provide the checking from rebase-iter
|
||||
(define (id-table-iterate-value who d pos)
|
||||
(let-values ([(h a br b) (rebase-iter who d pos)])
|
||||
(cdar b)))
|
||||
(if (id-table-impersonator? d)
|
||||
(id-table-ref d (id-table-iterate-key d pos))
|
||||
(let-values ([(h a br b) (rebase-iter who d pos)])
|
||||
(cdar b))))
|
||||
|
||||
(define (rebase-iter who d pos)
|
||||
(unless (eq? d (id-table-iter-d pos))
|
||||
|
|
@ -206,7 +244,9 @@ Notes (FIXME?):
|
|||
[mutable-idtbl?
|
||||
(format-id #'idtbl "mutable-~a?" (syntax-e #'idtbl))]
|
||||
[immutable-idtbl?
|
||||
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))])
|
||||
(format-id #'idtbl "immutable-~a?" (syntax-e #'idtbl))]
|
||||
[chaperone-idtbl
|
||||
(format-id #'idtbl "chaperone-~a" (syntax-e #'idtbl))])
|
||||
(define (s x) (format-id #'idtbl "~a~a" (syntax-e #'idtbl) x))
|
||||
(with-syntax ([idtbl? (s '?)]
|
||||
[idtbl-ref (s '-ref)]
|
||||
|
|
@ -228,7 +268,6 @@ Notes (FIXME?):
|
|||
#'(begin
|
||||
|
||||
;; Struct defs at end, so that dict methods can refer to earlier procs
|
||||
|
||||
(define (make-idtbl [init-dict null]
|
||||
#:phase [phase (syntax-local-phase-level)])
|
||||
(make-id-table/constructor 'make-idtbl init-dict phase mutable-idtbl
|
||||
|
|
@ -239,6 +278,14 @@ Notes (FIXME?):
|
|||
(make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl
|
||||
identifier->symbol identifier=?))
|
||||
|
||||
(define (chaperone-idtbl d ref set! remove! key . args)
|
||||
(apply chaperone-struct d
|
||||
id-table-phase (lambda (d p) p)
|
||||
prop:id-table-impersonator
|
||||
(vector d ref set! remove! key)
|
||||
args))
|
||||
|
||||
|
||||
(define (idtbl-ref d id [default not-given])
|
||||
(id-table-ref 'idtbl-ref d id default identifier->symbol identifier=?))
|
||||
(define (idtbl-set! d id v)
|
||||
|
|
@ -249,6 +296,7 @@ Notes (FIXME?):
|
|||
(idtbl-set/constructor d id v immutable-idtbl))
|
||||
(define (idtbl-remove! d id)
|
||||
(id-table-remove! 'idtbl-remove! d id identifier->symbol identifier=?))
|
||||
|
||||
(define (idtbl-remove/constructor d id constructor)
|
||||
(id-table-remove/constructor 'idtbl-remove d id constructor identifier->symbol identifier=?))
|
||||
(define (idtbl-remove d id)
|
||||
|
|
@ -317,6 +365,7 @@ Notes (FIXME?):
|
|||
idtbl-for-each
|
||||
|
||||
;; just for use/extension by syntax/id-table
|
||||
chaperone-idtbl
|
||||
idtbl-set/constructor
|
||||
idtbl-remove/constructor
|
||||
idtbl-mutable-methods
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user