syntax/id-table: simplify use of chaperones
This commit is contained in:
Ryan Culpepper
parent
3ccc93590a
commit
70a2ced71a
|
|
@ -64,11 +64,12 @@
|
|||
(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 (make-id-table/c idtbl/c-symbol
|
||||
idtbl?
|
||||
mutable-idtbl?
|
||||
immutable-idtbl?
|
||||
immutable-idtbl)
|
||||
|
||||
(define (id-table/c-name ctc)
|
||||
(apply build-compound-type-name
|
||||
idtbl/c-symbol
|
||||
|
|
@ -136,23 +137,50 @@
|
|||
(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)))))
|
||||
neg-dom-proj
|
||||
pos-dom-proj
|
||||
neg-rng-proj
|
||||
pos-rng-proj
|
||||
impersonator-prop:contracted ctc)))))
|
||||
|
||||
(values id-table/c-name
|
||||
id-table/c-first-order
|
||||
check-id-table/c
|
||||
fo-projection
|
||||
ho-projection))
|
||||
(struct flat-id-table/c base-id-table/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:name id-table/c-name
|
||||
#:first-order id-table/c-first-order
|
||||
#:projection fo-projection))
|
||||
|
||||
(struct chaperone-id-table/c base-id-table/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:name id-table/c-name
|
||||
#:first-order id-table/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
;; Note: impersonator contracts not currently supported.
|
||||
(struct impersonator-id-table/c base-id-table/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name id-table/c-name
|
||||
#:first-order id-table/c-first-order
|
||||
#:projection ho-projection))
|
||||
|
||||
(define (id-table/c key/c value/c #:immutable [immutable 'dont-care])
|
||||
(define key/ctc (coerce-contract idtbl/c-symbol key/c))
|
||||
(define value/ctc (coerce-contract idtbl/c-symbol value/c))
|
||||
(cond [(and (eq? immutable #t)
|
||||
(flat-contract? key/ctc)
|
||||
(flat-contract? value/ctc))
|
||||
(flat-id-table/c key/ctc value/ctc immutable)]
|
||||
[(chaperone-contract? value/ctc)
|
||||
(chaperone-id-table/c key/ctc value/ctc immutable)]
|
||||
[else
|
||||
(impersonator-id-table/c key/ctc value/ctc immutable)]))
|
||||
|
||||
(procedure-rename id-table/c idtbl/c-symbol))
|
||||
|
||||
;; ========
|
||||
|
||||
|
|
@ -174,8 +202,7 @@
|
|||
idtbl-iterate-key idtbl-iterate-value
|
||||
idtbl-map idtbl-for-each
|
||||
idtbl-mutable-methods idtbl-immutable-methods
|
||||
idtbl/c
|
||||
chaperone-mutable-idtbl))
|
||||
idtbl/c))
|
||||
#'(begin
|
||||
|
||||
;; Struct defs at end, so that dict methods can refer to earlier procs
|
||||
|
|
@ -225,52 +252,10 @@
|
|||
(list idtbl-immutable-methods
|
||||
dict-contract-methods))
|
||||
|
||||
(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)]))
|
||||
(define idtbl/c
|
||||
(make-id-table/c 'idtbl/c
|
||||
idtbl? mutable-idtbl? immutable-idtbl?
|
||||
immutable-idtbl))
|
||||
|
||||
(provide/contract
|
||||
[make-idtbl
|
||||
|
|
@ -308,7 +293,7 @@
|
|||
[idtbl-for-each
|
||||
(-> idtbl? (-> identifier? any/c any) any)]
|
||||
[idtbl/c
|
||||
(->* (flat-contract? contract?)
|
||||
(->* (flat-contract? chaperone-contract?)
|
||||
(#:immutable (or/c 'dont-care #t #f))
|
||||
contract?)])))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -27,26 +27,20 @@
|
|||
[entry (in-list l-alist)])
|
||||
(equal? (idtbl-ref right (car entry) (lambda () (k #f))) (cdr entry)))))))
|
||||
|
||||
#|
|
||||
prop:id-table-impersonator : (vector wrapped-id-table key-in key-out value-in value-out)
|
||||
The {key,value}-{in-out} functions should all return a chaperone of their argument.
|
||||
|#
|
||||
(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 (chaperone-mutable-id-table d ref set! remove! key . args)
|
||||
(define (chaperone-mutable-id-table d key-in key-out value-in value-out . 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)
|
||||
prop:id-table-impersonator (vector d key-in key-out value-in value-out)
|
||||
args))
|
||||
|
||||
(define (chaperone-immutable-id-table d wrap-key wrap-value . args)
|
||||
|
|
@ -79,31 +73,29 @@
|
|||
;; ========
|
||||
|
||||
(define (id-table-ref who d id default identifier->symbol identifier=?)
|
||||
(let loop ((d d) (id id) (return values))
|
||||
(let do-ref ([d d] [id id] [escape #f])
|
||||
(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-values ([(wrapped key-in key-out value-in value-out)
|
||||
(vector->values (id-table-impersonator-value d))])
|
||||
(let/ec k
|
||||
(value-out (do-ref wrapped (key-in id) (or escape k)))))
|
||||
(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)])
|
||||
(let* ([sym (identifier->symbol id phase)]
|
||||
[l (hash-ref (id-table-hash d) sym null)]
|
||||
[i (for/first ([i (in-list l)] #:when (identifier=? (car i) id phase)) i)])
|
||||
(if i
|
||||
(return (cdr i))
|
||||
(cdr i)
|
||||
(cond [(eq? default not-given)
|
||||
(error who "no mapping for ~e" id)]
|
||||
[(procedure? default) (default)]
|
||||
[else default])))))))
|
||||
[(procedure? default) ((or escape values) (default))]
|
||||
[else ((or escape values) default)])))))))
|
||||
|
||||
(define (id-table-set! who d id v identifier->symbol identifier=?)
|
||||
(let loop ((d d) (id id) (v v))
|
||||
(let do-set! ([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-values ([(wrapped key-in key-out value-in value-out)
|
||||
(vector->values (id-table-impersonator-value d))])
|
||||
(do-set! wrapped (key-in id) (value-in v)))
|
||||
(let* ([phase (id-table-phase d)]
|
||||
[sym (identifier->symbol id phase)]
|
||||
[l (hash-ref (id-table-hash d) sym null)]
|
||||
|
|
@ -111,10 +103,11 @@
|
|||
(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))
|
||||
(let do-remove! ([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-values ([(wrapped key-in key-out value-in value-out)
|
||||
(vector->values (id-table-impersonator-value d))])
|
||||
(do-remove! wrapped (key-in id)))
|
||||
(let* ([phase (id-table-phase d)]
|
||||
[sym (identifier->symbol id phase)]
|
||||
[l (hash-ref (id-table-hash d) sym null)]
|
||||
|
|
@ -182,18 +175,22 @@ Notes (FIXME?):
|
|||
|
||||
(define (id-table-iterate-key who d pos)
|
||||
(if (id-table-impersonator? d)
|
||||
(let ((wrapper (id-table-imp-key-wrapper d)))
|
||||
(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))))
|
||||
(let-values ([(wrapped key-in key-out value-in value-out)
|
||||
(vector->values (id-table-impersonator-value d))])
|
||||
(key-out (id-table-iterate-key who wrapped 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 identifier->symbol identifier=?)
|
||||
(if (id-table-impersonator? d)
|
||||
(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))))
|
||||
(let do-iterate-value ([d d])
|
||||
(if (id-table-impersonator? d)
|
||||
(let-values ([(wrapped key-in key-out value-in value-out)
|
||||
(vector->values (id-table-impersonator-value d))])
|
||||
(value-out (do-iterate-value wrapped)))
|
||||
(let-values ([(h a br b) (rebase-iter who d pos)])
|
||||
(cdar b)))))
|
||||
|
||||
(define (rebase-iter who d pos)
|
||||
(unless (chaperone-of? (id-table-iter-d pos) d)
|
||||
|
|
@ -415,5 +412,6 @@ Notes (FIXME?):
|
|||
free-identifier=?)
|
||||
|
||||
(provide id-table-iter?
|
||||
;; just for use by syntax/id-table
|
||||
chaperone-mutable-id-table
|
||||
chaperone-immutable-id-table)
|
||||
|
|
|
|||
|
|
@ -155,7 +155,7 @@ otherwise.
|
|||
}
|
||||
|
||||
@defproc[(free-id-table/c [key-ctc flat-contract?]
|
||||
[val-ctc contract?]
|
||||
[val-ctc chaperone-contract?]
|
||||
[#:immutable immutable? (or/c #t #f 'dont-care) 'dont-care])
|
||||
contract?]{
|
||||
|
||||
|
|
@ -214,10 +214,6 @@ etc) can be used on bound-identifier tables.
|
|||
void?]
|
||||
@defproc[(bound-id-table-count [table bound-id-table?])
|
||||
exact-nonnegative-integer?]
|
||||
@defproc[(bound-id-table/c [val contract?]
|
||||
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care])
|
||||
contract?]
|
||||
@;{
|
||||
@defproc[(bound-id-table-iterate-first [table bound-id-table?])
|
||||
id-table-position?]
|
||||
@defproc[(bound-id-table-iterate-next [table bound-id-table?]
|
||||
|
|
@ -229,7 +225,11 @@ etc) can be used on bound-identifier tables.
|
|||
@defproc[(bound-id-table-iterate-value [table bound-id-table?]
|
||||
[position id-table-position?])
|
||||
identifier?]
|
||||
}]]{
|
||||
@defproc[(bound-id-table/c [key-ctc flat-contract?]
|
||||
[val-ctc chaperone-contract?]
|
||||
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care])
|
||||
contract?]
|
||||
]]{
|
||||
|
||||
Like the procedures for free-identifier tables
|
||||
(@racket[make-free-id-table], @racket[free-id-table-ref], etc), but
|
||||
|
|
|
|||
|
|
@ -253,8 +253,9 @@
|
|||
(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))
|
||||
;; --- ryanc: chaperone contracts only for now
|
||||
;; (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 ()
|
||||
|
||||
|
|
@ -295,19 +296,11 @@
|
|||
(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))
|
||||
;; --- 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
|
||||
;(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)))
|
||||
(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))
|
||||
|
||||
(define (short-identifier? id)
|
||||
(and (identifier? id) (equal? 1 (string-length (symbol->string (syntax-e id))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user