Change contracts of the form (-> any/c ... any) to not be flat contracts

The issue is what happens when the actual function has other arities.
For example, if the function were (λ (x [y 1]) y) then it is not okay
to simply check if procedure-arity-includes? of 1 is true (what the
code used to do) because then when the function is applied to 2
arguments, the call won't fail like it should. It is possible to check
and reject functions that don't have exactly the right arity, but if
the contract were (-> string? any), then the function would have been
allowed and only when the extra argument is supplied would the error
occur. So, this commit makes it so that (-> any/c any) is like
(-> string? any), but with the optimization that if the procedure
accepts only one argument, then no wrapper is created.

This is a backwards incompatible change because it used to be the
case that (flat-contract? (-> any)) returned #t and it now returns #f.

pkgs/racket-test/tests/racket/contract/arrow.rkt

@@ -318,6 +318,10 @@
   (test/pos-blame
    'contract-any/c-arrow4
    '(contract (-> any/c any) (λ (x #:y y) x) 'pos 'neg))
+
+  (test/neg-blame
+   'contract-any/c-arrow5
+   '((contract (-> any/c any) (λ (x [y 1]) x) 'pos 'neg) 1 2))
   
   (test/spec-passed
    'contract-arrow-all-kwds2

pkgs/racket-test/tests/racket/contract/flat-contracts.rkt

@@ -71,11 +71,6 @@
   (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/predicates.rkt

@@ -15,8 +15,6 @@
   (ctest #t flat-contract? (first-or/c (flat-contract integer?) (flat-contract boolean?)))
   (ctest #t flat-contract? (first-or/c integer? boolean?))
   
-  (ctest #t flat-contract? (-> any/c any/c any))
-
   (ctest #t flat-contract? (and/c))
   (ctest #t flat-contract? (and/c number? integer?))
   (ctest #t flat-contract? (and/c (flat-contract number?)

racket/collects/racket/contract/private/arrow-higher-order.rkt

@@ -357,6 +357,14 @@
                  late-neg?)
   (define optionals-length (- (length doms) min-arity))
   (define mtd? #f) ;; not yet supported for the new contracts
+  (define okay-to-do-only-arity-check?
+    (and (not rest)
+         (not pre?)
+         (not post?)
+         (null? kwd-infos)
+         (not rngs)
+         (andmap any/c? doms)
+         (= optionals-length 0)))
   (λ (orig-blame)
     (define rng-blame (arrow:blame-add-range-context orig-blame))
     (define swapped-domain (blame-add-context orig-blame "the domain of" #:swap? #t))
@@ -425,19 +433,24 @@
               impersonator-prop:application-mark
               (cons arrow:tail-contract-key (list* neg-party blame-party-info rngs))))]
         [else val]))
-    
     (cond
       [late-neg?
-       (λ (val neg-party)
+       (define (arrow-higher-order:lnp val neg-party)
          (cond
            [(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
             =>
             (λ (f)
               (f neg-party))]
            [else
-            (successfully-got-the-right-kind-of-function val neg-party)]))]
+            (successfully-got-the-right-kind-of-function val neg-party)]))
+       (if okay-to-do-only-arity-check?
+           (λ (val neg-party)
+             (cond
+               [(procedure-arity-exactly/no-kwds val min-arity) val]
+               [else (arrow-higher-order:lnp val neg-party)]))
+           arrow-higher-order:lnp)]
       [else
-       (λ (val)
+       (define (arrow-higher-order:vfp val)
          (wrapped-extra-arg-arrow 
           (cond
             [(do-arity-checking orig-blame val doms rest min-arity kwd-infos)
@@ -446,4 +459,20 @@
             [else
              (λ (neg-party)
                (successfully-got-the-right-kind-of-function val neg-party))])
-          (apply plus-one-arity-function orig-blame val plus-one-constructor-args)))])))
+          (apply plus-one-arity-function orig-blame val plus-one-constructor-args)))
+       (if okay-to-do-only-arity-check?
+           (λ (val)
+             (cond
+               [(procedure-arity-exactly/no-kwds val min-arity)
+                (wrapped-extra-arg-arrow 
+                 (λ (neg-party) val)
+                 (apply plus-one-arity-function orig-blame val plus-one-constructor-args))]
+               [else (arrow-higher-order:vfp val)]))
+           arrow-higher-order:vfp)])))
+
+(define (procedure-arity-exactly/no-kwds val min-arity)
+  (and (procedure? val)
+       (equal? (procedure-arity val) min-arity)
+       (let-values ([(man opt) (procedure-keywords val)])
+         (and (null? man)
+              (null? opt)))))

racket/collects/racket/contract/private/arrow-val-first.rkt

@@ -542,9 +542,6 @@
     [(_ 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->))
@@ -662,10 +659,6 @@
 
 (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
@@ -826,18 +819,6 @@
                           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 '()]
@@ -1244,34 +1225,6 @@
        (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

racket/collects/racket/contract/private/arrow.rkt

@@ -41,8 +41,7 @@
          blame-add-range-context
          blame-add-nth-arg-context
          raise-no-keywords-arg
-         raise-wrong-number-of-args-error
-         procedure-arity-includes?/no-kwds)
+         raise-wrong-number-of-args-error)
 
 (define-syntax-parameter making-a-method #f)
 (define-syntax-parameter method-contract? #f)
@@ -1908,25 +1907,7 @@
 
 
 (define-syntax (-> stx) 
-  (syntax-case stx (any any/c boolean?)
-    [(_ 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)
-          (λ (x) 
-            (procedure-arity-includes?/no-kwds x #,dom-len))))]
-    [_
-     #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))]))
-
-(define (procedure-arity-includes?/no-kwds val dom-len)
-  (and (procedure? val)
-       (procedure-arity-includes? val dom-len)
-       (let-values ([(man opt) (procedure-keywords val)])
-         (null? man))))
+  #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx)))
 
 ;; this is to make the expanded versions a little easier to read
 (define-syntax (values/drop stx)