From e4a3001af67f0d5246b6ee090c5ad04d33eac9fe Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Tue, 8 May 2012 21:32:54 -0400
Subject: [PATCH] Reimplement racket/dict using generics.

---
 collects/racket/dict.rkt         |   3 +-
 collects/racket/private/dict.rkt | 210 ++++++++++++++++---------------
 2 files changed, 112 insertions(+), 101 deletions(-)

diff --git a/collects/racket/dict.rkt b/collects/racket/dict.rkt
index 9147cd7e7d..39f2ed6634 100644
--- a/collects/racket/dict.rkt
+++ b/collects/racket/dict.rkt
@@ -217,7 +217,8 @@
   (->i ([d dict?])
        [_r (d) (listof (cons/c (dict-key-contract d) (dict-value-contract d)))])])
 
-(provide prop:dict
+(provide dict
+         prop:dict
 
          make-custom-hash
          make-immutable-custom-hash
diff --git a/collects/racket/private/dict.rkt b/collects/racket/private/dict.rkt
index acefeff2b6..8e45cce0a9 100644
--- a/collects/racket/private/dict.rkt
+++ b/collects/racket/private/dict.rkt
@@ -1,5 +1,19 @@
 #lang racket/base
-(require (for-syntax racket/base))
+
+(require generics
+         (for-syntax racket/base))
+
+(define-generics (dict prop:dict dict? dict-def-table)
+  (dict-ref  dict key [default])
+  (dict-set! dict key val)
+  (dict-set  dict key val)
+  (dict-remove! dict key)
+  (dict-remove  dict key)
+  (dict-count dict)
+  (dict-iterate-first dict)
+  (dict-iterate-next dict pos)
+  (dict-iterate-key dict pos)
+  (dict-iterate-value dict pos))
 
 (define (dict-property-guard v info)
   (check-dict-vector 'prop:dict "dictionary property" v)
@@ -90,9 +104,6 @@
     (apply format fmt args)
     (current-continuation-marks))))
 
-(define-values (prop:dict dict-struct? dict-struct-ref)
-  (make-struct-type-property 'dict dict-property-guard))
-
 (define (get-dict-ref v)
   (vector-ref v 0))
 (define (get-dict-set! v)
@@ -117,46 +128,46 @@
 (define (assoc? v) 
   (and (list? v) (andmap pair? v)))
 
-(define (dict? v)
+(define (d:dict? v)
   (or (hash? v)
       (vector? v)
       (assoc? v)
-      (dict-struct? v)))
+      (dict? v)))
 
 (define (dict-mutable? d)
-  (if (dict? d)
+  (if (d:dict? d)
       (or (and (or (hash? d)
                    (vector? d))
                (not (immutable? d)))
-          (and (dict-struct? d)
-               (get-dict-set! (dict-struct-ref d))
+          (and (dict? d)
+               (hash-ref (dict-def-table d) 'dict-set! #f)
                #t))
       (raise-type-error 'dict-mutable? "dict" d)))
 
 (define (dict-can-remove-keys? d)
-  (if (dict? d)
+  (if (d:dict? d)
       (or (hash? d)
           (assoc? d)
-          (and (dict-struct? d)
-               (or (get-dict-remove! (dict-struct-ref d))
-                   (get-dict-remove (dict-struct-ref d)))
+          (and (dict? d)
+               (or (hash-ref (dict-def-table d) 'dict-remove! #f)
+                   (hash-ref (dict-def-table d) 'dict-remove #f))
                #t))
       (raise-type-error 'dict-can-remove-keys? "dict" d)))
 
 (define (dict-can-functional-set? d)
-  (if (dict? d)
+  (if (d:dict? d)
       (or (and (hash? d) (immutable? d))
           (assoc? d)
-          (and (dict-struct? d)
-               (get-dict-set (dict-struct-ref d))
+          (and (dict? d)
+               (hash-ref (dict-def-table d) 'dict-set #f)
                #t))
       (raise-type-error 'dict-can-functional-set? "dict" d)))
 
 (define (dict-has-key? d k)
   (define not-there (gensym))
-  (not (eq? not-there (dict-ref d k not-there))))
+  (not (eq? not-there (d:dict-ref d k not-there))))
 
-(define dict-ref
+(define d:dict-ref
   (case-lambda
    [(d key)
     (cond
@@ -170,8 +181,7 @@
                                   (format "no value for key: ~e in: "
                                           key)
                                   d)))]
-     [(dict-struct? d)
-      ((get-dict-ref (dict-struct-ref d)) d key)]
+     [(dict? d) (dict-ref d key)]
      [else
       (raise-type-error 'dict-ref "dict" 0 d key)])]
    [(d key default)
@@ -190,30 +200,30 @@
             (if (procedure? default)
                 (default)
                 default)))]
-     [(dict-struct? d)
-      ((get-dict-ref (dict-struct-ref d)) d key default)]
+     [(dict? d)
+      (dict-ref d key default)]
      [else
       (raise-type-error 'dict-ref "dict" 0 d key default)])]))
 
 (define (dict-ref! d key new)
   (define not-there (gensym))
-  (define v (dict-ref d key not-there))
+  (define v (d:dict-ref d key not-there))
   (if (eq? not-there v)
       (let ([n (if (procedure? new) (new) new)])
-        (dict-set! d key n)
+        (d:dict-set! d key n)
         n)
       v))
 
-(define (dict-set! d key val)
+(define (d:dict-set! d key val)
   (cond
    [(hash? d) (hash-set! d key val)]
    [(vector? d) (vector-set! d key val)]
    [(assoc? d)
     (raise-type-error 'dict-set! "mutable dict" 0 d key val)]
-   [(dict-struct? d)
-    (let ([s! (get-dict-set! (dict-struct-ref d))])
+   [(dict? d)
+    (let ([s! (hash-ref (dict-def-table d) 'dict-set! #f)])
       (if s!
-          (s! d key val)
+          (dict-set! d key val)
           (raise-type-error 'dict-set! "mutable dict" 0 d key val)))]
    [else
     (raise-type-error 'dict-set! "dict" 0 d key val)]))
@@ -223,10 +233,10 @@
     (error 'dict-set*! "expected an even number of association elements, but received an odd number: ~e" pairs))
   (let loop ([pairs pairs])
     (unless (null? pairs)
-      (dict-set! d (car pairs) (cadr pairs))
+      (d:dict-set! d (car pairs) (cadr pairs))
       (loop (cddr pairs)))))
 
-(define (dict-set d key val)
+(define (d:dict-set d key val)
   (cond
    [(hash? d) (hash-set d key val)]
    [(vector? d)
@@ -240,10 +250,10 @@
           (if (equal? (car a) key) 
               (cons (cons key val) (cdr xd))
               (cons a (loop (cdr xd)))))]))]
-   [(dict-struct? d)
-    (let ([s (get-dict-set (dict-struct-ref d))])
+   [(dict? d)
+    (let ([s (hash-ref (dict-def-table d) 'dict-set #f)])
       (if s
-          (s d key val)
+          (dict-set d key val)
           (raise-type-error 'dict-set "functional-update dict" 0 d key val)))]
    [else
     (raise-type-error 'dict-set "dict" 0 d key val)]))
@@ -255,39 +265,39 @@
                [pairs pairs])
       (if (null? pairs)
           d
-          (loop (dict-set d (car pairs) (cadr pairs))
+          (loop (d:dict-set d (car pairs) (cadr pairs))
                 (cddr pairs)))))
 
 (define dict-update!
   (case-lambda
    [(d key xform)
-    (dict-set! d key (xform (dict-ref d key)))]
+    (d:dict-set! d key (xform (d:dict-ref d key)))]
    [(d key xform default)
-    (dict-set! d key (xform (dict-ref d key default)))]))
+    (d:dict-set! d key (xform (d:dict-ref d key default)))]))
 
 (define dict-update
   (case-lambda
    [(d key xform)
-    (dict-set d key (xform (dict-ref d key)))]
+    (d:dict-set d key (xform (d:dict-ref d key)))]
    [(d key xform default)
-    (dict-set d key (xform (dict-ref d key default)))]))
+    (d:dict-set d key (xform (d:dict-ref d key default)))]))
 
-(define (dict-remove! d key)
+(define (d:dict-remove! d key)
   (cond
    [(hash? d) (hash-remove! d key)]
    [(vector? d)
     (raise-type-error 'dict-remove! "dict with removeable keys" 0 d key)]
    [(assoc? d)
     (raise-type-error 'dict-remove! "mutable dict" 0 d key)]
-   [(dict-struct? d)
-    (let ([r! (get-dict-remove! (dict-struct-ref d))])
+   [(dict? d)
+    (let ([r! (hash-ref (dict-def-table d) 'dict-remove! #f)])
       (if r!
-          (r! d key)
+          (dict-remove! d key)
           (raise-type-error 'dict-remove! "mutable dict with removable keys" 0 d key)))]
    [else
     (raise-type-error 'dict-remove! "dict" 0 d key)]))
 
-(define (dict-remove d key)
+(define (d:dict-remove d key)
   (cond
    [(hash? d) (hash-remove d key)]
    [(vector? d)
@@ -301,37 +311,37 @@
           (if (equal? (car a) key) 
               (cdr xd)
               (cons a (loop (cdr xd)))))]))]
-   [(dict-struct? d)
-    (let ([s (get-dict-remove (dict-struct-ref d))])
+   [(dict? d)
+    (let ([s (hash-ref (dict-def-table d) 'dict-remove #f)])
       (if s
-          (s d key)
+          (dict-remove d key)
           (raise-type-error 'dict-remove "dict with functionally removeable keys" 0 d key)))]
    [else
     (raise-type-error 'dict-remove "dict" 0 d key)]))
 
-(define (dict-count d)
+(define (d:dict-count d)
   (cond
    [(hash? d) (hash-count d)]
    [(vector? d) (vector-length d)]
    [(assoc? d) (length d)]
-   [(dict-struct? d) ((get-dict-count (dict-struct-ref d)) d)]
+   [(dict? d) (dict-count d)]
    [else
     (raise-type-error 'dict-count "dict" d)]))
 
 (struct assoc-iter (head pos))
 
-(define (dict-iterate-first d)
+(define (d:dict-iterate-first d)
   (cond
    [(hash? d) (hash-iterate-first d)]
    [(vector? d) (if (zero? (vector-length d))
                     #f
                     0)]
    [(assoc? d) (if (null? d) #f (assoc-iter d d))]
-   [(dict-struct? d) ((get-dict-iterate-first (dict-struct-ref d)) d)]
+   [(dict? d) (dict-iterate-first d)]
    [else
     (raise-type-error 'dict-iterate-first "dict" d)]))
 
-(define (dict-iterate-next d i)
+(define (d:dict-iterate-next d i)
   (cond
    [(hash? d) (hash-iterate-next d i)]
    [(vector? d) (let ([len (vector-length d)])
@@ -353,7 +363,7 @@
       (if (null? pos)
           #f
           (assoc-iter d pos)))]
-   [(dict-struct? d) ((get-dict-iterate-next (dict-struct-ref d)) d i)]
+   [(dict? d) (dict-iterate-next d i)]
    [(assoc? d)
     (raise-mismatch-error 
      'dict-iterate-next
@@ -362,12 +372,12 @@
    [else
     (raise-type-error 'dict-iterate-next "dict" d)]))
 
-(define (dict-iterate-key d i)
+(define (d:dict-iterate-key d i)
   (cond
    [(hash? d) (hash-iterate-key d i)]
    [(vector? d) i]
    [(and (assoc-iter? i) (eq? d (assoc-iter-head i))) (caar (assoc-iter-pos i))]
-   [(dict-struct? d) ((get-dict-iterate-key (dict-struct-ref d)) d i)]
+   [(dict? d) (dict-iterate-key d i)]
    [(assoc? d)
     (raise-mismatch-error 
      'dict-iterate-key
@@ -376,12 +386,12 @@
    [else
     (raise-type-error 'dict-iterate-key "dict" d)]))
 
-(define (dict-iterate-value d i)
+(define (d:dict-iterate-value d i)
   (cond
    [(hash? d) (hash-iterate-value d i)]
    [(vector? d) (vector-ref d i)]
    [(and (assoc-iter? i) (eq? d (assoc-iter-head i))) (cdar (assoc-iter-pos i))]
-   [(dict-struct? d) ((get-dict-iterate-value (dict-struct-ref d)) d i)]
+   [(dict? d) (dict-iterate-value d i)]
    [(assoc? d)
     (raise-mismatch-error 
      'dict-iterate-value
@@ -398,35 +408,35 @@
        #'[(key-id val-id)
           (:do-in ([(d) dict-expr])
                   (void)
-                  ([i (dict-iterate-first d)])
+                  ([i (d:dict-iterate-first d)])
                   i
-                  ([key-id (dict-iterate-key d i)]
-                   [val-id (dict-iterate-value d i)])
+                  ([key-id (d:dict-iterate-key d i)]
+                   [val-id (d:dict-iterate-value d i)])
                   #t
                   #t
-                  ((dict-iterate-next d i)))]]
+                  ((d:dict-iterate-next d i)))]]
       [_ #f])))
 
 (define (in-dict d)
   (make-dict-sequence
    d
    (lambda (i)
-     (values (dict-iterate-key d i)
-             (dict-iterate-value d i)))
+     (values (d:dict-iterate-key d i)
+             (d:dict-iterate-value d i)))
    (lambda (k v) #t)
    (lambda (i k v) #t)))
 
 (define (in-dict-keys d)
   (make-dict-sequence
    d
-   (lambda (i) (dict-iterate-key d i))
+   (lambda (i) (d:dict-iterate-key d i))
    (lambda (k) #t)
    (lambda (i k) #t)))
 
 (define (in-dict-values d)
   (make-dict-sequence
    d
-   (lambda (i) (dict-iterate-value d i))
+   (lambda (i) (d:dict-iterate-value d i))
    (lambda (v) #t)
    (lambda (i v) #t)))
 
@@ -434,8 +444,8 @@
   (make-dict-sequence
    d
    (lambda (i)
-     (cons (dict-iterate-key d i)
-           (dict-iterate-value d i)))
+     (cons (d:dict-iterate-key d i)
+           (d:dict-iterate-value d i)))
    (lambda (p) #t)
    (lambda (i p) #t)))
 
@@ -443,8 +453,8 @@
   (make-do-sequence
    (lambda ()
      (values get
-             (lambda (i) (dict-iterate-next d i))
-             (dict-iterate-first d)
+             (lambda (i) (d:dict-iterate-next d i))
+             (d:dict-iterate-first d)
              (lambda (i) i)
              val-true
              val+pos-true))))
@@ -525,16 +535,15 @@
 
 (struct custom-hash (table make-box)
   #:property prop:dict
-  (vector custom-hash-ref
-          custom-hash-set!
-          #f
-          custom-hash-remove!
-          #f
-          custom-hash-count
-          custom-hash-iterate-first
-          custom-hash-iterate-next
-          custom-hash-iterate-key
-          custom-hash-iterate-value)
+  (define-methods dict
+    (define dict-ref custom-hash-ref)
+    (define dict-set! custom-hash-set!)
+    (define dict-remove! custom-hash-remove!)
+    (define dict-count custom-hash-count)
+    (define dict-iterate-first custom-hash-iterate-first)
+    (define dict-iterate-next custom-hash-iterate-next)
+    (define dict-iterate-key custom-hash-iterate-key)
+    (define dict-iterate-value custom-hash-iterate-value))
   #:property prop:equal+hash
   (list (lambda (a b recur)
           (and (recur (custom-hash-make-box a)
@@ -546,16 +555,15 @@
 
 (struct immutable-custom-hash custom-hash ()
   #:property prop:dict
-  (vector custom-hash-ref
-          #f
-          custom-hash-set
-          #f
-          custom-hash-remove
-          custom-hash-count
-          custom-hash-iterate-first
-          custom-hash-iterate-next
-          custom-hash-iterate-key
-          custom-hash-iterate-value))
+  (define-methods dict
+    (define dict-ref custom-hash-ref)
+    (define dict-set custom-hash-set)
+    (define dict-remove custom-hash-remove)
+    (define dict-count custom-hash-count)
+    (define dict-iterate-first custom-hash-iterate-first)
+    (define dict-iterate-next custom-hash-iterate-next)
+    (define dict-iterate-key custom-hash-iterate-key)
+    (define dict-iterate-value custom-hash-iterate-value)))
           
 (define-values (create-custom-hash 
                 create-immutable-custom-hash
@@ -605,27 +613,29 @@
 
 ;; --------------------
 
-(provide prop:dict
-         dict?
+(provide dict
+         prop:dict
+         (rename-out
+           [d:dict?              dict?]
+           [d:dict-ref           dict-ref]
+           [d:dict-set!          dict-set!]
+           [d:dict-set           dict-set]
+           [d:dict-remove!       dict-remove!]
+           [d:dict-remove        dict-remove]
+           [d:dict-count         dict-count]
+           [d:dict-iterate-first dict-iterate-first]
+           [d:dict-iterate-next  dict-iterate-next]
+           [d:dict-iterate-key   dict-iterate-key]
+           [d:dict-iterate-value dict-iterate-value])
          dict-mutable?
          dict-can-remove-keys?
          dict-can-functional-set?
          dict-has-key?
-         dict-ref
          dict-ref!
-         dict-set!
-         dict-set
          dict-set*!
          dict-set*
          dict-update!
          dict-update
-         dict-remove!
-         dict-remove
-         dict-count
-         dict-iterate-first
-         dict-iterate-next
-         dict-iterate-key
-         dict-iterate-value
          dict-map
          dict-for-each
          dict-keys