remove the user field from blame structs (code cleanup after last commit)
This commit is contained in:
parent
a8e9eabf7d
commit
2308ad7b8a
|
@ -28,25 +28,24 @@ improve method arity mismatch contract violation error messages?
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ c v pos neg name loc)
|
[(_ c v pos neg name loc)
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(apply-contract c v pos neg name loc (current-contract-region)))]
|
(apply-contract c v pos neg name loc))]
|
||||||
[(_ c v pos neg)
|
[(_ c v pos neg)
|
||||||
(with-syntax ([name (syntax-local-infer-name stx)])
|
(with-syntax ([name (syntax-local-infer-name stx)])
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(apply-contract c v pos neg 'name
|
(apply-contract c v pos neg 'name
|
||||||
(build-source-location #f)
|
(build-source-location #f))))]
|
||||||
(current-contract-region))))]
|
|
||||||
[(_ c v pos neg src)
|
[(_ c v pos neg src)
|
||||||
(raise-syntax-error 'contract
|
(raise-syntax-error 'contract
|
||||||
(string-append
|
(string-append
|
||||||
"please update contract application to new protocol "
|
"please update contract application to new protocol "
|
||||||
"(either 4 or 6 arguments)"))]))
|
"(either 4 or 6 arguments)"))]))
|
||||||
|
|
||||||
(define (apply-contract c v pos neg name loc usr)
|
(define (apply-contract c v pos neg name loc)
|
||||||
(let ([c (coerce-contract 'contract c)])
|
(let ([c (coerce-contract 'contract c)])
|
||||||
(check-source-location! 'contract loc)
|
(check-source-location! 'contract loc)
|
||||||
(let ([new-val
|
(let ([new-val
|
||||||
(((contract-projection c)
|
(((contract-projection c)
|
||||||
(make-blame loc name (contract-name c) pos neg usr #t))
|
(make-blame loc name (contract-name c) pos neg #t))
|
||||||
v)])
|
v)])
|
||||||
(if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
|
(if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
|
||||||
(procedure? new-val)
|
(procedure? new-val)
|
||||||
|
|
|
@ -7,7 +7,6 @@
|
||||||
blame-source
|
blame-source
|
||||||
blame-positive
|
blame-positive
|
||||||
blame-negative
|
blame-negative
|
||||||
blame-user
|
|
||||||
blame-contract
|
blame-contract
|
||||||
blame-value
|
blame-value
|
||||||
blame-original?
|
blame-original?
|
||||||
|
@ -36,7 +35,7 @@
|
||||||
(hash/recur (blame-original? b))))
|
(hash/recur (blame-original? b))))
|
||||||
|
|
||||||
(define-struct blame
|
(define-struct blame
|
||||||
[source value contract positive negative user original?]
|
[source value contract positive negative original?]
|
||||||
#:property prop:equal+hash
|
#:property prop:equal+hash
|
||||||
(list blame=? blame-hash blame-hash))
|
(list blame=? blame-hash blame-hash))
|
||||||
|
|
||||||
|
@ -101,16 +100,11 @@
|
||||||
contract-message+at)]
|
contract-message+at)]
|
||||||
[else
|
[else
|
||||||
(define negative-message (show/display (blame-negative b)))
|
(define negative-message (show/display (blame-negative b)))
|
||||||
(define user-message
|
|
||||||
(if (equal? (blame-positive b) (blame-user b))
|
|
||||||
""
|
|
||||||
(format " via ~a" (show/display (blame-user b)))))
|
|
||||||
(string-append
|
(string-append
|
||||||
(format "contract violation: ~a\n" custom-message)
|
(format "contract violation: ~a\n" custom-message)
|
||||||
(format " contract~a from ~a~a~a blaming ~a~a"
|
(format " contract~a from ~a~a blaming ~a~a"
|
||||||
value-message
|
value-message
|
||||||
negative-message
|
negative-message
|
||||||
user-message
|
|
||||||
(if (regexp-match #rx"\n" negative-message)
|
(if (regexp-match #rx"\n" negative-message)
|
||||||
" "
|
" "
|
||||||
",")
|
",")
|
||||||
|
|
|
@ -21,8 +21,7 @@
|
||||||
name
|
name
|
||||||
(unpack-blame pos)
|
(unpack-blame pos)
|
||||||
"<<unknown party>>"
|
"<<unknown party>>"
|
||||||
#t
|
#t)
|
||||||
"<<unknown party>>")
|
|
||||||
x
|
x
|
||||||
fmt
|
fmt
|
||||||
args))
|
args))
|
||||||
|
|
|
@ -39,32 +39,6 @@
|
||||||
(current-inspector) #f '(0))])
|
(current-inspector) #f '(0))])
|
||||||
make-))
|
make-))
|
||||||
|
|
||||||
(define (first-requiring-module id self)
|
|
||||||
(define (resolved-module-path->module-path rmp)
|
|
||||||
(cond
|
|
||||||
[(not rmp) 'top-level]
|
|
||||||
[(path? (resolved-module-path-name rmp))
|
|
||||||
`(file ,(path->string (resolved-module-path-name rmp)))]
|
|
||||||
[(symbol? (resolved-module-path-name rmp))
|
|
||||||
`(module ,(resolved-module-path-name rmp))]))
|
|
||||||
;; Here we get the module-path-index corresponding to the identifier.
|
|
||||||
;; We know we can split it at least once, because the contracted identifier
|
|
||||||
;; we've provided must have been required. If the second returned value is #f,
|
|
||||||
;; we just fall back on the old behavior. If we split again without getting
|
|
||||||
;; either "self", that is, the first value returned is not #f, then we should
|
|
||||||
;; use the second mpi result as the module that required the value.
|
|
||||||
(let ([mpi (syntax-source-module id)])
|
|
||||||
(let*-values ([(first-mp second-mpi)
|
|
||||||
(module-path-index-split mpi)]
|
|
||||||
[(second-mp third-mpi)
|
|
||||||
(if second-mpi
|
|
||||||
(module-path-index-split second-mpi)
|
|
||||||
(values #f #f))])
|
|
||||||
(if second-mp
|
|
||||||
(resolved-module-path->module-path
|
|
||||||
(module-path-index-resolve second-mpi))
|
|
||||||
self))))
|
|
||||||
|
|
||||||
(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
|
(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source)
|
||||||
(make-set!-transformer
|
(make-set!-transformer
|
||||||
(let ([saved-id-table (make-hasheq)])
|
(let ([saved-id-table (make-hasheq)])
|
||||||
|
|
Loading…
Reference in New Issue
Block a user