add context to blame error messages
This is using the same idea that Stevie had, more than two years ago(!). Sorry for not picking up on this earlier
This commit is contained in:
Robby Findler
parent
1c9de39348
commit
81252541dc
|
|
@ -105,27 +105,28 @@ v4 todo:
|
|||
(define name
|
||||
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
|
||||
(define (projection wrapper)
|
||||
(λ (blame)
|
||||
(let* ([p-app-x (proj-x blame)] ...
|
||||
[res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
|
||||
(λ (val)
|
||||
(unless (procedure? val)
|
||||
(raise-blame-error blame val "expected a procedure, got ~v" val))
|
||||
(wrapper
|
||||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-vals . args)
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s kwd-vals args))))
|
||||
(λ args
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s args)))))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key (list p-app-x ...)))))))
|
||||
(λ (orig-blame)
|
||||
(let ([rng-blame (blame-add-context orig-blame "the range of")])
|
||||
(let* ([p-app-x (proj-x rng-blame)] ...
|
||||
[res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
|
||||
(λ (val)
|
||||
(unless (procedure? val)
|
||||
(raise-blame-error orig-blame val "expected a procedure, got ~v" val))
|
||||
(wrapper
|
||||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-vals . args)
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s kwd-vals args))))
|
||||
(λ args
|
||||
#,(check-tail-contract
|
||||
#'(p-app-x ...)
|
||||
(list #'res-checker)
|
||||
(λ (s) #`(apply values #,@s args)))))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key (list p-app-x ...))))))))
|
||||
(define ctc
|
||||
(if (and (chaperone-contract? rngs-x) ...)
|
||||
(make-chaperone-contract
|
||||
|
|
@ -464,33 +465,45 @@ v4 todo:
|
|||
[pre (base->-pre ctc)]
|
||||
[post (base->-post ctc)]
|
||||
[mtd? (base->-mtd? ctc)])
|
||||
(λ (blame)
|
||||
(let ([swapped (blame-swap blame)])
|
||||
(let ([partial-doms (map (λ (dom) (dom swapped)) doms-proj)]
|
||||
[partial-optional-doms (map (λ (dom) (dom swapped)) doms-optional-proj)]
|
||||
[partial-ranges (map (λ (rng) (rng blame)) rngs-proj)]
|
||||
[partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj)]
|
||||
[partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj)])
|
||||
(define the-args (append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges))
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame))
|
||||
(define chap/imp-func (apply func blame val the-args))
|
||||
(if post
|
||||
(wrapper
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:contracted ctc)
|
||||
(wrapper
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key
|
||||
;; is this right?
|
||||
partial-ranges)))))))))
|
||||
(λ (orig-blame)
|
||||
(define rng-blame (blame-add-context orig-blame "the range of"))
|
||||
(define swapped (blame-swap orig-blame))
|
||||
(define swapped-domain (blame-add-context swapped "the domain of"))
|
||||
(define partial-doms
|
||||
(for/list ([dom (in-list doms-proj)]
|
||||
[n (in-naturals 1)])
|
||||
(dom (blame-add-context swapped
|
||||
(format "the ~a argument of"
|
||||
(n->th n))))))
|
||||
(define partial-optional-doms
|
||||
(for/list ([dom (in-list doms-optional-proj)]
|
||||
[n (in-naturals (+ 1 (length doms-proj)))])
|
||||
(dom (blame-add-context swapped
|
||||
(format "the ~a argument of"
|
||||
(n->th n))))))
|
||||
(define partial-ranges (map (λ (rng) (rng rng-blame)) rngs-proj))
|
||||
(define partial-mandatory-kwds (map (λ (kwd) (kwd swapped)) mandatory-kwds-proj))
|
||||
(define partial-optional-kwds (map (λ (kwd) (kwd swapped)) optional-kwds-proj))
|
||||
(define the-args (append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges))
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords orig-blame)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords orig-blame))
|
||||
(define chap/imp-func (apply func orig-blame val the-args))
|
||||
(if post
|
||||
(wrapper
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:contracted ctc)
|
||||
(wrapper
|
||||
val
|
||||
chap/imp-func
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:application-mark (cons contract-key
|
||||
;; is this right?
|
||||
partial-ranges)))))))
|
||||
|
||||
(define (->-name ctc)
|
||||
(single-arrow-name-maker
|
||||
|
|
@ -1169,132 +1182,133 @@ v4 todo:
|
|||
[else
|
||||
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(if (base-->d-rest-ctc ->d-stct)
|
||||
(check-procedure/more val
|
||||
(base-->d-mtd? ->d-stct)
|
||||
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
|
||||
(base-->d-mandatory-keywords ->d-stct)
|
||||
(base-->d-optional-keywords ->d-stct)
|
||||
blame)
|
||||
(check-procedure val
|
||||
(base-->d-mtd? ->d-stct)
|
||||
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
|
||||
(length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length
|
||||
(base-->d-mandatory-keywords ->d-stct)
|
||||
(base-->d-optional-keywords ->d-stct)
|
||||
blame))
|
||||
(wrap-procedure
|
||||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwd-args kwd-arg-vals . raw-orig-args)
|
||||
(let* ([orig-args (if (base-->d-mtd? ->d-stct)
|
||||
(cdr raw-orig-args)
|
||||
raw-orig-args)]
|
||||
[this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))]
|
||||
[dep-pre-args
|
||||
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (base-->d-rest-ctc ->d-stct)
|
||||
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
|
||||
(when (base-->d-pre-cond ->d-stct)
|
||||
(unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
val
|
||||
"#:pre violation~a"
|
||||
(build-values-string ", argument" dep-pre-args))))
|
||||
(apply
|
||||
values
|
||||
|
||||
(append
|
||||
|
||||
(let ([rng (let ([rng (base-->d-range ->d-stct)])
|
||||
(cond
|
||||
[(not rng) #f]
|
||||
[(box? rng)
|
||||
(map (λ (val) (apply val dep-pre-args))
|
||||
(unbox rng))]
|
||||
[else rng]))]
|
||||
[rng-underscore? (box? (base-->d-range ->d-stct))])
|
||||
(if rng
|
||||
(list (λ orig-results
|
||||
(let* ([range-count (length rng)]
|
||||
[post-args (append orig-results raw-orig-args)]
|
||||
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
|
||||
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
|
||||
post-args (base-->d-rest-ctc ->d-stct)
|
||||
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
|
||||
(when (base-->d-post-cond ->d-stct)
|
||||
(unless (apply (base-->d-post-cond ->d-stct) dep-post-args)
|
||||
(let ([blame (blame-add-context blame "the domain of")])
|
||||
(λ (val)
|
||||
(if (base-->d-rest-ctc ->d-stct)
|
||||
(check-procedure/more val
|
||||
(base-->d-mtd? ->d-stct)
|
||||
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
|
||||
(base-->d-mandatory-keywords ->d-stct)
|
||||
(base-->d-optional-keywords ->d-stct)
|
||||
blame)
|
||||
(check-procedure val
|
||||
(base-->d-mtd? ->d-stct)
|
||||
(length (base-->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
|
||||
(length (base-->d-optional-dom-ctcs ->d-stct)) ; optionals-length
|
||||
(base-->d-mandatory-keywords ->d-stct)
|
||||
(base-->d-optional-keywords ->d-stct)
|
||||
blame))
|
||||
(wrap-procedure
|
||||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwd-args kwd-arg-vals . raw-orig-args)
|
||||
(let* ([orig-args (if (base-->d-mtd? ->d-stct)
|
||||
(cdr raw-orig-args)
|
||||
raw-orig-args)]
|
||||
[this (and (base-->d-mtd? ->d-stct) (car raw-orig-args))]
|
||||
[dep-pre-args
|
||||
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (base-->d-rest-ctc ->d-stct)
|
||||
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
|
||||
(when (base-->d-pre-cond ->d-stct)
|
||||
(unless (apply (base-->d-pre-cond ->d-stct) dep-pre-args)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
val
|
||||
"#:pre violation~a"
|
||||
(build-values-string ", argument" dep-pre-args))))
|
||||
(apply
|
||||
values
|
||||
|
||||
(append
|
||||
|
||||
(let ([rng (let ([rng (base-->d-range ->d-stct)])
|
||||
(cond
|
||||
[(not rng) #f]
|
||||
[(box? rng)
|
||||
(map (λ (val) (apply val dep-pre-args))
|
||||
(unbox rng))]
|
||||
[else rng]))]
|
||||
[rng-underscore? (box? (base-->d-range ->d-stct))])
|
||||
(if rng
|
||||
(list (λ orig-results
|
||||
(let* ([range-count (length rng)]
|
||||
[post-args (append orig-results raw-orig-args)]
|
||||
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
|
||||
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
|
||||
post-args (base-->d-rest-ctc ->d-stct)
|
||||
(base-->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
|
||||
(when (base-->d-post-cond ->d-stct)
|
||||
(unless (apply (base-->d-post-cond ->d-stct) dep-post-args)
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"#:post violation~a~a"
|
||||
(build-values-string ", argument" dep-pre-args)
|
||||
(build-values-string (if (null? dep-pre-args)
|
||||
", result"
|
||||
"\n result")
|
||||
orig-results))))
|
||||
|
||||
(unless (= range-count (length orig-results))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"#:post violation~a~a"
|
||||
(build-values-string ", argument" dep-pre-args)
|
||||
(build-values-string (if (null? dep-pre-args)
|
||||
", result"
|
||||
"\n result")
|
||||
orig-results))))
|
||||
|
||||
(unless (= range-count (length orig-results))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected ~a results, got ~a"
|
||||
range-count
|
||||
(length orig-results)))
|
||||
(apply
|
||||
values
|
||||
(let loop ([results orig-results]
|
||||
[result-contracts rng])
|
||||
"expected ~a results, got ~a"
|
||||
range-count
|
||||
(length orig-results)))
|
||||
(apply
|
||||
values
|
||||
(let loop ([results orig-results]
|
||||
[result-contracts rng])
|
||||
(cond
|
||||
[(null? result-contracts) '()]
|
||||
[else
|
||||
(cons
|
||||
(invoke-dep-ctc (car result-contracts)
|
||||
(if rng-underscore? #f dep-post-args)
|
||||
(car results)
|
||||
blame)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))
|
||||
null))
|
||||
|
||||
;; contracted keyword arguments
|
||||
(let ([kwd-res (let loop ([all-kwds (base-->d-keywords ->d-stct)]
|
||||
[kwd-ctcs (base-->d-keyword-ctcs ->d-stct)]
|
||||
[building-kwd-args kwd-args]
|
||||
[building-kwd-arg-vals kwd-arg-vals])
|
||||
(cond
|
||||
[(null? result-contracts) '()]
|
||||
[else
|
||||
(cons
|
||||
(invoke-dep-ctc (car result-contracts)
|
||||
(if rng-underscore? #f dep-post-args)
|
||||
(car results)
|
||||
blame)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))
|
||||
null))
|
||||
|
||||
;; contracted keyword arguments
|
||||
(let ([kwd-res (let loop ([all-kwds (base-->d-keywords ->d-stct)]
|
||||
[kwd-ctcs (base-->d-keyword-ctcs ->d-stct)]
|
||||
[building-kwd-args kwd-args]
|
||||
[building-kwd-arg-vals kwd-arg-vals])
|
||||
(cond
|
||||
[(or (null? building-kwd-args) (null? all-kwds)) '()]
|
||||
[else (if (eq? (car all-kwds)
|
||||
(car building-kwd-args))
|
||||
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))])
|
||||
(if (null? kwd-res) null (list kwd-res)))
|
||||
|
||||
|
||||
;; this parameter (if necc.)
|
||||
(if (base-->d-mtd? ->d-stct)
|
||||
(list (car raw-orig-args))
|
||||
'())
|
||||
|
||||
;; contracted ordinary arguments
|
||||
(let loop ([args orig-args]
|
||||
[non-kwd-ctcs (append (base-->d-mandatory-dom-ctcs ->d-stct)
|
||||
(base-->d-optional-dom-ctcs ->d-stct))])
|
||||
(cond
|
||||
[(null? args)
|
||||
(if (base-->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
|
||||
'())]
|
||||
[(null? non-kwd-ctcs)
|
||||
(if (base-->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
|
||||
|
||||
;; ran out of arguments, but don't have a rest parameter.
|
||||
;; procedure-reduce-arity (or whatever the new thing is
|
||||
;; going to be called) should ensure this doesn't happen.
|
||||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))))
|
||||
impersonator-prop:contracted ->d-stct)))))
|
||||
[(or (null? building-kwd-args) (null? all-kwds)) '()]
|
||||
[else (if (eq? (car all-kwds)
|
||||
(car building-kwd-args))
|
||||
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))])
|
||||
(if (null? kwd-res) null (list kwd-res)))
|
||||
|
||||
|
||||
;; this parameter (if necc.)
|
||||
(if (base-->d-mtd? ->d-stct)
|
||||
(list (car raw-orig-args))
|
||||
'())
|
||||
|
||||
;; contracted ordinary arguments
|
||||
(let loop ([args orig-args]
|
||||
[non-kwd-ctcs (append (base-->d-mandatory-dom-ctcs ->d-stct)
|
||||
(base-->d-optional-dom-ctcs ->d-stct))])
|
||||
(cond
|
||||
[(null? args)
|
||||
(if (base-->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
|
||||
'())]
|
||||
[(null? non-kwd-ctcs)
|
||||
(if (base-->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (base-->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
|
||||
|
||||
;; ran out of arguments, but don't have a rest parameter.
|
||||
;; procedure-reduce-arity (or whatever the new thing is
|
||||
;; going to be called) should ensure this doesn't happen.
|
||||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))))
|
||||
impersonator-prop:contracted ->d-stct))))))
|
||||
|
||||
(define (build-values-string desc dep-pre-args)
|
||||
(cond
|
||||
|
|
@ -1604,8 +1618,10 @@ v4 todo:
|
|||
[rst-ctcs (base-case->-rst-ctcs ctc)]
|
||||
[specs (base-case->-specs ctc)])
|
||||
(λ (blame)
|
||||
(let ([projs (append (map (λ (f) (f (blame-swap blame))) dom-ctcs)
|
||||
(map (λ (f) (f blame)) rng-ctcs))]
|
||||
(define dom-blame (blame-add-context (blame-swap blame) "the domain of"))
|
||||
(define rng-blame (blame-add-context blame "the range of"))
|
||||
(let ([projs (append (map (λ (f) (f dom-blame)) dom-ctcs)
|
||||
(map (λ (f) (f rng-blame)) rng-ctcs))]
|
||||
[chk
|
||||
(λ (val mtd?)
|
||||
(cond
|
||||
|
|
@ -1915,7 +1931,8 @@ v4 todo:
|
|||
|
||||
(define (bad-number-of-results blame val rng-len args)
|
||||
(define num-values (length args))
|
||||
(raise-blame-error blame val
|
||||
(raise-blame-error (blame-add-context blame "the range of")
|
||||
val
|
||||
"expected ~a value~a, returned ~a value~a"
|
||||
rng-len (if (= rng-len 1) "" "s")
|
||||
num-values (if (= num-values 1) "" "s")))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(require syntax/srcloc racket/pretty setup/path-to-relative)
|
||||
|
||||
(provide blame?
|
||||
make-blame
|
||||
(rename-out [-make-blame make-blame])
|
||||
blame-source
|
||||
blame-positive
|
||||
blame-negative
|
||||
|
|
@ -12,7 +12,9 @@
|
|||
blame-swapped?
|
||||
blame-swap
|
||||
blame-replace-negative ;; used for indy blame
|
||||
|
||||
blame-add-context
|
||||
blame-context
|
||||
|
||||
raise-blame-error
|
||||
current-blame-format
|
||||
(struct-out exn:fail:contract:blame))
|
||||
|
|
@ -34,10 +36,21 @@
|
|||
(hash/recur (blame-original? b))))
|
||||
|
||||
(define-struct blame
|
||||
[source value build-name positive negative original?]
|
||||
[source value build-name positive negative original? context]
|
||||
#:property prop:equal+hash
|
||||
(list blame=? blame-hash blame-hash))
|
||||
|
||||
(define -make-blame
|
||||
(let ([make-blame
|
||||
(λ (source value build-name positive negative original?)
|
||||
(make-blame source value build-name positive negative original? '()))])
|
||||
make-blame))
|
||||
|
||||
(define (blame-add-context b s)
|
||||
(struct-copy
|
||||
blame b
|
||||
[context (cons s (blame-context b))]))
|
||||
|
||||
(define (blame-contract b) ((blame-build-name b)))
|
||||
|
||||
(define (blame-swap b)
|
||||
|
|
@ -67,17 +80,33 @@
|
|||
(let* ([source-message (source-location->string (blame-source b))]
|
||||
[positive-message (show/display (convert-blame-party (blame-positive b)))]
|
||||
|
||||
[contract-message (format " contract: ~a" (show/write (blame-contract b)))]
|
||||
[contract-message+at (if (regexp-match #rx"\n$" contract-message)
|
||||
(string-append contract-message
|
||||
(if (string=? source-message "")
|
||||
""
|
||||
(format " at: ~a" source-message)))
|
||||
(string-append contract-message
|
||||
"\n"
|
||||
(if (string=? source-message "")
|
||||
""
|
||||
(format " at: ~a" source-message))))])
|
||||
[context-message (apply string-append
|
||||
(for/list ([context (in-list (blame-context b))]
|
||||
[n (in-naturals)])
|
||||
(format (if (zero? n)
|
||||
" in: ~a\n"
|
||||
" ~a\n")
|
||||
context)))]
|
||||
[the-contract-str (show/write (blame-contract b))]
|
||||
[contract-message (string-append (if (regexp-match #rx"\n" the-contract-str)
|
||||
(string-append (regexp-replace #rx"\n$" context-message "")
|
||||
the-contract-str)
|
||||
(string-append context-message
|
||||
(format " ~a" the-contract-str))))]
|
||||
[contract-message+at
|
||||
(regexp-replace
|
||||
#rx"^\n"
|
||||
(if (regexp-match #rx"\n$" contract-message)
|
||||
(string-append contract-message
|
||||
(if (string=? source-message "")
|
||||
""
|
||||
(format " at: ~a" source-message)))
|
||||
(string-append contract-message
|
||||
"\n"
|
||||
(if (string=? source-message "")
|
||||
""
|
||||
(format " at: ~a" source-message))))
|
||||
"")])
|
||||
;; use (regexp-match #rx"\n" ...) to find out if show/display decided that this
|
||||
;; is a multiple-line message and adjust surrounding formatting accordingly
|
||||
(cond
|
||||
|
|
@ -153,7 +182,7 @@
|
|||
(define (show-line-break line port len cols)
|
||||
(newline port)
|
||||
(if line
|
||||
(begin (display " " port) 4)
|
||||
(begin (display " " port) 6)
|
||||
0))
|
||||
|
||||
(define current-blame-format
|
||||
|
|
|
|||
|
|
@ -44,7 +44,8 @@
|
|||
flat-named-contract
|
||||
|
||||
contract-projection
|
||||
contract-name)
|
||||
contract-name
|
||||
n->th)
|
||||
|
||||
(define-syntax (flat-rec-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -146,11 +147,12 @@
|
|||
(let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
|
||||
[pred (single-or/c-pred ctc)])
|
||||
(λ (blame)
|
||||
(let ([partial-contract (c-proc blame)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else (partial-contract val)]))))))
|
||||
(define partial-contract
|
||||
(c-proc (blame-add-context blame "a disjunct of")))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[else (partial-contract val)])))))
|
||||
|
||||
(define (single-or/c-name ctc)
|
||||
(apply build-compound-type-name
|
||||
|
|
@ -199,42 +201,45 @@
|
|||
[first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
|
||||
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
|
||||
(λ (blame)
|
||||
(let ([partial-contracts (map (λ (c-proc) (c-proc blame)) c-procs)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts ho-contracts]
|
||||
[candidate-proc #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-blame-error blame val
|
||||
"none of the branches of the or/c matched, given ~e"
|
||||
val))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(raise-blame-error blame val
|
||||
"two of the clauses in the or/c might both match: ~s and ~s, given ~e"
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
(car procs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
candidate-proc
|
||||
candidate-contract)]))]))))))
|
||||
(define disj-blame (blame-add-context blame "a disjunct of"))
|
||||
(define partial-contracts
|
||||
(for/list ([c-proc (in-list c-procs)])
|
||||
(c-proc disj-blame)))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts ho-contracts]
|
||||
[candidate-proc #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-blame-error blame val
|
||||
"none of the branches of the or/c matched, given ~e"
|
||||
val))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(raise-blame-error blame val
|
||||
"two of the clauses in the or/c might both match: ~s and ~s, given ~e"
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
(car procs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
candidate-proc
|
||||
candidate-contract)]))])))))
|
||||
|
||||
(define (multi-or/c-name ctc)
|
||||
(apply build-compound-type-name
|
||||
|
|
@ -336,10 +341,13 @@
|
|||
(define (and-proj ctc)
|
||||
(let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))])
|
||||
(lambda (blame)
|
||||
(let ([projs (map (λ (c) (c blame)) mk-pos-projs)])
|
||||
(for/fold ([proj (car projs)])
|
||||
([p (in-list (cdr projs))])
|
||||
(λ (v) (p (proj v))))))))
|
||||
(define projs
|
||||
(for/list ([c (in-list mk-pos-projs)]
|
||||
[n (in-naturals 1)])
|
||||
(c (blame-add-context blame (format "the ~a conjunct of" (n->th n))))))
|
||||
(for/fold ([proj (car projs)])
|
||||
([p (in-list (cdr projs))])
|
||||
(λ (v) (p (proj v)))))))
|
||||
|
||||
(define (first-order-and-proj ctc)
|
||||
(λ (blame)
|
||||
|
|
@ -630,7 +638,7 @@
|
|||
(for/and ([v (in-list x)])
|
||||
(contract-first-order-passes? ctc v))))
|
||||
(define ((ho-check check-all) blame)
|
||||
(let ([p-app (proj blame)])
|
||||
(let ([p-app (proj (blame-add-context blame "an element of"))])
|
||||
(λ (val)
|
||||
(unless (predicate? val)
|
||||
(raise-blame-error blame val
|
||||
|
|
@ -675,8 +683,8 @@
|
|||
(contract-first-order-passes? ctc-car (car v))
|
||||
(contract-first-order-passes? ctc-cdr (cdr v))))
|
||||
(define ((ho-check combine) blame)
|
||||
(let ([car-p (car-proj blame)]
|
||||
[cdr-p (cdr-proj blame)])
|
||||
(let ([car-p (car-proj (blame-add-context blame "the car of"))]
|
||||
[cdr-p (cdr-proj (blame-add-context blame "the cdr of"))])
|
||||
(λ (v)
|
||||
(unless (pair? v)
|
||||
(raise-blame-error blame v "expected <cons?>, given: ~e" v))
|
||||
|
|
@ -729,41 +737,53 @@
|
|||
#:first-order list/c-first-order
|
||||
#:projection
|
||||
(lambda (c)
|
||||
(lambda (b)
|
||||
(lambda (blame)
|
||||
(lambda (x)
|
||||
(unless (list? x)
|
||||
(raise-blame-error b x "expected a list, got: ~e" x))
|
||||
(raise-blame-error blame x "expected a list, got: ~e" x))
|
||||
(let* ([args (generic-list/c-args c)]
|
||||
[expected (length args)]
|
||||
[actual (length x)])
|
||||
(unless (= actual expected)
|
||||
(raise-blame-error
|
||||
b x
|
||||
blame x
|
||||
"expected a list of ~a elements, but got ~a elements in: ~e"
|
||||
expected actual x))
|
||||
(for ([arg/c (in-list args)] [v (in-list x)])
|
||||
(((contract-projection arg/c) b) v))
|
||||
(for ([arg/c (in-list args)] [v (in-list x)] [i (in-naturals 1)])
|
||||
(((contract-projection arg/c)
|
||||
(add-list-context blame i))
|
||||
v))
|
||||
x))))))
|
||||
|
||||
(define (list/c-chaperone/other-projection c)
|
||||
(define args (map contract-projection (generic-list/c-args c)))
|
||||
(define expected (length args))
|
||||
(λ (b)
|
||||
(define projs (for/list ([arg/c (in-list args)])
|
||||
(arg/c b)))
|
||||
(λ (blame)
|
||||
(define projs (for/list ([arg/c (in-list args)]
|
||||
[i (in-naturals 1)])
|
||||
(arg/c (add-list-context blame i))))
|
||||
(λ (x)
|
||||
(unless (list? x)
|
||||
(raise-blame-error b x "expected a list, got: ~e" x))
|
||||
(raise-blame-error blame x "expected a list, got: ~e" x))
|
||||
(define actual (length x))
|
||||
(unless (= actual expected)
|
||||
(raise-blame-error
|
||||
b x
|
||||
blame x
|
||||
"expected a list of ~a elements, but got ~a elements in: ~e"
|
||||
expected actual x))
|
||||
(for/list ([item (in-list x)]
|
||||
[proj (in-list projs)])
|
||||
(proj item)))))
|
||||
|
||||
(define (add-list-context blame i)
|
||||
(blame-add-context blame (format "the ~a~a element of"
|
||||
i
|
||||
(case (modulo i 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[else "th"]))))
|
||||
|
||||
(struct chaperone-list/c generic-list/c ()
|
||||
#:property prop:chaperone-contract
|
||||
(parameterize ([skip-projection-wrapper? #t])
|
||||
|
|
@ -796,7 +816,7 @@
|
|||
#:name (build-compound-type-name 'promise/c ctc)
|
||||
#:projection
|
||||
(λ (blame)
|
||||
(let ([p-app (ctc-proc blame)])
|
||||
(let ([p-app (ctc-proc (blame-add-context blame "the promise from"))])
|
||||
(λ (val)
|
||||
(unless (promise? val)
|
||||
(raise-blame-error
|
||||
|
|
@ -818,17 +838,18 @@
|
|||
(λ (ctc)
|
||||
(let ([c-proc (contract-projection (parameter/c-ctc ctc))])
|
||||
(λ (blame)
|
||||
(let ([partial-neg-contract (c-proc (blame-swap blame))]
|
||||
[partial-pos-contract (c-proc blame)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(parameter? val)
|
||||
(make-derived-parameter
|
||||
val
|
||||
partial-neg-contract
|
||||
partial-pos-contract)]
|
||||
[else
|
||||
(raise-blame-error blame val "expected a parameter")]))))))
|
||||
(define blame/c (blame-add-context blame "the parameter of"))
|
||||
(define partial-neg-contract (c-proc (blame-swap blame/c)))
|
||||
(define partial-pos-contract (c-proc blame/c))
|
||||
(λ (val)
|
||||
(cond
|
||||
[(parameter? val)
|
||||
(make-derived-parameter
|
||||
val
|
||||
partial-neg-contract
|
||||
partial-pos-contract)]
|
||||
[else
|
||||
(raise-blame-error blame val "expected a parameter")])))))
|
||||
|
||||
#:name
|
||||
(λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
|
||||
|
|
@ -970,3 +991,13 @@
|
|||
(integer? x)
|
||||
(exact? x)
|
||||
(x . >= . 0)))))
|
||||
|
||||
(define (n->th n)
|
||||
(string-append
|
||||
(number->string n)
|
||||
(case (modulo n 10)
|
||||
[(1) "st"]
|
||||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[else "th"])))
|
||||
|
||||
|
|
|
|||
|
|
@ -246,10 +246,12 @@
|
|||
(define ((get-first-order-projection get-name get-first-order) c)
|
||||
(first-order-projection (get-name c) (get-first-order c)))
|
||||
|
||||
(define (((first-order-projection name first-order) b) x)
|
||||
(if (first-order x)
|
||||
x
|
||||
(raise-blame-error b x "expected: ~s, given: ~e" name x)))
|
||||
(define (first-order-projection name first-order)
|
||||
(λ (b)
|
||||
(λ (x)
|
||||
(if (first-order x)
|
||||
x
|
||||
(raise-blame-error b x "expected: ~s, given: ~e" name x)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -2777,9 +2777,10 @@
|
|||
(for ([m (in-list (class/c-methods ctc))]
|
||||
[c (in-list (class/c-method-contracts ctc))])
|
||||
(when c
|
||||
(let ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) blame)])
|
||||
(vector-set! methods i (make-method (p (vector-ref methods i)) m))))))
|
||||
(define i (hash-ref method-ht m))
|
||||
(define mp (vector-ref methods i))
|
||||
(define p ((contract-projection c) (blame-add-method-context blame mp)))
|
||||
(vector-set! methods i (make-method (p mp) m)))))
|
||||
|
||||
;; Handle super contracts
|
||||
(unless (null? (class/c-supers ctc))
|
||||
|
|
@ -2789,9 +2790,10 @@
|
|||
(for ([m (in-list (class/c-supers ctc))]
|
||||
[c (in-list (class/c-super-contracts ctc))])
|
||||
(when c
|
||||
(let ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) blame)])
|
||||
(vector-set! super-methods i (make-method (p (vector-ref super-methods i)) m))))))
|
||||
(define i (hash-ref method-ht m))
|
||||
(define mp (vector-ref super-methods i))
|
||||
(define p ((contract-projection c) (blame-add-method-context blame mp)))
|
||||
(vector-set! super-methods i (make-method (p mp) m)))))
|
||||
|
||||
;; Add inner projections
|
||||
(unless (null? (class/c-inners ctc))
|
||||
|
|
@ -2799,10 +2801,10 @@
|
|||
(for ([m (in-list (class/c-inners ctc))]
|
||||
[c (in-list (class/c-inner-contracts ctc))])
|
||||
(when c
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) bswap)]
|
||||
[old-proj (vector-ref inner-projs i)])
|
||||
(vector-set! inner-projs i (λ (v) (old-proj (p v))))))))
|
||||
(define i (hash-ref method-ht m))
|
||||
(define old-proj (vector-ref inner-projs i))
|
||||
(define p ((contract-projection c) (blame-add-method-context bswap old-proj)))
|
||||
(vector-set! inner-projs i (λ (v) (old-proj (p v)))))))
|
||||
|
||||
;; Handle both internal and external field contracts
|
||||
(unless no-field-ctcs?
|
||||
|
|
@ -2810,8 +2812,8 @@
|
|||
[c (in-list (class/c-field-contracts ctc))])
|
||||
(when c
|
||||
(let ([fi (hash-ref field-ht f)]
|
||||
[p-pos ((contract-projection c) blame)]
|
||||
[p-neg ((contract-projection c) bswap)])
|
||||
[p-pos ((contract-projection c) (blame-add-context blame (format "the ~a field in" f)))]
|
||||
[p-neg ((contract-projection c) (blame-add-context bswap (format "the ~a field in" f)))])
|
||||
(hash-set! field-ht f (field-info-extend-external fi p-pos p-neg)))))
|
||||
(for ([f (in-list (class/c-inherit-fields ctc))]
|
||||
[c (in-list (class/c-inherit-field-contracts ctc))])
|
||||
|
|
@ -2861,7 +2863,7 @@
|
|||
[c (in-list (class/c-override-contracts ctc))])
|
||||
(when c
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) bswap)]
|
||||
[p ((contract-projection c) (blame-add-method-context bswap i))]
|
||||
[old-idx (vector-ref old-idxs i)]
|
||||
[proj-vec (vector-ref dynamic-projs i)]
|
||||
[old-proj (vector-ref proj-vec old-idx)])
|
||||
|
|
@ -2878,7 +2880,7 @@
|
|||
(class/c-augride-contracts ctc)))])
|
||||
(when c
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) blame)]
|
||||
[p ((contract-projection c) (blame-add-method-context blame i))]
|
||||
[old-idx (vector-ref old-idxs i)]
|
||||
[new-idx (vector-ref dynamic-idxs i)]
|
||||
[proj-vec (vector-ref dynamic-projs i)]
|
||||
|
|
@ -2895,7 +2897,7 @@
|
|||
[c (in-list (class/c-inherit-contracts ctc))])
|
||||
(when c
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) blame)]
|
||||
[p ((contract-projection c) (blame-add-method-context blame i))]
|
||||
[new-idx (vector-ref dynamic-idxs i)]
|
||||
[int-vec (vector-ref int-methods i)])
|
||||
(vector-set! int-vec new-idx
|
||||
|
|
@ -2961,6 +2963,16 @@
|
|||
|
||||
c)))))
|
||||
|
||||
(define (blame-add-method-context blame method-proc)
|
||||
(define name (object-name method-proc))
|
||||
(cond
|
||||
[name
|
||||
;; the procedure name of a method has ' method in ...' in it; trim that away
|
||||
(define method-name (regexp-replace #rx" method in .*%.?$" (symbol->string name) ""))
|
||||
(blame-add-context blame (format "the ~a method in" method-name))]
|
||||
[else
|
||||
(blame-add-context blame "an unnamed method in")]))
|
||||
|
||||
(define-struct class/c
|
||||
(methods method-contracts fields field-contracts inits init-contracts
|
||||
inherits inherit-contracts inherit-fields inherit-field-contracts
|
||||
|
|
|
|||
|
|
@ -11276,6 +11276,123 @@ so that propagation occurs.
|
|||
values)])
|
||||
((car s) 1)))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ;
|
||||
; ;;; ;;;
|
||||
; ;;; ;;; ;;; ;; ;;;; ;;;; ;;; ;;; ;;;;
|
||||
; ;;;;; ;;;;; ;;;;;;; ;;;; ;; ;;; ;; ;; ;;;;
|
||||
; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;;
|
||||
; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;;
|
||||
; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;;
|
||||
; ;;;;; ;;;;; ;;; ;;; ;;;; ;;;;;; ;; ;; ;;;;
|
||||
; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
(contract-eval '(define (extract-context-lines thunk num)
|
||||
(define str
|
||||
(with-handlers ((exn:fail:contract:blame? exn-message))
|
||||
(thunk)
|
||||
"didn't raise an exception"))
|
||||
(define lines
|
||||
(regexp-split
|
||||
#rx"\n "
|
||||
(regexp-replace #rx"(.*)\n in: " str "")))
|
||||
(for/list ([answer-count (in-range num)]
|
||||
[msg-str (in-list lines)])
|
||||
msg-str)))
|
||||
|
||||
(ctest '("the cdr of" "the 1st argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (-> (cons/c integer? boolean?) integer? integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
(cons 1 2) 1))
|
||||
2)
|
||||
|
||||
(ctest '("the 3rd element of" "the 2nd argument of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (-> integer? (list/c integer? integer? boolean?) integer?)
|
||||
(λ (x y) x)
|
||||
'pos
|
||||
'neg)
|
||||
1 (list 1 2 3)))
|
||||
2)
|
||||
|
||||
(ctest '("the range of" "the 4th element of")
|
||||
extract-context-lines
|
||||
(λ () ((cadddr (contract (list/c integer? integer? boolean? (-> number? number?))
|
||||
(list 1 2 #f (λ (x) #f))
|
||||
'pos
|
||||
'neg))
|
||||
1))
|
||||
2)
|
||||
|
||||
(ctest '("a disjunct of")
|
||||
extract-context-lines
|
||||
(λ () (contract (or/c 1 (-> number? number?))
|
||||
3
|
||||
'pos
|
||||
'neg))
|
||||
1)
|
||||
|
||||
(ctest '("the range of" "a disjunct of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (or/c 1 (-> number? number?) (-> number? boolean? number?))
|
||||
(λ (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
2)
|
||||
|
||||
(ctest '("the 2nd conjunct of")
|
||||
extract-context-lines
|
||||
(λ () (contract (and/c procedure? (-> integer? integer?))
|
||||
(λ (x y) 1)
|
||||
'pos
|
||||
'neg))
|
||||
1)
|
||||
|
||||
(ctest '("an element of")
|
||||
extract-context-lines
|
||||
(λ () (contract (listof number?)
|
||||
(list #f)
|
||||
'pos
|
||||
'neg))
|
||||
1)
|
||||
|
||||
(ctest '("the promise from")
|
||||
extract-context-lines
|
||||
(λ () (force (contract (promise/c number?)
|
||||
(delay #f)
|
||||
'pos
|
||||
'neg)))
|
||||
1)
|
||||
|
||||
(ctest '("the parameter of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (parameter/c number?)
|
||||
(make-parameter #f)
|
||||
'pos
|
||||
'neg)))
|
||||
1)
|
||||
(ctest '("the parameter of")
|
||||
extract-context-lines
|
||||
(λ () ((contract (parameter/c number?)
|
||||
(make-parameter 1)
|
||||
'pos
|
||||
'neg)
|
||||
#f))
|
||||
1)
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user