From 8bcb035693ab40caad3c55a49c51bcd2dc35474d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 11 Mar 2016 11:39:52 -0600 Subject: [PATCH] add suggest/c --- .../scribblings/reference/contracts.scrbl | 19 ++++++++++ .../tests/racket/contract/blame.rkt | 12 ++++++ racket/collects/racket/contract.rkt | 3 +- racket/collects/racket/contract/base.rkt | 3 ++ .../racket/contract/private/blame.rkt | 37 ++++++++++++++++--- .../collects/racket/contract/private/misc.rkt | 27 +++++++++++++- 6 files changed, 93 insertions(+), 8 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 2c60e97e66..15c371416e 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -984,6 +984,25 @@ This function is a holdover from before @tech{flat contracts} could be used directly as predicates. It exists today for backwards compatibility. } +@defproc[(suggest/c [c contract?] + [field string?] + [message string?]) contract?]{ + Returns a contract that behaves like @racket[c], except + that it adds an extra line to the error message on a contract + violation. + + The @racket[field] and @racket[message] strings are added + following the guidelines in + @secref["err-msg-conventions"]. + + @examples[#:eval (contract-eval) #:once + (define allow-calls? #f) + (define/contract (f) + (suggest/c (->* () #:pre allow-calls? any) + "suggestion" "maybe you should set! allow-calls? to #t") + 5) + (eval:error (f))] +} @; ------------------------------------------------------------------------ diff --git a/pkgs/racket-test/tests/racket/contract/blame.rkt b/pkgs/racket-test/tests/racket/contract/blame.rkt index 61f70d0469..e8eabaab33 100644 --- a/pkgs/racket-test/tests/racket/contract/blame.rkt +++ b/pkgs/racket-test/tests/racket/contract/blame.rkt @@ -283,4 +283,16 @@ (define-struct/contract thing ([stuff flat-blame-ok/c])) (thing-stuff (thing 5))))) + (test/spec-passed/result + 'suggest/c1 + '(with-handlers ([exn:fail? + (λ (x) + (define m (regexp-match #rx"suggestion:[^\n]*\n" + (exn-message x))) + (and m (car m)))]) + (contract (suggest/c zero? "suggestion" "try zero?") + 1 + 'pos 'neg)) + "suggestion: try zero?\n") + ) diff --git a/racket/collects/racket/contract.rkt b/racket/collects/racket/contract.rkt index e744348c81..0cb54b1f11 100644 --- a/racket/collects/racket/contract.rkt +++ b/racket/collects/racket/contract.rkt @@ -5,7 +5,8 @@ "contract/region.rkt" "contract/private/legacy.rkt" "contract/private/ds.rkt" - "contract/private/generate.rkt") + "contract/private/generate.rkt" + "contract/private/blame.rkt") (provide (all-from-out "contract/base.rkt" "contract/combinator.rkt" "contract/parametric.rkt" diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index 243f92d39f..d2b97e703e 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -141,6 +141,8 @@ contract-val-first-projection get/build-late-neg-projection get/build-val-first-projection + + suggest/c ;; not documented.... (ie unintentional export) n->th) @@ -152,3 +154,4 @@ ;; the argument is simply the value to return. (define failure-result/c (if/c procedure? (-> any) any/c)) + diff --git a/racket/collects/racket/contract/private/blame.rkt b/racket/collects/racket/contract/private/blame.rkt index da3b3b925c..f2d27f8064 100644 --- a/racket/collects/racket/contract/private/blame.rkt +++ b/racket/collects/racket/contract/private/blame.rkt @@ -19,6 +19,7 @@ blame-add-missing-party blame-missing-party? + blame-add-extra-field raise-blame-error current-blame-format @@ -53,7 +54,8 @@ ;; is still missing and it is #f when the missing party ;; has been filled in (or if it was filled in from the start) (define-struct blame - [source value build-name positive negative original? context top-known? important missing-party?] + [source value build-name positive negative original? context top-known? important missing-party? + extra-fields] #:property prop:equal+hash (list blame=? blame-hash blame-hash)) @@ -80,7 +82,8 @@ '() #t #f - (not negative)))]) + (not negative) + '()))]) make-blame)) ;; s : (or/c string? #f) @@ -183,7 +186,7 @@ (raise (make-exn:fail:contract:blame - ((current-blame-format) + ((current-blame-format) blame x (apply format (blame-fmt->-string blame fmt) args)) (current-continuation-marks) @@ -331,6 +334,8 @@ (define custom-message-appears-to-start-with-fields? (regexp-match? #rx"^[^\n]*:" custom-message)) + + (define extra-fields (blame-extra-fields blme)) (combine-lines (if custom-message-appears-to-start-with-fields? @@ -340,6 +345,7 @@ " ~a" " ~a") custom-message) + extra-fields context-lines (if context-lines contract-line @@ -352,16 +358,35 @@ " (assuming the contract is correct)" at-line)) -;; combine-lines : (->* #:rest (listof (or/c string? #f))) string?) +(define (blame-add-extra-field b name field) + (unless (blame? b) + (raise-argument-error 'blame-add-extra-field + "blame?" + 0 b name field)) + (unless (string? name) + (raise-argument-error 'blame-add-extra-field + "string?" + 1 b name field)) + (unless (string? field) + (raise-argument-error 'blame-add-extra-field + "string?" + 2 b name field)) + (struct-copy + blame b + [extra-fields (cons (format " ~a: ~a" name field) + (blame-extra-fields b))])) + +;; combine-lines : (-> (listof (or/c string? #f))) string?) ;; combines each of 'lines' into a single message, dropping #fs, ;; and otherwise guaranteeing that each string is on its own line, -;; with no ending newline. +;; with no ending newline. (Note that the argument contract is +;; more restrictive than the function actually requires) (define (combine-lines . lines) (regexp-replace #rx"\n$" (apply string-append - (for/list ([line (in-list lines)] + (for/list ([line (in-list (flatten lines))] #:when (string? line)) (if (regexp-match #rx"\n$" line) line diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 7c0ae6598d..be53f38773 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -49,7 +49,9 @@ if/c pairwise-stronger-contracts? - check-two-args) + check-two-args + + suggest/c) (define-syntax (flat-murec-contract stx) (syntax-case stx () @@ -1012,3 +1014,26 @@ (and (contract-struct-stronger? (car c1s) (car c2s)) (loop (cdr c1s) (cdr c2s)))] [else #f]))) + +(define (suggest/c _ctc field message) + (define ctc (coerce-contract 'suggest/c _ctc)) + (unless (string? field) + (raise-argument-error 'suggest/c + "string?" + 1 _ctc field message)) + (unless (string? message) + (raise-argument-error 'suggest/c + "string?" + 2 _ctc field message)) + (define ctc-lnp (contract-late-neg-projection ctc)) + (define constructor + (cond + [(flat-contract? ctc) make-flat-contract] + [(chaperone-contract? ctc) make-chaperone-contract] + [else make-contract])) + (constructor + #:name (contract-name ctc) + #:first-order (contract-first-order ctc) + #:late-neg-projection (λ (b) (ctc-lnp (blame-add-extra-field b field message))) + #:stronger (λ (this that) (contract-stronger? ctc that)) + #:list-contract? (list-contract? ctc)))