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

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

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/racket/contract/private/base.rkt
View File

@ -28,25 +28,24 @@ improve method arity mismatch contract violation error messages?
(syntax-case stx ()
[(_ c v pos neg name loc)
(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)
(with-syntax ([name (syntax-local-infer-name stx)])
(syntax/loc stx
(apply-contract c v pos neg 'name
(build-source-location #f)
(current-contract-region))))]
(build-source-location #f))))]
[(_ c v pos neg src)
(raise-syntax-error 'contract
(string-append
"please update contract application to new protocol "
"(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)])
(check-source-location! 'contract loc)
(let ([new-val
(((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)])
(if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
(procedure? new-val)

10
collects/racket/contract/private/blame.rkt
View File

@ -7,7 +7,6 @@
blame-source
blame-positive
blame-negative
blame-user
blame-contract
blame-value
blame-original?
@ -36,7 +35,7 @@
(hash/recur (blame-original? b))))
(define-struct blame
[source value contract positive negative user original?]
[source value contract positive negative original?]
#:property prop:equal+hash
(list blame=? blame-hash blame-hash))
@ -101,16 +100,11 @@
contract-message+at)]
[else
(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
(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
negative-message
user-message
(if (regexp-match #rx"\n" negative-message)
" "
",")

3
collects/racket/contract/private/legacy.rkt
View File

@ -21,8 +21,7 @@
name
(unpack-blame pos)
"<<unknown party>>"
#t
"<<unknown party>>")
#t)
x
fmt
args))

26
collects/racket/contract/private/provide.rkt
View File

@ -39,32 +39,6 @@
(current-inspector) #f '(0))])
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)
(make-set!-transformer
(let ([saved-id-table (make-hasheq)])