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

add suggest/c

Browse Source
This commit is contained in:
Robby Findler 2016-03-11 11:39:52 -06:00
parent 33acbaeaf1
commit 8bcb035693
6 changed files with 93 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

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

12
pkgs/racket-test/tests/racket/contract/blame.rkt
View File

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

3
racket/collects/racket/contract.rkt
View File

@ -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"

3
racket/collects/racket/contract/base.rkt
View File

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

37
racket/collects/racket/contract/private/blame.rkt
View File

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

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

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