From d5c62424f8884a824b2fbe06c6ad81e49b6256f0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Thu, 18 Apr 2013 17:02:47 -0400 Subject: [PATCH] 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 3fd9df03f7236c803125170e03773218d70c6665) --- collects/typed-racket/base-env/base-env.rkt | 81 ++++++++++++--------- collects/typed-racket/types/base-abbrev.rkt | 42 +++++++---- collects/typed-racket/types/kw-types.rkt | 22 ++++-- 3 files changed, 90 insertions(+), 55 deletions(-) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index f4e10e2730..51e61fd3f9 100644 --- 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))))))] diff --git a/collects/typed-racket/types/base-abbrev.rkt b/collects/typed-racket/types/base-abbrev.rkt index dba6ad6627..673655a9ac 100644 --- 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) ...) - keywordlist #'(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) ...) + keywordlist #'(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 (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)