Added tests to idtbl/c and fixed revealed bugs.

This commit is contained in:
Eric Dobson 2012-07-12 20:38:49 -07:00 committed by Ryan Culpepper
parent d4efe8f5aa
commit e7c7e14485
3 changed files with 212 additions and 92 deletions

View File

@ -64,7 +64,7 @@
idtbl-map idtbl-for-each
idtbl-mutable-methods idtbl-immutable-methods
idtbl/c
chaperone-idtbl idtbl-chaperone-keys+values/constructor))
chaperone-mutable-idtbl chaperone-immutable-idtbl))
#'(begin
;; Struct defs at end, so that dict methods can refer to earlier procs
@ -130,7 +130,7 @@
(define (proj acc location swap)
(lambda (ctc blame)
((contract-projection (acc ctc))
(blame-add-context blame "the keys of" #:swap swap))))
(blame-add-context blame location #:swap? swap))))
(values
(proj base-idtbl/c-dom "the keys of" #f)
(proj base-idtbl/c-dom "the keys of" #t)
@ -144,8 +144,8 @@
(λ (val)
(and (idtbl? val)
(case immutable
[(#t) (immutable? val)]
[(#f) (not (immutable? val))]
[(#t) (immutable-idtbl? val)]
[(#f) (mutable-idtbl? val)]
[else #t])
(for/and ([(k v) (in-dict val)])
(and (contract-first-order-passes? dom-ctc k)
@ -158,11 +158,11 @@
'(expected "a ~a," given: "~e") 'idtbl val))
(case immutable
[(#t)
(unless (immutable? val)
(unless (immutable-idtbl? val)
(raise-blame-error blame val
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
[(#f)
(when (immutable? val)
(unless (mutable-idtbl? val)
(raise-blame-error blame val
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
[(dont-care) (void)]))
@ -170,29 +170,30 @@
(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)
(idtbl-chaperone-keys+values/constructor
tbl pos-dom-proj pos-rng-proj immutable-idtbl)
(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)))))))
(define pos-dom-proj (idtbl/c-dom-pos-proj ctc blame))
(define neg-dom-proj (idtbl/c-dom-neg-proj ctc blame))
(define pos-rng-proj (idtbl/c-rng-pos-proj ctc blame))
(define neg-rng-proj (idtbl/c-rng-neg-proj ctc blame))
(lambda (tbl)
(check-idtbl/c ctc tbl blame)
;TODO for immutable hash tables optimize this chaperone to a flat
;check if possible
(if (immutable-idtbl? tbl)
(chaperone-immutable-idtbl tbl pos-dom-proj pos-rng-proj
impersonator-prop:contracted ctc)
(chaperone-mutable-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))))))
@ -207,8 +208,8 @@
(λ (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))
(define dom-proj (idtbl/c-dom-pos-proj ctc blame))
(define rng-proj (idtbl/c-rng-pos-proj ctc blame))
(for ([(k v) (in-dict val)])
(dom-proj k)
(rng-proj v))

View File

@ -2,7 +2,8 @@
(require (for-syntax racket/base
racket/syntax)
(for-meta 2 racket/base)
racket/private/dict)
racket/private/dict
racket/promise)
;; No-contract version.
@ -11,6 +12,13 @@
;; phase is a phase-level (integer or #f)
(define (id-table-hash-code d hash-code)
(+ (hash-code (id-table-phase d))
(for/sum (((k v) (in-dict d)))
(* (hash-code (syntax-e k)) (hash-code v)))))
(define-values (prop:id-table-impersonator
id-table-impersonator?
id-table-impersonator-value)
@ -44,47 +52,50 @@
(id-table-set/constructor who t k v make identifier->symbol identifier=?)))
(define (id-table-ref who d id default identifier->symbol identifier=?)
(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]))))))
(let loop ((d d) (id id) (return values))
(if (id-table-impersonator? d)
(let-values (((new-id return-wrapper)
((id-table-imp-ref-wrapper d) d id)))
(loop (id-table-imp-wrapped d) new-id
(lambda (new-v) (return-wrapper d new-id new-v))))
(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
(return (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=?)
(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))))
(let loop ((d d) (id id) (v v))
(if (id-table-impersonator? d)
(let-values (((new-id new-v)
((id-table-imp-set!-wrapper d) d id v)))
(loop (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=?)
(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)))))
(let loop ((d d) (id id))
(if (id-table-impersonator? d)
(let ((new-id ((id-table-imp-remove!-wrapper d) d id)))
(loop (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)]
@ -108,14 +119,6 @@
(define (id-table-count d)
(apply + (hash-map (id-table-hash d) (lambda (k v) (length v)))))
(define (id-table-for-each d p)
(define (pp i) (p (car i) (cdr i)))
(hash-for-each (id-table-hash d) (lambda (k v) (for-each pp v))))
(define (id-table-map d f)
(define (fp i) (f (car i) (cdr i)))
(apply append (hash-map (id-table-hash d) (lambda (k v) (map fp v)))))
(define-struct id-table-iter (d a br b))
;; where d is an id-table
@ -154,20 +157,20 @@ Notes (FIXME?):
(define (id-table-iterate-key who d pos)
(if (id-table-impersonator? d)
(let ((wrapper (id-table-imp-key-wrapper d)))
(wrapper (id-table-iterate-key (id-table-imp-wrapped d) pos)))
(wrapper d (id-table-iterate-key who (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)
(define (id-table-iterate-value who d pos identifier->symbol identifier=?)
(if (id-table-impersonator? d)
(id-table-ref d (id-table-iterate-key d pos))
(id-table-ref who d (id-table-iterate-key who d pos) not-given identifier->symbol identifier=?)
(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))
(unless (chaperone-of? (id-table-iter-d pos) d)
(error who "invalid iteration position for identifier table"))
(let* ([h (id-table-hash d)]
[a (id-table-iter-a pos)]
@ -260,7 +263,7 @@ Notes (FIXME?):
idtbl-iterate-key idtbl-iterate-value
idtbl-map idtbl-for-each
idtbl-mutable-methods idtbl-immutable-methods
chaperone-idtbl idtbl-chaperone-keys+values/constructor))
chaperone-mutable-idtbl chaperone-immutable-idtbl))
#'(begin
;; Struct defs at end, so that dict methods can refer to earlier procs
@ -274,13 +277,26 @@ 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)
(define (chaperone-mutable-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 (chaperone-immutable-idtbl d wrap-key wrap-value . args)
(define cached-hash
(delay
(for/hasheq (((sym alist) (id-table-hash d)))
(values sym
(for/list (((key value) (in-dict alist)))
(cons (wrap-key key) (wrap-value value)))))))
(apply chaperone-struct d
id-table-hash (lambda (d h)
(force cached-hash))
args))
(define (idtbl-ref d id [default not-given])
(id-table-ref 'idtbl-ref d id default identifier->symbol identifier=?))
@ -300,9 +316,9 @@ Notes (FIXME?):
(define (idtbl-count d)
(id-table-count d))
(define (idtbl-for-each d p)
(id-table-for-each d p))
(dict-for-each d p))
(define (idtbl-map d f)
(id-table-map d f))
(dict-map d f))
(define (idtbl-iterate-first d)
(id-table-iterate-first d))
(define (idtbl-iterate-next d pos)
@ -310,13 +326,14 @@ Notes (FIXME?):
(define (idtbl-iterate-key d pos)
(id-table-iterate-key 'idtbl-iterate-key d pos))
(define (idtbl-iterate-value d pos)
(id-table-iterate-value 'idtbl-iterate-value d pos))
(id-table-iterate-value 'idtbl-iterate-value d pos identifier->symbol identifier=?))
(define (idtbl-chaperone-keys+values/constructor d wrap-key wrap-value constructor)
(constructor
(for/hasheq (((sym alist) (id-table-hash d)))
(for/list (((key value) (in-dict alist)))
(cons (wrap-key key) (wrap-value value))))
(values sym
(for/list (((key value) (in-dict alist)))
(cons (wrap-key key) (wrap-value value)))))
(id-table-phase d)))
(define idtbl-mutable-methods
@ -343,11 +360,22 @@ Notes (FIXME?):
idtbl-iterate-key
idtbl-iterate-value))
(define (idtbl-equal? left right equal?)
(let/ec k
(and (equal? (id-table-phase left) (id-table-phase right))
(equal? (idtbl-count left) (idtbl-count right))
(for/and (((l-key l-value) (in-dict left)))
(equal? (idtbl-ref right l-key (lambda () (k #f))) l-value)))))
(struct idtbl id-table ())
(struct mutable-idtbl idtbl ()
#:property prop:dict idtbl-mutable-methods)
#:property prop:dict idtbl-mutable-methods
#:property prop:equal+hash (list idtbl-equal? id-table-hash-code id-table-hash-code))
(struct immutable-idtbl idtbl ()
#:property prop:dict idtbl-immutable-methods)
#:property prop:dict idtbl-immutable-methods
#:property prop:equal+hash (list idtbl-equal? id-table-hash-code id-table-hash-code))
(provide make-idtbl
make-immutable-idtbl
@ -368,8 +396,8 @@ Notes (FIXME?):
idtbl-for-each
;; just for use/extension by syntax/id-table
chaperone-idtbl
idtbl-chaperone-keys+values/constructor
chaperone-mutable-idtbl
chaperone-immutable-idtbl
idtbl-set/constructor
idtbl-remove/constructor
idtbl-mutable-methods

View File

@ -241,6 +241,97 @@
(lambda (x y)
(set! l (cons y l))))
l))
)))
))
(test #t contract? (free-id-table/c any/c number?))
(test #t contract? (bound-id-table/c any/c number?))
(test #t contract? (bound-id-table/c any/c number? #:immutable #t))
(test #t contract? (free-id-table/c any/c number? #:immutable #f))
(test #t contract? (bound-id-table/c any/c number? #:immutable 'dont-care))
(test #t chaperone-contract? (free-id-table/c any/c number?))
(test #f flat-contract? (free-id-table/c any/c number?))
(test #t flat-contract? (free-id-table/c any/c number? #:immutable #t))
(test #f flat-contract? (free-id-table/c any/c (vectorof number?) #:immutable #t))
(test #f chaperone-contract? (free-id-table/c any/c (new-∀/c 'v)))
(error-test #'(free-id-table/c (new-∀/c 'v) any/c))
(let ()
(define (app-ctc ctc value)
(contract ctc value 'positive 'negative))
(define (positive-error? exn)
(and exn:fail:contract?
(regexp-match? "blaming: positive" (exn-message exn))))
(define (negative-error? exn)
(and exn:fail:contract?
(regexp-match? "blaming: negative" (exn-message exn))))
(define-syntax-rule (test/blame-pos e)
(thunk-error-test (lambda () e) #'e positive-error?))
(define-syntax-rule (test/blame-neg e)
(thunk-error-test (lambda () e) #'e negative-error?))
(define-values (a b c d) (values 'A 'B 'C 'D))
(define tbl (make-free-id-table))
(free-id-table-set! tbl #'a a)
(free-id-table-set! tbl #'b b)
(free-id-table-set! tbl #'c c)
(free-id-table-set! tbl #'d d)
(define im-tbl
((compose
(lambda (tbl) (free-id-table-set tbl #'a a))
(lambda (tbl) (free-id-table-set tbl #'b b))
(lambda (tbl) (free-id-table-set tbl #'c c))
(lambda (tbl) (free-id-table-set tbl #'d d)))
(make-immutable-free-id-table)))
(test #t free-id-table? (app-ctc (free-id-table/c any/c any/c) (make-free-id-table)))
(test #t bound-id-table? (app-ctc (bound-id-table/c identifier? number?) (make-bound-id-table)))
(test #t free-id-table? (app-ctc (free-id-table/c identifier? symbol?) tbl))
(test #t free-id-table? (app-ctc (free-id-table/c identifier? symbol?) im-tbl))
(test #t free-id-table? (app-ctc (free-id-table/c identifier? number?) tbl))
(test/blame-pos (app-ctc (free-id-table/c symbol? symbol? #:immutable #t) im-tbl))
(test/blame-pos (app-ctc (free-id-table/c identifier? number? #:immutable #t) im-tbl))
(test #t free-id-table? (app-ctc (free-id-table/c identifier? number?) im-tbl))
(test #t free-id-table? (app-ctc (free-id-table/c symbol? symbol?) im-tbl))
; These are not failures yet because they are not flat contracts
; Looking at the hash ensures that the contract fails
;(test/blame-pos (app-ctc (free-id-table/c identifier? number?) im-tbl))
;(test/blame-pos (app-ctc (free-id-table/c symbol? symbol?) im-tbl))
(test/blame-pos (free-id-table-count (app-ctc (free-id-table/c identifier? number?) im-tbl)))
(test/blame-pos (free-id-table-count (app-ctc (free-id-table/c symbol? symbol?) im-tbl)))
(define (short-identifier? id)
(and (identifier? id) (equal? 1 (string-length (symbol->string (syntax-e id))))))
(define ctced-tbl (app-ctc (free-id-table/c short-identifier? number?) tbl))
(test/blame-pos (free-id-table-ref ctced-tbl #'a))
(test/blame-neg (free-id-table-ref ctced-tbl #'ab))
(test/blame-neg (free-id-table-set! ctced-tbl #'a 'c))
(test/blame-neg (free-id-table-set! ctced-tbl #'ab 2))
(test/blame-neg (free-id-table-remove! ctced-tbl #'ab))
(test/blame-pos
(let ((ctced-tbl (app-ctc (free-id-table/c symbol? number?) tbl)))
(free-id-table-iterate-key ctced-tbl (free-id-table-iterate-first ctced-tbl))))
(define/contract ctc-tbl (free-id-table/c any/c number?) (make-free-id-table))
(test #t void? (free-id-table-set! ctc-tbl #'a 1))
(test #t void? (free-id-table-set! ctc-tbl #'b 2))
(test #t number? (free-id-table-ref ctc-tbl #'b))
(test #t string? (free-id-table-ref ctc-tbl #'c "3"))
(test #t void? (free-id-table-set! ctc-tbl #'a 4))
(test #t void? (free-id-table-remove! ctc-tbl #'b))
(test #t number? (free-id-table-count ctc-tbl))
(test #t list? (free-id-table-map ctc-tbl (λ (k v) v)))
))
(report-errs)