Rewrite tables.ss in terms of new functional maps.

Improve error messages with contract errors.

svn: r9228
This commit is contained in:
Sam Tobin-Hochstadt 2008-04-09 23:29:29 +00:00
parent 13b7f8c506
commit 589850b998
2 changed files with 19 additions and 33 deletions

View File

@ -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))

View File

@ -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)