From 1ec2bc0ea47791258d4aefebb0dfae5104456703 Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Wed, 9 May 2012 15:31:17 -0400
Subject: [PATCH] Add tests for generics.

---
 collects/tests/generics/alist.rkt       | 32 +++++++++
 collects/tests/generics/custom-hash.rkt | 95 +++++++++++++++++++++++++
 collects/tests/generics/from-docs.rkt   | 59 +++++++++++++++
 collects/tests/generics/tests.rkt       |  5 ++
 4 files changed, 191 insertions(+)
 create mode 100644 collects/tests/generics/alist.rkt
 create mode 100644 collects/tests/generics/custom-hash.rkt
 create mode 100644 collects/tests/generics/from-docs.rkt
 create mode 100644 collects/tests/generics/tests.rkt

diff --git a/collects/tests/generics/alist.rkt b/collects/tests/generics/alist.rkt
new file mode 100644
index 0000000000..be621b465d
--- /dev/null
+++ b/collects/tests/generics/alist.rkt
@@ -0,0 +1,32 @@
+#lang racket/base
+
+(require generics racket/dict racket/list)
+
+(define-struct alist (v)
+  #:property prop:dict
+  (methods dict
+    (define (dict-ref dict key
+                      [default (lambda () (error "key not found" key))])
+      (cond [(assoc key (alist-v dict)) => cdr]
+            [else (if (procedure? default) (default) default)]))
+    (define (dict-set dict key val)
+      (alist (cons (cons key val) (alist-v dict))))
+    (define (dict-remove dict key)
+      (define al (alist-v dict))
+      (remove* (assoc key al) al))
+    (define (dict-count dict #:default [x #f])
+      (or x
+          (length (remove-duplicates (alist-v dict) #:key car))))))
+
+
+(module+ test
+  (require rackunit)
+
+  (define d1 '((1 . a) (2 . b)))
+
+  (check-true (dict? d1))
+  (check-eq? (dict-ref d1 1) 'a)
+  (check-equal? (dict-count (dict-remove d1 2)) 1)
+  (check-false (dict-mutable? d1))
+  (check-true (dict-can-remove-keys? d1))
+  (check-true (dict-can-functional-set? d1)))
diff --git a/collects/tests/generics/custom-hash.rkt b/collects/tests/generics/custom-hash.rkt
new file mode 100644
index 0000000000..3748f862ec
--- /dev/null
+++ b/collects/tests/generics/custom-hash.rkt
@@ -0,0 +1,95 @@
+#lang racket/base
+
+(require generics
+         (only-in racket/dict
+                  dict prop:dict
+                  dict?
+                  dict-ref
+                  dict-set!
+                  dict-set
+                  dict-remove!
+                  dict-remove
+                  dict-count)
+         (only-in racket/list remove-duplicates))
+
+(struct hash-box (key))
+
+(define custom-hash-ref
+  (case-lambda
+      [(d k) (hash-ref (custom-hash-table d)
+                       ((custom-hash-make-box d) k)
+                       (lambda ()
+                         (raise-mismatch-error
+                          'dict-ref
+                          "no value found for key: "
+                          k)))]
+    [(d k fail) (hash-ref (custom-hash-table d)
+                          ((custom-hash-make-box d) k)
+                          fail)]))
+
+(define (custom-hash-set! d k v)
+  (hash-set! (custom-hash-table d)
+             ((custom-hash-make-box d) k)
+             v))
+
+(define (custom-hash-remove! d k)
+  (hash-remove! (custom-hash-table d)
+                ((custom-hash-make-box d) k)))
+
+(define (custom-hash-count d)
+  (hash-count (custom-hash-table d)))
+
+
+(struct custom-hash (table make-box)
+  #:property prop:dict
+  (methods dict
+    (define dict-ref custom-hash-ref)
+    (define dict-set! custom-hash-set!)
+    (define (dict-set dict key val)
+      (error "no functional update"))
+    (define dict-remove! custom-hash-remove!)
+    (define (dict-remove dict key)
+      (error "no functional update"))
+    (define dict-count custom-hash-count))
+  #:property prop:equal+hash
+  (list (lambda (a b recur)
+          (and (recur (custom-hash-make-box a)
+                      (custom-hash-make-box b))
+               (recur (custom-hash-table a)
+                      (custom-hash-table b))))
+        (lambda (a recur) (recur (custom-hash-table a)))
+        (lambda (a recur) (recur (custom-hash-table a)))))
+
+
+(define (make-custom-hash =? hash [hash2 (lambda (v) 10001)])
+  (unless (and (procedure? =?)
+               (procedure-arity-includes? =? 2))
+    (raise-type-error 'make-custom-hash "procedure (arity 2)" =?))
+  (unless (and (procedure? hash)
+               (procedure-arity-includes? hash 1))
+    (raise-type-error 'make-custom-hash "procedure (arity 1)" hash))
+  (unless (and (procedure? hash2)
+               (procedure-arity-includes? hash2 1))
+    (raise-type-error 'make-custom-hash "procedure (arity 1)" hash2))
+  (let ()
+    (struct box hash-box ()
+            #:property prop:equal+hash
+            (list
+             (lambda (a b recur) (=? (hash-box-key a) (hash-box-key b)))
+             (lambda (v recur)   (hash (hash-box-key v)))
+             (lambda (v recur)   (hash2 (hash-box-key v)))))
+    (custom-hash (make-hash) box)))
+
+
+(module+ test
+  (require rackunit)
+
+  ;; from the docs
+  (define h (make-custom-hash (lambda (a b)
+                                (string=? (format "~a" a)
+                                          (format "~a" b)))
+                              (lambda (a)
+                                (equal-hash-code
+                                 (format "~a" a)))))
+  (dict-set! h 1 'one)
+  (check-eq? (dict-ref h "1") 'one))
diff --git a/collects/tests/generics/from-docs.rkt b/collects/tests/generics/from-docs.rkt
new file mode 100644
index 0000000000..a298bc9ef7
--- /dev/null
+++ b/collects/tests/generics/from-docs.rkt
@@ -0,0 +1,59 @@
+#lang racket/base
+
+(require generics racket/port)
+
+(define-generics (printable prop:printable printable?)
+  (gen-print printable [port])
+  (gen-port-print port printable)
+  (gen-print* printable [port] #:width width #:height [height]))
+
+(define-struct num (v)
+  #:property prop:printable
+  (methods printable
+    (define/generic super-print gen-print)
+    (define (gen-print n [port (current-output-port)])
+      (fprintf port "Num: ~a" (num-v n)))
+    (define (gen-port-print port n)
+      (super-print n port))
+    (define (gen-print* n [port (current-output-port)]
+                        #:width w #:height [h 0])
+      (fprintf port "Num (~ax~a): ~a" w h (num-v n)))))
+
+(define-struct bool (v)
+  #:property prop:printable
+  (methods printable
+    (define/generic super-print gen-print)
+    (define (gen-print b [port (current-output-port)])
+      (fprintf port "Bool: ~a"
+               (if (bool-v b) "Yes" "No")))
+    (define (gen-port-print port b)
+      (super-print b port))
+    (define (gen-print* b [port (current-output-port)]
+                        #:width w #:height [h 0])
+      (fprintf port "Bool (~ax~a): ~a" w h
+               (if (bool-v b) "Yes" "No")))))
+
+(module+ test
+  (require rackunit)
+
+  (define x (make-num 10))
+  (check-equal? (with-output-to-string (lambda () (gen-print x)))
+                "Num: 10")
+  (check-equal? (with-output-to-string
+                  (lambda () (gen-port-print (current-output-port)
+                                             x)))
+                "Num: 10")
+  (check-equal? (with-output-to-string
+                  (lambda () (gen-print* x #:width 100 #:height 90)))
+                "Num (100x90): 10")
+
+  (define y (make-bool #t))
+  (check-equal? (with-output-to-string (lambda () (gen-print y)))
+                "Bool: Yes")
+  (check-equal? (with-output-to-string
+                  (lambda () (gen-port-print (current-output-port)
+                                             y)))
+                "Bool: Yes")
+  (check-equal? (with-output-to-string
+                  (lambda () (gen-print* y #:width 100 #:height 90)))
+                "Bool (100x90): Yes"))
diff --git a/collects/tests/generics/tests.rkt b/collects/tests/generics/tests.rkt
new file mode 100644
index 0000000000..ee7349d732
--- /dev/null
+++ b/collects/tests/generics/tests.rkt
@@ -0,0 +1,5 @@
+#lang racket/base
+
+(require (submod "custom-hash.rkt" test)
+         (submod "alist.rkt" test)
+         (submod "from-docs.rkt" test))