suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add make-input-port, make-output-port to TR

Browse Source 
original commit: 32cd4d297316b76d9eb7b2e9608618552e8a2a6b
This commit is contained in:
Asumu Takikawa 2014-02-28 16:16:01 -05:00
parent 448e538142
commit 47080bc073
2 changed files with 117 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -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

80
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -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"