Print ->* style types with ->* constructor

This recognizes the type for a function like
`regexp-match?` and will print it concisely.

original commit: 54f72050a631c45785b95bdfaca9877db41bc3b8

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

@@ -100,12 +100,16 @@
     [(:All^ (_:id ...) _ _ _ ...) (tc-error "All: too many forms in body of All type")]
     [(:All^ . rest) (tc-error "All: bad syntax")]))
 
-(define-splicing-syntax-class mandatory-kw-tys
+;; syntax class for standard keyword syntax (same as contracts), may be
+;; optional or mandatory depending on where it's used
+(define-splicing-syntax-class plain-kw-tys
   (pattern (~seq k:keyword t:expr)
-           #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t)))
+           #:attr mand-kw (make-Keyword (syntax-e #'k) (parse-type #'t) #t)
+           #:attr opt-kw  (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
 
 (define-splicing-syntax-class keyword-tys
-  (pattern kw:mandatory-kw-tys #:attr Keyword (attribute kw.Keyword))
+  (pattern kw:plain-kw-tys #:attr Keyword (attribute kw.mand-kw))
+  ;; custom optional keyword syntax for TR
   (pattern (~seq [k:keyword t:expr])
            #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f)))
 
@@ -376,11 +380,8 @@
                  (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 ...))
+        (dom:non-keyword-ty ... mand-kws:plain-kw-tys ...)
+        (~optional (opt-dom:non-keyword-ty ... opt-kws:plain-kw-tys ...))
         (~optional (~seq #:rest rest-type:non-keyword-ty))
         rng)
        (define doms (for/list ([d (in-syntax #'(dom ...))])
@@ -392,11 +393,10 @@
        (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))))]
+               #:kws (append (attribute mand-kws.mand-kw)
+                             (if (attribute opt-kws)
+                                 (attribute opt-kws.opt-kw)
+                                 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/printer.rkt

@@ -5,10 +5,13 @@
 
 (require racket/require racket/match unstable/sequence racket/string racket/promise
          racket/pretty
+         racket/list
          (prefix-in s: srfi/1)
          (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt"
                   "rep/rep-utils.rkt" "types/subtype.rkt"
                   "types/match-expanders.rkt"
+                  "types/kw-types.rkt"
+                  "types/utils.rkt"
                   "utils/utils.rkt"
                   "utils/tc-utils.rkt")
          (for-syntax racket/base syntax/parse))
@@ -257,6 +260,59 @@
         [_ (list (type->sexp rng))]))]
     [else `(Unknown Function Type: ,(struct->vector arr))]))
 
+;; format->* : (Listof arr) -> S-Expression
+;; Format arrs that correspond to a ->* type
+(define (format->* arrs)
+  (define out (open-output-string))
+  (define (fp . args) (apply fprintf out args))
+  ;; see type-contract.rkt, which does something similar and this code
+  ;; was stolen from/inspired by/etc.
+  (match* ((first arrs) (last arrs))
+    [((arr: first-dom rng rst _ kws)
+      (arr: last-dom _ _ _ _))
+     (define-values (mand-kws opt-kws) (partition-kws kws))
+     (define opt-doms (drop last-dom (length first-dom)))
+     `(->*
+       ,(append* (for/list ([dom (in-list first-dom)])
+                   (type->sexp dom))
+                 (for/list ([mand-kw (in-list mand-kws)])
+                   (match-define (Keyword: k t _) mand-kw)
+                   (list k (type->sexp t))))
+       ,(append* (for/list ([opt-dom (in-list opt-doms)])
+                   (type->sexp opt-dom))
+                 (for/list ([opt-kw (in-list opt-kws)])
+                   (match-define (Keyword: k t _) opt-kw)
+                   (list k (type->sexp t))))
+       ,@(if rst (list '#:rest (type->sexp rst)) null)
+       ,(type->sexp rng))]))
+
+;; cover-case-lambda : (Listof arr) -> (Listof s-expression)
+;; Try to cover a case-> type with ->* types
+(define (cover-case-lambda arrs)
+  ;; sublists : (Listof X) -> (Listof (List (Listof X) (Listof X) (Listof X)))
+  ;; produce sublists of a list in decreasing order, also
+  ;; returning the rest of the list before and after the
+  ;; sublist for each.
+  (define (sublists lst)
+    (define (sublist-n n lst)
+      (for/list ([to-drop (range (- (length lst) (- n 1)))])
+        (define-values (pre mid) (split-at lst to-drop))
+        (define-values (sub post) (split-at mid n))
+        (list pre sub post)))
+    (apply append (for/list ([i (range (length lst) 0 -1)])
+                    (sublist-n i lst))))
+  (let loop ([left-to-cover arrs])
+    ;; try to match the largest sublists possible that correspond to
+    ;; ->* types and then the remainder are formatted normally
+    (define a-match
+      (for/first ([sub (in-list (sublists left-to-cover))]
+                  #:when (has-optional-args? (second sub)))
+        sub))
+    (cond [a-match
+           (match-define (list pre sub post) a-match)
+           (append (loop pre) (list (format->* sub)) (loop post))]
+          [else (map arr->sexp left-to-cover)])))
+
 ;; case-lambda->sexp : Type -> S-expression
 ;; Convert a case-> type to an s-expression
 (define (case-lambda->sexp type)
@@ -265,8 +321,11 @@
      (match arities
        [(list) '(case->)]
        [(list a) (arr->sexp a)]
-       [(list a b ...)
-        `(case-> ,(arr->sexp a) ,@(map arr->sexp b))])]))
+       [(and arrs (list a b ...))
+        (define cover (cover-case-lambda arrs))
+        (if (> (length cover) 1)
+            `(case-> ,@cover)
+            (car cover))])]))
 
 ;; type->sexp : Type -> S-expression
 ;; convert a type to an s-expression that can be printed

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

@@ -86,7 +86,24 @@
                       (string-append "(Any Path-String [#:exists (U 'error"
                                      " 'append 'update 'replace 'truncate"
                                      " 'truncate/replace)] [#:mode (U"
-                                     " 'binary 'text)] -> Void)")))
+                                     " 'binary 'text)] -> Void)"))
+    (check-prints-as? (->opt Univ [] -Void) "(Any -> Void)")
+    (check-prints-as? (->opt [-String] -Void) "(->* () (String) Void)")
+    (check-prints-as? (->opt Univ [-String] -Void) "(->* (Any) (String) Void)")
+    (check-prints-as? (->opt Univ -Symbol [-String] -Void)
+                      "(->* (Any Symbol) (String) Void)")
+    (check-prints-as? (->optkey Univ [-String] #:x -String #f -Void)
+                      "(->* (Any) (String #:x String) Void)")
+    (check-prints-as? (->optkey Univ [-String] #:x -String #t -Void)
+                      "(->* (Any #:x String) (String) Void)")
+    (check-prints-as? (->optkey Univ [-String] #:x -String #t -Void)
+                      "(->* (Any #:x String) (String) Void)")
+    (check-prints-as? (->optkey Univ [-String] #:rest -String #:x -String #t -Void)
+                      "(->* (Any #:x String) (String) #:rest String Void)")
+    (check-prints-as? (cl->* (->opt -Pathlike [-String] -Void)
+                             (->optkey Univ [-String] #:rest -String #:x -String #t -Void))
+                      (string-append "(case-> (->* (Path-String) (String) Void) "
+                                     "(->* (Any #:x String) (String) #:rest String Void))")))
    (test-suite
     "Pretty printing tests"
     (check-pretty-prints-as? (-val 3) "3")