From 7fcf28bef2aa0ebeee043b252caac27065bbad65 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Tue, 13 Sep 2011 20:09:05 -0700 Subject: [PATCH] Gave subprocess and similar functions more precise types. --- .../unit-tests/typecheck-tests.rkt | 50 ++++++- collects/typed-racket/base-env/base-env.rkt | 123 +++++++++++++----- 2 files changed, 137 insertions(+), 36 deletions(-) diff --git a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt index b6a1a59abb..dc244ff243 100644 --- a/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/collects/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -1183,16 +1183,19 @@ (tc-e (subprocess #f #f #f (string->path "/usr/bin/echo") "string" (string->path "path") #"bytes") (list -Subprocess - (-opt -Input-Port) - (-opt -Output-Port) - (-opt -Input-Port))) + -Input-Port + -Output-Port + -Input-Port)) - (tc-e (subprocess #f #f #f (string->path "/usr/bin/echo") 'exact "arg") + + + + (tc-e (subprocess (current-output-port) (current-input-port) (current-error-port) (string->path "/usr/bin/echo") 'exact "arg") (list -Subprocess - (-opt -Input-Port) - (-opt -Output-Port) - (-opt -Input-Port))) + (-val #f) + (-val #f) + (-val #f))) (tc-e (let () (: p Subprocess) @@ -1204,6 +1207,39 @@ (subprocess? p)) #:ret (ret B (-FS -top -bot))) + + (tc-e (let () + (: std-out Input-Port) + (: std-in Output-Port) + (: std-err Input-Port) + (: proc-id Natural) + (: f Any) + (define-values (std-out std-in proc-id std-err f) + (apply values (process/ports #f #f #f "/bin/bash"))) + proc-id) + -Nat) + + + (tc-e (let () + (: std-out #f) + (: std-in #f) + (: std-err #f) + (: proc-id Natural) + (: f Any) + (define-values (std-out std-in proc-id std-err f) + (apply values (process*/ports (current-output-port) + (current-input-port) + (current-error-port) + "/bin/bash" + "arg1" + #"arg2"))) + proc-id) + -Nat) + + + + + ;Compilation (tc-e (compile-syntax #'(+ 1 2)) -Compiled-Expression) (tc-e (let: ((e : Compiled-Expression (compile #'(+ 1 2)))) diff --git a/collects/typed-racket/base-env/base-env.rkt b/collects/typed-racket/base-env/base-env.rkt index 4a2745f467..98b1109ee2 100644 --- a/collects/typed-racket/base-env/base-env.rkt +++ b/collects/typed-racket/base-env/base-env.rkt @@ -1523,11 +1523,32 @@ ;Section 14.4 (Processes) [subprocess - (let ((ret-type (-values (list -Subprocess (-opt -Input-Port) (-opt -Output-Port) (-opt -Input-Port))))) - (cl->* - (->* (list (-opt -Output-Port) (-opt -Input-Port) (-opt -Output-Port) -Pathlike) - (Un -Path -String -Bytes) ret-type) - (-> (-opt -Output-Port) (-opt -Input-Port) (-opt -Output-Port) -Pathlike (-val 'exact) -String ret-type)))] + (let* ((make-opt-in-port (lambda (port) (if port -Input-Port (-val #f)))) + (make-opt-out-port (lambda (port) (if port -Output-Port (-val #f)))) + (ret-type (-values (list -Subprocess (-opt -Input-Port) (-opt -Output-Port) (-opt -Input-Port)))) + (make-specific-case (lambda (out in err exact) + (let ((arg-out (make-opt-out-port out)) + (arg-in (make-opt-in-port in)) + (arg-err (make-opt-out-port err)) + (result (-values (list -Subprocess + (make-opt-in-port (not out)) + (make-opt-out-port (not in)) + (make-opt-in-port (not err)))))) + (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))))) + (specific-cases + (let ((bools '(#t #f))) + (for*/list ((out bools) (in bools) (err bools) (exact bools)) + (make-specific-case out in err exact))))) + (apply cl->* + (append specific-cases + (list + (->* (list (-opt -Output-Port) (-opt -Input-Port) (-opt -Output-Port) -Pathlike) + (Un -Path -String -Bytes) ret-type) + (-> (-opt -Output-Port) (-opt -Input-Port) (-opt -Output-Port) -Pathlike (-val 'exact) -String ret-type)))))] [subprocess-wait (-> -Subprocess -Void)] [subprocess-status (-> -Subprocess (Un (-val 'running) -Nat))] [subprocess-kill (-> -Subprocess Univ -Void)] @@ -1576,34 +1597,78 @@ (-> (-val 'kill) -Void))))))] [process/ports - (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -String - (-values (list (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -Input-Port) - (cl->* - (-> (-val 'status) (one-of/c 'running 'done-ok 'done-error)) + (let* ((fun-type + (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)))))] + (-> (-val 'kill) -Void))) + (make-opt-in-port (lambda (port) (if port -Input-Port (-val #f)))) + (make-opt-out-port (lambda (port) (if port -Output-Port (-val #f)))) + (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)))) + (specific-cases + (let ((bools '(#t #f)) + (err-vals '(#t #f stdout))) + (for*/list ((out bools) (in bools) (err err-vals)) + (make-specific-case out in err))))) + (apply cl->* + (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))))))] [process*/ports - (cl->* - (->* (list (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike) - (Un -Path -String -Bytes) - (-values (list (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -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))))) - (-> (-opt -Output-Port) (-opt -Input-Port) (Un -Output-Port (one-of/c #f 'stdout)) -Pathlike (-val 'exact) -String - (-values (list (-opt -Input-Port) (-opt -Output-Port) -Nat (-opt -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))))))] + (let* ((fun-type + (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))) + (make-opt-in-port (lambda (port) (if port -Input-Port (-val #f)))) + (make-opt-out-port (lambda (port) (if port -Output-Port (-val #f)))) + (make-specific-case (lambda (out in err exact) + (let ((arg-out (make-opt-out-port out)) + (arg-in (make-opt-in-port in)) + (arg-err + (case err + ((stdout) (-val 'stdout)) + (else (make-opt-out-port err)))) + (result + (-lst* (make-opt-in-port (not out)) + (make-opt-out-port (not in)) + -Nat + (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))))) + (specific-cases + (let ((bools '(#t #f)) + (err-vals '(#t #f stdout))) + (for*/list ((out bools) (in bools) (err err-vals) (exact bools)) + (make-specific-case out in err exact))))) + (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))))))] @@ -2475,4 +2540,4 @@ [will-try-execute (-> -Will-Executor ManyUniv)] ;; reader graphs -[make-reader-graph (-> Univ Univ)] \ No newline at end of file +[make-reader-graph (-> Univ Univ)]