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

adjust case-> so that the blame context information includes

Browse Source 
which case of the case-> happened
This commit is contained in:
Robby Findler 2013-04-16 17:40:09 -05:00
parent a46e4c71b6
commit c50005870f
2 changed files with 50 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/racket/contract/private/arrow.rkt
View File

@ -1540,7 +1540,7 @@ v4 todo:
[_ [_
(raise-syntax-error #f "expected ->" stx case)])) (raise-syntax-error #f "expected ->" stx case)]))
(define-for-syntax (parse-out-case stx case) (define-for-syntax (parse-out-case stx case n)
(let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)]) (let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)])
(with-syntax ([(dom-proj-x ...) (generate-temporaries doms)] (with-syntax ([(dom-proj-x ...) (generate-temporaries doms)]
[(rst-proj-x) (generate-temporaries '(rest-proj-x))] [(rst-proj-x) (generate-temporaries '(rest-proj-x))]
@ -1566,7 +1566,8 @@ v4 todo:
[args [args
(bad-number-of-results blame f (bad-number-of-results blame f
#,(length (syntax->list #'(rng-id ...))) #,(length (syntax->list #'(rng-id ...)))
args)]))] args
#,n)]))]
[rng-length (length (syntax->list rng))]) [rng-length (length (syntax->list rng))])
(if rst (if rst
(check-tail-contract #'(rng-proj-x ...) rng-checkers (check-tail-contract #'(rng-proj-x ...) rng-checkers
@ -1608,7 +1609,9 @@ v4 todo:
(rng-proj-x ...) (rng-proj-x ...)
formals formals
body) ...) body) ...)
(map (λ (x) (parse-out-case stx x)) (syntax->list #'(cases ...)))] (for/list ([x (in-list (syntax->list #'(cases ...)))]
[n (in-naturals)])
(parse-out-case stx x n))]
[mctc? (and (syntax-parameter-value #'method-contract?) #t)]) [mctc? (and (syntax-parameter-value #'method-contract?) #t)])
#`(syntax-parameterize #`(syntax-parameterize
((making-a-method #f)) ((making-a-method #f))
@ -1657,7 +1660,7 @@ v4 todo:
(define (case->-proj wrapper) (define (case->-proj wrapper)
(λ (ctc) (λ (ctc)
(define dom-ctcs (map contract-projection (get-case->-dom-ctcs ctc))) (define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc))
(define rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)]) (define rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)])
(and rngs (map contract-projection rngs)))) (and rngs (map contract-projection rngs))))
(define rst-ctcs (base-case->-rst-ctcs ctc)) (define rst-ctcs (base-case->-rst-ctcs ctc))
@ -1665,7 +1668,14 @@ v4 todo:
(λ (blame) (λ (blame)
(define dom-blame (blame-add-context blame "the domain of" #:swap? #t)) (define dom-blame (blame-add-context blame "the domain of" #:swap? #t))
(define rng-blame (blame-add-context blame "the range of")) (define rng-blame (blame-add-context blame "the range of"))
(define projs (append (map (λ (f) (f dom-blame)) dom-ctcs) (define projs (append (map (λ (f) ((cdr f)
(blame-add-context
(blame-add-context
blame
(format "the ~a case of" (n->th (+ (car f) 1))))
"the domain of"
#:swap? #t)))
dom-ctcs+case-nums)
(map (λ (f) (f rng-blame)) rng-ctcs))) (map (λ (f) (f rng-blame)) rng-ctcs)))
(define (chk val mtd?) (define (chk val mtd?)
(cond (cond
@ -1738,14 +1748,18 @@ v4 todo:
(make-chaperone-case-> dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper) (make-chaperone-case-> dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper)
(make-impersonator-case-> dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper)))) (make-impersonator-case-> dom-ctcs rst-ctcs rng-ctcs specs mctc? wrapper))))
(define (get-case->-dom-ctcs ctc) (define (get-case->-dom-ctcs+case-nums ctc)
(for/fold ([acc '()]) (for/fold ([acc '()])
([doms (in-list (base-case->-dom-ctcs ctc))] ([doms (in-list (base-case->-dom-ctcs ctc))]
[rst (in-list (base-case->-rst-ctcs ctc))]) [rst (in-list (base-case->-rst-ctcs ctc))]
[i (in-naturals)])
(define dom+case-nums
(map (λ (dom) (cons i (contract-projection dom))) doms))
(append acc (append acc
(if rst (if rst
(append doms (list rst)) (append dom+case-nums
doms)))) (list (cons i (contract-projection rst))))
dom+case-nums))))
(define (get-case->-rng-ctcs ctc) (define (get-case->-rng-ctcs ctc)
(for/fold ([acc '()]) (for/fold ([acc '()])
@ -1977,9 +1991,12 @@ v4 todo:
[else [else
passes?])) passes?]))
(define (bad-number-of-results blame val rng-len args) (define (bad-number-of-results blame val rng-len args [case-context #f])
(define num-values (length args)) (define num-values (length args))
(raise-blame-error (blame-add-context blame "the range of") (define blame-case (if case-context
(blame-add-context blame (format "the ~a case of" (n->th (+ case-context 1))))
blame))
(raise-blame-error (blame-add-context blame-case "the range of")
val val
"expected ~a value~a, returned ~a value~a" "expected ~a value~a, returned ~a value~a"
rng-len (if (= rng-len 1) "" "s") rng-len (if (= rng-len 1) "" "s")

22
collects/tests/racket/contract-test.rktl
View File

@ -13745,6 +13745,28 @@ so that propagation occurs.
'pos 'neg) 'pos 'neg)
1 "a"))) 1 "a")))
(ctest '("the range of" "the 2nd case of")
extract-context-lines
(λ ()
((contract (case-> (-> real? real? real?)
(-> real? (values real? real?)))
(case-lambda
[(x y) 1]
[(x) 1])
'pos 'neg)
1)))
(ctest '("the domain of" "the 2nd case of")
extract-context-lines
(λ ()
((contract (case-> (-> real? real? real?)
(-> real? (values real? real?)))
(case-lambda
[(x y) 1]
[(x) 1])
'pos 'neg)
#f)))
(let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) 'positive 'negative #t))] (let* ([blame-pos (contract-eval '(make-blame (srcloc #f #f #f #f #f) #f (λ () 'integer?) 'positive 'negative #t))]
[blame-neg (contract-eval `(blame-swap ,blame-pos))]) [blame-neg (contract-eval `(blame-swap ,blame-pos))])