syntax/id-table: more work on *-id-table/c

This commit is contained in:
Ryan Culpepper 2012-08-28 20:14:48 -04:00
parent e7c7e14485
commit 3ccc93590a
4 changed files with 232 additions and 213 deletions

View File

@ -30,6 +30,7 @@
any/c
id-table-iter?
#f #f #f))
(begin-for-syntax
(define (replace old new template)
(datum->syntax new
@ -44,6 +45,116 @@
#`(begin
(define/with-syntax template (replace old new 'template)) ...)])))
;; ========
(define-struct base-id-table/c (dom rng immutable))
(define-values (id-table/c-dom-pos-proj
id-table/c-dom-neg-proj
id-table/c-rng-pos-proj
id-table/c-rng-neg-proj)
(let ()
(define (proj acc location swap)
(lambda (ctc blame)
((contract-projection (acc ctc))
(blame-add-context blame location #:swap? swap))))
(values
(proj base-id-table/c-dom "the keys of" #f)
(proj base-id-table/c-dom "the keys of" #t)
(proj base-id-table/c-rng "the values of" #f)
(proj base-id-table/c-rng "the values of" #t))))
(define (make-id-table/c-functions idtbl/c-symbol
idtbl?
mutable-idtbl?
immutable-idtbl?
immutable-idtbl)
(define (id-table/c-name ctc)
(apply build-compound-type-name
idtbl/c-symbol
(base-id-table/c-dom ctc)
(base-id-table/c-rng ctc)
(case (base-id-table/c-immutable ctc)
[(dont-care) null]
[(#t)
(list '#:immutable #t)]
[(#f)
(list '#:immutable #f)])))
(define (id-table/c-first-order ctc)
(define dom-ctc (base-id-table/c-dom ctc))
(define rng-ctc (base-id-table/c-rng ctc))
(define immutable (base-id-table/c-immutable ctc))
(λ (val)
(and (idtbl? val)
(case immutable
[(#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)
(contract-first-order-passes? rng-ctc v))))))
(define (check-id-table/c ctc val blame)
(define immutable (base-id-table/c-immutable ctc))
(case immutable
[(#t)
(unless (immutable-idtbl? val)
(raise-blame-error blame val
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
[(#f)
(unless (mutable-idtbl? val)
(raise-blame-error blame val
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
[(dont-care)
(unless (idtbl? val)
(raise-blame-error blame val
'(expected "a ~a," given: "~e") 'idtbl val))]))
(define (fo-projection ctc)
(λ (blame)
(define dom-proj (id-table/c-dom-pos-proj ctc blame))
(define rng-proj (id-table/c-rng-pos-proj ctc blame))
(λ (val)
(check-id-table/c ctc val blame)
(for ([(k v) (in-dict val)])
(dom-proj k)
(rng-proj v))
val)))
(define (ho-projection ctc)
(lambda (blame)
(define pos-dom-proj (id-table/c-dom-pos-proj ctc blame))
(define neg-dom-proj (id-table/c-dom-neg-proj ctc blame))
(define pos-rng-proj (id-table/c-rng-pos-proj ctc blame))
(define neg-rng-proj (id-table/c-rng-neg-proj ctc blame))
(lambda (tbl)
(check-id-table/c ctc tbl blame)
;;TODO for immutable hash tables optimize this chaperone to a flat
;;check if possible
(if (immutable-idtbl? tbl)
(chaperone-immutable-id-table tbl pos-dom-proj pos-rng-proj
impersonator-prop:contracted ctc)
(chaperone-mutable-id-table 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)))))
(values id-table/c-name
id-table/c-first-order
check-id-table/c
fo-projection
ho-projection))
;; ========
(define-syntax (make-code stx)
(syntax-case stx ()
@ -64,7 +175,7 @@
idtbl-map idtbl-for-each
idtbl-mutable-methods idtbl-immutable-methods
idtbl/c
chaperone-mutable-idtbl chaperone-immutable-idtbl))
chaperone-mutable-idtbl))
#'(begin
;; Struct defs at end, so that dict methods can refer to earlier procs
@ -105,133 +216,6 @@
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 location #: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-idtbl? val)]
[(#f) (mutable-idtbl? 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-idtbl? val)
(raise-blame-error blame val
'(expected "an immutable ~a," given: "~e") 'idtbl val))]
[(#f)
(unless (mutable-idtbl? val)
(raise-blame-error blame val
'(expected "a mutable ~a," given: "~e") 'idtbl val))]
[(dont-care) (void)]))
(define ho-projection
(lambda (ctc)
(lambda (blame)
(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))))))
(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 blame))
(define rng-proj (idtbl/c-rng-pos-proj ctc blame))
(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
@ -241,18 +225,52 @@
(list idtbl-immutable-methods
dict-contract-methods))
(define (idtbl/c key/c value/c #:immutable (immutable 'dont-care))
(define-values (idtbl/c-name
idtbl/c-first-order
check-idtbl/c
fo-projection
ho-projection)
(make-id-table/c-functions 'idtbl/c
idtbl?
mutable-idtbl?
immutable-idtbl?
immutable-idtbl))
(struct flat-idtbl/c base-id-table/c ()
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:name idtbl/c-name
#:first-order idtbl/c-first-order
#:projection fo-projection))
(struct chaperone-idtbl/c base-id-table/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-id-table/c ()
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:name idtbl/c-name
#:first-order idtbl/c-first-order
#:projection ho-projection))
(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))))
(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
@ -290,7 +308,7 @@
[idtbl-for-each
(-> idtbl? (-> identifier? any/c any) any)]
[idtbl/c
(->* (chaperone-contract? contract?)
(->* (flat-contract? contract?)
(#:immutable (or/c 'dont-care #t #f))
contract?)])))]))

View File

@ -11,13 +11,21 @@
;; where hash maps symbol => (listof (cons identifier value))
;; phase is a phase-level (integer or #f)
(define (make-id-table-hash-code identifier->symbol)
(lambda (d hash-code)
(+ (hash-code (id-table-phase d))
(for/sum (((k v) (in-dict d)))
(* (hash-code (identifier->symbol k)) (hash-code v))))))
(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 (make-id-table-equal? idtbl-count idtbl-ref)
(lambda (left right equal?)
;; gen:equal+hash guarantees that left, right are same kind of hash
(and (equal? (id-table-phase left) (id-table-phase right))
(equal? (idtbl-count left) (idtbl-count right))
(let/ec k
(for*/and ([l-alist (in-hash-values (id-table-hash left))]
[entry (in-list l-alist)])
(equal? (idtbl-ref right (car entry) (lambda () (k #f))) (cdr entry)))))))
(define-values (prop:id-table-impersonator
id-table-impersonator?
@ -34,7 +42,24 @@
(vector-ref (id-table-impersonator-value d) i)))))
(apply values (build-list 5 extractor))))
(define (chaperone-mutable-id-table d ref set! remove! key . args)
(apply chaperone-struct d
;; FIXME: chaperone-struct currently demands at least one orig-proc+redirect-proc pair
id-table-phase (lambda (d p) p)
prop:id-table-impersonator (vector d ref set! remove! key)
args))
(define (chaperone-immutable-id-table d wrap-key wrap-value . args)
(apply chaperone-struct d
id-table-hash
(let ([hash (for/hasheq ([(sym alist) (id-table-hash d)])
(values sym
(for/list ([entry (in-list alist)])
(cons (wrap-key (car entry)) (wrap-value (cdr entry))))))])
(lambda (d v) hash))
args))
;; ========
(define (make-id-table/constructor who init-dict phase make identifier->symbol identifier=?)
(let ([t (make (make-hasheq) phase)])
@ -51,25 +76,27 @@
(raise-type-error who "dictionary with identifier keys" init-dict))
(id-table-set/constructor who t k v make identifier->symbol identifier=?)))
;; ========
(define (id-table-ref who d id default identifier->symbol identifier=?)
(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])))))))
(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=?)
(let loop ((d d) (id id) (v v))
@ -83,7 +110,6 @@
[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 loop ((d d) (id id))
(if (id-table-impersonator? d)
@ -117,8 +143,8 @@
phase)))
(define (id-table-count d)
(apply + (hash-map (id-table-hash d) (lambda (k v) (length v)))))
(for/sum ([(k v) (in-hash (id-table-hash d))])
(length v)))
(define-struct id-table-iter (d a br b))
;; where d is an id-table
@ -229,6 +255,7 @@ Notes (FIXME?):
(define not-given (gensym 'not-given))
;; ========
(begin-for-syntax
(define (replace old new template)
(datum->syntax new
@ -262,11 +289,11 @@ Notes (FIXME?):
idtbl-iterate-first idtbl-iterate-next
idtbl-iterate-key idtbl-iterate-value
idtbl-map idtbl-for-each
idtbl-mutable-methods idtbl-immutable-methods
chaperone-mutable-idtbl chaperone-immutable-idtbl))
idtbl-mutable-methods idtbl-immutable-methods))
#'(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
@ -277,27 +304,6 @@ Notes (FIXME?):
(make-immutable-id-table/constructor 'make-immutable-idtbl init-dict phase immutable-idtbl
identifier->symbol identifier=?))
(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=?))
(define (idtbl-set! d id v)
@ -328,14 +334,6 @@ Notes (FIXME?):
(define (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)))
(values sym
(for/list (((key value) (in-dict alist)))
(cons (wrap-key key) (wrap-value value)))))
(id-table-phase d)))
(define idtbl-mutable-methods
(vector-immutable idtbl-ref
idtbl-set!
@ -360,22 +358,20 @@ 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:equal+hash (list idtbl-equal? id-table-hash-code id-table-hash-code))
#:property prop:equal+hash
(let ([hash-code (make-id-table-hash-code identifier->symbol)]
[eql (make-id-table-equal? idtbl-count idtbl-ref)])
(list eql hash-code hash-code)))
(struct immutable-idtbl idtbl ()
#:property prop:dict idtbl-immutable-methods
#:property prop:equal+hash (list idtbl-equal? id-table-hash-code id-table-hash-code))
#:property prop:equal+hash
(let ([hash-code (make-id-table-hash-code identifier->symbol)]
[eql (make-id-table-equal? idtbl-count idtbl-ref)])
(list eql hash-code hash-code)))
(provide make-idtbl
make-immutable-idtbl
@ -396,8 +392,6 @@ Notes (FIXME?):
idtbl-for-each
;; just for use/extension by syntax/id-table
chaperone-mutable-idtbl
chaperone-immutable-idtbl
idtbl-set/constructor
idtbl-remove/constructor
idtbl-mutable-methods
@ -420,4 +414,6 @@ Notes (FIXME?):
free-identifier->symbol
free-identifier=?)
(provide id-table-iter?)
(provide id-table-iter?
chaperone-mutable-id-table
chaperone-immutable-id-table)

View File

@ -154,11 +154,15 @@ identifier table (free or bound, mutable or immutable), @racket[#f]
otherwise.
}
@defproc[(free-id-table/c [val contract?]
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care])
@defproc[(free-id-table/c [key-ctc flat-contract?]
[val-ctc contract?]
[#:immutable immutable? (or/c #t #f 'dont-care) 'dont-care])
contract?]{
Like @racket[hash/c], but more limited. It only supports contracts on the values in the identifier table.
Like @racket[hash/c], but for free-identifier tables. If
@racket[immutable?] is @racket[#t], the contract accepts only
immutable identifier tables; if @racket[immutable?] is @racket[#f],
the contract accepts only mutable identifier tables.
}
@;{----------}

View File

@ -298,8 +298,9 @@
(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))
;; --- ryanc: I don't think these should be checked lazily.
;; (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