From 47080bc073b6aaf7d1d41a6130bd454c5edb85c1 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 28 Feb 2014 16:16:01 -0500 Subject: [PATCH] Add make-input-port, make-output-port to TR original commit: 32cd4d297316b76d9eb7b2e9608618552e8a2a6b --- .../typed-racket/base-env/base-env.rkt | 42 ++++++++-- .../unit-tests/typecheck-tests.rkt | 80 +++++++++++++++++++ 2 files changed, 117 insertions(+), 5 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt index 24cde9da..e64b0535 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -1603,11 +1603,43 @@ [prop:output-port -Struct-Type-Property] ;; Section 13.1.9 -;; TODO write the types for these -;; They are fairly complicated and require events - -;make-input-port -;make-output-port +[make-input-port + (->opt Univ + (Un (-> -Bytes (Un -Nat (-val eof) top-func (make-Evt Univ))) + -Input-Port) + (Un (-> -Bytes -Nat (-opt (make-Evt Univ)) + (Un -Nat (-val eof) top-func (make-Evt Univ) (-val #f))) + -Input-Port + (-val #f)) + (-> Univ) + [(-opt (-> (make-Evt Univ))) + (-opt (-> -PosInt (make-Evt Univ) (make-Evt Univ) Univ)) + (-opt (-> (-values (list (-opt -Integer) + (-opt -Integer) + (-opt -Integer))))) + (-> Univ) + (Un -Integer -Port (-val #f) (-> (-opt -Integer))) + (-opt (cl->* (-> (one-of/c 'block 'none) Univ) + (-> (-opt (one-of/c 'block 'none)))))] + -Input-Port)] +[make-output-port + (->opt Univ + (make-Evt Univ) + (Un (-> -Bytes -Nat -Nat -Boolean -Boolean + (Un -Integer (-val #f) (make-Evt Univ))) + -Output-Port) + (-> Univ) + [(-opt (Un -Output-Port (-> Univ -Boolean -Boolean Univ))) + (-opt (-> -Bytes -Nat -Nat (make-Evt Univ))) + (-opt (-> Univ (make-Evt Univ))) + (-opt (-> (-values (list (-opt -Integer) + (-opt -Integer) + (-opt -Integer))))) + (-> Univ) + (Un -Integer -Port (-val #f) (-> (-opt -Integer))) + (-opt (cl->* (-> (one-of/c 'block 'none) Univ) + (-> (-opt (one-of/c 'block 'none)))))] + -Output-Port)] ;; Section 13.1.10 diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index 517e40da..41b7dcd0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -2318,6 +2318,86 @@ #:ret (ret (t:-> -String -String -Symbol (-values (list -String -String -Symbol))) (-FS -top -bot))] + + ;; make-input-port, make-output-port (examples from Reference) + [tc-e (let () + (define /dev/null-in + (make-input-port + 'null + (lambda (s) eof) + (lambda (skip s progress-evt) eof) + void + (lambda () never-evt) + (lambda (k progress-evt done-evt) + (error "no successful peeks!")))) + (read-char /dev/null-in)) + (t:Un -Char (-val eof))] + [tc-e (let () + (define infinite-ones + (let ([one! (tr:lambda ([s : Bytes]) + (bytes-set! s 0 (char->integer #\1)) 1)]) + (make-input-port + 'ones + one! + (tr:lambda ([s : Bytes] skip progress-evt) (one! s)) + void))) + (read-string 5 infinite-ones)) + (t:Un -String (-val eof))] + [tc-e (let () + (define infinite-voids + (make-input-port + 'voids + (lambda (s) (lambda args 'void)) + (lambda (skip s evt) (lambda args 'void)) + void)) + (read-char-or-special infinite-voids)) + Univ] + [tc-e (let () + (define mod3-cycle/one-thread + (let* ([n 2] + [mod! (tr:lambda ([s : Bytes] [delta : Integer]) + (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3))) + 1)]) + (make-input-port + 'mod3-cycle/not-thread-safe + (tr:lambda ([s : Bytes]) + (set! n (modulo (add1 n) 3)) + (mod! s 0)) + (tr:lambda ([s : Bytes] [skip : Integer] evt) + (mod! s skip)) + void))) + (read-string 5 mod3-cycle/one-thread)) + (t:Un -String (-val eof))] + [tc-e (let () + (define /dev/null-out + (make-output-port + 'null + always-evt + (tr:lambda (s [start : Integer] [end : Integer] non-block? breakable?) + (- end start)) + void + (lambda (special non-block? breakable?) #t) + (tr:lambda (s [start : Integer] [end : Integer]) + (wrap-evt always-evt (lambda (x) (- end start)))) + (lambda (special) always-evt))) + (display "hello" /dev/null-out)) + -Void] + [tc-e (let () + (: accum-list (Listof Char)) + (define accum-list null) + (define accumulator/not-thread-safe + (make-output-port + 'accum/not-thread-safe + always-evt + (tr:lambda ([s : Bytes] [start : Integer] [end : Integer] _1 _2) + (set! accum-list + (append accum-list + (map integer->char + (bytes->list (subbytes s start end))))) + (- end start)) + void)) + (display "hello" accumulator/not-thread-safe)) + -Void] ) (test-suite "tc-literal tests"