Redo the calculation of opt-lambda expansion.

Closes PR 13661.
Closes PR 13584.

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt

@@ -1115,24 +1115,51 @@ This file defines two sorts of primitives. All of them are provided into any mod
         (quasisyntax/loc stx (#,l/c k.ann-name . body))]))
     (values (mk #'let/cc) (mk #'let/ec))))
 
+
+(begin-for-syntax
+  (define-syntax-class optional-arg
+    (pattern name:id #:attr value #f)
+    (pattern (name:id value:expr)))
+  (define-splicing-syntax-class lambda-args
+    #:attributes (required-pos
+                  optional-pos
+                  optional-kws
+                  required-kws)
+    (pattern (~seq (~or pos:optional-arg (~seq kw:keyword key:optional-arg)) ...)
+             #:attr optional-pos (length (filter values (attribute pos.value)))
+             #:attr required-pos (- (length (filter values (attribute pos.name)))
+                                    (attribute optional-pos))
+             #:attr optional-kws
+               (for/list ((kw (attribute kw))
+                          (kw-value (attribute key.value))
+                          #:when kw-value)
+                 kw)
+             #:attr required-kws (remove* (attribute optional-kws) (attribute kw)))))
+
+
 ;; annotation to help tc-expr pick out keyword functions
 (define-syntax (-lambda stx)
   (syntax-parse stx
     [(_ formals . body)
-     (define-values (has-kw? has-opt?)
+     (define d (syntax/loc stx (λ formals . body)))
-       (syntax-parse #'formals
+     (syntax-parse #'formals
-        ((~or (~and rest:id (~bind ((args 1) null)))
+      [(~or (~and (args:lambda-args) (~bind (rest #f)))
-              (args ...)
+            (args:lambda-args . rest:id))
-              (args ...+ . rest:id))
+       (define kw-property
-         (define arg-list (syntax->list #'(args ...)))
+         (> (+ (length (attribute args.required-kws))
-         (values
+               (length (attribute args.optional-kws)))
-           (ormap keyword? (map syntax-e arg-list))
+            0))
-           (ormap syntax->list arg-list)))))
+       (define opt-property
-      (opt-lambda-property
+         (and (> (attribute args.optional-pos) 0)
-        (kw-lambda-property
+           (list
-          (syntax/loc stx (λ formals . body))
+             (attribute args.required-pos)
-          has-kw?)
+             (attribute args.optional-pos))))
-        has-opt?)]))
+       (syntax-property
+         (syntax-property d 'kw-lambda kw-property)
+         'opt-lambda opt-property)]
+       ;; This is an error and will be caught by the real lambda
+      [_ d])]))
+
 
 ;; do this ourselves so that we don't get the static bindings,
 ;; which are harder to typecheck

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt

@@ -263,10 +263,9 @@
            (let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _))))
              (#%plain-app _ _ args ...))))
        (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
-      ;; kw/opt function def
+      ;; kw function def
-      [(let-values ([(_) fun])
+      [(let-values ([(_) fun]) . body)
-         . body)
+       #:when (syntax-property form 'kw-lambda)
-       #:when (or (kw-lambda-property form) (opt-lambda-property form))
        (match expected
          [(tc-result1: (and f (or (Function: _)
                                   (Poly: _ (Function: _)))))
@@ -274,6 +273,22 @@
          [(or (tc-results: _) (tc-any-results:))
           (tc-error/expr "Keyword functions must have function type, given ~a" expected)])
        expected]
+      ;; opt function def
+      [(let-values ([(f) fun]) . body)
+       #:when (syntax-property form 'opt-lambda)
+       (define conv-type
+         (match expected
+           [(tc-result1: fun-type)
+            (match-define (list required-pos optional-pos)
+              (syntax-property form 'opt-lambda))
+            (opt-convert fun-type required-pos optional-pos)]
+           [_ #f]))
+       (match-define (tc-result1: returned-fun-type)
+         (if conv-type
+             (tc-expr/check/type #'fun conv-type)
+             (tc-expr #'fun)))
+       (with-lexical-env/extend (list #'f) (list returned-fun-type)
+         (tc-exprs/check (syntax->list #'body) expected))]
       ;; let
       [(let-values ([(name ...) expr] ...) . body)
        (tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/kw-types.rkt

@@ -2,9 +2,10 @@
 
 (require "abbrev.rkt" "../rep/type-rep.rkt"
          "union.rkt" "../utils/tc-utils.rkt"
-         racket/list racket/dict racket/match)
+         racket/list racket/set racket/dict racket/match)
 
-;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type] [Option Type] -> (values Type Type)
+;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type]
+;;           [Option Type] [Option (Pair Type symbol)] boolean -> Type
 (define (convert kw-t plain-t opt-t rng rest drest split?)
   (define-values (mand-kw-t opt-kw-t) (partition (match-lambda [(Keyword: _ _ m) m]) kw-t))
 
@@ -57,13 +58,13 @@
           [(Keyword: _ t _) (list (-val #f) (-val #f))]))
       plain-t
       (for/list ([t (in-list opt-t)]) (-val #f))
-      (for/list ([t (in-list opt-t)]) (-val #f))
+      (for/list ([t (in-list opt-t)]) (-val #f)))))
-      ;; the kw function protocol passes rest args as an explicit list
+  (make-Function
-      (if rest (-lst rest) empty))))
+    (if split?
-  (if split?
+        (remove-duplicates
-      (make-Function (list (make-arr* ts/true rng)
+          (list (make-arr* ts/true rng #:rest rest #:drest drest)
-                           (make-arr* ts/false rng)))
+                (make-arr* ts/false rng #:rest rest #:drest drest)))
-      (make-Function (list (make-arr* ts rng)))))
+        (list (make-arr* ts rng #:rest rest #:drest drest)))))
 
 (define (prefix-of a b)
   (define (rest-equal? a b)
@@ -110,24 +111,59 @@
         (dict-set d prefix (arg-diff prefix e))
         (dict-set d e empty))))
 
+(define (inner-kw-convert arrs split?)
+  (define table (find-prefixes arrs))
+  (define fns
+    (for/set ([(k v) (in-dict table)])
+      (match k
+        [(arr: mand rng rest drest kws)
+         (convert kws mand v rng rest drest split?)])))
+  (apply cl->* (set->list fns)))
+
 (define (kw-convert ft #:split [split? #f])
     (match ft
       [(Function: arrs)
-       (define table (find-prefixes arrs))
+       (inner-kw-convert arrs split?)]
-       (define fns 
+      [(Poly-names: names f)
-         (for/list ([(k v) (in-dict table)])
+       (make-Poly names (kw-convert f #:split split?))]
-           (match k
+      [(PolyDots-names: names f)
-             [(arr: mand rng rest drest kws)
+       (make-PolyDots names (kw-convert f #:split split?))]))
-              (convert kws mand v rng rest drest split?)])))
-       (apply cl->* fns)]
-      [(Poly-names: names (Function: arrs))
-       (define table (find-prefixes arrs))
-       (define fns 
-         (for/list ([(k v) (in-dict table)])
-           (match k
-             [(arr: mand rng rest drest kws)
-              (convert kws mand v rng rest drest split?)])))
-       (make-Poly names (apply cl->* fns))]
-      [_ (int-err "kw-convert: non-function type ~a" ft)]))
 
-(provide kw-convert)
+(define ((opt-convert-arr required-pos optional-pos) arr)
+  (match arr
+    [(arr: args result #f #f '())
+     (define num-args (length args))
+     (and (>= num-args required-pos)
+          (<= num-args (+ required-pos optional-pos))
+          (let* ([required-args (take args required-pos)]
+                 [opt-args (drop args required-pos)]
+                 [missing-opt-args (- (+ required-pos optional-pos) num-args)]
+                 [present-flags (map (λ (t) (-val #t)) opt-args)]
+                 [missing-args (make-list missing-opt-args (-val #f))])
+            (make-arr (append required-args
+                              opt-args
+                              missing-args
+                              present-flags
+                              missing-args)
+                      result
+                      #f
+                      #f
+                      '())))]
+    [(arr: args result _ _ _) #f]))
+
+(define (opt-convert ft required-pos optional-pos)
+  (let/ec exit
+    (let loop ((ft ft))
+      (match ft
+        [(Function: arrs)
+         (let ((arrs (map (opt-convert-arr required-pos optional-pos) arrs)))
+           (if (andmap values arrs)
+               (make-Function arrs)
+               (exit #f)))]
+        [(Poly-names: names f)
+         (make-Poly names (loop f))]
+        [(PolyDots-names: names f)
+         (make-PolyDots names (loop f))]
+        [t t]))))
+
+(provide kw-convert opt-convert)

pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/succeed/pr13584.rkt

@@ -0,0 +1,13 @@
+#lang typed/racket
+
+(: f (case->
+      (-> Boolean)
+      (Input-Port -> Boolean)
+      (Bytes -> Boolean)))
+
+(define (f (p #f))
+  (cond ((input-port? p) #t)
+        ((bytes? p) #f)
+        (else #f)))
+
+(assert (call-with-input-bytes #"port" f))

pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/all-tests.rkt

@@ -11,6 +11,7 @@
  "subst-tests.rkt" ;; pass
  "infer-tests.rkt" ;; pass
  "type-annotation-test.rkt" ;; pass
+ "keyword-expansion-test.rkt" ;;pass
 
  "module-tests.rkt" ;; pass
  "contract-tests.rkt"
@@ -38,6 +39,7 @@
                   module-tests
                   fv-tests
                   contract-tests
+                  keyword-tests
                   ;; this uses dynamic require because the file fails to compile when there's a test failure
                   (λ () ((dynamic-require special 'typecheck-special-tests))))])
      (f))))

pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/keyword-expansion-test.rkt

@@ -0,0 +1,84 @@
+#lang racket/base
+
+(require "test-utils.rkt" 
+         (rep type-rep)
+         (types utils kw-types abbrev numeric-tower)
+         racket/match racket/set
+         rackunit)
+(provide keyword-tests)
+
+(define-syntax-rule (t arg expected)
+  (begin
+    (test-equal? (format "~a" '(arg expected))
+                 (kw-convert arg)
+                 expected)))
+
+(define (extract-arrs t)
+  (match t
+    [(Function: arrs) (apply set arrs)]
+    [t t]))
+
+(define-syntax-rule (t-opt ((req-arg ...) (opt-arg ...)) expected)
+  (let ()
+    (test-equal? (format "~a" '(opt-convert (->opt req-arg ... (opt-arg ...) result) expected))
+                 (extract-arrs
+                   (opt-convert (->opt req-arg ... (opt-arg ...) result)
+                                (length (list 'req-arg ...))
+                                (length (list 'opt-arg ...))))
+                 (extract-arrs expected))))
+
+
+(define flag -Boolean)
+(define true (-val #t))
+(define false (-val #f))
+(define result (-val 'result))
+(define one (-val 'one))
+(define two (-val 'two))
+(define three (-val 'three))
+(define four (-val 'four))
+
+(define (keyword-tests)
+  (test-suite "Tests for keyword expansion"
+
+    [t (-> result) (-> result)]
+    [t (-> one result)
+       (-> one result)]
+    [t (-> one two three four result)
+       (-> one two three four result)]
+    [t (->opt (one) result)
+       (-> (-opt one) flag result)]
+    [t (->opt (one two) result)
+       (-> (-opt one) (-opt two) flag flag result)]
+    [t (->opt one (two three) result)
+       (-> one (-opt two) (-opt three) flag flag result)]
+
+    [t-opt (() ()) (-> result)]
+    [t-opt ((one) ())
+           (-> one result)]
+    [t-opt (() (one))
+           (cl->*
+             (-> one true result)
+             (-> false false result))]
+    [t-opt ((one two three four) ())
+       (-> one two three four result)]
+    [t-opt (() (one))
+           (cl->*
+             (-> one true result)
+             (-> false false result))]
+    [t-opt (() (one two))
+           (cl->*
+             (-> one two true true result)
+             (-> one false true false result)
+             (-> false false false false result))]
+    [t-opt ((one) (two three))
+           (cl->*
+             (-> one two three true true result)
+             (-> one two false true false  result)
+             (-> one false false false false result))]
+
+
+
+
+    ))
+
+(define-go keyword-tests)

pkgs/typed-racket-pkgs/typed-racket-tests/tests/typed-racket/unit-tests/typecheck-tests.rkt

@@ -1647,6 +1647,11 @@
             [w 'result]
             [(x) (add1 "hello")])
           (->* (list) Univ (-val 'result) : -true-lfilter)]
+
+        [tc-e
+           (opt-lambda: ((x : Symbol 'a)) x)
+           #:ret (ret (t:-> -Symbol -Symbol) (-FS -top -bot))
+           #:expected (ret (t:-> -Symbol -Symbol) (-FS -top -bot))]
         )
   (test-suite
    "check-type tests"