From 9d58a067e3370d9831296a7556bf6156bb207fed Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 22 Dec 2014 14:48:44 -0600 Subject: [PATCH] add #:pre/desc to ->* --- .../scribblings/reference/contracts.scrbl | 22 +++++- .../tests/racket/contract/arrow-star.rkt | 79 +++++++++++++++++++ .../contract/private/arrow-higher-order.rkt | 73 ++++++++++++++--- .../contract/private/arrow-val-first.rkt | 69 +++++++--------- .../racket/contract/private/arrow.rkt | 46 +++++++++-- 5 files changed, 224 insertions(+), 65 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index e3b28c6333..cf73a985ac 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -976,9 +976,13 @@ each value must match its respective contract.} [optional-doms (code:line) (optional-dom ...)] [optional-dom dom-expr (code:line keyword dom-expr)] [rest (code:line) (code:line #:rest rest-expr)] - [pre (code:line) (code:line #:pre pre-cond-expr)] + [pre (code:line) + (code:line #:pre pre-cond-expr) + (code:line #:pre/desc pre-cond-expr)] [range range-expr (values range-expr ...) any] - [post (code:line) (code:line #:post post-cond-expr)])]{ + [post (code:line) + (code:line #:post post-cond-expr) + (code:line #:post/desc post-cond-expr)])]{ The @racket[->*] contract combinator produces contracts for functions that accept optional arguments (either keyword or positional) and/or @@ -1005,14 +1009,24 @@ going to end up disallowing empty argument lists. The @racket[pre-cond-expr] and @racket[post-cond-expr] expressions are checked as the function is called and returns, respectively, and allow checking of the environment without an -explicit connection to an argument (or a result). +explicit connection to an argument (or a result). If the @racket[#:pre] +or @racket[#:post] keywords are used, then a @racket[#f] result is +treated as a failure and any other result is treated as success. +If the @racket[#:pre/desc] or @racket[#:post/desc] keyword is used, +the result of the expression must be either a boolean, a string, or a +list of strings, where @racket[#t] means success and any of the other +results mean failure. If the result is a string or a list of strings, +the strings are expected to have at exactly one space after each +newline and multiple are used as lines in the error message; the contract +itself adds single space of indentation to each of the strings in that case. +The formatting requirements are not checked but they +match the recommendations in @secref["err-msg-conventions"]. As an example, the contract @racketblock[(->* () (boolean? #:x integer?) #:rest (listof symbol?) symbol?)] matches functions that optionally accept a boolean, an integer keyword argument @racket[#:x] and arbitrarily more symbols, and that return a symbol. - } @defform*/subs[#:literals (any values) diff --git a/pkgs/racket-test/tests/racket/contract/arrow-star.rkt b/pkgs/racket-test/tests/racket/contract/arrow-star.rkt index 4f105543bf..04507c1668 100644 --- a/pkgs/racket-test/tests/racket/contract/arrow-star.rkt +++ b/pkgs/racket-test/tests/racket/contract/arrow-star.rkt @@ -14,6 +14,7 @@ (values (flat-contract integer?) (flat-contract boolean?)))) (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) any)) (test/no-error '(->* ((flat-contract integer?)) () #:pre #t (flat-contract integer?) #:post #t)) + (test/no-error '(->* (any/c) () #:pre/desc #t (flat-contract integer?) #:post/desc #t)) @@ -602,6 +603,84 @@ 'pos 'neg))) + (test/neg-blame + '->*pre/post-8 + '((contract (->* () () #:pre/desc #f integer? #:post/desc #f) + (λ () 1) + 'pos + 'neg))) + + (test/neg-blame + '->*pre/post-9 + '((contract (->* () () #:pre/desc "" integer? #:post/desc #f) + (λ () 1) + 'pos + 'neg))) + + (test/neg-blame + '->*pre/post-10 + '((contract (->* () () #:pre/desc '("qqq") integer? #:post/desc #f) + (λ () 1) + 'pos + 'neg))) + + (test/pos-blame + '->*pre/post-11 + '((contract (->* () () #:pre/desc #t integer? #:post/desc #f) + (λ () 1) + 'pos + 'neg))) + + (test/pos-blame + '->*pre/post-12 + '((contract (->* () () #:pre/desc #t integer? #:post/desc "") + (λ () 1) + 'pos + 'neg))) + + (test/pos-blame + '->*pre/post-13 + '((contract (->* () () #:pre/desc #t integer? #:post/desc '("qqc")) + (λ () 1) + 'pos + 'neg))) + + (test/pos-blame + '->*pre/post-14 + '((contract (->* () () #:pre/desc #t integer? #:post/desc '("qqc")) + (λ () 1) + 'pos + 'neg))) + + (test/neg-blame + '->*pre/post-15 + '((contract (->* (integer?) #:pre/desc '("something" "not so great" "happened") any) + (λ (x) 1) + 'pos 'neg) + 1)) + + (contract-error-test + '->*pre/post-16 + '((contract (->* () () #:pre/desc '("something wonderful") integer? #:post/desc '("qqc")) + (λ () 1) + 'pos + 'neg)) + (λ (x) + (and (exn:fail:contract? x) + (regexp-match #rx"\n *something wonderful\n" + (exn-message x))))) + + (contract-error-test + '->*pre/post-17 + '((contract (->* () () integer? #:post/desc "something horrible") + (λ () 1) + 'pos + 'neg)) + (λ (x) + (and (exn:fail:contract? x) + (regexp-match #rx"\n *something horrible\n" + (exn-message x))))) + (test/spec-passed '->*-opt-optional1 '((contract (->* () integer?) (lambda () 1) 'pos 'neg))) diff --git a/racket/collects/racket/contract/private/arrow-higher-order.rkt b/racket/collects/racket/contract/private/arrow-higher-order.rkt index 53a47da3e3..b5f18cd2be 100644 --- a/racket/collects/racket/contract/private/arrow-higher-order.rkt +++ b/racket/collects/racket/contract/private/arrow-higher-order.rkt @@ -12,17 +12,19 @@ (prefix-in arrow: "arrow.rkt")) (provide (for-syntax build-chaperone-constructor/real) - ->-proj) + ->-proj + check-pre-cond + check-post-cond) (define-for-syntax (build-chaperone-constructor/real this-args mandatory-dom-projs optional-dom-projs mandatory-dom-kwds optional-dom-kwds - pre + pre pre/desc rest rngs - post) + post post/desc) (define (nvars n sym) (generate-temporaries (for/list ([i (in-range n)]) sym))) (with-syntax ([(mandatory-dom-proj ...) (generate-temporaries mandatory-dom-projs)] [(optional-dom-proj ...) (generate-temporaries optional-dom-projs)] @@ -48,10 +50,11 @@ (map list optional-dom-kwds (syntax->list #'(optional-dom-kwd-proj ...))) - pre + pre pre/desc (if rest (car (syntax->list #'(rest-proj ...))) #f) (if rngs (syntax->list #'(rng-proj ...)) #f) - post)))) + post post/desc)))) + (define (check-pre-cond pre blame neg-party val) (unless (pre) @@ -65,24 +68,68 @@ #:missing-party neg-party val "#:post condition"))) +(define (check-pre-cond/desc post blame neg-party val) + (handle-pre-post/desc-string #t post blame neg-party val)) +(define (check-post-cond/desc post blame neg-party val) + (handle-pre-post/desc-string #f post blame neg-party val)) +(define (handle-pre-post/desc-string pre? thunk blame neg-party val) + (define condition-result (thunk)) + (cond + [(equal? condition-result #t) + (void)] + [else + (define msg + (cond + [(equal? condition-result #f) + (if pre? + "#:pre condition" + "#:post condition")] + [(string? condition-result) condition-result] + [(and (list? condition-result) + (andmap string? condition-result)) + (apply + string-append + (let loop ([s condition-result]) + (cond + [(null? s) '()] + [(null? (cdr s)) s] + [else (list* (car s) + "\n " + (loop (cdr s)))])))] + [else + (error + '->* + "expected #:~a/desc to produce (or/c boolean? string? (listof string?)), got ~e" + (if pre? "pre" "post") + condition-result)])) + (raise-blame-error (if pre? (blame-swap blame) blame) + #:missing-party neg-party + val "~a" msg)])) + (define-for-syntax (create-chaperone blame val this-args doms opt-doms req-kwds opt-kwds - pre + pre pre/desc dom-rest rngs - post) + post post/desc) (with-syntax ([blame blame] [val val]) (with-syntax ([(pre ...) - (if pre - (list #`(check-pre-cond #,pre blame neg-party val)) - null)] + (cond + [pre + (list #`(check-pre-cond #,pre blame neg-party val))] + [pre/desc + (list #`(check-pre-cond/desc #,pre/desc blame neg-party val))] + [else null])] [(post ...) - (if post - (list #`(check-post-cond #,post blame neg-party val)) - null)]) + (cond + [post + (list #`(check-post-cond #,post blame neg-party val))] + [post/desc + (list #`(check-post-cond/desc #,post/desc blame neg-party val))] + [else null])]) (with-syntax ([(this-param ...) this-args] [(dom-ctc ...) doms] [(dom-x ...) (generate-temporaries doms)] diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 7b90abe863..1d4867ab66 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -73,12 +73,12 @@ optional-args mandatory-kwds optional-kwds - pre + pre pre/desc rest rngs - post) - (define key (and (not pre) - (not post) + post post/desc) + (define key (and (not pre) (not pre/desc) + (not post) (not post/desc) (list (length regular-args) (length optional-args) (map syntax-e mandatory-kwds) @@ -100,20 +100,20 @@ optional-args mandatory-kwds optional-kwds - pre + pre pre/desc rest rngs - post) + post post/desc) (build-chaperone-constructor/real '() ;; this-args regular-args optional-args mandatory-kwds optional-kwds - pre + pre pre/desc rest rngs - post))])) + post post/desc))])) (define-syntax (build-populars stx) (syntax-case stx () @@ -142,20 +142,20 @@ mans opts mandatory-kwds optional-kwds - #f + #f #f rest rng-vars - #f)) + #f #f)) (define #,(syntax-local-introduce chaperone-id) #,(build-chaperone-constructor/real '() ;; this arg mans opts mandatory-kwds optional-kwds - #f + #f #f rest rng-vars - #f)))) + #f #f)))) (define popular-chaperone-key-table (make-hash (list #,@(for/list ([id (in-list popular-key-ids)] @@ -167,10 +167,10 @@ optional-args mandatory-kwds optional-kwds - pre + pre pre/desc rest rngs - post) + post post/desc) (with-syntax ([(regb ...) (generate-temporaries regular-args)] [(optb ...) (generate-temporaries optional-args)] [(kb ...) (generate-temporaries mandatory-kwds)] @@ -194,11 +194,11 @@ [(the-call ...) #'(f ((regb arg-x) neg-party) ... kwd-arg-exps ...)] [(pre-check ...) (if pre - (list #`(check-pre-condition blame neg-party f #,pre)) + (list #`(check-pre-cond #,pre blame neg-party f)) (list))] [(post-check ...) (if post - (list #`(check-post-condition blame neg-party f #,post)) + (list #`(check-post-cond #,post blame neg-party f)) (list))] [(restb) (generate-temporaries '(rest-args))]) (define body-proc @@ -412,19 +412,6 @@ [(keyword) (let loop ([args args] [regular-args '()] @@ -501,7 +488,7 @@ [rng (add-pos-obligations (list #'rng))])) (define-values (plus-one-arity-function chaperone-constructor) (build-plus-one-arity-function+chaperone-constructor - stx regular-args '() kwds '() #f #f rngs #f)) + stx regular-args '() kwds '() #f #f #f rngs #f #f)) (syntax-property #`(let #,let-bindings #,(quasisyntax/loc stx @@ -568,7 +555,7 @@ (syntax-case stx () [(_ (raw-mandatory-dom ...) . other) (let () - (define-values (raw-optional-doms rest-ctc pre rng-ctcs post) + (define-values (raw-optional-doms rest-ctc pre pre/desc rng-ctcs post post/desc) (arrow:parse-leftover->* stx #'other)) (with-syntax ([(man-dom man-dom-kwds @@ -585,13 +572,13 @@ #'opt-dom #'opt-dom-kwds #'opt-lets - rest-ctc pre rng-ctcs post)))])) + rest-ctc pre pre/desc rng-ctcs post post/desc)))])) (define-for-syntax (->*-valid-app-shapes stx) (define this->* (gensym 'this->*)) (define-values (man-dom man-dom-kwds man-lets opt-dom opt-dom-kwds opt-lets - rest-ctc pre rng-ctcs post) + rest-ctc pre pre/desc rng-ctcs post post/desc) (parse->*2 stx this->*)) (with-syntax ([((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds] [((optional-dom-kwd optional-dom-kwd-ctc) ...) opt-dom-kwds]) @@ -607,7 +594,7 @@ (define this->* (gensym 'this->*)) (define-values (man-dom man-dom-kwds man-lets opt-dom opt-dom-kwds opt-lets - rest-ctc pre rng-ctcs post) + rest-ctc pre pre/desc rng-ctcs post post/desc) (parse->*2 stx this->*)) (with-syntax ([(mandatory-dom ...) man-dom] [((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...) man-dom-kwds] @@ -618,11 +605,11 @@ [(pre-x post-x) (generate-temporaries '(pre-cond post-cond))]) (with-syntax ([((kwd dom opt?) ...) #'((mandatory-dom-kwd mandatory-dom-kwd-ctc #f) ... (optional-dom-kwd optional-dom-kwd-ctc #t) ...)] - [(pre-let-binding ...) (if pre - (list #`[pre-x (λ () #,pre)]) - (list))] - [(post-let-binding ...) (if post - (list #`[post-x (λ () #,post)]) + [(pre-let-binding ...) (if (or pre pre/desc) + (list #`[pre-x (λ () #,(or pre pre/desc))]) + (list))] + [(post-let-binding ...) (if (or post post/desc) + (list #`[post-x (λ () #,(or post post/desc))]) (list))]) (define-values (plus-one-arity-function chaperone-constructor) (build-plus-one-arity-function+chaperone-constructor @@ -632,9 +619,11 @@ (syntax->list #'(mandatory-dom-kwd ...)) (syntax->list #'(optional-dom-kwd ...)) (and pre #'pre-x) + (and pre/desc #'pre-x) rest-ctc rng-ctcs - (and post #'post-x))) + (and post #'post-x) + (and post/desc #'post-x))) (syntax-property #`(let (mandatory-let-bindings ... optional-let-bindings ... diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index b2c625ee45..9a44fad451 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -836,6 +836,8 @@ (values #'() leftover)] [(rng #:post . rst) (values #'() leftover)] + [(rng #:post/desc . rst) + (values #'() leftover)] [(rng) (values #'() leftover)] [((raw-optional-dom ...) . leftover) @@ -847,11 +849,13 @@ [(#:rest rest-expr . leftover) (values #'rest-expr #'leftover)] [_ (values #f leftover)])] - [(pre leftover) + [(pre pre/desc leftover) (syntax-case leftover () [(#:pre pre-expr . leftover) - (values #'pre-expr #'leftover)] - [_ (values #f leftover)])] + (values #'pre-expr #f #'leftover)] + [(#:pre/desc pre-expr . leftover) + (values #f #'pre-expr #'leftover)] + [_ (values #f #f leftover)])] [(rng leftover) (syntax-case leftover (any values) [(any) (values #f #'())] @@ -865,22 +869,33 @@ (values #'(rng) #'leftover))] [_ (raise-syntax-error #f "expected a range contract" stx leftover)])] - [(post leftover) + [(post post/desc leftover) (syntax-case leftover () [(#:post post-expr . leftover) - (values #'post-expr #'leftover)] + (values #'post-expr #f #'leftover)] + [(#:post/desc post-expr . leftover) + (values #f #'post-expr #'leftover)] [else - (values #f leftover)])]) + (values #f #f leftover)])]) (syntax-case leftover () - [() (values raw-optional-doms rst pre rng post)] + [() (values raw-optional-doms rst pre pre/desc rng post post/desc)] [x (raise-syntax-error #f "expected the end of the contract" stx #'x)]))) ;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) (define-for-syntax (->*/proc/main stx) (syntax-case* stx (->* any) module-or-top-identifier=? [(->* (raw-mandatory-dom ...) . rst) - (let-values ([(raw-optional-doms rest-ctc pre rng-ctc post) + (let-values ([(raw-optional-doms rest-ctc raw-pre pre/desc rng-ctc raw-post post/desc) (parse-leftover->* stx #'rst)]) + (define pre (cond + [raw-pre raw-pre] + [pre/desc + #`(convert-pre-post/desc-to-boolean #t #,pre/desc)] + [else #f])) + (define post (cond + [raw-post raw-post] + [post/desc #`(convert-pre-post/desc-to-boolean #f #,post/desc)] + [else #f])) (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)) (split-doms stx '->* #'(raw-mandatory-dom ...))] [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...)) @@ -962,6 +977,21 @@ (syntax->list #'(optional-dom-kwd-proj ...))) (if rng-ctc (syntax->list #'(rng-proj ...)) #f)))))))))))])) +(define (convert-pre-post/desc-to-boolean pre? b) + (cond + [(not b) #f] + [(or (not b) + (string? b) + (and (list? b) + (andmap string? b))) + #f] + [(equal? b #t) #t] + [else + (error '->* "expected #:~a to return (or/c boolean? string? (listof string?)), got ~e" + (if pre? "pre" "post") + b)])) + + (define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx)))