Change contract error reporting back to how it was (at least how it is on
unit-contracts, which avoids the spacing issue), and just change the blame notation so that we can still report the region/definition stuff. svn: r13122
This commit is contained in:
Stevie Strickland
parent
9facb3ffaf
commit
8ef9977f57
|
|
@ -102,9 +102,10 @@ v4 todo:
|
|||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let* ([doms-proj (map (λ (x) ((proj-get x) x)) (->-doms/c ctc))]
|
||||
[rest-proj (and (->-dom-rest/c ctc)
|
||||
((λ (x) ((proj-get x) x)) (->-dom-rest/c ctc)))]
|
||||
(let* ([doms-proj (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest/c ctc)
|
||||
(append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
|
||||
(->-doms/c ctc)))]
|
||||
[doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
|
||||
[rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
|
||||
[mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
|
||||
|
|
@ -116,36 +117,22 @@ v4 todo:
|
|||
[optionals-length (length (->-optional-doms/c ctc))]
|
||||
[has-rest? (and (->-dom-rest/c ctc) #t)])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (for/list ([dom (in-list doms-proj)]
|
||||
[n (in-naturals 1)])
|
||||
(dom neg-blame pos-blame src-info
|
||||
(cons (format "required argument ~a" n) orig-str)))]
|
||||
[partial-rest (if rest-proj
|
||||
(list (rest-proj neg-blame pos-blame src-info
|
||||
(cons "rest argument" orig-str)))
|
||||
null)]
|
||||
[partial-optional-doms (for/list ([dom (in-list doms-optional-proj)]
|
||||
[n (in-naturals 1)])
|
||||
(dom neg-blame pos-blame src-info
|
||||
(cons (format "optional argument ~a" n) orig-str)))]
|
||||
[partial-ranges (for/list ([rng (in-list rngs-proj)]
|
||||
[n (in-naturals 1)])
|
||||
(rng pos-blame neg-blame src-info
|
||||
(cons (format "result ~a" n) orig-str)))]
|
||||
[partial-mandatory-kwds (for/list ([kwd (in-list mandatory-kwds-proj)]
|
||||
[kwd-lit (in-list mandatory-keywords)])
|
||||
(kwd neg-blame pos-blame src-info
|
||||
(cons (format "keyword argument ~a" kwd-lit) orig-str)))]
|
||||
[partial-optional-kwds (for/list ([kwd (in-list optional-kwds-proj)]
|
||||
[kwd-lit (in-list optional-keywords)])
|
||||
(kwd neg-blame pos-blame src-info
|
||||
(cons (format "keyword argument ~a" kwd-lit) orig-str)))])
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms-proj)]
|
||||
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms-optional-proj)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs-proj)]
|
||||
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
mandatory-kwds-proj)]
|
||||
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
optional-kwds-proj)])
|
||||
(apply func
|
||||
(λ (val mtd?)
|
||||
(if has-rest?
|
||||
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-rest partial-optional-doms
|
||||
(append partial-doms partial-optional-doms
|
||||
partial-mandatory-kwds partial-optional-kwds
|
||||
partial-ranges))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "contract-helpers.ss"
|
||||
scheme/pretty
|
||||
(only-in scheme/list add-between))
|
||||
scheme/pretty)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
"contract-helpers.ss"))
|
||||
|
|
@ -176,35 +175,22 @@
|
|||
(lambda (x) (get x 0))
|
||||
(lambda (x) (get x 1)))))
|
||||
|
||||
(define (default-contract-violation->string val src-info to-blame contract-sexp+extra msg)
|
||||
(define (add-modifiers-to-contract modifiers contract-str)
|
||||
(if (null? modifiers)
|
||||
contract-str
|
||||
(string-append "for "
|
||||
(apply string-append (add-between modifiers " of "))
|
||||
" in " contract-str)))
|
||||
(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
|
||||
(let ([blame-src (src-info-as-string src-info)]
|
||||
[formatted-contract-sexp
|
||||
(let-values ([(modifiers contract-sexp)
|
||||
(let loop ([dlist contract-sexp+extra]
|
||||
[modifiers null])
|
||||
(if (and (pair? dlist)
|
||||
(string? (car dlist)))
|
||||
(loop (cdr dlist) (cons (car dlist) modifiers))
|
||||
(values (reverse modifiers) dlist)))])
|
||||
(let ([one-line
|
||||
(let ([sp (open-output-string)])
|
||||
(parameterize ([pretty-print-columns 'infinity])
|
||||
(pretty-print contract-sexp sp)
|
||||
(get-output-string sp)))])
|
||||
(if (< (string-length one-line) 30)
|
||||
(add-modifiers-to-contract modifiers one-line)
|
||||
(let ([sp (open-output-string)])
|
||||
(newline sp)
|
||||
(parameterize ([pretty-print-print-line print-contract-liner]
|
||||
[pretty-print-columns 50])
|
||||
(pretty-print contract-sexp sp))
|
||||
(add-modifiers-to-contract modifiers (get-output-string sp))))))]
|
||||
(let ([one-line
|
||||
(let ([sp (open-output-string)])
|
||||
(parameterize ([pretty-print-columns 'infinity])
|
||||
(pretty-print contract-sexp sp)
|
||||
(get-output-string sp)))])
|
||||
(if (< (string-length one-line) 30)
|
||||
one-line
|
||||
(let ([sp (open-output-string)])
|
||||
(newline sp)
|
||||
(parameterize ([pretty-print-print-line print-contract-liner]
|
||||
[pretty-print-columns 50])
|
||||
(pretty-print contract-sexp sp))
|
||||
(get-output-string sp))))]
|
||||
[specific-blame
|
||||
(cond
|
||||
[(syntax? src-info)
|
||||
|
|
@ -223,9 +209,8 @@
|
|||
(pair? (cdr to-blame))
|
||||
(null? (cddr to-blame))
|
||||
(equal? 'quote (car to-blame)))
|
||||
(format "module '~s" (cadr to-blame))]
|
||||
[(string? to-blame) to-blame]
|
||||
[else (format "module ~s" to-blame)])
|
||||
(format "'~s" (cadr to-blame))]
|
||||
[else (format "~s" to-blame)])
|
||||
formatted-contract-sexp
|
||||
specific-blame)
|
||||
msg)))
|
||||
|
|
|
|||
|
|
@ -135,13 +135,12 @@ improve method arity mismatch contract violation error messages?
|
|||
;
|
||||
;
|
||||
|
||||
(define-syntax-parameter current-contract-region #f)
|
||||
(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference)))
|
||||
|
||||
(define-for-syntax (make-with-contract-transformer contract-id id pos-blame-id)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
|
||||
#'(#%variable-reference))]
|
||||
(with-syntax ([neg-blame-id #'(current-contract-region)]
|
||||
[pos-blame-id pos-blame-id]
|
||||
[contract-id contract-id]
|
||||
[id id])
|
||||
|
|
@ -259,10 +258,10 @@ improve method arity mismatch contract violation error messages?
|
|||
dupd-id))
|
||||
(check-exports (append unprotected protected) expanded-bodies))
|
||||
(with-syntax ([(contract-def ...) (map marker (filter values contract-defs))]
|
||||
[blame-str (format "~a ~a" (syntax-e #'type) (syntax-e #'blame))]
|
||||
[blame-stx #''(type blame)]
|
||||
[(marked-body ...) (map marker expanded-bodies)])
|
||||
(quasisyntax/loc stx
|
||||
(splicing-syntax-parameterize ([current-contract-region blame-str])
|
||||
(splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
|
||||
marked-body ...
|
||||
contract-def ...
|
||||
#,@(map (λ (p c)
|
||||
|
|
@ -270,7 +269,7 @@ improve method arity mismatch contract violation error messages?
|
|||
(make-with-contract-transformer
|
||||
(quote-syntax #,(marker c))
|
||||
(quote-syntax #,(marker p))
|
||||
blame-str)))
|
||||
(quote-syntax blame-stx))))
|
||||
protected-ids contracts)
|
||||
#,@(map (λ (u)
|
||||
#`(define-syntax #,u
|
||||
|
|
@ -279,7 +278,7 @@ improve method arity mismatch contract violation error messages?
|
|||
(define-values ()
|
||||
(begin
|
||||
#,@(map (λ (p c)
|
||||
#`(-contract #,(marker c) #,p blame-str 'ignored #,(id->contract-src-info p)))
|
||||
#`(-contract #,(marker c) #,p blame-stx 'ignored #,(id->contract-src-info p)))
|
||||
protected-ids contracts)
|
||||
(values)))
|
||||
)))))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user