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

more stuff works

Browse Source 
original commit: a1825082df673c1fd4bf8e288230c63bb142d9f3
This commit is contained in:
Sam Tobin-Hochstadt 2008-09-05 16:52:00 -04:00
parent 9a357ebf84
commit 8701782f17
2 changed files with 32 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/typed-scheme/private/base-env.ss
View File

@ -57,6 +57,9 @@
[qq-append qq-append-ty]
[id ty] ...)))]))
(define-for-syntax (one-of/c . args)
(apply Un (map -val args)))
(define-initial-env initial-env
;; make-promise
@ -145,9 +148,13 @@
[string-append (->* null -String -String)]
[open-input-string (-> -String -Input-Port)]
[open-output-file
(cl->
[(-Pathlike) -Port]
[(-Pathlike Sym) -Port])]
(->key -Pathlike
#:mode (one-of/c 'binary 'text) #f
#:exists (one-of/c 'error 'append 'update 'can-update
'replace 'truncate
'must-truncate 'truncate/replace)
#f
-Output-Port)]
[read (cl->
[(-Port) -Sexp]
[() -Sexp])]
@ -205,9 +212,7 @@
[remove* (-poly (a b)
(cl-> [((-lst a) (-lst a)) (-lst a)]
[((-lst a) (-lst b) (a b . -> . B)) (-lst b)]))]
[call-with-values (-poly (a b) (-> (-> a) (-> a b) b))]
(error
(make-Function (list
(make-arr null (Un))
@ -246,7 +251,6 @@
(- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N)))
(max (->* (list N) N N))
(min (->* (list N) N N))
[values (make-Poly '(a) (-> (-v a) (-v a)))]
[vector-ref
(make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))]
[build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))]
@ -467,7 +471,7 @@
[(-Bytes N) -Bytes]
[(-Bytes N N) -Bytes])]
[bytes-length (-> -Bytes N)]
[open-input-file (-> -Pathlike -Input-Port)]
[open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)]
[close-input-port (-> -Input-Port -Void)]
[close-output-port (-> -Output-Port -Void)]
[read-line (cl->
@ -553,10 +557,10 @@
[syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a))
(-> (-Syntax Univ) Univ Univ)))]
[values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
[call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))]
[values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
[call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))]
[foo (make-Function (list (make-arr (list N) B #f #f (list (make-Keyword '#:bar B #f)) null null)))]
[foo (N #:bar B #f . ->key . B)]
)
(begin-for-syntax

19
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -9,6 +9,7 @@
"type-utils.ss"
"tc-utils.ss"
scheme/promise
(for-syntax macro-debugger/stxclass/stxclass)
(for-syntax scheme/base))
(provide (all-defined-out))
@ -78,12 +79,26 @@
[(Function: as) as]))
(make-Function (map car (map funty-arities args))))
(define-syntax (->key stx)
(syntax-parse stx
[(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng)
#'(make-Function
(list
(make-arr* (list ty ...)
rng
#f
#f
(list (make-Keyword 'k kty opt) ...)
null
null)))]))
(define make-arr*
(case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))]
(case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))]
[(dom rng rest) (make-arr dom rng rest #f null (list) (list))]
[(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)]
[(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]
[(dom rng rest drest kws eff1 eff2) (make-arr dom rng rest drest kws eff1 eff2)]))
[(dom rng rest drest kws eff1 eff2)
(make-arr dom rng rest drest (sort #:key Keyword-kw kws keyword<?) eff1 eff2)]))
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #f (cons dty dbound) null null))