Fix types of system etc for new keyword arguments.

This requires extending the ->optkey type constructor to support rest arguments, and fixing the keyword function type generation code. Testing is still limited because there's no parsing for such types. That will be handled in a later commit. (cherry picked from commit 3fd9df03f7)
2013-04-18 17:02:47 -04:00 · 2013-04-18 17:02:47 -04:00 · d5c62424f8
commit d5c62424f8
parent 0503bcd7c6
3 changed files with 90 additions and 55 deletions
--- a/collects/typed-racket/base-env/base-env.rkt
+++ b/collects/typed-racket/base-env/base-env.rkt
@ -1666,31 +1666,34 @@


 ;Section 14.4.1 (racket/system)
-[system ((Un -String -Bytes) . -> . -Boolean)]
-[system* ((list -Pathlike) (Un -Path -String -Bytes) . ->* . -Boolean)]
-[system/exit-code ((Un -String -Bytes) . -> . -Byte)]
-[system*/exit-code ((list -Pathlike) (Un -Path -String -Bytes) . ->* . -Byte)]
+[system ((Un -String -Bytes) [] #:set-pwd? Univ #f . ->optkey . -Boolean)]
+[system* (-Pathlike [] #:rest (Un -Path -String -Bytes) #:set-pwd? Univ #f . ->optkey . -Boolean)]
+[system/exit-code ((Un -String -Bytes) [] #:set-pwd? Univ #f . ->optkey . -Byte)]
+[system*/exit-code (-Pathlike [] #:rest (Un -Path -String -Bytes) #:set-pwd? Univ #f . ->optkey . -Byte)]

-[process (-> -String
-             (-values (list -Input-Port -Output-Port -Nat -Input-Port
-                            (cl->* (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error))
-                                   (-> (-val 'exit-code) (-opt -Byte))
-                                   (-> (-val 'wait) ManyUniv)
-                                   (-> (-val 'interrupt) -Void)
-                                   (-> (-val 'kill) -Void)))))]
+[process (->key 
+	  -String
+	   #:set-pwd? Univ #f
+	  (-values (list -Input-Port -Output-Port -Nat -Input-Port
+			 (cl->* (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error))
+				(-> (-val 'exit-code) (-opt -Byte))
+				(-> (-val 'wait) ManyUniv)
+				(-> (-val 'interrupt) -Void)
+				(-> (-val 'kill) -Void)))))]


 [process*
 (cl->*
-   (->* (list -Pathlike) (Un -Path -String -Bytes)
+   (->optkey -Pathlike [] #:rest (Un -Path -String -Bytes) #:set-pwd? Univ #f
        (-values (list -Input-Port -Output-Port -Nat -Input-Port
                       (cl->* (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error))
                              (-> (-val 'exit-code) (-opt -Byte))
                              (-> (-val 'wait) ManyUniv)
                              (-> (-val 'interrupt) -Void)
                              (-> (-val 'kill) -Void)))))
-   (-> -Pathlike (-val 'exact) -String
-       (-values (list -Input-Port -Output-Port -Nat -Input-Port
+   (->key -Pathlike (-val 'exact) -String
+	  #:set-pwd? Univ #f
+	  (-values (list -Input-Port -Output-Port -Nat -Input-Port
                      (cl->* (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error))
                             (-> (-val 'exit-code) (-opt -Byte))
                             (-> (-val 'wait) ManyUniv)
@ -1713,17 +1716,18 @@
        ;; The return value is the function type that is one branch
        ;; of the case lambda.
        (make-specific-case (lambda (out in err)
-                              (-> (make-opt-out-port out)
-                                  (make-opt-in-port in)
-                                  (case err
-                                   ((stdout) (-val 'stdout))
-                                   (else (make-opt-out-port err)))
-                                  -String
-                                  (-lst* (make-opt-in-port (not out))
-                                         (make-opt-out-port (not in))
-                                         -Nat
-                                         (make-opt-in-port (not err))
-                                         fun-type))))
+                              (->key (make-opt-out-port out)
+				     (make-opt-in-port in)
+				     (case err
+				       ((stdout) (-val 'stdout))
+				       (else (make-opt-out-port err)))
+				     -String
+				     #:set-pwd? Univ #f
+				     (-lst* (make-opt-in-port (not out))
+					    (make-opt-out-port (not in))
+					    -Nat
+					    (make-opt-in-port (not err))
+					    fun-type))))
        (specific-cases
         (let ((bools '(#t #f))
               (err-vals '(#t #f stdout)))
@ -1733,8 +1737,9 @@
    (append
      specific-cases
      (list
-       (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -String
-           (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))]
+       (->key (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -String
+	      #:set-pwd? Univ #f
+	      (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))]

 [process*/ports
 (let* ((fun-type
@ -1765,10 +1770,11 @@
                                            (make-opt-in-port (not err))
                                            fun-type)))
                                (if exact
-                                  (-> arg-out arg-in arg-err -Pathlike (-val 'exact) -String result)
-                                  (->* (list arg-out arg-in arg-err -Pathlike)
-                                       (Un -Path -String -Bytes)
-                                       result)))))
+                                  (->key arg-out arg-in arg-err -Pathlike (-val 'exact) -String  #:set-pwd? Univ #f result)
+                                  (->optkey arg-out arg-in arg-err -Pathlike []
+					    #:rest (Un -Path -String -Bytes)
+					    #:set-pwd? Univ #f
+					    result)))))
        (specific-cases
         (let ((bools '(#t #f))
               (err-vals '(#t #f stdout)))
@ -1777,11 +1783,14 @@
   (apply cl->*
    (append specific-cases
     (list
-       (->* (list (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike)
-            (Un -Path -String -Bytes)
-            (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))
-       (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike (-val 'exact) -String
-           (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))]
+       (->optkey (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike
+		 []
+		 #:rest (Un -Path -String -Bytes)
+		 #:set-pwd? Univ #f
+		 (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))
+       (->key (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike (-val 'exact) -String
+	      #:set-pwd? Univ #f
+	      (-lst* (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) fun-type))))))]



--- a/collects/typed-racket/types/base-abbrev.rkt
+++ b/collects/typed-racket/types/base-abbrev.rkt
@ -201,19 +201,35 @@

 (define-syntax (->optkey stx)
  (syntax-parse stx
-                [(_ ty:expr ... [oty:expr ...] (~seq k:keyword kty:expr opt:boolean) ... rng)
-                 (let ([l (syntax->list #'(oty ...))])
-                   (with-syntax ([((extra ...) ...)
-                                  (for/list ([i (in-range (add1 (length l)))])
-                                    (take l i))])
-                     #'(make-Function
-                        (list
-                         (make-arr* (list ty ... extra ...)
-                                    rng
-                                    #:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
-                                                (list (make-Keyword 'k kty opt) ...)
-                                                keyword<?))
-                         ...))))]))
+    [(_ ty:expr ... [oty:expr ...] #:rest rst:expr (~seq k:keyword kty:expr opt:boolean) ... rng)
+     (let ([l (syntax->list #'(oty ...))])
+       (with-syntax ([((extra ...) ...)
+		      (for/list ([i (in-range (add1 (length l)))])
+				(take l i))]
+		     [(rsts ...) (for/list ([i (add1 (length l))]) #'rst)])
+		    #'(make-Function
+		       (list
+			(make-arr* (list ty ... extra ...)
+				   rng
+				   #:rest rsts
+				   #:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
+					       (list (make-Keyword 'k kty opt) ...)
+					       keyword<?))
+			...))))]
+    [(_ ty:expr ... [oty:expr ...] (~seq k:keyword kty:expr opt:boolean) ... rng)
+     (let ([l (syntax->list #'(oty ...))])
+       (with-syntax ([((extra ...) ...)
+		      (for/list ([i (in-range (add1 (length l)))])
+				(take l i))])
+		    #'(make-Function
+		       (list
+			(make-arr* (list ty ... extra ...)
+				   rng
+				   #:rest #f
+				   #:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
+					       (list (make-Keyword 'k kty opt) ...)
+					       keyword<?))
+			...))))]))

 (define (make-arr-dots dom rng dty dbound)
  (make-arr* dom rng #:drest (cons dty dbound)))
--- a/collects/typed-racket/types/kw-types.rkt
+++ b/collects/typed-racket/types/kw-types.rkt
@ -7,6 +7,10 @@
 ;; convert : [Listof Keyword] [Listof Type] [Listof Type] [Option Type] [Option Type] -> (values Type 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))
+
+  (when drest
+    (int-err "drest passed to kw-convert"))
+
  (define arities
    (for/list ([i (length opt-t)])
      (make-arr* (append plain-t (take opt-t i))
@ -25,7 +29,9 @@
          [(Keyword: _ t _) (list (-opt t) -Boolean)]))
      plain-t
      (for/list ([t (in-list opt-t)]) (-opt t))
-      (for/list ([t (in-list opt-t)]) -Boolean))))
+      (for/list ([t (in-list opt-t)]) -Boolean)
+      ;; the kw function protocol passes rest args as an explicit list
+      (if rest (-lst rest) empty))))
  (define ts/true
    (flatten
     (list
@ -37,7 +43,9 @@
          [(Keyword: _ t _) (list t (-val #t))]))
      plain-t
      (for/list ([t (in-list opt-t)]) t)
-      (for/list ([t (in-list opt-t)]) (-val #t)))))
+      (for/list ([t (in-list opt-t)]) (-val #t))
+      ;; the kw function protocol passes rest args as an explicit list
+      (if rest (-lst rest) empty))))
  (define ts/false
    (flatten
     (list
@ -49,11 +57,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
+      (if rest (-lst rest) empty))))
  (if split?
-      (make-Function (list (make-arr* ts/true rng #:rest rest #:drest drest)
-                           (make-arr* ts/false rng #:rest rest #:drest drest)))
-      (make-Function (list (make-arr* ts rng #:rest rest #:drest drest)))))
+      (make-Function (list (make-arr* ts/true rng)
+                           (make-arr* ts/false rng)))
+      (make-Function (list (make-arr* ts rng)))))

 (define (prefix-of a b)
  (define (rest-equal? a b)