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

Change over some of the base environment over to dotted types.

Browse Source
This commit is contained in:
Stevie Strickland 2008-06-16 13:01:16 -04:00
parent 14da71b5c2
commit c4e253d2d1
2 changed files with 27 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,9 +1,11 @@
#lang scheme/base #lang scheme/base
;; these are libraries providing functions we add types to that are not in scheme/base ;; these are libraries providing functions we add types to that are not in scheme/base
(require (require
"extra-procs.ss" "extra-procs.ss"
(only-in scheme/list cons? take drop add-between last) (only-in scheme/list cons? take drop add-between last)
(only-in rnrs/lists-6 fold-left)
'#%paramz '#%paramz
(only-in scheme/match/runtime match:error)) (only-in scheme/match/runtime match:error))
@ -99,11 +101,8 @@
[read (cl-> [read (cl->
[(-Port) -Sexp] [(-Port) -Sexp]
[() -Sexp])] [() -Sexp])]
[ormap (-poly (a b) ((-> a b) (-lst a) . -> . b))] [ormap (-polydots (a b) (->... (list (->... (list a) (b b) B) (-lst a)) ((-lst b) b) B))]
[andmap (-poly (a b c d e) [andmap (-polydots (a b) (->... (list (->... (list a) (b b) B) (-lst a)) ((-lst b) b) B))]
(cl->*
((-> a b) (-lst a) . -> . b)
((-> c d e) (-lst c) (-lst d) . -> . e)))]
[newline (cl-> [() -Void] [newline (cl-> [() -Void]
[(-Port) -Void])] [(-Port) -Void])]
[not (-> Univ B)] [not (-> Univ B)]
@ -122,16 +121,12 @@
[list? (make-pred-ty (-lst Univ))] [list? (make-pred-ty (-lst Univ))]
[list (-poly (a) (->* '() a (-lst a)))] [list (-poly (a) (->* '() a (-lst a)))]
[procedure? (make-pred-ty (make-Function (list (make-top-arr))))] [procedure? (make-pred-ty (make-Function (list (make-top-arr))))]
[map [map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-lst a))
(-poly (a b c d) ((-lst b) b) . ->... .(-lst c)))]
(cl-> [((-> a b) (-lst a)) (-lst b)] [for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . -Void) (-lst a))
[((-> a b c) (-lst a) (-lst b)) (-lst c)] ((-lst b) b) . ->... . -Void))]
[((-> a b c d) (-lst a) (-lst b) (-lst c)) (-lst d)]))] [fold-left (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
[for-each ((-lst b) b) . ->... . c))]
(-poly (a b c d)
(cl-> [((-> a b) (-lst a)) -Void]
[((-> a b c) (-lst a) (-lst b)) -Void]
[((-> a b c d) (-lst a) (-lst b) (-lst c)) -Void]))]
[foldl [foldl
(-poly (a b c) (-poly (a b c)
(cl-> [((a b . -> . b) b (make-lst a)) b] (cl-> [((a b . -> . b) b (make-lst a)) b]

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

@ -52,6 +52,16 @@
(make-Function (list (make-arr* dom rng #f eff1 eff2)))] (make-Function (list (make-arr* dom rng #f eff1 eff2)))]
[(_ dom rst rng : eff1 eff2) [(_ dom rst rng : eff1 eff2)
(make-Function (list (make-arr* dom rng rst eff1 eff2)))])) (make-Function (list (make-arr* dom rng rst eff1 eff2)))]))
(define-syntax ->...
(syntax-rules (:)
[(_ dom rng)
(->* dom rng)]
[(_ dom (dty dbound) rng)
(make-Function (list (make-arr* dom rng #f (cons dty 'dbound) (list) (list))))]
[(_ dom rng : eff1 eff2)
(->* dom rng : eff1 eff2)]
[(_ dom (dty dbound) rng : eff1 eff2)
(make-Function (list (make-arr* dom rng #f (cons dty 'dbound) eff1 eff2)))]))
(define-syntax cl-> (define-syntax cl->
(syntax-rules (:) (syntax-rules (:)
[(_ [(dom ...) rng] ...) [(_ [(dom ...) rng] ...)
@ -114,6 +124,13 @@
(let ([vars (-v vars)] ...) (let ([vars (-v vars)] ...)
(make-Poly (list 'vars ...) ty))])) (make-Poly (list 'vars ...) ty))]))
(define-syntax -polydots
(syntax-rules ()
[(_ (vars ... dotted) ty)
(let ([dotted (-v dotted)]
[vars (-v vars)] ...)
(make-PolyDots (list 'vars ... 'dotted) ty))]))
(define-syntax -mu (define-syntax -mu
(syntax-rules () (syntax-rules ()
[(_ var ty) [(_ var ty)