suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve the error messages for flat hash/dc contracts

Browse Source
This commit is contained in:
Robby Findler 2020-11-03 09:47:18 -06:00
parent 6e917a610e
commit daf142c1c0
2 changed files with 73 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
pkgs/racket-test/tests/racket/contract/hash.rkt
View File

@ -288,7 +288,54 @@
'(contract (hash/dc [d integer?] [r (d) string?] #:immutable #t)
(hash 3 "x")
'pos 'neg))
(test/pos-blame
'hash/dc-flat1
'(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
1
'pos 'neg))
(test/pos-blame
'hash/dc-flat2
'(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
(hash #f #f)
'pos 'neg))
(test/pos-blame
'hash/dc-flat3
'(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
(hash 0 #f)
'pos 'neg))
(test/pos-blame
'hash/dc-flat4
'(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
(hash 1 "x")
'pos 'neg))
(test/pos-blame
'hash/dc-flat5
'(contract (hash/dc [d integer?] [r (d) (if (even? d) string? symbol?)] #:kind 'flat)
(hash 3 "x")
'pos 'neg))
(test/pos-blame
'hash/dc-flat6
'(contract (hash/dc [d integer?] [r (d) string?] #:immutable #f #:kind 'flat)
(hash 3 "x")
'pos 'neg))
(test/spec-passed
'hash/dc-flat7
'(contract (hash/dc [d integer?] [r (d) string?] #:immutable #t #:kind 'flat)
(hash 3 "x")
'pos 'neg))
(test/spec-passed/result
'hash/dc-flat8
'(regexp-match?
#rx"\n *in: the values of\n"
(with-handlers ([exn:fail? exn-message])
(contract (hash/dc [d integer?] [r (d) string?] #:immutable #t #:kind 'flat)
(hash 3 'not-a-string)
'pos 'neg)))
#t)
(test/no-error
'(let ([v (chaperone-hash (make-immutable-hash (list (cons 1 2)))
(λ (hash k) (values k (λ (h k v) v)))

36
racket/collects/racket/contract/private/hash.rkt
View File

@ -423,17 +423,32 @@
(base-hash/dc-here ctc))))
(define pos-value-blame (blame-add-value-context blame #f))
(define neg-value-blame (blame-add-value-context blame #t))
(λ (val neg-party)
(cond
[(check-hash/c dom-ctc immutable flat? val blame neg-party) val]
[else
(cond
[chaperone-or-impersonate-hash
(λ (val neg-party)
(cond
[(check-hash/c dom-ctc immutable flat? val blame neg-party) val]
[else
(define ((mk-rng-proj x-value-blame) key)
((get/build-late-neg-projection (dep-rng-proc (indy-dom-proj key neg-party)))
x-value-blame))
(handle-the-hash val neg-party
pos-dom-proj neg-dom-proj
(mk-rng-proj pos-value-blame) (mk-rng-proj neg-value-blame)
chaperone-or-impersonate-hash ctc blame)]))]
[else
(λ (val neg-party)
(check-hash/c dom-ctc immutable flat? val blame neg-party)
(define ((mk-rng-proj x-value-blame) key)
((get/build-late-neg-projection (dep-rng-proc (indy-dom-proj key neg-party)))
x-value-blame))
(handle-the-hash val neg-party
pos-dom-proj neg-dom-proj
(mk-rng-proj pos-value-blame) (mk-rng-proj neg-value-blame)
chaperone-or-impersonate-hash ctc blame)]))))
(define mk-pos-rng-proj (mk-rng-proj pos-value-blame))
(define mk-neg-rng-proj (mk-rng-proj neg-value-blame))
(with-contract-continuation-mark (cons blame neg-party)
(for ([(k v) (in-hash val)])
(pos-dom-proj k neg-party)
((mk-pos-rng-proj k) v neg-party)))
val)])))
(struct base-hash/dc (dom dep-rng here name-info immutable))
(struct flat-hash/dc base-hash/dc ()
@ -444,7 +459,8 @@
#:name hash/dc-name
#:first-order hash/dc-first-order
#:equivalent hash/dc-equivalent
#:stronger hash/dc-stronger))
#:stronger hash/dc-stronger
#:late-neg-projection (hash/dc-late-neg-projection #f)))
(struct chaperone-hash/dc base-hash/dc ()
#:property prop:custom-write custom-write-property-proc
@ -522,7 +538,7 @@
(loop #'more))]
[(x . y)
(raise-syntax-error 'hash/dc
"expected either the keyword #:flat? or #:immutable"
"expected either the keyword #:kind or #:immutable"
stx
#'x)]))
#`(build-hash/dc dom-ctc-expr