Fix contract generation for functions with optionals and keyword arguments.

Closes PR13354.

collects/tests/typed-racket/succeed/arrow-star-contracts.rkt

@@ -0,0 +1,120 @@
+#lang racket/base
+
+(require typed/rackunit)
+
+(module defs typed/racket/base
+  (provide (all-defined-out))
+
+  (: foo0k (case-> ([#:kw Real] -> Real)))
+  (define (foo0k #:kw [kw 0])
+    kw)
+
+  (: foo01k (case-> ([#:kw Real] -> Real)
+                    (Real [#:kw Real] -> Real)))
+  (define (foo01k [x 0] #:kw [kw 0])
+    (+ x kw))
+
+  (: foo012k (case-> ([#:kw Real] -> Real)
+                     (Real [#:kw Real] -> Real)
+                     (Real Real [#:kw Real] -> Real)))
+  (define (foo012k [x 0] [y 0] #:kw [kw 0])
+    (+ x y kw))
+
+  (: foo12k (case-> (Real [#:kw Real] -> Real)
+                    (Real Real [#:kw Real] -> Real)))
+  (define (foo12k x [y 0] #:kw [kw 0])
+    (+ x y kw))
+
+  (: foo123k (case-> (Real [#:kw Real] -> Real)
+                     (Real Real [#:kw Real] -> Real)
+                     (Real Real Real [#:kw Real] -> Real)))
+  (define (foo123k x [y 0] [z 0] #:kw [kw 0])
+    (+ x y z kw))
+
+  (: foo23k (case-> (Real Real [#:kw Real] -> Real)
+                    (Real Real Real [#:kw Real] -> Real)))
+  (define (foo23k x y [z 0] #:kw [kw 0])
+    (+ x y z kw))
+
+  (: foo234k (case-> (Real Real [#:kw Real] -> Real)
+                     (Real Real Real [#:kw Real] -> Real)
+                     (Real Real Real Real [#:kw Real] -> Real)))
+  (define (foo234k x y [z 0] [w 0] #:kw [kw 0])
+    (+ x y z w kw))
+  )
+
+(require 'defs)
+
+(void foo0k)
+(void foo01k)
+(void foo12k)
+
+(check-equal? (foo0k) 0)
+(check-exn exn:fail:contract? (λ () (foo0k 1)))
+(check-equal? (foo0k #:kw 10) 10)
+(check-exn exn:fail:contract? (λ () (foo0k 1 #:kw 10)))
+
+(check-equal? (foo01k) 0)
+(check-equal? (foo01k 1) 1)
+(check-exn exn:fail:contract? (λ () (foo01k 1 1)))
+(check-equal? (foo01k #:kw 10) 10)
+(check-equal? (foo01k 1 #:kw 10) 11)
+(check-exn exn:fail:contract? (λ () (foo01k 1 1 #:kw 10)))
+
+(check-exn exn:fail:contract? (λ () (foo12k)))
+(check-equal? (foo12k 1) 1)
+(check-equal? (foo12k 1 1) 2)
+(check-exn exn:fail:contract? (λ () (foo12k 1 1 1)))
+(check-exn exn:fail:contract? (λ () (foo12k #:kw 10)))
+(check-equal? (foo12k 1 #:kw 10) 11)
+(check-equal? (foo12k 1 1 #:kw 10) 12)
+(check-exn exn:fail:contract? (λ () (foo12k 1 1 1 #:kw 10)))
+
+(void foo012k)
+(void foo123k)
+(void foo23k)
+(void foo234k)
+
+(check-equal? (foo012k) 0)
+(check-equal? (foo012k 1) 1)
+(check-equal? (foo012k 1 1) 2)
+(check-exn exn:fail:contract? (λ () (foo012k 1 1 1)))
+(check-equal? (foo012k #:kw 10) 10)
+(check-equal? (foo012k 1 #:kw 10) 11)
+(check-equal? (foo012k 1 1 #:kw 10) 12)
+(check-exn exn:fail:contract? (λ () (foo012k 1 1 1 #:kw 10)))
+
+(check-exn exn:fail:contract? (λ () (foo123k)))
+(check-equal? (foo123k 1) 1)
+(check-equal? (foo123k 1 1) 2)
+(check-equal? (foo123k 1 1 1) 3)
+(check-exn exn:fail:contract? (λ () (foo123k 1 1 1 1)))
+(check-exn exn:fail:contract? (λ () (foo123k #:kw 10)))
+(check-equal? (foo123k 1 #:kw 10) 11)
+(check-equal? (foo123k 1 1 #:kw 10) 12)
+(check-equal? (foo123k 1 1 1 #:kw 10) 13)
+(check-exn exn:fail:contract? (λ () (foo123k 1 1 1 1 #:kw 10)))
+
+(check-exn exn:fail:contract? (λ () (foo23k)))
+(check-exn exn:fail:contract? (λ () (foo23k 1)))
+(check-equal? (foo23k 1 1) 2)
+(check-equal? (foo23k 1 1 1) 3)
+(check-exn exn:fail:contract? (λ () (foo23k 1 1 1 1)))
+(check-exn exn:fail:contract? (λ () (foo23k #:kw 10)))
+(check-exn exn:fail:contract? (λ () (foo23k 1 #:kw 10)))
+(check-equal? (foo23k 1 1 #:kw 10) 12)
+(check-equal? (foo23k 1 1 1 #:kw 10) 13)
+(check-exn exn:fail:contract? (λ () (foo23k 1 1 1 1 #:kw 10)))
+
+(check-exn exn:fail:contract? (λ () (foo234k)))
+(check-exn exn:fail:contract? (λ () (foo234k 1)))
+(check-equal? (foo234k 1 1) 2)
+(check-equal? (foo234k 1 1 1) 3)
+(check-equal? (foo234k 1 1 1 1) 4)
+(check-exn exn:fail:contract? (λ () (foo234k 1 1 1 1 1)))
+(check-exn exn:fail:contract? (λ () (foo234k #:kw 10)))
+(check-exn exn:fail:contract? (λ () (foo234k 1 #:kw 10)))
+(check-equal? (foo234k 1 1 #:kw 10) 12)
+(check-equal? (foo234k 1 1 1 #:kw 10) 13)
+(check-equal? (foo234k 1 1 1 1 #:kw 10) 14)
+(check-exn exn:fail:contract? (λ () (foo234k 1 1 1 1 1 #:kw 10)))

collects/typed-racket/private/type-contract.rkt

@@ -153,15 +153,17 @@
             [(and
               (> (length arrs) 1)
               ;; Keyword args, range and rest specs all the same.
-              (let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
+              (let* ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws)
                                              (list rng rest-spec kws)])
-			     arrs)])
+                              arrs)]
-                (foldl equal? (first xs) (rest xs)))
+                     [first-x (first xs)])
+                (for/and ([x (in-list (rest xs))])
+                  (equal? x first-x)))
               ;; Positionals are monotonically increasing by at most one.
               (let-values ([(_ ok?)
-                            (for/fold ([positionals '()]
+                            (for/fold ([positionals (arr-dom (first arrs))]
                                        [ok-so-far?  #t])
-                                ([arr (in-list arrs)])
+                                ([arr (in-list (rest arrs))])
                               (match arr
                                 [(arr: dom _ _ _ _)
                                  (define ldom         (length dom))