Add idtbl-chaperone and implement contracts on top of that.

collects/syntax/id-table.rkt

@@ -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)
+             (define (idtbl/c key/c value/c #:immutable (immutable 'dont-care))
-               (struct/c mutable-idtbl
+               (define key/ctc (coerce-contract 'idtbl/c key/c))
-                         (hash/c any/c
+               (define value/ctc (coerce-contract 'idtbl/c value/c))
-                                 (listof (cons/c any/c value/c))
+               (cond
-                                 #:immutable #f)
+                ((and (eq? immutable #t)
-                         any/c))
+                      (flat-contract? key/ctc)
-
+                      (flat-contract? value/ctc))
-             (define (immutable-idtbl/c value/c)
+                 (flat-idtbl/c key/ctc value/ctc immutable))
-               (struct/c immutable-idtbl
+                ((chaperone-contract? value/ctc)
-                         (hash/c any/c
+                 (chaperone-idtbl/c key/ctc value/ctc immutable))
-                                 (listof (cons/c any/c value/c))
+                (else
-                                 #:immutable #t)
+                 (impersonator-idtbl/c key/ctc value/ctc immutable))))
-                         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))))
-               
 
              (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?)]))))]))
 

collects/syntax/private/id-table.rkt

@@ -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)])
+  (if (id-table-impersonator? d)
-    (let ([i (for/first ([i (in-list (hash-ref (id-table-hash d)
+       (let-values (((new-id return-wrapper)
-                                               (identifier->symbol id phase)
+                     ((id-table-imp-ref-wrapper d) d id)))
-                                               null))]
+         (return-wrapper
-                         #:when (identifier=? (car i) id phase))
+           (id-table-ref (id-table-imp-wrapped d) new-id default)))
-               i)])
+       (let ([phase (id-table-phase d)])
-      (if i
+         (let ([i (for/first ([i (in-list (hash-ref (id-table-hash d)
-          (cdr i)
+                                                    (identifier->symbol id phase)
-          (cond [(eq? default not-given)
+                                                    null))]
-                 (error who "no mapping for ~e" id)]
+                              #:when (identifier=? (car i) id phase))
-                [(procedure? default) (default)]
+                    i)])
-                [else default])))))
+           (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)]
+  (if (id-table-impersonator? d)
-         [sym (identifier->symbol id phase)]
+      (let-values (((new-id new-v)
-         [l (hash-ref (id-table-hash d) sym null)]
+                    ((id-table-imp-set!-wrapper d) d id v)))
-         [new-l (alist-set identifier=? phase l id v)])
+        (id-table-set! (id-table-imp-wrapped d) new-id new-v))
-    (hash-set! (id-table-hash d) sym new-l)))
+      (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)]
+  (if (id-table-impersonator? d)
-         [sym (identifier->symbol id phase)]
+      (let ((new-id ((id-table-imp-remove!-wrapper d) d id)))
-         [l (hash-ref (id-table-hash d) sym null)]
+        (id-table-remove! (id-table-imp-wrapped d) new-id))
-         [newl (alist-remove identifier=? phase l id)])
+      (let* ([phase (id-table-phase d)]
-    (if (pair? newl)
+             [sym (identifier->symbol id phase)]
-        (hash-set! (id-table-hash d) sym newl)
+             [l (hash-ref (id-table-hash d) sym null)]
-        (hash-remove! (id-table-hash d) sym))))
+             [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)])
+  (if (id-table-impersonator? d)
-    (caar b)))
+      (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)])
+ (if (id-table-impersonator? d)
-    (cdar b)))
+     (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