implement the (-> any/c ... any) special case for the new -> contract combinator

(new is being used in a relative sense here; it is the newer of the
two -> combinators; the old one is used currently only for ->m)

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

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)
   

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

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
+   #:stronger ->-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))))
    #: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

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)

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