remove the user field from blame structs (code cleanup after last commit)

This commit is contained in:
Robby Findler 2011-02-12 11:29:20 -06:00
parent a8e9eabf7d
commit 2308ad7b8a
4 changed files with 7 additions and 41 deletions

View File

@ -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)

View File

@ -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)
" " " "
",") ",")

View File

@ -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))

View File

@ -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)])