From f3b687c8ed62bf224345f443293f3d1b93474f33 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 3 May 2012 20:14:21 -0400 Subject: [PATCH] Add contract-add-context to contract system. This procedure is used to add blame contexts to an existing contract. This prevents the need to re-create the contract in order to add blame contexts. --- collects/racket/contract/private/misc.rkt | 70 ++++++++++++++++++- .../scribblings/reference/contracts.scrbl | 12 ++++ collects/tests/racket/contract-test.rktl | 46 ++++++++++++ 3 files changed, 127 insertions(+), 1 deletion(-) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 2630c53dfb..d8b98610b3 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -45,7 +45,9 @@ contract-projection contract-name - n->th) + n->th + + contract-add-context) (define-syntax (flat-rec-contract stx) (syntax-case stx () @@ -1013,3 +1015,69 @@ [(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)) \ No newline at end of file diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index e673e49078..5065fbb597 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -2059,6 +2059,18 @@ 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 diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index cc04348813..694db4927c 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -8391,6 +8391,52 @@ [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))))) + ; ; ;