Added tests to idtbl/c and fixed revealed bugs.
This commit is contained in:
parent
d4efe8f5aa
commit
e7c7e14485
|
@ -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))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user