adjust -> contract so that (-> any/c ... any) contracts are now

flat contracts and using (-> any/c boolean?) uses predicate/c
without special intervention.

also, fix a bug in the opter contracts

collects/racket/contract/private/arrow.rkt

@@ -363,7 +363,7 @@ v4 todo:
 
 ;; should we pass both the basic-lambda and the kwd-lambda?
 (define (arity-checking-wrapper val blame basic-lambda kwd-lambda min-method-arity max-method-arity min-arity max-arity req-kwd opt-kwd)
-  ;; should not build this unless we are in the 'else' case (and maybe not at all
+  ;; should not build this unless we are in the 'else' case (and maybe not at all)
   (cond
     [(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
      (if (and (null? req-kwd) (null? opt-kwd)) 
@@ -438,7 +438,13 @@ v4 todo:
 ;; func : the wrapper function maker. It accepts a procedure for
 ;;        checking the first-order properties and the contracts
 ;;        and it produces a wrapper-making function.
-(define-struct base-> (pre post doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? mtd? func))
+(define-struct base-> (pre post
+                       doms/c optional-doms/c dom-rest/c
+                       mandatory-kwds/c mandatory-kwds
+                       optional-kwds/c optional-kwds
+                       rngs/c rng-any?
+                       mtd?
+                       func))
 
 (define ((->-proj wrapper) ctc) 
   (let* ([doms-proj (map contract-projection
@@ -561,8 +567,6 @@ v4 todo:
                              ((contract-struct-exercise c) v new-fuel)))])
        (andmap gen-if-fun (base->-doms/c ctc) args))))
 
-
-
 (define-struct (chaperone-> base->) ()
   #:property prop:chaperone-contract
   (build-chaperone-contract-property
@@ -752,10 +756,6 @@ v4 todo:
                  (list (car (syntax-e stx)))
                  '()))))))
 
-(define-syntax (-> stx) 
-  #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx)))
-
-
 
 ;                     
 ;                     
@@ -2001,8 +2001,14 @@ v4 todo:
 
 
 (define predicate/c-private->ctc
-  (let ([predicate/c (-> any/c boolean?)])
+  (let-syntax ([m (λ (stx)
-    predicate/c))
+                    ;; we don't use -> directly here to avoid a circularity, since
+                    ;; (-> any/c boolean?) expands into the identifier -predicate/c
+                    (syntax-case stx ()
+                      [(_ arg)
+                       #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main #'arg))]))])
+    (let ([predicate/c (m (-> any/c boolean?))])
+      predicate/c)))
 
 (struct predicate/c ()
   #:property prop:chaperone-contract
@@ -2020,3 +2026,16 @@ v4 todo:
    #:stronger (λ (this that) (contract-struct-stronger? predicate/c-private->ctc that))))
 
 (define -predicate/c (predicate/c))
+
+(define-syntax (-> stx) 
+  (syntax-case stx (any any/c boolean?)
+    [(_ any/c ... any)
+     ;; special case the (-> any/c ... any) contracts to be first-order checks only
+     (with-syntax ([dom-len (- (length (syntax->list stx)) 2)]
+                   [name (syntax->datum stx)])
+       #'(flat-named-contract 'name (λ (x) (and (procedure? x) (procedure-arity-includes? x dom-len #t)))))]
+    [(_ any/c boolean?)
+     ;; special case (-> any/c boolean?) to use predicate/c
+     #'-predicate/c]
+    [_
+     #`(syntax-parameterize ((making-a-method #f)) #,(->/proc/main stx))]))

collects/racket/contract/private/opters.rkt

@@ -382,14 +382,17 @@
                    (check-procedure val #f dom-len 0 '() '() #| keywords |# blame)
                    (chaperone-procedure
                     val
-                    (λ (dom-arg ...)
+                    (case-lambda
+                      [(dom-arg ...)
                        (values 
                         (case-lambda
                           [(rng-arg ...)
                            (values next-rng ...)]
                           [args 
                            (bad-number-of-results blame val rng-len args)])
-                       next-dom ...))))))
+                        next-dom ...)]
+                      [args
+                       (bad-number-of-arguments blame val args dom-len)])))))
        (append lifts-doms lifts-rngs)
        (append superlifts-doms superlifts-rngs)
        (append partials-doms partials-rngs)
@@ -439,8 +442,10 @@
                    (check-procedure val #f dom-len 0 '() '() #|keywords|# blame)
                    (chaperone-procedure
                     val
-                    (λ (dom-arg ...)
+                    (case-lambda
-                      (values next-dom ...))))))
+                      [(dom-arg ...)  (values next-dom ...)]
+                      [args 
+                       (bad-number-of-arguments blame val args dom-len)])))))
        lifts-doms
        superlifts-doms
        partials-doms
@@ -477,3 +482,10 @@
                (values next lift superlift partial flat _ stronger-ribs chaperone?)
                (opt/unknown opt/i opt/info stx))))]))
 
+
+(define (bad-number-of-arguments blame val args dom-len)
+  (define num-values (length args))
+  (raise-blame-error (blame-swap blame) val 
+                     "expected ~a argument~a, got ~a argument~a"
+                     dom-len (if (= dom-len 1) "" "s")
+                     num-values (if (= num-values 1) "" "s")))

collects/tests/racket/contract-test.rktl

@@ -1131,6 +1131,18 @@
    'contract-arrow-any3
    '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t))
 
+  (test/spec-passed
+   'contract-arrow-all-anys1 
+   '((contract (-> any) (lambda () #f) 'pos 'neg)))
+
+  (test/pos-blame
+   'contract-arrow-all-anys2
+   '((contract (-> any) (lambda (x) #f) 'pos 'neg)))
+
+  (test/spec-passed
+   'contract-arrow-all-anys3
+   '((contract (-> any) (lambda ([x #f]) #f) 'pos 'neg)))
+
   (test/spec-passed
    'contract-arrow-all-kwds
    '(contract (-> #:a string? string?) 
@@ -9572,6 +9584,8 @@ so that propagation occurs.
   (test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t)
   (test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t)
   
+  (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?)