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. original commit: 3fd9df03f7236c803125170e03773218d70c6665
2013-04-18 17:02:47 -04:00 · 2013-04-18 17:02:47 -04:00 · 1e8e959025
commit 1e8e959025
parent 632b14c736 de94f17bb6
4 changed files with 93 additions and 55 deletions
--- a/collects/typed-racket/base-env/base-env.rkt
+++ b/collects/typed-racket/base-env/base-env.rkt
@ -1655,31 +1655,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)
@ -1702,17 +1705,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)))
@ -1722,8 +1726,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
@ -1754,10 +1759,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)))
@ -1766,11 +1772,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)
--- a/doc/release-notes/typed-racket/HISTORY.txt
+++ b/doc/release-notes/typed-racket/HISTORY.txt
@ -1,3 +1,6 @@
+5.3.4
+- Moved Optimization Coach to the package system
+- Multiple fixes to polydots
 5.3.3
  No changes
 5.3.2