From 3fd9df03f7236c803125170e03773218d70c6665 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. --- 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 ad881fd510..6132c8df1f 100644 --- 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))))))] diff --git a/collects/typed-racket/types/base-abbrev.rkt b/collects/typed-racket/types/base-abbrev.rkt index 5584fdaff2..9e0394f561 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)