Add ->* type constructor for optional arguments

original commit: 02dd958a697bf897a412f24547dfd07d11a62b72

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt

@@ -15,7 +15,7 @@
 
 ;; special type names that are not bound to particular types
 (define-other-types
-  -> case-> U Rec All Opaque Vector
+  -> ->* case-> U Rec All Opaque Vector
   Parameterof List List* Class Values Instance Refinement
   pred Struct Struct-Type Top Bot)
 

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

@@ -50,7 +50,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
 (require "../utils/require-contract.rkt"
          "colon.rkt"
          "../typecheck/internal-forms.rkt"
-         (rename-in racket/contract/base [-> c->] [case-> c:case->])
+         (rename-in racket/contract/base [-> c->] [->* c->*] [case-> c:case->])
          ;; contracted bindings to replace built-in ones
          (except-in "base-contracted.rkt" initialize-contracted)
          "top-interaction.rkt"

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt

@@ -39,6 +39,7 @@
 (define-literal-syntax-class #:for-label List*)
 (define-literal-syntax-class #:for-label pred)
 (define-literal-syntax-class #:for-label ->)
+(define-literal-syntax-class #:for-label ->*)
 (define-literal-syntax-class #:for-label case->^ (case-> case-lambda))
 (define-literal-syntax-class #:for-label Rec)
 (define-literal-syntax-class #:for-label U)
@@ -99,9 +100,12 @@
     [(:All^ (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")]
     [(:All^ . rest) (tc-error "All: bad syntax")]))
 
-(define-splicing-syntax-class keyword-tys
+(define-splicing-syntax-class mandatory-kw-tys
   (pattern (~seq k:keyword t:expr)
-           #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t))
+           #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t)))
+
+(define-splicing-syntax-class keyword-tys
+  (pattern kw:mandatory-kw-tys #:attr Keyword (attribute kw.Keyword))
   (pattern (~seq [k:keyword t:expr])
            #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
 
@@ -371,7 +375,28 @@
                  doms
                  (parse-values-type #'rng)
                  #:kws (attribute kws.Keyword)))))]
-
+      [(:->*^
+        (dom:non-keyword-ty ... mand-kws:mandatory-kw-tys ...)
+        ;; this clause uses the syntax of mandatory keyword types to
+        ;; match the ->* contract, but they are optional
+        ;; (the code below swaps the boolean appropriately)
+        (~optional (opt-dom:non-keyword-ty ... opt-kws:mandatory-kw-tys ...))
+        (~optional (~seq #:rest rest-type:non-keyword-ty))
+        rng)
+       (define doms (for/list ([d (in-syntax #'(dom ...))])
+                      (parse-type d)))
+       (define opt-doms (if (attribute opt-dom)
+                            (for/list ([d (in-syntax #'(opt-dom ...))])
+                              (parse-type d))
+                            null))
+       (opt-fn doms opt-doms (parse-values-type #'rng)
+               #:rest (and (attribute rest-type)
+                           (parse-type #'rest-type))
+               #:kws (append (attribute mand-kws.Keyword)
+                             (map (match-lambda [(Keyword: k t _) (make-Keyword k t #f)])
+                                  (if (attribute opt-kws)
+                                      (attribute opt-kws.Keyword)
+                                      null))))]
       [id:identifier
        (cond
          ;; if it's a type variable, we just produce the corresponding reference (which is in the HT)

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

@@ -260,9 +260,10 @@
 (define/decl -true-filter (-FS -top -bot))
 (define/decl -false-filter (-FS -bot -top))
 
-(define (opt-fn args opt-args result)
+(define (opt-fn args opt-args result #:rest [rest #f] #:kws [kws null])
   (apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])
-                 (make-Function (list (make-arr* (append args (take opt-args i)) result))))))
+                 (make-Function (list (make-arr* (append args (take opt-args i)) result
+                                                 #:rest rest #:kws kws))))))
 
 (define-syntax-rule (->opt args ... [opt ...] res)
   (opt-fn (list args ...) (list opt ...) res))

pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt

@@ -147,6 +147,25 @@
    [(-> Integer (All (X) (-> X X)))
     (t:-> -Integer (-poly (x) (t:-> x x)))]
 
+   ;; ->* types
+   [(->* (String Symbol) Void) (t:-> -String -Symbol -Void)]
+   [(->* (String Symbol) (String) Void)
+    (->opt -String -Symbol [-String] -Void)]
+   [(->* (String Symbol) (String Symbol) Void)
+    (->opt -String -Symbol [-String -Symbol] -Void)]
+   [(->* (String Symbol) (String) (values Void String))
+    (->opt -String -Symbol [-String] (-values (list -Void -String)))]
+   [(->* (String Symbol) (String) #:rest Symbol Void)
+    (->optkey -String -Symbol [-String] #:rest -Symbol -Void)]
+   [(All (a) (->* (a Symbol) (String) #:rest Symbol Void))
+    (-poly (a) (->optkey a -Symbol [-String] #:rest -Symbol -Void))]
+   [(->* (Integer) (String #:foo Integer) Void)
+    (->optkey -Integer [-String] #:foo -Integer #f -Void)]
+   [(->* (Integer #:bar Integer) (String) Void)
+    (->optkey -Integer [-String] #:bar -Integer #t -Void)]
+   [(->* (Integer #:bar Integer) (String #:foo Integer) Void)
+    (->optkey -Integer [-String] #:bar -Integer #t #:foo -Integer #f -Void)]
+
    [(Opaque foo?) (make-Opaque #'foo?)]
    ;; PR 14122
    [FAIL (Opaque 3)]