From b63514a2c3b0a73d7d26e1a10aeb1c969099db18 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Tue, 2 Jun 2015 01:02:01 -0400
Subject: [PATCH] Allow more flexible keywords in ->* types

Keyword argument types in ->* are now allowed intermixed with
positional arguments instead of at the end.

Closes #145
---
 .../typed-racket/private/parse-type.rkt       | 47 ++++++++++++-------
 .../unit-tests/parse-type-tests.rkt           |  8 ++++
 2 files changed, 39 insertions(+), 16 deletions(-)

diff --git a/typed-racket-lib/typed-racket/private/parse-type.rkt b/typed-racket-lib/typed-racket/private/parse-type.rkt
index 01eb098b..7332cd02 100644
--- a/typed-racket-lib/typed-racket/private/parse-type.rkt
+++ b/typed-racket-lib/typed-racket/private/parse-type.rkt
@@ -13,6 +13,7 @@
          (env tvar-env type-alias-env mvar-env
               lexical-env index-env row-constraint-env)
          racket/dict
+         racket/list
          racket/promise
          racket/format
          racket/match
@@ -185,23 +186,33 @@
            #:when (not (syntax->list #'t))))
 
 ;; syntax classes for parsing ->* function types
-(define-syntax-class ->*-mand
-  #:description "mandatory arguments for ->*"
+(define-syntax-class (->*-args mand?)
+  #:description "type arguments for ->*"
   #:attributes (doms kws)
-  (pattern (dom:non-keyword-ty ... kw:plain-kw-tys ...)
-           #:attr doms (syntax->list #'(dom ...))
-           #:attr kws  (attribute kw.mand-kw)))
+  (pattern ((~var dom (->*-dom mand?)) ...)
+           #:do [(define-values (kws doms)
+                   ;; would like to use `partition` but we need to traverse multiple
+                   ;; lists rather than just checking Keyword? due to laziness
+                   (for/fold ([kws null] [doms null])
+                             ([kw? (in-list (attribute dom.kw?))]
+                              [type/kw (attribute dom.result)])
+                     (if kw?
+                         (values (cons type/kw kws) doms)
+                         (values kws (cons type/kw doms)))))]
+           #:attr doms (reverse doms)
+           #:attr kws (reverse kws)))
 
-(define-splicing-syntax-class ->*-opt
-  #:description "optional arguments for ->*"
-  #:attributes (doms kws)
- (pattern (~optional (dom:non-keyword-ty ... kw:plain-kw-tys ...))
-          #:attr doms (if (attribute dom)
-                          (syntax->list #'(dom ...))
-                          null)
-          #:attr kws (if (attribute kw)
-                         (attribute kw.opt-kw)
-                         null)))
+;; parameterized syntax class for parsing ->* domains.
+(define-splicing-syntax-class (->*-dom mand?)
+  #:attributes (kw? result)
+  (pattern (~seq k:keyword t:expr)
+           #:attr kw? #t
+           #:attr result
+           (delay (make-Keyword (syntax-e #'k) (parse-type #'t) mand?)))
+  (pattern t:expr
+           #:attr kw? #f
+           ;; does not need to be delayed since there's no parsing done
+           #:attr result #'t))
 
 (define-splicing-syntax-class ->*-rest
   #:description "rest argument type for ->*"
@@ -502,7 +513,11 @@
               (parse-type #'rng)
               : (-FS (attribute latent.positive) (attribute latent.negative))
               : (attribute latent.object)))]
-      [(:->*^ mand:->*-mand opt:->*-opt rest:->*-rest rng)
+      [(:->*^ (~var mand (->*-args #t))
+              (~optional (~var opt (->*-args #f))
+                         #:defaults ([opt.doms null] [opt.kws null]))
+              rest:->*-rest
+              rng)
        (with-arity (length (attribute mand.doms))
          (define doms (for/list ([d (attribute mand.doms)])
                         (parse-type d)))
diff --git a/typed-racket-test/unit-tests/parse-type-tests.rkt b/typed-racket-test/unit-tests/parse-type-tests.rkt
index 46c61ed0..884d3d5a 100644
--- a/typed-racket-test/unit-tests/parse-type-tests.rkt
+++ b/typed-racket-test/unit-tests/parse-type-tests.rkt
@@ -222,12 +222,20 @@
     (->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 String) Void)
+    (->optkey -Integer [-String -String] #:foo -Integer #f -Void)]
    [(->* (Integer) (String #:foo Integer) Void)
     (->optkey -Integer [-String] #:foo -Integer #f -Void)]
+   [(->* (Integer) (#:foo Integer String) Void)
+    (->optkey -Integer [-String] #:foo -Integer #f -Void)]
    [(->* (Integer #:bar Integer) (String) Void)
     (->optkey -Integer [-String] #:bar -Integer #t -Void)]
+   [(->* (#:bar Integer 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)]
+   [(->* (#:bar Integer Integer) (#:foo Integer String) Void)
+    (->optkey -Integer [-String] #:bar -Integer #t #:foo -Integer #f -Void)]
    [(->* (Any (-> Any Boolean : #:+ (String @ 1 0))) Void)
     (t:-> Univ (t:->* (list Univ) -Boolean : (-FS (-filter -String '(1 0)) -top))
           -Void)]