From a8994c72611caffac15d4744f2db900d0622fe00 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 8 May 2012 11:39:08 -0400 Subject: [PATCH] Revert "Add contract-add-context to contract system." This reverts commit f3b687c8ed62bf224345f443293f3d1b93474f33. 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. --- collects/racket/contract/private/misc.rkt | 70 +------------------ .../scribblings/reference/contracts.scrbl | 12 ---- collects/tests/racket/contract-test.rktl | 46 ------------ 3 files changed, 1 insertion(+), 127 deletions(-) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index d8b98610b3..2630c53dfb 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -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)) \ No newline at end of file diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index d778011633..b1c88a6cb8 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -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 diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 2af37db0ae..8ef4c8569d 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -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