From 589850b99828dcdeabe158f7bbb96e3eb57cc62f Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Wed, 9 Apr 2008 23:29:29 +0000
Subject: [PATCH] Rewrite tables.ss in terms of new functional maps. Improve
 error messages with contract errors.

svn: r9228
---
 collects/typed-scheme/private/tables.ss       | 45 +++++++------------
 .../typed-scheme/private/type-contract.ss     |  7 ++-
 2 files changed, 19 insertions(+), 33 deletions(-)

diff --git a/collects/typed-scheme/private/tables.ss b/collects/typed-scheme/private/tables.ss
index 1437ced3ac..41842a851c 100644
--- a/collects/typed-scheme/private/tables.ss
+++ b/collects/typed-scheme/private/tables.ss
@@ -1,40 +1,27 @@
 #lang scheme/base
 
-(require mzlib/plt-match)
-
 (provide (all-defined-out))
 
-;; a table is represented by an association list, (cons key value)
-
 ;; alist->eq : alist -> table
-(define (alist->eq l) l)
+(define (alist->eq l) 
+  (for/hasheq ([e l])
+    (values (car e) (cdr e))))
 
 ;; to-sexp : table -> Listof(List k v)
-(define (to-sexp t)
-  (map (match-lambda [(cons k v) (list k v)]) t))
+(define (to-sexp t) (hash-map list t))
 
-;; union/value : table(k,v) table(k,v) (v v -> v) -> table(k,v)
-(define (union/value t1 t2 f)
-  (define ks1 (map car t1))
-  (define ks2 (map car t2))
-  ;; everything but the common ones
-  (define t1* (filter (match-lambda [(cons k v) (not (memq k ks2))]) t1))
-  (define t2* (filter (match-lambda [(cons k v) (not (memq k ks1))]) t2))
-  (define pre-result (append t1* t2*))
-  ;; the common ones
-  (define *t1 (filter (match-lambda [(cons k v) (memq k ks2)]) t1))
-  (define *t2 (filter (match-lambda [(cons k v) (memq k ks1)]) t2))
-  (define merged (map (match-lambda [(cons k v1)
-                                     (let ([v2 (cdr (assq k *t2))])
-                                       (cons k (f v1 v2)))])
-                      *t1))
-  (append pre-result merged))
+;; union/value : table(k,v) table(k,v) [(v v -> v)] -> table(k,v)
+(define (union/value t1 t2 [f (lambda (x y) x)])
+  (for/fold ([new-table t1])
+	    ([(k v) t2])
+	    (cond [(hash-ref new-table k #f)
+		   => 
+		   (lambda (v*) (hash-set new-table k (f v* v)))]
+		  [else
+		   (hash-set new-table k v)])))
 
-(define (make-eq) null)
+(define make-eq make-immutable-hasheq)
 
-(define (lookup k t) 
-  (cond [(assq k t) => cdr]
-        [else #f]))
+(define (lookup k t) (hash-ref t k #f))
 
-(define (insert k v t)
-  (cons (cons k v) t))
+(define (insert k v t) (hash-set t k v))
\ No newline at end of file
diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss
index 8a7af132e0..87d3500440 100644
--- a/collects/typed-scheme/private/type-contract.ss
+++ b/collects/typed-scheme/private/type-contract.ss
@@ -97,10 +97,9 @@
                (if rst
                    #'(dom* ...  #:rest (listof rst*) . -> . rng*)
                    #'(dom* ...  . -> . rng*))))
-           (let ([l (map f arrs)])
-             (if (and (pair? l) (null? (cdr l)))
-                 #`(case-> #,@l)
-                 #`(case-> #,@l))))]
+	   (match (map f arrs)
+	     [(list e) e]
+	     [l #`(case-> #,@l)]))]
         [(Vector: t)
          #`(vectorof #,(t->c t))]
         [(Pair: t1 t2)