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

Revert "Add contract-add-context to contract system."

Browse Source 
This reverts commit f3b687c8ed.

After discussion with Robby and Stevie, we concluded that
this procedure isn't necessary for now. If we ever think
of more examples where it's useful we can bring it back.
This commit is contained in:
Asumu Takikawa 2012-05-08 11:39:08 -04:00
parent e786149434
commit a8994c7261
3 changed files with 1 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/racket/contract/private/misc.rkt
View File

@ -45,9 +45,7 @@
contract-projection
contract-name
n->th
contract-add-context)
n->th)
(define-syntax (flat-rec-contract stx)
(syntax-case stx ()
@ -1015,69 +1013,3 @@
[(3) "rd"]
[else "th"])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Adding blame context information to a contract
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; contract (or/c string #f) (or/c string #f) any -> contract
;; Wrap the given contract, adding blame context information
(define (contract-add-context contract context
#:important [important #f]
#:swap? [swap #f])
(define ctc (coerce-contract 'contract-add-context contract))
(unless (or (string? context) (not context))
(raise-type-error 'contract-add-context "string or #f" context))
(unless (or (string? important) (not important))
(raise-type-error 'contract-add-context "string or #f" important))
(cond [(flat-contract? ctc)
(flat-wrapper/c ctc context important swap)]
[(chaperone-contract? ctc)
(chaperone-wrapper/c ctc context important swap)]
[else
(impersonator-wrapper/c ctc context important swap)]))
;; utilities for wrapping
(define (wrapper/c-name ctc)
(contract-name (wrapper/c-ctc ctc)))
(define ((wrapper/c-first-order ctc) v)
(contract-first-order-passes? (wrapper/c-ctc ctc) v))
(define (wrapper/c-projection ctc)
(define proj (contract-projection (wrapper/c-ctc ctc)))
(λ (blame)
(define new-blame (construct-new-blame blame ctc))
(proj new-blame)))
;; use blade-add-context to construct a new blame object
(define (construct-new-blame blame ctc)
(define ctx (wrapper/c-context ctc))
(define imp? (wrapper/c-important ctc))
(define swap? (wrapper/c-swap? ctc))
(blame-add-context blame ctx #:important imp? #:swap? swap?))
;; wrappers that track the extra context info to be added
(struct wrapper/c (ctc context important swap?))
(struct flat-wrapper/c wrapper/c ()
#:property prop:flat-contract
(build-flat-contract-property
#:name wrapper/c-name
#:first-order wrapper/c-first-order
#:projection wrapper/c-projection))
(struct chaperone-wrapper/c wrapper/c ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name wrapper/c-name
#:first-order wrapper/c-first-order
#:projection wrapper/c-projection))
(struct impersonator-wrapper/c wrapper/c ()
#:property prop:contract
(build-contract-property
#:name wrapper/c-name
#:first-order wrapper/c-first-order
#:projection wrapper/c-projection))

12
collects/scribblings/reference/contracts.scrbl
View File

@ -2084,18 +2084,6 @@ Produces the name used to describe the contract in error messages.
Produces the projection defining a contract's behavior on protected values.
}
@defproc[(contract-add-context [contract contract?]
[context (or/c string? #f)]
[#:important important (or/c string? #f) #f]
[#:swap? swap? any/c #f])
contract?]{
Produces a new contract that checks like @racket[contract], but
adds the context information @racket[context] to the resulting blame error
messages. The arguments are similar to those of @racket[blame-add-context].
See also @racket[blame-add-context].
}
@defproc[(make-none/c [sexp-name any/c]) contract?]{
Makes a contract that accepts no values, and reports the

46
collects/tests/racket/contract-test.rktl
View File

@ -8401,52 +8401,6 @@
[o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)])
(send o m #t)))
;; contract-add-context tests
(contract-error-test
'contract-add-context-1
#'((contract
(contract-add-context (-> integer? integer?)
"additional info")
(λ (x) "bad")
'pos
'neg)
5)
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match #rx"additional info" (exn-message x)))))
(contract-error-test
'contract-add-context-2
#'((contract
(contract-add-context (-> integer? integer?)
"additional info"
#:important "starts with")
(λ (x) "bad")
'pos
'neg)
5)
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match #rx"additional info" (exn-message x))
(regexp-match #rx"^starts with:" (exn-message x))
(regexp-match #rx"blaming: pos" (exn-message x)))))
(contract-error-test
'contract-add-context-3
#'((contract
(contract-add-context (-> integer? integer?)
"additional info"
#:swap? #t)
(λ (x) "bad")
'pos
'neg)
5)
(λ (x)
(and (exn:fail:contract:blame? x)
(regexp-match #rx"additional info" (exn-message x))
(regexp-match #rx"blaming: neg" (exn-message x)))))
;; interface contracts
(test/spec-passed