add suggest/c

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))]
+}
 
 @; ------------------------------------------------------------------------
 

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")
+
   )

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"

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))
+

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

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)))