-
Notifications
You must be signed in to change notification settings - Fork 2
/
hash-contract.rkt
40 lines (32 loc) · 1.16 KB
/
hash-contract.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#lang racket
(provide
(contract-out
[hash-carrier/c (-> list? contract?)]))
;; -----------------------------------------------------------------------------
(define (hash-carrier/c domain [range any/c])
(define unique (gensym))
(~a "hash carrier of " domain)
(and/c
(hash/c any/c range)
(λ (h)
(for/and ([d domain])
(unless (not (eq? (hash-ref h d unique) unique))
(fprintf (current-error-port) "missing key: ~e\n" d)
#false)))))
;; -----------------------------------------------------------------------------
(module+ test
(require rackunit)
(define server-options '[a b c])
(define/contract (f h)
(-> (hash-carrier/c server-options) 0)
0)
(check-equal? (f (hash 'a 0 'b 1 'c #false)) 0 "exact")
(check-equal? (f (hash 'a 0 'b 1 'c 1 'd 2)) 0 "too much")
(check-exn exn:fail:contract?
(λ ()
(parameterize ([current-error-port (open-output-string)])
(f (hash 'a 0 'b 1 'd 1)))) "too little")
(define/contract (g h)
(-> (hash-carrier/c server-options boolean?) 0)
0)
(check-exn exn:fail:contract? (λ () (g (hash 'a 0 'b 1 'c 1 'd 2))) "range"))