diff --git a/pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-test/tests/racket/contract-rand-test.rkt index a53fe1eb58..785aa14f06 100644 --- a/pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-test/tests/racket/contract-rand-test.rkt @@ -157,6 +157,7 @@ (λ () ((test-contract-generation (-> some-crazy-predicate? some-crazy-predicate?)) 11))) (check-not-exn (λ () (((test-contract-generation (-> (-> (>/c 10) (>/c 10))))) 11))) +(check-not-exn (λ () ((test-contract-generation (-> any/c any)) 1))) (check-not-exn (λ () diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index 3c538b504d..2eb2d1418f 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -71,6 +71,11 @@ (test-flat-contract #rx#".x." "axq" "x") (test-flat-contract ''() '() #f) + (test-flat-contract '(-> any/c any/c any) (λ (x y) 1) (λ (x y z) 1)) + (test-flat-contract '(->* (any/c any/c) any) (λ (x y) 1) (λ (x y z) 1)) + (test-flat-contract '(->* () any) (λ () 1) (λ (x y z w) 1)) + (test-flat-contract '(->* () () any) (λ () 1) (λ (x) 1)) + (test-flat-contract '(if/c integer? even? list?) 2 3) (test-flat-contract '(if/c integer? even? list?) '() #f) diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index 38d5c5d1a2..9783e91149 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -72,7 +72,9 @@ (-> integer? #:x integer? integer?) (-> integer? #:x integer? integer?)) (ctest #t contract-stronger? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2))) - + (ctest #t contract-stronger? (-> any/c any/c any) (-> any/c any/c any)) + (ctest #f contract-stronger? (-> any/c any/c any/c any) (-> any/c any/c any)) + (let ([c (contract-eval '(->* () () any))]) (test #t (contract-eval 'contract-stronger?) c c)) (let ([c (contract-eval '(->d () () any))]) diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index 8e229e3c95..5d9891fd8f 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -15,7 +15,9 @@ (provide ->2 ->*2 dynamic->* (for-syntax ->2-handled? + ->2-arity-check-only->? ->*2-handled? + ->2*-arity-check-only->? ->-valid-app-shapes ->*-valid-app-shapes) (rename-out [-predicate/c predicate/c])) @@ -25,11 +27,13 @@ [(_ args ...) (syntax-parameter-value #'arrow:making-a-method) #f] - [(_ any/c ... any) - ;; should turn into a flat contract - #f] [_ #t])) +(define-for-syntax (->2-arity-check-only->? stx) + (syntax-case stx (any any/c) + [(_ any/c ... any) (- (length (syntax->list stx)) 2)] + [_ #f])) + (define-for-syntax (->*2-handled? stx) (syntax-case stx (any values any/c) [(_ args ...) @@ -37,6 +41,12 @@ #f] [_ #t])) +(define-for-syntax (->2*-arity-check-only->? stx) + (syntax-case stx (any any/c) + [(_ (any/c ...) any) (length (syntax->list (cadr (syntax->list stx))))] + [(_ (any/c ...) () any) (length (syntax->list (cadr (syntax->list stx))))] + [_ #f])) + (define-for-syntax popular-keys ;; of the 8417 contracts that get compiled during ;; 'raco setup' of the current tree, these are all @@ -532,6 +542,9 @@ [(_ args ...) (not (->2-handled? stx)) #'(arrow:-> args ...)] + [(_ args ...) + (->2-arity-check-only->? stx) + #`(build-arity-check-only-> #,(->2-arity-check-only->? stx))] [(_ args ... rng) (let () (define this-> (gensym 'this->)) @@ -649,6 +662,10 @@ (define-syntax (->*2 stx) (cond + [(->2*-arity-check-only->? stx) + => + (λ (n) + #`(build-arity-check-only-> #,n))] [(->*2-handled? stx) (define this->* (gensym 'this->*)) (define-values (man-dom man-dom-kwds man-lets @@ -809,6 +826,18 @@ plus-one-arity-function chaperone-constructor)])) +(define (build-arity-check-only-> n) + (make-arity-check-only-> n + (build-list n (λ (_) any/c)) + '() #f #f #f #f + (λ args + (error 'arity-check-only->-plus-one-arity-function + "this function should not be called ~s" args)) + (λ args + (error 'arity-check-only->-chaperone-constructor + "this function should not be called ~s" args)) + n)) + (define (dynamic->* #:mandatory-domain-contracts [mandatory-domain-contracts '()] #:optional-domain-contracts [optional-domain-contracts '()] #:mandatory-keywords [unsorted-mandatory-keywords '()] @@ -1187,34 +1216,63 @@ (define cblame (cthis blame)) (λ (val) ((cblame val) #f)))) - #:stronger - (λ (this that) - (and (base->? that) - (= (length (base->-doms that)) - (length (base->-doms this))) - (= (base->-min-arity this) (base->-min-arity that)) - (andmap contract-stronger? (base->-doms that) (base->-doms this)) - (= (length (base->-kwd-infos this)) - (length (base->-kwd-infos that))) - (for/and ([this-kwd-info (base->-kwd-infos this)] - [that-kwd-info (base->-kwd-infos that)]) - (and (equal? (kwd-info-kwd this-kwd-info) - (kwd-info-kwd that-kwd-info)) - (contract-stronger? (kwd-info-ctc that-kwd-info) - (kwd-info-ctc this-kwd-info)))) - (if (base->-rngs this) - (and (base->-rngs that) - (andmap contract-stronger? (base->-rngs this) (base->-rngs that))) - (not (base->-rngs that))) - (not (base->-pre? this)) - (not (base->-pre? that)) - (not (base->-post? this)) - (not (base->-post? that)))) + #:stronger ->-stronger #:generate ->-generate #:exercise ->-exercise #:val-first-projection val-first-proj #:late-neg-projection late-neg-proj)) +(define (->-stronger this that) + (and (base->? that) + (= (length (base->-doms that)) + (length (base->-doms this))) + (= (base->-min-arity this) (base->-min-arity that)) + (andmap contract-stronger? (base->-doms that) (base->-doms this)) + (= (length (base->-kwd-infos this)) + (length (base->-kwd-infos that))) + (for/and ([this-kwd-info (base->-kwd-infos this)] + [that-kwd-info (base->-kwd-infos that)]) + (and (equal? (kwd-info-kwd this-kwd-info) + (kwd-info-kwd that-kwd-info)) + (contract-stronger? (kwd-info-ctc that-kwd-info) + (kwd-info-ctc this-kwd-info)))) + (if (base->-rngs this) + (and (base->-rngs that) + (andmap contract-stronger? (base->-rngs this) (base->-rngs that))) + (not (base->-rngs that))) + (not (base->-pre? this)) + (not (base->-pre? that)) + (not (base->-post? this)) + (not (base->-post? that)))) + +(define-struct (arity-check-only-> base->) (arity) + #:property + prop:flat-contract + (build-flat-contract-property + #:name base->-name + #:first-order + (λ (ctc) + (define arity (arity-check-only->-arity ctc)) + (λ (val) + (arrow:procedure-arity-includes?/no-kwds val arity))) + #:late-neg-projection + (λ (ctc) + (define arity (arity-check-only->-arity ctc)) + (λ (blame) + (λ (val neg-party) + (if (arrow:procedure-arity-includes?/no-kwds val arity) + val + (raise-blame-error + blame #:missing-party neg-party val + '(expected: "a procedure that accepts ~a non-keyword argument~a" + given: "~e") + arity + (if (= arity 1) "" "s") + val))))) + #:stronger ->-stronger + #:generate ->-generate + #:exercise ->-exercise)) + (define-struct (-> base->) () #:property prop:chaperone-contract diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index 0d9f9dea3a..c7c510a193 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -41,7 +41,8 @@ blame-add-range-context blame-add-nth-arg-context raise-no-keywords-arg - raise-wrong-number-of-args-error) + raise-wrong-number-of-args-error + procedure-arity-includes?/no-kwds) (define-syntax-parameter making-a-method #f) (define-syntax-parameter method-contract? #f) @@ -1911,6 +1912,8 @@ [(_ any/c ... any) (not (syntax-parameter-value #'making-a-method)) ;; special case the (-> any/c ... any) contracts to be first-order checks only + ;; this is now implemented by ->2 so we should get here only when we're + ;; building an ->m contract (let ([dom-len (- (length (syntax->list stx)) 2)]) #`(flat-named-contract '(-> #,@(build-list dom-len (λ (x) 'any/c)) any) diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index bd943af7bb..066c37d0f9 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -276,10 +276,12 @@ (define-values (arrow? the-valid-app-shapes) (syntax-case ctrct (->2 ->*2 ->i) [(->2 . _) - (->2-handled? ctrct) + (and (->2-handled? ctrct) + (not (->2-arity-check-only->? ctrct))) (values #t (->-valid-app-shapes ctrct))] [(->*2 . _) - (values (->*2-handled? ctrct) + (values (and (->*2-handled? ctrct) + (not (->2*-arity-check-only->? ctrct))) (->*-valid-app-shapes ctrct))] [(->i . _) (values #t (->i-valid-app-shapes ctrct))] [_ (values #f #f)]))