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

Merge in paths branch.

Browse Source 
Includes -
- Reimplementation of core typechecking algorithm
- support for (number? (car x)) etc

svn: r14985
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-25 17:40:46 +00:00
commit 33587b6dd5
85 changed files with 3892 additions and 3136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/tests/typed-scheme/succeed/dot-intro.ss
View File

@ -8,6 +8,10 @@
(plambda: (a ...) ([x : Number] . [y : a ... a])
(ormap null? (map list y))))
(define y*
(plambda: (a ...) ([x : Number] . [y : a ... a])
(andmap null? (map list y))))
(plambda: (a ...) ([x : Number] . [y : Number ... a])
y)

9
collects/tests/typed-scheme/succeed/little-schemer.ss
View File

@ -17,10 +17,11 @@
(define-syntax (cond* stx)
(syntax-case stx (else)
[(_ [pred expr id rhs] . rest)
#'(let ([id expr])
(if (pred id)
rhs
(cond . rest)))]
(quasisyntax/loc stx
(let ([id expr])
(if (pred id)
rhs
#,(syntax/loc #'rest (cond . rest)))))]
[(_ [else . rest]) #'(begin . rest)]
[(_ [p . rhs] . rest)
#'(if p (begin . rhs)

2
collects/tests/typed-scheme/succeed/struct-exec.ss
View File

@ -1,3 +1,3 @@
#lang typed-scheme
(define-typed-struct/exec X ([a : Number] [b : Boolean]) [(lambda: ([x : X]) (+ 3 )) : (X -> Number)])
(define-typed-struct/exec X ([a : Number] [b : Boolean]) [(lambda: ([x : X]) (+ 3 (X-a x))) : (X -> Number)])
((make-X 1 #f))

101
collects/tests/typed-scheme/succeed/test.ss Normal file
View File

@ -0,0 +1,101 @@
#lang typed-scheme
(define: x : (U Number #f) 1)
(if x #{x :: Number} 1)
(lambda () 1)
(lambda: ([y : Number]) (if #t y y))
(plambda: (a) ([y : Number]) (if y #t #f))
(plambda: (a) ([y : a]) y)
(plambda: (a) ([y : a]) y)
(plambda: () ([y : Boolean]) (if y #t #f))
#{(if #t #t #t) :: Boolean}
(let () 3)
(let ([x 1] [y 2]) x)
#{(let ([x 1] [y 2]) x) :: Number}
(let: ([x : Number 1] [y : Integer 2]) x)
#{(let: ([x : Integer 1] [y : Integer 2]) x) :: Integer}
#{(let*: ([x : Number 1] [x : Integer 2]) x) :: Integer}
#{(let*: ([x : Number 1] [x : Integer 2]) #{x :: Integer}) :: Integer}
#{(letrec: ([x : Integer 1] [y : Integer 2]) #{x :: Integer}) :: Integer}
(letrec: ([x : Integer 1] [y : Integer 2]) #{x :: Integer})
(let ()
(define x 1)
(define y 2)
x)
(letrec: ([z : (-> Any) (lambda () z)]) 1)
(letrec: ([z : (-> Any) (lambda () w)]
[w : (-> Any) (lambda () z)]) z)
(let ()
(define: (z) : Any w)
(define: (w) : Any z)
z)
(let ()
(define: (z [x : Number]) : Any w)
(define: (w) : Any z)
z)
(case-lambda: [() 1]
[([x : Number]) x])
;; Error
#;#{(case-lambda: [() 1]
[([x : Number]) x]) :: String}
#{(lambda: ([x : Number]) 1) :: (Number -> Number)}
#{(lambda: ([x : Number]) 1) :: Any}
#{(lambda: ([x : Number]) 1) :: (Integer -> Any)}
#{(lambda: ([x : Number]) x) :: (Number -> Number)}
#{(lambda: ([x : Number]) x) :: (Integer -> Any)}
(define zzz 1)
(set! zzz 2)
(define-struct: xxx ())
(define-struct: xxx2 ([y : Number]))
(define-struct: xxx3 ([y : Number] [z : Number]))
(define-struct: xxx4 ([y : Number] [z : xxx4]))
(define-struct: xxx5 ([y : Number] [z : xxx4]))
(define-struct: (A) xxx6 ([y : A] [z : xxx4]))
xxx6-y
(with-continuation-mark 1 1 1)
'foo
'(foo foo foo)
(define-type-alias NNN Number)
(define-type-alias (NNN2 A) (Listof Number))
(define-type-alias (NNN3 A) (Listof A))
(define-syntax-rule (m x) 1)
(m 2)
#{1 :: 1}
(lambda: ([x : String]) (lambda () (set! x "foo")))
#'(x y z)
(begin0 1 1 1)
(begin 1 1 1)
(#%expression (begin 1 1 1))
(values 1)
(values 1 1)
(values)
(: ff (Number -> Number))
(define (ff x) x)
(ff 1)
(lambda: ([y : String][x : Number]) (values 1 x 1))
(lambda: ([x : Number]) (values 1 x 1))
(lambda () (values 1 1))
(lambda () 1)
#{(lambda (x) x) :: (Number -> Number)}
{ann (values (lambda (x) x) (lambda (x) x)) (values (Number -> Number) (String -> String))}
(list 1 2 3)
(ann (list 1 2 3) (Pair Number (Listof Integer)))
(ann (list 1 2 3) (Listof Integer))
(ann (list 1 2 3) (Listof Number))
(list* 1 2 3)
(ann (list* 1 2 3 (list)) (Pair Number (Listof Integer)))
((lambda (x) 1) 1)
((lambda (x y) 1) 1 2)

52
collects/tests/typed-scheme/succeed/test2.ss Normal file
View File

@ -0,0 +1,52 @@
#lang typed-scheme
(: f (Number String -> Number))
(define (f x z) #;(f x z) 7)
(lambda: ([x : Any] [y : Any]) (values (number? y) (number? x)))
(lambda: ([x : Any] [y : Any]) (values (number? x) (number? y)))
(lambda: ([x : Any] [y : Any]) (values (and (number? x) (boolean? y)) (number? y)))
(lambda: ([x : Any]) (values (number? x) (number? x)))
(: g (Any -> Boolean : Number))
(define g (lambda: ([x : Any]) (number? x)))
(: q ((Number -> Number) -> Number))
(define q (lambda: ([x : (Number -> Number)]) (x 1)))
;(q (lambda (z) (f z "foo")))
(: p (Number * -> Number))
(define (p . x) 7)
(lambda x (number? x))
(+)
(+ 1 2 3)
(+ 1 2 3.5)
(define-struct: (Z) X ([y : Z]))
(define: my-x : (X Number) (make-X 1))
(X-y my-x)
; FIXME - doesn't work yet
(number? (X-y my-x))
(if (number? (X-y my-x)) (+ 1 (X-y my-x)) 7)
(define: (f2) : (U) (error 'foo))
(lambda: ([x : Number]) #{((f2)) :: (U)})
(: f3 (U (Number -> Number) (Number -> String)))
(define (f3 x) 7)
(define: x : (List Any Any) (list 1 23 ))
(car x)
(if (number? (car x)) (add1 (car #{x :: (Pair Number Any)})) 7)
(if (number? (car x)) (add1 (car x)) 7)
;; error
;(f 12 "hi")
(map + (list 1 2 3))
(map + (list 1 2 3) (list 1 2 3))
;; error
;(map + (list 1 2 3) (list 1 2 "foo"))
((lambda (a b . c) (+ a b (car c))) 1 2 3 4)

24
collects/tests/typed-scheme/unit-tests/all-tests.ss
View File

@ -3,15 +3,17 @@
(require
"test-utils.ss"
"planet-requires.ss"
"typecheck-tests.ss"
"subtype-tests.ss" ;; done
"type-equal-tests.ss" ;; done
"remove-intersect-tests.ss" ;; done
"parse-type-tests.ss" ;; done
"type-annotation-test.ss" ;; done
"module-tests.ss"
"subst-tests.ss"
"infer-tests.ss")
"typecheck-tests.ss" ;;fail
"subtype-tests.ss" ;; pass
"type-equal-tests.ss" ;; pass
"remove-intersect-tests.ss" ;; pass
"parse-type-tests.ss" ;; pass
"type-annotation-test.ss" ;; pass
"module-tests.ss" ;; pass
"subst-tests.ss" ;; pass
"infer-tests.ss" ;; pass
"contract-tests.ss"
)
(require (r:infer infer infer-dummy)
(schemeunit))
@ -30,10 +32,12 @@
type-equal-tests
restrict-tests
remove-tests
overlap-tests
parse-type-tests
type-annotation-tests
module-tests
fv-tests)])
fv-tests
contract-tests)])
(f))))

21
collects/tests/typed-scheme/unit-tests/contract-tests.ss Normal file
View File

@ -0,0 +1,21 @@
#lang scheme/base
(require "test-utils.ss" "planet-requires.ss"
(for-syntax scheme/base)
(for-template scheme/base)
(private type-contract)
(rep type-rep filter-rep object-rep)
(types utils union convenience)
(utils tc-utils mutated-vars)
(schemeunit)
stxclass)
(define-syntax-rule (t e)
(test-not-exn (format "~a" e) (lambda () (type->contract e (lambda _ (error "type could not be converted to contract"))))))
(define (contract-tests)
(test-suite "Contract Tests"
(t (-Number . -> . -Number))))
(define-go contract-tests)
(provide contract-tests)

6
collects/tests/typed-scheme/unit-tests/infer-tests.ss
View File

@ -2,7 +2,7 @@
(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (rep type-rep)
(r:infer infer)
(private type-effect-convenience union type-utils)
(types convenience union utils abbrev)
(schemeunit))
@ -18,7 +18,7 @@
(define (fv-tests)
(test-suite "Tests for fv"
(fv-t N)
(fv-t -Number)
[fv-t (-v a) a]
[fv-t (-poly (a) a)]
[fv-t (-poly (a b c d e) a)]
@ -27,7 +27,7 @@
[fv-t (-mu a (-lst a))]
[fv-t (-mu a (-lst (-pair a (-v b)))) b]
[fv-t (->* null (-v a) N) a] ;; check that a is CONTRAVARIANT
[fv-t (->* null (-v a) -Number) a] ;; check that a is CONTRAVARIANT
))
(define-syntax-rule (i2-t t1 t2 (a b) ...)

25
collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
View File

@ -3,14 +3,12 @@
(require (utils tc-utils)
(env type-alias-env type-environments type-name-env init-envs)
(rep type-rep)
(rename-in (private type-comparison parse-type subtype
union type-utils)
[Un t:Un])
(schemeunit))
(require (rename-in (private type-effect-convenience) [-> t:->])
(rename-in (types comparison subtype union utils convenience)
[Un t:Un] [-> t:->])
(private base-types base-types-extra)
(for-template (private base-types base-types-extra)))
(for-template (private base-types base-types-extra))
(private parse-type)
(schemeunit))
(provide parse-type-tests)
@ -57,6 +55,10 @@
(test-suite nm
(pt-test elems ...) ...)]))
(define N -Number)
(define B -Boolean)
(define Sym -Symbol)
(define (parse-type-tests)
(pt-tests
"parse-type tests"
@ -67,7 +69,7 @@
[(Listof Boolean) (make-Listof B)]
[(Vectorof (Listof Symbol)) (make-Vector (make-Listof Sym))]
[(pred Number) (make-pred-ty N)]
[(values Number Boolean Number) (-values (list N B N))]
[(-> (values Number Boolean Number)) (t:-> (-values (list N B N)))]
[(Number -> Number) (t:-> N N)]
[(Number -> Number) (t:-> N N)]
[(Number Number Number Boolean -> Number) (N N N B . t:-> . N)]
@ -82,8 +84,8 @@
[(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))]
[(All (a ...) (a ... -> Number))
(-polydots (a) ((list) [a a] . ->... . N))]
[(All (a ...) (values a ...))
(-polydots (a) (make-ValuesDots (list) a 'a))]
[(All (a ...) (-> (values a ...)))
(-polydots (a) (t:-> (make-ValuesDots (list) a 'a)))]
[(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B]
[(N N) N])]
[1 (-val 1)]
@ -98,8 +100,11 @@
[(All (a ...) (a ... -> Number))
(-polydots (a) ((list) [a a] . ->... . N))]
[(Any -> Boolean : Number) (make-pred-ty -Number)]
))
;; FIXME - add tests for parse-values-type, parse-tc-results
(define-go
parse-type-tests)

21
collects/tests/typed-scheme/unit-tests/planet-requires.ss
View File

@ -9,28 +9,11 @@
(define-syntax define-module
(syntax-rules ()
[(_ nm spec ...)
[(_ nm spec ...)
(define-syntax nm
(make-require-transformer
(lambda (stx)
(splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...)))))
#;
(define-require-syntax nm
(lambda (stx)
(syntax-case stx ()
[(_) (datum->syntax stx (syntax->datum #'(combine-in spec ...)))])))]))
#;
(define-syntax define-module
(lambda (stx)
(syntax-case stx ()
[(_ nm spec ...)
(syntax/loc stx
(define-syntax nm
(make-require-transformer
(lambda (stx)
(splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))))])))
(splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...)))))]))
(define-syntax planet/multiple
(make-require-transformer

67
collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss
View File

@ -1,27 +1,39 @@
#lang scheme/base
(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (rep type-rep)
(r:infer infer)
(private type-effect-convenience remove-intersect subtype union)
(r:infer infer infer-dummy)
(types convenience subtype union remove-intersect)
(schemeunit))
(define-syntax (over-tests stx)
(syntax-case stx ()
[(_ [t1 t2 res] ...)
#'(test-suite "Tests for intersect"
(test-check (format "Overlap test: ~a ~a" t1 t2) (lambda (a b) (eq? (not (not a)) b)) (overlap t1 t2) res) ...)]))
(define (overlap-tests)
(over-tests
[-Number -Integer #t]))
(define-syntax (restr-tests stx)
(syntax-case stx ()
[(_ [t1 t2 res] ...)
#'(test-suite "Tests for intersect"
(test-check (format "Restrict test: ~a ~a" t1 t2) type-compare? (restrict t1 t2) res) ...)]))
(infer-param infer)
(define (restrict-tests)
(restr-tests
[N (Un N Sym) N]
[N N N]
[(Un (-val 'foo) (-val 6)) (Un N Sym) (Un (-val 'foo) (-val 6))]
[N (-mu a (Un N Sym (make-Listof a))) N]
[(Un N B) (-mu a (Un N Sym (make-Listof a))) N]
[(-mu x (Un N (make-Listof x))) (Un Sym N B) N]
[(Un N -String Sym B) N N]
[-Number (Un -Number -Symbol) -Number]
[-Number -Number -Number]
[(Un (-val 'foo) (-val 6)) (Un -Number -Symbol) (Un (-val 'foo) (-val 6))]
[-Number (-mu a (Un -Number -Symbol (make-Listof a))) -Number]
[(Un -Number -Boolean) (-mu a (Un -Number -Symbol (make-Listof a))) -Number]
[(-mu x (Un -Number (make-Listof x))) (Un -Symbol -Number -Boolean) -Number]
[(Un -Number -String -Symbol -Boolean) -Number -Number]
[(-lst N) (-pair Univ Univ) (-pair N (-lst N))]
[(-lst -Number) (-pair Univ Univ) (-pair -Number (-lst -Number))]
;; FIXME
#;
[-Listof -Sexp (-lst (Un B N -String Sym))]
@ -38,33 +50,34 @@
(define (remove-tests)
(remo-tests
[(Un N Sym) N Sym]
[N N (Un)]
[(-mu x (Un N Sym (make-Listof x))) N (Un Sym (make-Listof (-mu x (Un N Sym (make-Listof x)))))]
[(-mu x (Un N Sym B (make-Listof x))) N (Un Sym B (make-Listof (-mu x (Un N Sym B (make-Listof x)))))]
[(Un (-val #f) (-mu x (Un N Sym (make-Listof (-v x)))))
(Un B N)
(Un Sym (make-Listof (-mu x (Un N Sym (make-Listof x)))))]
[(Un (-val 'foo) (-val 6)) (Un N Sym) (Un)]
[(-> (Un Sym N) N) (-> N N) (Un)]
[(Un (-poly (a) (make-Listof a)) (-> N N)) (-> N N) (-poly (a) (make-Listof a))]
[(Un Sym N) (-poly (a) N) Sym]
[(-pair N (-v a)) (-pair Univ Univ) (Un)]
[(Un -Number -Symbol) -Number -Symbol]
[-Number -Number (Un)]
[(-mu x (Un -Number -Symbol (make-Listof x))) -Number (Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))]
[(-mu x (Un -Number -Symbol -Boolean (make-Listof x))) -Number (Un -Symbol -Boolean (make-Listof (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))))]
[(Un (-val #f) (-mu x (Un -Number -Symbol (make-Listof (-v x)))))
(Un -Boolean -Number)
(Un -Symbol (make-Listof (-mu x (Un -Number -Symbol (make-Listof x)))))]
[(Un (-val 'foo) (-val 6)) (Un -Number -Symbol) (Un)]
[(-> (Un -Symbol -Number) -Number) (-> -Number -Number) (Un)]
[(Un (-poly (a) (make-Listof a)) (-> -Number -Number)) (-> -Number -Number) (-poly (a) (make-Listof a))]
[(Un -Symbol -Number) (-poly (a) -Number) -Symbol]
[(-pair -Number (-v a)) (-pair Univ Univ) (Un)]
))
(define-go
restrict-tests
remove-tests)
remove-tests
overlap-tests)
(define x1
(-mu list-rec
(Un
(-val '())
(-pair (-mu x (Un B N -String Sym (-val '()) (-pair x x)))
(-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))
list-rec))))
(define x2
(Un (-val '())
(-pair (-mu x (Un B N -String Sym (-val '()) (-pair x x)))
(-mu x (Un B N -String Sym (-val '()) (-pair x x))))))
(provide remove-tests restrict-tests)
(-pair (-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x)))
(-mu x (Un -Boolean -Number -String -Symbol (-val '()) (-pair x x))))))
(provide remove-tests restrict-tests overlap-tests)

16
collects/tests/typed-scheme/unit-tests/subst-tests.ss
View File

@ -2,23 +2,23 @@
(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (rep type-rep)
(private type-utils type-effect-convenience)
(types utils abbrev)
(schemeunit))
(define-syntax-rule (s img var tgt result)
(test-eq? "test" (substitute img 'var tgt) result))
(define-syntax-rule (s... imgs var tgt result)
(test-eq? "test" (substitute-dots (list . imgs) 'var tgt) result))
(test-eq? "test" (substitute-dots (list . imgs) #f 'var tgt) result))
(define (subst-tests)
(test-suite "Tests for substitution"
(s N a (-v a) N)
(s... (N B) a (make-Function (list (make-arr-dots null N (-v a) 'a))) (N B . -> . N))
(s... (N B) a (make-Function (list (make-arr-dots (list -String) N (-v a) 'a))) (-String N B . -> . N))
(s... (N B) a (make-Function (list (make-arr-dots (list -String) N (-v b) 'a))) (-String (-v b) (-v b) . -> . N))
(s... (N B) a (make-Function (list (make-arr-dots (list -String) N (-v b) 'b)))
(make-Function (list (make-arr-dots (list -String) N (-v b) 'b))))))
(s -Number a (-v a) -Number)
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots null -Number (-v a) 'a))) (-Number -Boolean . -> . -Number))
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v a) 'a))) (-String -Number -Boolean . -> . -Number))
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'a))) (-String (-v b) (-v b) . -> . -Number))
(s... (-Number -Boolean) a (make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b)))
(make-Function (list (make-arr-dots (list -String) -Number (-v b) 'b))))))
(define-go subst-tests)

134
collects/tests/typed-scheme/unit-tests/subtype-tests.ss
View File

@ -2,7 +2,7 @@
(require "test-utils.ss" "planet-requires.ss")
(require (private subtype type-effect-convenience union)
(require (types subtype convenience union)
(rep type-rep)
(env init-envs type-environments)
(r:infer infer infer-dummy)
@ -29,97 +29,97 @@
(subtyping-tests
;; trivial examples
(Univ Univ)
(N Univ)
(B Univ)
(Sym Univ)
(-Number Univ)
(-Boolean Univ)
(-Symbol Univ)
(-Void Univ)
#;(Sym Dyn)
#;(Dyn N)
[N N]
[-Number -Number]
[(Un (-pair Univ (-lst Univ)) (-val '())) (-lst Univ)]
[(-pair N (-pair N (-pair (-val 'foo) (-val '())))) (-lst Univ)]
[(-pair N (-pair N (-pair (-val 'foo) (-val '())))) (-lst (Un N Sym))]
[(-pair (-val 6) (-val 6)) (-pair N N)]
[(-pair -Number (-pair -Number (-pair (-val 'foo) (-val '())))) (-lst Univ)]
[(-pair -Number (-pair -Number (-pair (-val 'foo) (-val '())))) (-lst (Un -Number -Symbol))]
[(-pair (-val 6) (-val 6)) (-pair -Number -Number)]
[(-val 6) (-val 6)]
;; unions
[(Un N) N]
[(Un N N) N]
[(Un N Sym) (Un Sym N)]
[(Un (-val 6) (-val 7)) N]
[(Un (-val #f) (Un (-val 6) (-val 7))) (Un N (Un B Sym))]
[(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un N (Un B Sym)))]
[(Un N (-val #f) (-mu x (Un N Sym (make-Listof x))))
(-mu x (Un N Sym B (make-Listof x)))]
[(Un -Number) -Number]
[(Un -Number -Number) -Number]
[(Un -Number -Symbol) (Un -Symbol -Number)]
[(Un (-val 6) (-val 7)) -Number]
[(Un (-val #f) (Un (-val 6) (-val 7))) (Un -Number (Un -Boolean -Symbol))]
[(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un -Number (Un -Boolean -Symbol)))]
[(Un -Number (-val #f) (-mu x (Un -Number -Symbol (make-Listof x))))
(-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
;; sexps vs list*s of nums
[(-mu x (Un N Sym (make-Listof x))) (-mu x (Un N Sym B (make-Listof x)))]
[(-mu x (Un N (make-Listof x))) (-mu x (Un N Sym (make-Listof x)))]
[(-mu x (Un N (make-Listof x))) (-mu y (Un N Sym (make-Listof y)))]
[(-mu x (Un -Number -Symbol (make-Listof x))) (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
[(-mu x (Un -Number (make-Listof x))) (-mu x (Un -Number -Symbol (make-Listof x)))]
[(-mu x (Un -Number (make-Listof x))) (-mu y (Un -Number -Symbol (make-Listof y)))]
;; a hard one
[-NE -Sexp]
[(-mu x (*Un -Number (-pair x (-pair -Symbol (-pair x (-val null)))))) -Sexp]
;; simple function types
((Univ . -> . N) (N . -> . Univ))
[(Univ Univ Univ . -> . N) (Univ Univ N . -> . N)]
((Univ . -> . -Number) (-Number . -> . Univ))
[(Univ Univ Univ . -> . -Number) (Univ Univ -Number . -> . -Number)]
;; simple list types
[(make-Listof N) (make-Listof Univ)]
[(make-Listof N) (make-Listof N)]
[FAIL (make-Listof N) (make-Listof Sym)]
[(make-Listof -Number) (make-Listof Univ)]
[(make-Listof -Number) (make-Listof -Number)]
[FAIL (make-Listof -Number) (make-Listof -Symbol)]
[(-mu x (make-Listof x)) (-mu x* (make-Listof x*))]
[(-pair N N) (-pair Univ N)]
[(-pair N N) (-pair N N)]
[(-pair -Number -Number) (-pair Univ -Number)]
[(-pair -Number -Number) (-pair -Number -Number)]
;; from page 7
[(-mu t (-> t t)) (-mu s (-> s s))]
[(-mu s (-> N s)) (-mu t (-> N (-> N t)))]
[(-mu s (-> -Number s)) (-mu t (-> -Number (-> -Number t)))]
;; polymorphic types
[(-poly (t) (-> t t)) (-poly (s) (-> s s))]
[FAIL (make-Listof N) (-poly (t) (make-Listof t))]
[(-poly (a) (make-Listof (-v a))) (make-Listof N)] ;;
[(-poly (a) N) N]
[FAIL (make-Listof -Number) (-poly (t) (make-Listof t))]
[(-poly (a) (make-Listof (-v a))) (make-Listof -Number)] ;;
[(-poly (a) -Number) -Number]
[(-val 6) N]
[(-val 'hello) Sym]
[((Un Sym N) . -> . N) (-> N N)]
[(-poly (t) (-> N t)) (-mu t (-> N t))]
[(-val 6) -Number]
[(-val 'hello) -Symbol]
[((Un -Symbol -Number) . -> . -Number) (-> -Number -Number)]
[(-poly (t) (-> -Number t)) (-mu t (-> -Number t))]
;; not subtypes
[FAIL (-val 'hello) N]
[FAIL (-val #f) Sym]
[FAIL (Univ Univ N N . -> . N) (Univ Univ Univ . -> . N)]
[FAIL (N . -> . N) (-> Univ Univ)]
[FAIL (Un N Sym) N]
[FAIL N (Un (-val 6) (-val 11))]
[FAIL Sym (-val 'Sym)]
[FAIL (Un Sym N) (-poly (a) N)]
[FAIL (-val 'hello) -Number]
[FAIL (-val #f) -Symbol]
[FAIL (Univ Univ -Number -Number . -> . -Number) (Univ Univ Univ . -> . -Number)]
[FAIL (-Number . -> . -Number) (-> Univ Univ)]
[FAIL (Un -Number -Symbol) -Number]
[FAIL -Number (Un (-val 6) (-val 11))]
[FAIL -Symbol (-val 'Sym)]
[FAIL (Un -Symbol -Number) (-poly (a) -Number)]
;; bugs found
[(Un (-val 'foo) (-val 6)) (Un (-val 'foo) (-val 6))]
[(-poly (a) (make-Listof (-v a))) (make-Listof (-mu x (Un (make-Listof x) N)))]
[FAIL (make-Listof (-mu x (Un (make-Listof x) N))) (-poly (a) (make-Listof a))]
[(-poly (a) (make-Listof (-v a))) (make-Listof (-mu x (Un (make-Listof x) -Number)))]
[FAIL (make-Listof (-mu x (Un (make-Listof x) -Number))) (-poly (a) (make-Listof a))]
;; case-lambda
[(cl-> [(N) N] [(B) B]) (N . -> . N)]
[(cl-> [(-Number) -Number] [(-Boolean) -Boolean]) (-Number . -> . -Number)]
;; special case for unused variables
[N (-poly (a) N)]
[FAIL (cl-> [(N) B] [(B) N]) (N . -> . N)]
[-Number (-poly (a) -Number)]
[FAIL (cl-> [(-Number) -Boolean] [(-Boolean) -Number]) (-Number . -> . -Number)]
;; varargs
[(->* (list N) Univ B) (->* (list N) N B)]
[(->* (list Univ) N B) (->* (list N) N B)]
[(->* (list N) N B) (->* (list N) N B)]
[(->* (list N) N B) (->* (list N) N Univ)]
[(->* (list N) N N) (->* (list N N) N)]
[(->* (list N) N N) (->* (list N N N) N)]
[(->* (list N N) B N) (->* (list N N) N)]
[FAIL (->* (list N) N B) (->* (list N N N) N)]
[(->* (list N N) B N) (->* (list N N B B) N)]
[(->* (list -Number) Univ -Boolean) (->* (list -Number) -Number -Boolean)]
[(->* (list Univ) -Number -Boolean) (->* (list -Number) -Number -Boolean)]
[(->* (list -Number) -Number -Boolean) (->* (list -Number) -Number -Boolean)]
[(->* (list -Number) -Number -Boolean) (->* (list -Number) -Number Univ)]
[(->* (list -Number) -Number -Number) (->* (list -Number -Number) -Number)]
[(->* (list -Number) -Number -Number) (->* (list -Number -Number -Number) -Number)]
[(->* (list -Number -Number) -Boolean -Number) (->* (list -Number -Number) -Number)]
[FAIL (->* (list -Number) -Number -Boolean) (->* (list -Number -Number -Number) -Number)]
[(->* (list -Number -Number) -Boolean -Number) (->* (list -Number -Number -Boolean -Boolean) -Number)]
[(-poly (a) (cl-> [() a]
[(N) a]))
(cl-> [() (-pair N (-v b))]
[(N) (-pair N (-v b))])]
[(-Number) a]))
(cl-> [() (-pair -Number (-v b))]
[(-Number) (-pair -Number (-v b))])]
[(-poly (a) ((Un (make-Base 'foo #f) (-struct 'bar #f (list N a) #f #f #f values)) . -> . (-lst a)))
((Un (make-Base 'foo #f) (-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values)) . -> . (-lst (-pair N (-v a))))]
[(-poly (a) ((-struct 'bar #f (list N a) #f #f #f values) . -> . (-lst a)))
((-struct 'bar #f (list N (-pair N (-v a))) #f #f #f values) . -> . (-lst (-pair N (-v a))))]
[(-values (list -Number)) (-values (list Univ))]
[(-poly (a) ((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number a))) . -> . (-lst a)))
((Un (make-Base 'foo #'dummy) (-struct 'bar #f (list -Number (-pair -Number (-v a))))) . -> . (-lst (-pair -Number (-v a))))]
[(-poly (a) ((-struct 'bar #f (list -Number a)) . -> . (-lst a)))
((-struct 'bar #f (list -Number (-pair -Number (-v a)))) . -> . (-lst (-pair -Number (-v a))))]
[(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-v b)))]
[(-poly (a) (a . -> . (make-Listof a))) ((-pair N (-v b)) . -> . (make-Listof (-pair N (-v b))))]
[(-poly (a) (a . -> . (make-Listof a))) ((-pair -Number (-v b)) . -> . (make-Listof (-pair -Number (-v b))))]
(FAIL (-poly (a b) (-> a a)) (-poly (a b) (-> a b)))

13
collects/tests/typed-scheme/unit-tests/test-utils.ss
View File

@ -8,9 +8,10 @@
(for-syntax scheme/base))
(require (private type-comparison type-utils)
(require (types comparison utils)
(schemeunit))
(provide private typecheck (rename-out [infer r:infer]) utils env rep)
(provide private typecheck (rename-out [infer r:infer]) utils env rep types)
(define (mk-suite ts)
(match (map (lambda (f) (f)) ts)
@ -38,13 +39,9 @@
(values (lambda () (run tmps ...))
(lambda () (run/gui tmps ...))))))]))
;; FIXME - check that effects are equal
;; FIXME - do something more intelligent
(define (tc-result-equal/test? a b)
(match* (a b)
[((tc-result: t1 thn1 els1) (tc-result: t2 thn2 els2))
(and (type-equal? t1 t2)
(= (length thn1) (length thn2))
(= (length els1) (length els2)))]))
(equal? a b))
(define-syntax (check-type-equal? stx)
(syntax-case stx ()

29
collects/tests/typed-scheme/unit-tests/type-annotation-test.ss
View File

@ -1,7 +1,8 @@
#lang scheme/base
(require "test-utils.ss" "planet-requires.ss"
(for-syntax scheme/base))
(require (private type-annotation type-effect-convenience parse-type)
(require (private type-annotation parse-type base-types)
(types convenience utils)
(env type-environments type-name-env init-envs)
(utils tc-utils)
(rep type-rep)
@ -10,24 +11,26 @@
(provide type-annotation-tests)
(define-syntax-rule (tat ann-stx ty)
(check-type-equal? (format "~a" (quote ann-stx))
(type-ascription (let ([ons (current-namespace)]
[ns (make-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-attach-module ons 'scheme/base ns)
(namespace-require 'scheme/base)
(namespace-require 'typed-scheme/private/prims)
(expand 'ann-stx))))
ty))
(check-tc-result-equal? (format "~a" (quote ann-stx))
(type-ascription (let ([ons (current-namespace)]
[ns (make-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-attach-module ons 'scheme/base ns)
(namespace-require 'scheme/base)
(namespace-require 'typed-scheme/private/prims)
(namespace-require 'typed-scheme/private/base-types)
(namespace-require 'typed-scheme/private/base-types-extra)
(expand 'ann-stx))))
ty))
#reader typed-scheme/typed-reader
(define (type-annotation-tests)
(test-suite
"Type Annotation tests"
(tat (ann foo : Number) N)
;; FIXME - ask Ryan
;(tat (ann foo : Number) (ret -Number))
(tat foo #f)
(tat (ann foo : 3) (-val 3))))
(tat (ann foo : 3) (ret (-val 3)))))
(define-go
type-annotation-tests)

28
collects/tests/typed-scheme/unit-tests/type-equal-tests.ss
View File

@ -2,12 +2,12 @@
(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (rep type-rep)
(private type-comparison type-effect-convenience union subtype)
(types comparison abbrev union)
(schemeunit))
(provide type-equal-tests)
(define (-base x) (make-Base x #f))
(define (-base x) (make-Base x #'dummy))
(define-syntax (te-tests stx)
@ -26,25 +26,23 @@
(define (type-equal-tests)
(te-tests
[N N]
[(Un N) N]
[(Un N Sym B) (Un N B Sym)]
[(Un N Sym B) (Un Sym B N)]
[(Un N Sym B) (Un Sym N B)]
[(Un N Sym B) (Un B (Un Sym N))]
[(Un N Sym) (Un Sym N)]
[(-poly (x) (-> (Un Sym N) x)) (-poly (xyz) (-> (Un N Sym) xyz))]
[(-mu x (Un N Sym x)) (-mu y (Un N Sym y))]
[-Number -Number]
[(Un -Number) -Number]
[(Un -Number -Symbol -Boolean) (Un -Number -Boolean -Symbol)]
[(Un -Number -Symbol -Boolean) (Un -Symbol -Boolean -Number)]
[(Un -Number -Symbol -Boolean) (Un -Symbol -Number -Boolean)]
[(Un -Number -Symbol -Boolean) (Un -Boolean (Un -Symbol -Number))]
[(Un -Number -Symbol) (Un -Symbol -Number)]
[(-poly (x) (-> (Un -Symbol -Number) x)) (-poly (xyz) (-> (Un -Number -Symbol) xyz))]
[(-mu x (Un -Number -Symbol x)) (-mu y (Un -Number -Symbol y))]
;; found bug
[FAIL (Un (-mu heap-node
(-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))) #f #f #f values))
(-struct 'heap-node #f (list (-base 'comparator) -Number (-v a) (Un heap-node (-base 'heap-empty)))))
(-base 'heap-empty))
(Un (-mu heap-node
(-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))) #f #f #f values))
(-struct 'heap-node #f (list (-base 'comparator) -Number (-pair -Number -Number) (Un heap-node (-base 'heap-empty)))))
(-base 'heap-empty))]))
(define-go
type-equal-tests)

366
collects/tests/typed-scheme/unit-tests/typecheck-tests.ss
View File

@ -3,12 +3,14 @@
(require "test-utils.ss" "planet-requires.ss"
(for-syntax scheme/base)
(for-template scheme/base))
(require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation)
(require (private base-env prims type-annotation)
(typecheck typechecker)
(rep type-rep effect-rep)
(utils tc-utils)
(rep type-rep filter-rep object-rep)
(types utils union convenience)
(utils tc-utils mutated-vars)
(env type-name-env type-environments init-envs)
(schemeunit))
(schemeunit)
stxclass)
(require (for-syntax (utils tc-utils)
(typecheck typechecker)
@ -17,21 +19,42 @@
(for-template (private base-env base-types)))
(require (for-syntax syntax/kerncase stxclass))
(provide typecheck-tests g tc-expr/expand)
(define N -Number)
(define B -Boolean)
(define Sym -Symbol)
(define (g) (run typecheck-tests))
(define-namespace-anchor anch)
(define (-path t var [p null])
(ret t
(-FS (list (make-NotTypeFilter (-val #f) p var))
(list (make-TypeFilter (-val #f) p var)))
(make-Path p var)))
;; check that a literal typechecks correctly
(define-syntax tc-l
(syntax-rules ()
[(_ lit ty)
(check-type-equal? (format "~a" 'lit) (tc-literal #'lit) ty)]))
(check-type-equal? (format "~s" 'lit) (tc-literal #'lit) ty)]))
;; local-expand and then typecheck an expression
(define-syntax (tc-expr/expand/values stx)
(syntax-case stx ()
[(_ e)
#`(parameterize ([delay-errors? #f]
[current-namespace (namespace-anchor->namespace anch)]
[orig-module-stx (quote-syntax e)])
(let ([ex (expand 'e)])
(find-mutated-vars ex)
(values (lambda () (tc-expr ex)) ex)))]))
(define-syntax (tc-expr/expand stx)
(syntax-case stx ()
[(_ e)
@ -45,13 +68,19 @@
;; check that an expression typechecks correctly
(define-syntax (tc-e stx)
(syntax-case stx ()
[(_ expr ty) (syntax/loc stx (tc-e expr ty (list) (list)))]
[(_ expr ty eff1 eff2)
(syntax/loc stx (check-tc-result-equal? (format "~a" 'expr)
(tc-expr/expand expr)
(ret ty eff1 eff2)))]))
[(_ expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))]
[(_ expr #:proc p)
(syntax/loc stx
(let-values ([(t e) (tc-expr/expand/values expr)])
(check-tc-result-equal? (format "~s" 'expr) (t) (p e))))]
[(_ expr #:ret r)
(syntax/loc stx
(check-tc-result-equal? (format "~a" 'expr) (tc-expr/expand expr) r))]
[(_ expr ty f o) (syntax/loc stx (tc-e expr #:ret (ret ty f o)))]))
(require (for-syntax syntax/kerncase))
(define-syntax (tc-e/t stx)
(syntax-parse stx
[(_ e t) (syntax/loc stx (tc-e e #:ret (ret t (-FS (list) (list (make-Bot))))))]))
;; duplication of the mzscheme toplevel expander, necessary for expanding the rhs of defines
;; note that this ability is never used
@ -71,13 +100,21 @@
exn:fail:syntax?
(lambda () (tc-expr/expand expr)))]))
(define-syntax-class (let-name n)
#:literals (let-values)
(pattern (let-values ([(i:id) _] ...) . _)
#:with x (list-ref (syntax->list #'(i ...)) n)))
(define-syntax-rule (get-let-name id n e)
(syntax-parser
[p #:declare p (let-name n)
#:with id #'p.x
e]))
(define (typecheck-tests)
(test-suite
"Typechecker tests"
#reader typed-scheme/typed-reader
(let ([-vet (lambda (x) (list (-vet x)))]
[-vef (lambda (x) (list (-vef x)))])
(test-suite
"tc-expr tests"
@ -87,37 +124,37 @@
(+ 1 (car x))
5))
N]
(tc-e (if (let ([y 12]) y) 3 4) -Integer)
(tc-e 3 -Integer)
(tc-e "foo" -String)
(tc-e/t (if (let ([y 12]) y) 3 4) -Integer)
(tc-e/t 3 -Integer)
(tc-e/t "foo" -String)
(tc-e (+ 3 4) -Integer)
[tc-e (lambda: () 3) (-> -Integer)]
[tc-e (lambda: ([x : Number]) 3) (-> N -Integer)]
[tc-e (lambda: ([x : Number] [y : Boolean]) 3) (-> N B -Integer)]
[tc-e (lambda () 3) (-> -Integer)]
[tc-e (values 3 4) (-values (list -Integer -Integer))]
[tc-e/t (lambda: () 3) (-> -Integer : (-LFS (list) (list (make-LBot))))]
[tc-e/t (lambda: ([x : Number]) 3) (-> N -Integer : (-LFS (list) (list (make-LBot))))]
[tc-e/t (lambda: ([x : Number] [y : Boolean]) 3) (-> N B -Integer : (-LFS (list) (list (make-LBot))))]
[tc-e/t (lambda () 3) (-> -Integer : (-LFS (list) (list (make-LBot))))]
[tc-e (values 3 4) #:ret (ret (list -Integer -Integer) (list (-FS (list) (list (make-Bot))) (-FS (list) (list (make-Bot)))))]
[tc-e (cons 3 4) (-pair -Integer -Integer)]
[tc-e (cons 3 #{'() : (Listof -Integer)}) (make-Listof -Integer)]
[tc-e (void) -Void]
[tc-e (void 3 4) -Void]
[tc-e (void #t #f '(1 2 3)) -Void]
[tc-e #(3 4 5) (make-Vector -Integer)]
[tc-e '(2 3 4) (-lst* -Integer -Integer -Integer)]
[tc-e '(2 3 #t) (-lst* -Integer -Integer (-val #t))]
[tc-e #(2 3 #t) (make-Vector (Un -Integer (-val #t)))]
[tc-e '(#t #f) (-lst* (-val #t) (-val #f))]
[tc-e (plambda: (a) ([l : (Listof a)]) (car l))
[tc-e/t #(3 4 5) (make-Vector -Integer)]
[tc-e/t '(2 3 4) (-lst* -Integer -Integer -Integer)]
[tc-e/t '(2 3 #t) (-lst* -Integer -Integer (-val #t))]
[tc-e/t #(2 3 #t) (make-Vector (Un -Integer (-val #t)))]
[tc-e/t '(#t #f) (-lst* (-val #t) (-val #f))]
[tc-e/t (plambda: (a) ([l : (Listof a)]) (car l))
(make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))]
[tc-e/t (plambda: (a) ([l : (Listof a)]) (car l))
(make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))]
[tc-e (plambda: (a) ([l : (Listof a)]) (car l))
(make-Poly '(a) (-> (make-Listof (-v a)) (-v a)))]
[tc-e (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (-> N N N)]
[tc-e (let: ([x : Number 5]) x) N (-vet #'x) (-vef #'x)]
[tc-e/t (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (-> N N N)]
[tc-e (let: ([x : Number 5]) x) #:proc (get-let-name x 0 (-path -Number #'x))]
[tc-e (let-values ([(x) 4]) (+ x 1)) -Integer]
[tc-e (let-values ([(#{x : Number} #{y : Boolean}) (values 3 #t)]) (and (= x 1) (not y)))
B (list (-rest (-val #f) #'y)) (list)]
[tc-e (values 3) -Integer]
[tc-e (values) (-values (list))]
[tc-e (values 3 #f) (-values (list -Integer (-val #f)))]
#:proc (syntax-parser [(_ ([(_ y) . _]) . _) (ret -Boolean (-FS (list (make-TypeFilter (-val #f) null #'y)) null))])]
[tc-e/t (values 3) -Integer]
[tc-e (values) #:ret (ret null)]
[tc-e (values 3 #f) #:ret (ret (list -Integer (-val #f)) (list (-FS (list) (list (make-Bot))) (-FS (list (make-Bot)) (list))))]
[tc-e (map #{values @ Symbol} '(a b c)) (make-Listof Sym)]
[tc-e (letrec: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))])
(fact 20))
@ -133,11 +170,11 @@
N]
[tc-e (let: ([v : (Un Number Boolean) #f])
(if (boolean? v) 5 (+ v 1)))
N]
#:proc (get-let-name v 0 (ret N (-FS null (list (make-NotTypeFilter -Boolean null #'v)))))]
[tc-e (let: ([f : (Number Number -> Number) +]) (f 3 4)) N]
[tc-e (let: ([+ : (Boolean -> Number) (lambda: ([x : Boolean]) 3)]) (+ #f)) N]
[tc-e (when #f #t) (Un -Void)]
[tc-e (when (number? #f) (+ 4 5)) (Un -Integer -Void)]
[tc-e (when #f #t) -Void]
[tc-e (when (number? #f) (+ 4 5)) -Void]
[tc-e (let: ([x : (Un #f Number) 7])
(if x (+ x 1) 3))
N]
@ -146,25 +183,25 @@
(+ x 4)
'bc))
N]
[tc-e (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)]
[tc-e (begin 3) -Integer]
[tc-e (begin #f 3) -Integer]
[tc-e (begin #t) (-val #t) (list (make-True-Effect)) (list (make-True-Effect))]
[tc-e (begin0 #t) (-val #t) (list (make-True-Effect)) (list (make-True-Effect))]
[tc-e (begin0 #t 3) (-val #t) (list (make-True-Effect)) (list (make-True-Effect))]
[tc-e #t (-val #t) (list (make-True-Effect)) (list (make-True-Effect))]
[tc-e #f (-val #f) (list (make-False-Effect)) (list (make-False-Effect))]
[tc-e '#t (-val #t) (list (make-True-Effect)) (list (make-True-Effect))]
[tc-e '#f (-val #f) (list (make-False-Effect)) (list (make-False-Effect))]
[tc-e (if #f 'a 3) -Integer]
[tc-e (if #f #f #t) (Un (-val #t))]
[tc-e/t (let: ((x : Number 3)) (if (boolean? x) (not x) #t)) (-val #t)]
[tc-e/t (begin 3) -Integer]
[tc-e/t (begin #f 3) -Integer]
[tc-e/t (begin #t) (-val #t)]
[tc-e/t (begin0 #t) (-val #t)]
[tc-e/t (begin0 #t 3) (-val #t)]
[tc-e/t #t (-val #t)]
[tc-e #f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))]
[tc-e/t '#t (-val #t)]
[tc-e '#f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))]
[tc-e/t (if #f 'a 3) -Integer]
[tc-e/t (if #f #f #t) (Un (-val #t))]
[tc-e (when #f 3) -Void]
[tc-e '() (-val '())]
[tc-e (let: ([x : (Listof Number) '(1)])
(cond [(pair? x) 1]
[(null? x) 1]))
[tc-e/t '() (-val '())]
[tc-e/t (let: ([x : (Listof Number) '(1)])
(cond [(pair? x) 1]
[(null? x) 1]))
-Integer]
[tc-e (lambda: ([x : Number] . [y : Number *]) (car y)) (->* (list N) N N)]
[tc-e/t (lambda: ([x : Number] . [y : Number *]) (car y)) (->* (list N) N N)]
[tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3) N]
[tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4 5) N]
[tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4) N]
@ -172,18 +209,18 @@
[tc-e (apply (lambda: ([x : Number] . [y : Number *]) (car y)) 3 '(4 6 7)) N]
[tc-e (apply (lambda: ([x : Number] . [y : Number *]) (car y)) 3 '()) N]
[tc-e (lambda: ([x : Number] . [y : Boolean *]) (car y)) (->* (list N) B B)]
[tc-e/t (lambda: ([x : Number] . [y : Boolean *]) (car y)) (->* (list N) B B)]
[tc-e ((lambda: ([x : Number] . [y : Boolean *]) (car y)) 3) B]
[tc-e (apply (lambda: ([x : Number] . [y : Boolean *]) (car y)) 3 '(#f)) B]
[tc-e (let: ([x : Number 3])
(when (number? x) #t))
(-val #t) (list (make-True-Effect)) (list (make-True-Effect))]
[tc-e/t (let: ([x : Number 3])
(when (number? x) #t))
(-val #t)]
[tc-e (let: ([x : Number 3])
(when (boolean? x) #t))
-Void]
[tc-e (let: ([x : Any 3])
[tc-e/t (let: ([x : Any 3])
(if (list? x)
(begin (car x) 1) 2))
-Integer]
@ -195,13 +232,13 @@
3))
N]
[tc-e (let ([x 1]) x) -Integer (-vet #'x) (-vef #'x)]
[tc-e (let ([x 1]) (boolean? x)) B (list (-rest B #'x)) (list (-rem B #'x))]
[tc-e (boolean? number?) B (list (-rest B #'number?)) (list (-rem B #'number?))]
[tc-e (let ([x 1]) x) #:proc (get-let-name x 0 (-path -Integer #'x))]
[tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS (list (make-Bot)) null))]
[tc-e (boolean? number?) #:ret (ret -Boolean (-FS (list (make-Bot)) null))]
[tc-e (let: ([x : (Option Number) #f]) x) (Un N (-val #f)) (-vet #'x) (-vef #'x)]
[tc-e (let: ([x : Any 12]) (not (not x)))
B (list (-rem (-val #f) #'x)) (list (-rest (-val #f) #'x))]
[tc-e (let: ([x : (Option Number) #f]) x) #:proc (get-let-name x 0 (-path (Un N (-val #f)) #'x))]
[tc-e (let: ([x : Any 12]) (not (not x)))
#:proc (get-let-name x 0 (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x)) (list (make-TypeFilter (-val #f) null #'x)))))]
[tc-e (let: ([x : (Option Number) #f])
(if (let ([z 1]) x)
@ -213,7 +250,7 @@
[tc-err (map (lambda: ([x : Any] [y : Any]) 1) '(1))]
[tc-e (map add1 '(1)) (-lst -Integer)]
[tc-e (let ([x 5])
[tc-e/t (let ([x 5])
(if (eq? x 1)
12
14))
@ -261,22 +298,23 @@
N]
[tc-e null (-val null) (-vet #'null) (-vef #'null)]
[tc-e null #:ret (-path (-val null) #'null)]
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
x)
(Un (-val 'squarf) -Integer)
(-vet #'x) (-vef #'x)]
#:proc (syntax-parser [(_ _ (_ ([(x) _]) _)) (-path (Un (-val 'squarf) -Integer) #'x)])]
[tc-e (if #t 1 2) -Integer]
[tc-e/t (if #t 1 2) -Integer]
;; eq? as predicate
[tc-e (let: ([x : (Un 'foo Number) 'foo])
(if (eq? x 'foo) 3 x)) N]
(if (eq? x 'foo) 3 x))
#:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))]
[tc-e (let: ([x : (Un 'foo Number) 'foo])
(if (eq? 'foo x) 3 x)) N]
(if (eq? 'foo x) 3 x))
#:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))]
[tc-err (let: ([x : (U String 'foo) 'foo])
(if (string=? x 'foo)
@ -291,25 +329,31 @@
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
(if (eq? x sym) 3 x))
-Integer]
#:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
(ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])]
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
(if (eq? sym x) 3 x))
-Integer]
#:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
(ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])]
;; equal? as predicate for symbols
[tc-e (let: ([x : (Un 'foo Number) 'foo])
(if (equal? x 'foo) 3 x)) N]
(if (equal? x 'foo) 3 x))
#:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))]
[tc-e (let: ([x : (Un 'foo Number) 'foo])
(if (equal? 'foo x) 3 x)) N]
(if (equal? 'foo x) 3 x))
#:proc (get-let-name x 0 (ret N (-FS (list) (list (make-NotTypeFilter (-val 'foo) null #'x) (make-TypeFilter (-val #f) null #'x)))))]
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
(if (equal? x sym) 3 x))
-Integer]
#:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
(ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])]
[tc-e (let* ([sym 'squarf]
[x (if (= 1 2) 3 sym)])
(if (equal? sym x) 3 x))
-Integer]
#:proc (syntax-parser [(_ _ (_ ([(x) _]) _))
(ret -Integer (-FS (list) (list (make-NotTypeFilter (-val 'squarf) null #'x) (make-TypeFilter (-val #f) null #'x))))])]
[tc-e (let: ([x : (Listof Symbol)'(a b c)])
(cond [(memq 'a x) => car]
@ -343,16 +387,16 @@
;;; tests for and
[tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x))) B
(list (-rest N #'x) (-rest B #'x)) (list)]
[tc-e (let: ([x : Any 1]) (and (number? x) x)) (Un N (-val #f))
(list (-rest N #'x) (make-Var-True-Effect #'x)) (list)]
[tc-e (let: ([x : Any 1]) (and x (boolean? x))) B
(list (-rem (-val #f) #'x) (-rest B #'x)) (list)]
[tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x)))
#:ret (ret B (-FS (list (make-Bot)) null))]
[tc-e (let: ([x : Any 1]) (and (number? x) x))
#:proc (get-let-name x 0 (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-NotTypeFilter (-val #f) null #'x)) null)))]
[tc-e (let: ([x : Any 1]) (and x (boolean? x)))
#:proc (get-let-name x 0 (ret -Boolean (-FS (list (make-NotTypeFilter (-val #f) null #'x) (make-TypeFilter -Boolean null #'x)) null)))]
[tc-e (let: ([x : Any 3])
(if (and (list? x) (not (null? x)))
(begin (car x) 1) 2))
[tc-e/t (let: ([x : Any 3])
(if (and (list? x) (not (null? x)))
(begin (car x) 1) 2))
-Integer]
;; set! tests
@ -396,30 +440,34 @@
Univ]
;; T-AbsPred
[tc-e (let ([p? (lambda: ([x : Any]) (number? x))])
(lambda: ([x : Any]) (if (p? x) (add1 x) 12)))
(-> Univ N)]
[tc-e (let ([p? (lambda: ([x : Any]) (not (number? x)))])
(lambda: ([x : Any]) (if (p? x) 12 (add1 x))))
(-> Univ N)]
[tc-e (let* ([z 1]
[p? (lambda: ([x : Any]) (number? z))])
(lambda: ([x : Any]) (if (p? x) 11 12)))
(-> Univ -Integer)]
[tc-e (let* ([z 1]
[p? (lambda: ([x : Any]) (number? z))])
(lambda: ([x : Any]) (if (p? x) x 12)))
(-> Univ Univ)]
[tc-e (let* ([z 1]
[p? (lambda: ([x : Any]) (not (number? z)))])
(lambda: ([x : Any]) (if (p? x) x 12)))
(-> Univ Univ)]
[tc-e (let* ([z 1]
[p? (lambda: ([x : Any]) z)])
(lambda: ([x : Any]) (if (p? x) x 12)))
(-> Univ Univ)]
[tc-e/t (let ([p? (lambda: ([x : Any]) (number? x))])
(lambda: ([x : Any]) (if (p? x) (add1 x) 12)))
(-> Univ N)]
[tc-e/t (let ([p? (lambda: ([x : Any]) (not (number? x)))])
(lambda: ([x : Any]) (if (p? x) 12 (add1 x))))
(-> Univ N : (-LFS null (list (make-LTypeFilter -Number null 0))))]
[tc-e/t (let* ([z 1]
[p? (lambda: ([x : Any]) (number? z))])
(lambda: ([x : Any]) (if (p? x) 11 12)))
(-> Univ -Integer : (-LFS null (list (make-LBot))))]
[tc-e/t (let* ([z 1]
[p? (lambda: ([x : Any]) (number? z))])
(lambda: ([x : Any]) (if (p? x) x 12)))
(-> Univ Univ : (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))) : (make-LPath null 0))]
[tc-e/t (let* ([z (ann 1 : Any)]
[p? (lambda: ([x : Any]) (not (number? z)))])
(lambda: ([x : Any]) (if (p? x) x 12)))
(-> Univ Univ)]
[tc-e/t (let* ([z 1]
[p? (lambda: ([x : Any]) (not (number? z)))])
(lambda: ([x : Any]) (if (p? x) x 12)))
(-> Univ -Integer : (-LFS null (list (make-LBot))))]
[tc-e/t (let* ([z 1]
[p? (lambda: ([x : Any]) z)])
(lambda: ([x : Any]) (if (p? x) x 12)))
(-> Univ Univ)]
[tc-e (not 1) B]
[tc-e (not 1) #:ret (ret B (-FS (list (make-Bot)) null))]
[tc-err ((lambda () 1) 2)]
[tc-err (apply (lambda () 1) '(2))]
@ -442,7 +490,7 @@
(set! x "foo")
x)]
;; w-c-m
[tc-e (with-continuation-mark 'key 'mark
[tc-e/t (with-continuation-mark 'key 'mark
3)
-Integer]
[tc-err (with-continuation-mark (5 4) 1
@ -473,8 +521,8 @@
[tc-err (call-with-values (lambda () (values 2 1))
(lambda: ([x : String] [y : Number]) (+ x y)))]
;; quote-syntax
[tc-e #'3 (-Syntax -Integer)]
[tc-e #'(1 2 3) (-Syntax (-lst* -Integer -Integer -Integer))]
[tc-e/t #'3 (-Syntax -Integer)]
[tc-e/t #'(1 2 3) (-Syntax (-lst* -Integer -Integer -Integer))]
;; testing some primitives
[tc-e (let ([app apply]
@ -511,14 +559,14 @@
(* x z))
-Integer]
[tc-e (let ()
(define: (f [x : Number]) : Number
(define: (g [y : Number]) : Number
(let*-values ([(#{z : Number} #{w : Number}) (values (g (f x)) 5)])
(+ z w)))
(g 4))
5)
-Integer]
[tc-e/t (let ()
(define: (f [x : Number]) : Number
(define: (g [y : Number]) : Number
(let*-values ([(#{z : Number} #{w : Number}) (values (g (f x)) 5)])
(+ z w)))
(g 4))
5)
-Integer]
[tc-err (let ()
(define x x)
@ -547,7 +595,7 @@
((null? x) sum)))
N]
[tc-e (if #f 1 'foo) (-val 'foo)]
[tc-e/t (if #f 1 'foo) (-val 'foo)]
[tc-e (list* 1 2 3) (-pair -Integer (-pair -Integer -Integer))]
@ -555,8 +603,8 @@
[tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list 1))) (-lst -Integer)]
[tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-lst (Un -String -Integer))]
[tc-err (plambda: (b ...) [y : b ... b] (apply append (map list y)))]
[tc-e (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y))
(-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))]
[tc-e/t (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y))
(-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))]
[tc-err (plambda: (a ...) ([z : String] . [w : Number ... a])
(apply (plambda: (b) ([x : Number] . [y : Number ... a]) x)
@ -566,26 +614,28 @@
(apply (plambda: (b) ([x : Number] . [y : Number ... a]) x)
1 w))]
[tc-e (plambda: (a ...) ([z : String] . [w : Number ... a])
[tc-e/t (plambda: (a ...) ([z : String] . [w : Number ... a])
(apply (plambda: (b ...) ([x : Number] . [y : Number ... b]) x)
1 w))
(-polydots (a) ((list -String) (N a) . ->... . N))]
;; instantiating non-dotted terms
[tc-e (inst (plambda: (a) ([x : a]) x) Integer)
(-Integer . -> . -Integer : (list (make-Latent-Var-True-Effect)) (list (make-Latent-Var-False-Effect)))]
[tc-e (inst (plambda: (a) [x : a *] (apply list x)) Integer)
((list) -Integer . ->* . (-lst -Integer))]
[tc-e/t (inst (plambda: (a) ([x : a]) x) Integer)
(make-Function (list (make-arr* (list -Integer) -Integer
#:filters (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f))))
#:object (make-LPath null 0))))]
[tc-e/t (inst (plambda: (a) [x : a *] (apply list x)) Integer)
((list) -Integer . ->* . (-lst -Integer))]
;; instantiating dotted terms
[tc-e (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer)
(-Integer B -Integer . -> . -Integer)]
[tc-e (inst (plambda: (a ...) [xs : (a ... a -> Integer) ... a] 3) Integer Boolean Integer)
((-Integer B -Integer . -> . -Integer)
(-Integer B -Integer . -> . -Integer)
(-Integer B -Integer . -> . -Integer)
. -> . -Integer)]
[tc-e/t (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer)
(-Integer B -Integer . -> . -Integer : (-LFS null (list (make-LBot))))]
[tc-e/t (inst (plambda: (a ...) [xs : (a ... a -> Integer) ... a] 3) Integer Boolean Integer)
((-Integer B -Integer . -> . -Integer)
(-Integer B -Integer . -> . -Integer)
(-Integer B -Integer . -> . -Integer)
. -> . -Integer : (-LFS null (list (make-LBot))))]
[tc-e (plambda: (z x y ...) () (inst map z x y ... y))
[tc-e/t (plambda: (z x y ...) () (inst map z x y ... y))
(-polydots (z x y) (-> ((list ((list x) (y y) . ->... . z) (-lst x)) ((-lst y) y) . ->... . (-lst z))))]
;; error tests
@ -606,7 +656,7 @@
(if (number? x)
(begin (f) (add1 x))
12))]
#;
[tc-err (lambda: ([x : Any])
(if (number? (not (not x)))
(add1 x)
@ -628,27 +678,27 @@
(apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c)
3 (list #\c) (map list (map list as))))]
[tc-e (plambda: (a ...) [as : a ... a]
(apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c)
3 (list #\c) (map list as)))
(-polydots (a) ((list) (a a) . ->... . -Integer))]
[tc-e/t (plambda: (a ...) [as : a ... a]
(apply fold-left (lambda: ([c : Integer] [a : Char] . [xs : a ... a]) c)
3 (list #\c) (map list as)))
(-polydots (a) ((list) (a a) . ->... . -Integer))]
;; First is same as second, but with map explicitly instantiated.
[tc-e (plambda: (a ...) [ys : (a ... a -> Number) *]
[tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *]
(lambda: [zs : a ... a]
((inst map Number (a ... a -> Number))
(lambda: ([y : (a ... a -> Number)])
(apply y zs))
ys)))
(-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N))))]
[tc-e (plambda: (a ...) [ys : (a ... a -> Number) *]
(-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N)) : (-LFS null (list (make-LBot)))))]
[tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *]
(lambda: [zs : a ... a]
(map (lambda: ([y : (a ... a -> Number)])
(apply y zs))
ys)))
(-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N))))]
(-polydots (a) ((list) ((list) (a a) . ->... . N) . ->* . ((list) (a a) . ->... . (-lst N)) : (-LFS null (list (make-LBot)))))]
[tc-e (lambda: ((x : (All (t) t)))
[tc-e/t (lambda: ((x : (All (t) t)))
((inst (inst x (All (t) (t -> t)))
(All (t) t))
x))
@ -656,19 +706,29 @@
;; We need to make sure that even if a isn't free in the dotted type, that it gets replicated
;; appropriately.
[tc-e (inst (plambda: (a ...) [ys : Number ... a]
(apply + ys))
Boolean String Number)
(N N N . -> . N)]
[tc-e/t (inst (plambda: (a ...) [ys : Number ... a]
(apply + ys))
Boolean String Number)
(N N N . -> . N)]
[tc-e (assq 'foo #{'((a b) (foo bar)) :: (Listof (List Symbol Symbol))})
(Un (-val #f) (-pair Sym (-pair Sym (-val null))))]
[tc-e/t (ann (lambda (x) x) (All (a) (a -> a)))
(-poly (a) (a . -> . a))]
[tc-e (apply values (list 1 2 3)) #:ret (ret (list -Integer -Integer -Integer))]
[tc-e (ann (if #t 3 "foo") Integer) -Integer]
[tc-e/t (plambda: (a ...) ([x : Number] . [y : a ... a])
(andmap null? (map list y)))
(-polydots (a) ((list -Number) (a a) . ->... . -Boolean))]
[tc-e (ann (error 'foo) (values Number Number)) #:ret (ret (list -Number -Number))]
#;[tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))])
(fact 20))]
#;[tc-err ]
))
)
(test-suite
"check-type tests"
(test-exn "Fails correctly" exn:fail:syntax? (lambda () (parameterize ([orig-module-stx #'here])

20
collects/typed-scheme/env/init-envs.ss vendored
View File

@ -4,12 +4,12 @@
(require "type-env.ss"
"type-name-env.ss"
(rep type-rep effect-rep)
(for-template (rep type-rep effect-rep)
(private union)
"type-alias-env.ss"
(rep type-rep object-rep filter-rep rep-utils)
(for-template (rep type-rep object-rep filter-rep)
(types union)
mzlib/pconvert mzlib/shared scheme/base)
(private type-effect-convenience union)
"type-alias-env.ss"
(types union convenience)
mzlib/pconvert scheme/match mzlib/shared)
(define (initialize-type-name-env initial-type-names)
@ -22,7 +22,7 @@
(define (gen-constructor sym)
(string->symbol (string-append "make-" (substring (symbol->string sym) 7))))
(match v
[(Union: elems) `(make-Union (list ,@(map sub elems)))]
[(Union: elems) `(make-Union (sort (list ,@(map sub elems)) < #:key Type-seq))]
[(Base: n cnt) `(make-Base ',n (quote-syntax ,cnt))]
[(Name: stx) `(make-Name (quote-syntax ,stx))]
[(Struct: name parent flds proc poly? pred-id cert)
@ -35,9 +35,13 @@
[(Mu-name: n b) `(make-Mu ,(sub n) ,(sub b))]
[(Poly-names: ns b) `(make-Poly (list ,@(map sub ns)) ,(sub b))]
[(PolyDots-names: ns b) `(make-PolyDots (list ,@(map sub ns)) ,(sub b))]
[(? Type? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals)))
[(? (lambda (e) (or (LatentFilter? e)
(LatentObject? e)
(PathElem? e)))
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq vals)))
`(,(gen-constructor tag) ,@(map sub vals))]
[(? Effect? (app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals)))
[(? (lambda (e) (or (Type? e)))
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag key seq vals)))
`(,(gen-constructor tag) ,@(map sub vals))]
[_ (basic v)]))

25
collects/typed-scheme/env/lexical-env.ss vendored
View File

@ -2,13 +2,16 @@
(require (except-in "../utils/utils.ss" extend))
(require "type-environments.ss"
(utils tc-utils)
"type-env.ss"
(private mutated-vars)
(private type-utils)
(private type-effect-convenience))
(only-in scheme/contract ->* ->)
(utils tc-utils mutated-vars)
(only-in (rep type-rep) Type/c)
(except-in (types utils convenience) -> ->*))
(provide (all-defined-out))
(provide lexical-env with-lexical-env with-lexical-env/extend with-update-type/lexical)
(p/c
[lookup-type/lexical ((identifier?) (env?) . ->* . Type/c)]
[update-type/lexical (((identifier? Type/c . -> . Type/c) identifier?) (env?) . ->* . env?)])
;; the current lexical environment
(define lexical-env (make-parameter (make-empty-env free-identifier=?)))
@ -25,8 +28,8 @@
;; find the type of identifier i, looking first in the lexical env, then in the top-level env
;; identifer -> Type
(define (lookup-type/lexical i [fail #f])
(lookup (lexical-env) i
(define (lookup-type/lexical i [env (lexical-env)] #:fail [fail #f])
(lookup env i
(lambda (i) (lookup-type
i (lambda ()
(cond [(lookup (dotted-env) i (lambda _ #f))
@ -37,22 +40,22 @@
;; refine the type of i in the lexical env
;; (identifier type -> type) identifier -> environment
(define (update-type/lexical f i)
(define (update-type/lexical f i [env (lexical-env)])
;; do the updating on the given env
;; (identifier type -> type) identifier environment -> environment
(define (update f k env)
(parameterize
([current-orig-stx k])
(let* ([v (lookup-type/lexical k (lambda _ Univ))]
(let* ([v (lookup-type/lexical k env #:fail (lambda _ Univ))]
[new-v (f k v)]
[new-env (extend env k new-v)])
new-env)))
;; check if i is ever the target of a set!
(if (is-var-mutated? i)
;; if it is, we do nothing
(lexical-env)
env
;; otherwise, refine the type
(update f i (lexical-env))))
(update f i env)))
;; convenience macro for typechecking in the context of an updated env
(define-syntax with-update-type/lexical

2
collects/typed-scheme/env/type-alias-env.ss vendored
View File

@ -31,8 +31,6 @@
(mapping-put! id (make-unresolved stx #f)))
(define (register-resolved-type-alias id ty)
#;(when (eq? 'Number (syntax-e id))
(printf "registering type ~a ~a~n~a~n" id (syntax-e id) ty))
(mapping-put! id (make-resolved ty)))
(define (lookup-type-alias id parse-type [k (lambda () (tc-error "Unknown type alias: ~a" (syntax-e id)))])

2
collects/typed-scheme/env/type-env.ss vendored
View File

@ -3,7 +3,7 @@
(require (except-in "../utils/utils.ss" extend))
(require syntax/boundmap
(utils tc-utils)
(private type-utils))
(types utils))
(provide register-type
finish-register-type

22
collects/typed-scheme/env/type-environments.ss vendored
View File

@ -1,24 +1,26 @@
#lang scheme/base
(require scheme/contract
(prefix-in r: "../utils/utils.ss")
scheme/match
(except-in (r:utils tc-utils) make-env))
(provide current-tvars
extend
env?
lookup
make-empty-env
extend-env
extend/values
dotted-env
initial-tvar-env
env-map
env-filter
env-vals
env-keys+vals
with-dotted-env/extend)
(require (prefix-in r: "../utils/utils.ss"))
(require scheme/match
(r:utils tc-utils))
;; eq? has the type of equal?, and l is an alist (with conses!)
(define-struct env (eq? l))
(r:d-s/c env ([eq? (any/c any/c . -> . boolean?)] [l (listof pair?)]) #:transparent)
(define (env-vals e)
(map cdr (env-l e)))
@ -43,7 +45,9 @@
;; the environment for types of ... variables
(define dotted-env (make-parameter (make-empty-env free-identifier=?)))
(define/contract (env-map f env)
((pair? . -> . pair?) env? . -> . env?)
(make-env (env-eq? env) (map f (env-l env))))
;; extend that works on single arguments
(define (extend e k v)
@ -70,7 +74,7 @@
;; elements are not lists, or all at once, if the elements are lists
(define (extend/values kss vss env)
(foldr (lambda (ks vs env)
(cond [(and (list? ks) (list? vs))
(cond [(and (list? ks) (list? vs))
(extend-env ks vs env)]
[(or (list? ks) (list? vs))
(int-err "not both lists in extend/values: ~a ~a" ks vs)]
@ -81,3 +85,5 @@
(define-syntax with-dotted-env/extend
(syntax-rules ()
[(_ i t v . b) (parameterize ([dotted-env (extend/values (list i) (list (cons t v)) (dotted-env))]) . b)]))
(provide/contract [make-empty-env ((-> any/c any/c any/c) . -> . env?)])

4
collects/typed-scheme/env/type-name-env.ss vendored
View File

@ -6,7 +6,7 @@
(env type-alias-env)
(utils tc-utils)
(rep type-rep)
(private type-utils))
(types utils))
(provide register-type-name
lookup-type-name
@ -46,6 +46,6 @@
(define (type-name-env-map f)
(module-identifier-mapping-map the-mapping f))
(define (add-alias from to)
(define (add-alias from to)
(when (lookup-type-name to (lambda () #f))
(register-resolved-type-alias from (make-Name to))))

12
collects/typed-scheme/infer/constraint-structs.ss
View File

@ -31,18 +31,6 @@
;; don't want to rule them out too early
(define-struct cset (maps) #:prefab)
(define (hashof k/c v/c)
(flat-named-contract
(format "#<hashof ~a ~a>" k/c v/c)
(lambda (h)
(define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c))
(define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c))
(and (hash? h)
(for/and ([(k v) h])
(and (k/c? k)
(v/c? v)))))))
(provide/contract (struct c ([S Type?] [X symbol?] [T Type?]))
(struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
(struct dcon-exact ([fixed (listof c?)] [rest c?]))

2
collects/typed-scheme/infer/constraints.ss
View File

@ -1,7 +1,7 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss" extend))
(require (private type-effect-convenience type-utils union subtype)
(require (types convenience utils union subtype)
(rep type-rep)
(utils tc-utils)
"signatures.ss" "constraint-structs.ss"

3
collects/typed-scheme/infer/infer-dummy.ss
View File

@ -1,8 +1,9 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rep type-rep) (utils tc-utils))
(require (rep type-rep) (utils tc-utils) mzlib/trace)
(define infer-param (make-parameter (lambda e (int-err "infer not initialized"))))
(define (unify X S T) ((infer-param) X S T (make-Univ) null))
;(trace unify)
(provide unify infer-param)

137
collects/typed-scheme/infer/infer-unit.ss
View File

@ -1,11 +1,11 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss"))
(require (rep free-variance type-rep effect-rep rep-utils)
(private type-effect-convenience union subtype remove-intersect)
(utils tc-utils)
(require (rep free-variance type-rep filter-rep rep-utils)
(types convenience union subtype remove-intersect resolve)
(except-in (utils tc-utils) make-env)
(env type-name-env)
(except-in (private type-utils) Dotted)
(except-in (types utils) Dotted)
"constraint-structs.ss"
"signatures.ss"
(only-in (env type-environments) lookup current-tvars)
@ -96,32 +96,49 @@
dmap)))
cset))
;; t and s must be *latent* effects
(define (cgen/eff V X t s)
;; t and s must be *latent* filters
(define (cgen/filter V X t s)
(match* (t s)
[(e e) (empty-cset X)]
[((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: s))
(cset-meet (cgen V X t s) (cgen V X s t))]
[((Latent-Remove-Effect: t) (Latent-Remove-Effect: s))
(cset-meet (cgen V X t s) (cgen V X s t))]
;; FIXME - is there something to be said about LBot?
[((LTypeFilter: t p i) (LTypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))]
[((LNotTypeFilter: t p i) (LNotTypeFilter: s p i)) (cset-meet (cgen V X t s) (cgen V X s t))]
[(_ _) (fail! t s)]))
(define (cgen/eff/list V X ts ss)
(unless (>= (length ts) (length ss)) (fail! ts ss))
(cset-meet* (for/list ([t ts] [s ss]) (cgen/eff V X t s))))
(define (cgen/filters V X ts ss)
(cond
[(null? ss) (empty-cset X)]
;; FIXME - this can be less conservative
[(= (length ts) (length ss))
(cset-meet* (for/list ([t ts] [s ss]) (cgen/filter V X t s)))]
[else (fail! ts ss)]))
;; t and s must be *latent* filter sets
(define (cgen/filter-set V X t s)
(match* (t s)
[(e e) (empty-cset X)]
[((LFilterSet: t+ t-) (LFilterSet: s+ s-))
(cset-meet (cgen/filters V X t+ s+) (cgen/filters V X t- s-))]
[(_ _) (fail! t s)]))
(define (cgen/object V X t s)
(match* (t s)
[(e e) (empty-cset X)]
[(e (LEmpty:)) (empty-cset X)]
;; FIXME - do something here
[(_ _) (fail! t s)]))
(define (cgen/arr V X t-arr s-arr)
(define (cg S T) (cgen V X S T))
(match* (t-arr s-arr)
[((arr: ts t #f #f '() t-thn-eff t-els-eff)
(arr: ss s #f #f '() s-thn-eff s-els-eff))
[((arr: ts t #f #f '())
(arr: ss s #f #f '()))
(cset-meet*
(list (cgen/list V X ss ts)
(cg t s)
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff)))]
[((arr: ts t t-rest #f '() t-thn-eff t-els-eff)
(arr: ss s s-rest #f '() s-thn-eff s-els-eff))
(cg t s)))]
[((arr: ts t t-rest #f '())
(arr: ss s s-rest #f '()))
(let ([arg-mapping
(cond [(and t-rest s-rest (<= (length ts) (length ss)))
(cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))]
@ -134,11 +151,9 @@
[else (fail! S T)])]
[ret-mapping (cg t s)])
(cset-meet*
(list arg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))]
[((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f #f '() s-thn-eff s-els-eff))
(list arg-mapping ret-mapping)))]
[((arr: ts t #f (cons dty dbound) '())
(arr: ss s #f #f '()))
(unless (memq dbound X)
(fail! S T))
(unless (<= (length ts) (length ss))
@ -148,10 +163,10 @@
(gensym dbound))]
[new-tys (for/list ([var vars])
(substitute (make-F var) dbound dty))]
[new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)])
[new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null) s-arr)])
(move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f #f '() t-thn-eff t-els-eff)
(arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff))
[((arr: ts t #f #f '())
(arr: ss s #f (cons dty dbound) '()))
(unless (memq dbound X)
(fail! S T))
(unless (<= (length ss) (length ts))
@ -161,10 +176,10 @@
(gensym dbound))]
[new-tys (for/list ([var vars])
(substitute (make-F var) dbound dty))]
[new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))])
[new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null))])
(move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
[((arr: ts t #f (cons t-dty dbound) '())
(arr: ss s #f (cons s-dty dbound) '()))
(unless (= (length ts) (length ss))
(fail! S T))
;; If we want to infer the dotted bound, then why is it in both types?
@ -174,22 +189,18 @@
[darg-mapping (cgen V X s-dty t-dty)]
[ret-mapping (cg t s)])
(cset-meet*
(list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))]
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff))
(list arg-mapping darg-mapping ret-mapping)))]
[((arr: ts t #f (cons t-dty dbound) '())
(arr: ss s #f (cons s-dty dbound*) '()))
(unless (= (length ts) (length ss))
(fail! S T))
(let* ([arg-mapping (cgen/list V X ss ts)]
[darg-mapping (cgen V (cons dbound* X) s-dty t-dty)]
[ret-mapping (cg t s)])
(cset-meet*
(list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))]
[((arr: ts t t-rest #f '() t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
(list arg-mapping darg-mapping ret-mapping)))]
[((arr: ts t t-rest #f '())
(arr: ss s #f (cons s-dty dbound) '()))
(unless (memq dbound X)
(fail! S T))
(if (<= (length ts) (length ss))
@ -197,9 +208,7 @@
(let* ([arg-mapping (cgen/list V X ss (extend ss ts t-rest))]
[darg-mapping (move-rest-to-dmap (cgen V X s-dty t-rest) dbound)]
[ret-mapping (cg t s)])
(cset-meet* (list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))
(cset-meet* (list arg-mapping darg-mapping ret-mapping)))
;; the hard case
(let* ([num-vars (- (length ts) (length ss))]
[vars (for/list ([n (in-range num-vars)])
@ -207,11 +216,11 @@
[new-tys (for/list ([var vars])
(substitute (make-F var) dbound s-dty))]
[new-cset (cgen/arr V (append vars X) t-arr
(make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))])
(make-arr (append ss new-tys) s #f (cons s-dty dbound) null))])
(move-vars+rest-to-dmap new-cset dbound vars)))]
;; If dotted <: starred is correct, add it below. Not sure it is.
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s s-rest #f '() s-thn-eff s-els-eff))
[((arr: ts t #f (cons t-dty dbound) '())
(arr: ss s s-rest #f '()))
(unless (memq dbound X)
(fail! S T))
(cond [(< (length ts) (length ss))
@ -225,18 +234,14 @@
[darg-mapping (cgen V X s-rest t-dty)]
[ret-mapping (cg t s)]
[new-cset
(cset-meet* (list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff)))])
(cset-meet* (list arg-mapping darg-mapping ret-mapping))])
(move-vars+rest-to-dmap new-cset dbound vars #:exact #t))]
[else
;; the simple case
(let* ([arg-mapping (cgen/list V X (extend ts ss s-rest) ts)]
[darg-mapping (move-rest-to-dmap (cgen V X s-rest t-dty) dbound #:exact #t)]
[ret-mapping (cg t s)])
(cset-meet* (list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))])]
(cset-meet* (list arg-mapping darg-mapping ret-mapping)))])]
[(_ _) (fail! S T)]))
;; determine constraints on the variables in X that would make T a supertype of S
@ -254,10 +259,10 @@
(S T)
[(a a) empty]
[(_ (Univ:)) empty]
[((Refinement: S _ _) T)
(cg S T)]
[((F: (? (lambda (e) (memq e X)) v)) S)
(when (match S
[(F: v*)
@ -272,7 +277,7 @@
[_ #f])
(fail! S T))
(singleton (var-promote S V) v Univ)]
;; two unions with the same number of elements, so we just try to unify them pairwise
#;[((Union: l1) (Union: l2))
(=> unmatch)
@ -342,9 +347,9 @@
(App: (Name: n*) args* _))
(unless (free-identifier=? n n*)
(fail! S T))
(let ([x (instantiate-poly (lookup-type-name n) args)]
[y (instantiate-poly (lookup-type-name n) args*)])
(cg x y))]
(cg (resolve-once S) (resolve-once T))]
[((App: _ _ _) _) (cg (resolve-once S) T)]
[(_ (App: _ _ _)) (cg S (resolve-once T))]
[((Values: ss) (Values: ts))
(unless (= (length ss) (length ts))
(fail! ss ts))
@ -401,6 +406,12 @@
([t-arr t-arr] [s-arr s-arr])
(with-handlers ([exn:infer? (lambda (_) #f)])
(cgen/arr V X t-arr s-arr)))))]
;; this is overly conservative
[((Result: s f-s o-s)
(Result: t f-t o-t))
(cset-meet* (list (cg s t)
(cgen/filter-set V X f-s f-t)
(cgen/object V X o-s o-t)))]
[(_ _)
(cond [(subtype S T) empty]
;; or, nothing worked, and we fail
@ -462,11 +473,11 @@
(let ([cs (cgen/list null X S T)])
(if (not expected)
(subst-gen cs R must-vars)
(cset-meet cs (cgen null X R expected))))))
(subst-gen (cset-meet cs (cgen null X R expected)) R must-vars)))))
;; like infer, but T-var is the vararg type:
(define (infer/vararg X S T T-var R must-vars [expected #f])
(define new-T (extend S T T-var))
(define new-T (if T-var (extend S T T-var) T))
(and ((length S) . >= . (length T))
(infer X S new-T R must-vars expected)))
@ -486,7 +497,7 @@
[cs (cset-meet cs-short cs-dotted*)])
(if (not expected)
(subst-gen cs R must-vars)
(cset-meet cs (cgen null X R expected))))))
(subst-gen (cset-meet cs (cgen null X R expected)) R must-vars)))))
(define (infer/simple S T R)
(infer (fv/list T) S T R))
@ -494,4 +505,4 @@
(define (i s t r)
(infer/simple (list s) (list t) r))
;(trace cgen)
;(trace subst-gen cgen)

1
collects/typed-scheme/infer/infer.ss
View File

@ -3,6 +3,7 @@
(require (except-in "../utils/utils.ss" infer))
(require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss"
"restrict.ss" "promote-demote.ss"
mzlib/trace
(only-in scheme/unit provide-signature-elements
define-values/invoke-unit/infer link)
(utils unit-utils))

49
collects/typed-scheme/infer/promote-demote.ss
View File

@ -1,10 +1,10 @@
#lang scheme/unit
(require "../utils/utils.ss")
(require (rep type-rep)
(private type-effect-convenience union type-utils)
(require (rep type-rep rep-utils)
(types convenience union utils)
"signatures.ss"
scheme/list)
scheme/list scheme/match)
(import)
(export promote-demote^)
@ -13,10 +13,15 @@
(for/or ([e (append* (map fv ts))])
(memq e V)))
(define (get-filters rng)
(match rng
[(Values: (list (Result: _ lf _) ...)) lf]
[(ValuesDots: (list (Result: _ lf _) ...) _ _) lf]))
(define (var-promote T V)
(define (vp t) (var-promote t V))
(define (inv t) (if (V-in? V t) Univ t))
(type-case vp T
(type-case (#:Type vp #:LatentFilter (sub-lf vp)) T
[#:F name (if (memq name V) Univ T)]
[#:Vector t (make-Vector (inv t))]
[#:Box t (make-Box (inv t))]
@ -27,19 +32,16 @@
[#:Param in out
(make-Param (var-demote in V)
(vp out))]
[#:arr dom rng rest drest kws thn els
(cond
[(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)]
[#:arr dom rng rest drest kws
(cond
[(apply V-in? V (get-filters rng))
(make-top-arr)]
[(and drest (memq (cdr drest) V))
(make-arr (for/list ([d dom]) (var-demote d V))
(vp rng)
(var-demote (car drest) V)
#f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn
els)]
(for/list ([k kws]) (var-demote k V)))]
[else
(make-arr (for/list ([d dom]) (var-demote d V))
(vp rng)
@ -47,15 +49,12 @@
(and drest
(cons (var-demote (car drest) V)
(cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn
els)])]))
(for/list ([k kws]) (var-demote k V)))])]))
(define (var-demote T V)
(define (vd t) (var-demote t V))
(define (inv t) (if (V-in? V t) (Un) t))
(type-case vd T
(type-case (#:Type vd #:LatentFilter (sub-lf vd)) T
[#:F name (if (memq name V) (Un) T)]
[#:Vector t (make-Vector (inv t))]
[#:Box t (make-Box (inv t))]
@ -66,19 +65,16 @@
[#:Param in out
(make-Param (var-promote in V)
(vd out))]
[#:arr dom rng rest drest kws thn els
[#:arr dom rng rest drest kws
(cond
[(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)]
[(apply V-in? V (get-filters rng))
(make-top-arr)]
[(and drest (memq (cdr drest) V))
(make-arr (for/list ([d dom]) (var-promote d V))
(vd rng)
(var-promote (car drest) V)
#f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn
els)]
(for/list ([k kws]) (var-demote k V)))]
[else
(make-arr (for/list ([d dom]) (var-promote d V))
(vd rng)
@ -86,7 +82,4 @@
(and drest
(cons (var-promote (car drest) V)
(cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn
els)])]))
(for/list ([k kws]) (var-demote k V)))])]))

18
collects/typed-scheme/infer/restrict.ss
View File

@ -2,9 +2,9 @@
(require "../utils/utils.ss")
(require (rep type-rep)
(private type-utils union remove-intersect subtype)
(types utils union subtype remove-intersect resolve)
"signatures.ss"
scheme/match)
scheme/match mzlib/trace)
(import infer^)
(export restrict^)
@ -12,26 +12,26 @@
;; NEW IMPL
;; restrict t1 to be a subtype of t2
(define (restrict t1 t2)
(define (restrict* t1 t2)
;; we don't use union map directly, since that might produce too many elements
(define (union-map f l)
(match l
[(Union: es)
(let ([l (map f es)])
;(printf "l is ~a~n" l)
(apply Un l))]))
(cond
[(subtype t1 t2) t1] ;; already a subtype
[(match t2
[(Poly: vars t)
(let ([subst (infer vars (list t1) (list t) t1 vars)])
(and subst (restrict t1 (subst-all subst t1))))]
(and subst (restrict* t1 (subst-all subst t1))))]
[_ #f])]
[(Union? t1) (union-map (lambda (e) (restrict e t2)) t1)]
[(Mu? t1)
(restrict (unfold t1) t2)]
[(Mu? t2) (restrict t1 (unfold t2))]
[(Union? t1) (union-map (lambda (e) (restrict* e t2)) t1)]
[(needs-resolving? t1) (restrict* (resolve-once t1) t2)]
[(needs-resolving? t2) (restrict* t1 (resolve-once t2))]
[(subtype t2 t1) t2] ;; we don't actually want this - want something that's a part of t1
[(not (overlap t1 t2)) (Un)] ;; there's no overlap, so the restriction is empty
[else t2] ;; t2 and t1 have a complex relationship, so we punt
))
(define restrict restrict*)
;(trace restrict*)

3
collects/typed-scheme/infer/signatures.ss
View File

@ -33,7 +33,8 @@
[cnt infer/vararg (((listof symbol?)
(listof Type?)
(listof Type?)
Type? Type?
(or/c #f Type?)
Type?
(listof symbol?))
((or/c #f Type?)) . ->* . any)]
[cnt infer/dots (((listof symbol?)

29
collects/typed-scheme/no-check.ss
View File

@ -1,5 +1,30 @@
#lang scheme/base
(require "private/prims.ss")
#;(require "private/prims.ss")
(provide (all-from-out scheme/base)
(all-from-out "private/prims.ss"))
(all-defined-out)
#;(all-from-out "private/prims.ss"))
(define-syntax-rule (define-type-alias . _) (begin))
(define-syntax-rule (define: nm _ _ . body)
(define nm . body))
(define-syntax-rule (ann e . rest) e)
(define-syntax-rule (require/typed mod [id . _] ...)
(require (only-in mod id ...)))
(define-syntax-rule (: . args) (begin))
(define-syntax let:
(syntax-rules ()
[(_ ([id _ _ . rest] ...) . b)
(let ([id . rest] ...) . b)]
[(_ id _ _ ([ids _ _ e] ...) . b)
(let id ([ids e] ...) . b)]))
(define-syntax-rule (lambda: ([id . rest] ...) . b)
(lambda (id ...) . b))
(define-syntax-rule (λ: . arg) (lambda: . arg))

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

@ -9,11 +9,28 @@
(only-in '#%kernel [apply kernel:apply])
scheme/promise
(only-in string-constants/private/only-once maybe-print-message)
(only-in scheme/match/runtime match:error matchable? match-equality-test))
(only-in scheme/match/runtime match:error matchable? match-equality-test)
(for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym])))
[raise (Univ . -> . (Un))]
[car (-poly (a b) (cl-> [((-pair a b)) a] [((-lst a)) a]))]
[car (-poly (a b)
(cl->*
(->acc (list (-pair a b)) a (list -car))
(->* (list (-lst a)) a)))]
[cdr (-poly (a b)
(cl->*
(->acc (list (-pair a b)) b (list -cdr))
(->* (list (-lst a)) (-lst a))))]
[cadr (-poly (a b c)
(cl-> [((-pair a (-pair b c))) b]
[((-lst a)) a]))]
[caddr (-poly (a) (-> (-lst a) a))]
[cadddr (-poly (a) (-> (-lst a) a))]
[cddr (-poly (a) (-> (-lst a) (-lst a)))]
[cdddr (-poly (a) (-> (-lst a) (-lst a)))]
[first (-poly (a b) (cl-> [((-pair a b)) a] [((-lst a)) a]))]
[second (-poly (a b c)
(cl-> [((-pair a (-pair b c))) b]
@ -25,14 +42,7 @@
[fifth (-poly (a) ((-lst a) . -> . a))]
[sixth (-poly (a) ((-lst a) . -> . a))]
[rest (-poly (a) ((-lst a) . -> . (-lst a)))]
[cadr (-poly (a b c)
(cl-> [((-pair a (-pair b c))) b]
[((-lst a)) a]))]
[caddr (-poly (a) (-> (-lst a) a))]
[cadddr (-poly (a) (-> (-lst a) a))]
[cdr (-poly (a b) (cl-> [((-pair a b)) b] [((-lst a)) (-lst a)]))]
[cddr (-poly (a) (-> (-lst a) (-lst a)))]
[cdddr (-poly (a) (-> (-lst a) (-lst a)))]
[cons (-poly (a b)
(cl-> [(a (-lst a)) (-lst a)]
[(a b) (-pair a b)]))]
@ -46,7 +56,7 @@
[null (-val null)]
[number? (make-pred-ty N)]
[char? (make-pred-ty -Char)]
[integer? (Univ . -> . B : (list (make-Latent-Restrict-Effect N)) (list (make-Latent-Remove-Effect -Integer)))]
[integer? (Univ . -> . B : (-LFS (list (-filter N)) (list (-not-filter -Integer))))]
[exact-integer? (make-pred-ty -Integer)]
[boolean? (make-pred-ty B)]
[add1 (cl->* (-> -Integer -Integer)
@ -57,7 +67,7 @@
[eqv? (-> Univ Univ B)]
[equal? (-> Univ Univ B)]
[even? (-> N B)]
[assert (-poly (a) (-> (*Un a (-val #f)) a))]
[assert (-poly (a) (-> (Un a (-val #f)) a))]
[gensym (cl-> [(Sym) Sym]
[() Sym])]
[string-append (->* null -String -String)]
@ -110,10 +120,7 @@
[((a b c . -> . c) c (-lst a) (-lst b)) c]
[((a b c d . -> . d) d (-lst a) (-lst b) (-lst d)) d]))]
[filter (-poly (a b) (cl->*
((a . -> . B
:
(list (make-Latent-Restrict-Effect b))
(list (make-Latent-Remove-Effect b)))
((make-pred-ty (list a) B b)
(-lst a)
. -> .
(-lst b))
@ -139,8 +146,8 @@
(error
(make-Function (list
(make-arr (list Sym -String) (Un) Univ)
(make-arr (list -String) (Un) Univ)
(make-arr (list Sym -String) (Un) #:rest Univ)
(make-arr (list -String) (Un) #:rest Univ)
(make-arr (list Sym) (Un)))))
[namespace-variable-value
@ -252,17 +259,20 @@
[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
[time-apply (-polydots (b a) (((list) (a a) . ->... . b)
(-lst a)
. -> .
(-values (list (-pair b (-val '())) N N N))))]
[time-apply (-polydots (b a)
(make-Function
(list (make-arr
(list ((list) (a a) . ->... . b)
(-lst a))
(-values (list (-pair b (-val '())) N N N))))))]
[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (Un a b)))]
[quotient (-Integer -Integer . -> . -Integer)]
[remainder (-Integer -Integer . -> . -Integer)]
[quotient/remainder (-Integer -Integer . -> . (-values (list -Integer -Integer)))]
[quotient/remainder
(make-Function (list (make-arr (list -Integer -Integer) (-values (list -Integer -Integer)))))]
;; parameter stuff
@ -282,9 +292,9 @@
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
[-StrRx (Un -String -Regexp -PRegexp)]
[-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (Un -Input-Port -Bytes)])
(cl-> [(-StrRx -String ) (optlist -String)]
[(-StrRx -String N ) (optlist -String)]
[(-StrRx -String N ?N ) (optlist -String)]
@ -300,9 +310,9 @@
[regexp-match*
(let ([?N (-opt N)]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
[-StrRx (Un -String -Regexp -PRegexp)]
[-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (Un -Input-Port -Bytes)])
(cl->*
(-StrRx -String [N ?N] . ->opt . (-lst -String))
(-BtsRx -String [N ?N] . ->opt . (-lst -Bytes))
@ -321,17 +331,17 @@
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
[-StrRx (Un -String -Regexp -PRegexp)]
[-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (Un -Input-Port -Bytes)])
(->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))]
[regexp-match-positions*
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
[-StrRx (Un -String -Regexp -PRegexp)]
[-BtsRx (Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (Un -Input-Port -Bytes)])
(->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (-lst (-pair -Nat -Nat))))]
#;
[regexp-match-peek-positions*]
@ -450,8 +460,8 @@
[hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))]
[hash-ref (-poly (a b c)
(cl-> [((-HT a b) a) b]
[((-HT a b) a (-> c)) (*Un b c)]
[((-HT a b) a c) (*Un b c)]))]
[((-HT a b) a (-> c)) (Un b c)]
[((-HT a b) a c) (Un b c)]))]
#;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))]
[bytes (->* (list) N -Bytes)]
@ -471,7 +481,7 @@
[force (-poly (a) (-> (-Promise a) a))]
[bytes<? (->* (list -Bytes) -Bytes B)]
[regexp-replace*
(cl->* (-Pattern (*Un -Bytes -String) (*Un -Bytes -String) . -> . -Bytes)
(cl->* (-Pattern (Un -Bytes -String) (Un -Bytes -String) . -> . -Bytes)
(-Pattern -String -String . -> . -String))]
[peek-char
(cl->* [-> -Char]
@ -510,7 +520,7 @@
[delete-file (-> -Pathlike -Void)]
[make-namespace (cl->* (-> -Namespace)
(-> (*Un (-val 'empty) (-val 'initial)) -Namespace))]
(-> (Un (-val 'empty) (-val 'initial)) -Namespace))]
[make-base-namespace (-> -Namespace)]
[eval (-> -Sexp Univ)]

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

@ -16,17 +16,17 @@
;; these are all for constructing the types given to variables
(require (for-syntax
scheme/base
(utils tc-utils)
(env init-envs)
(except-in (rep effect-rep type-rep) make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"
(except-in (rep filter-rep object-rep type-rep) make-arr)
(types convenience union)
(only-in (types convenience) [make-arr* make-arr])
(typecheck tc-structs)))
(define-for-syntax (initialize-others)
(d-s date
([second : N] [minute : N] [hour : N] [day : N] [month : N]
[year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
([second : -Number] [minute : -Number] [hour : -Number] [day : -Number] [month : -Number]
[year : -Number] [weekday : -Number] [year-day : -Number] [dst? : -Boolean] [time-zone-offset : -Number])
())
(d-s exn ([message : -String] [continuation-marks : Univ]) ())
(d-s (exn:fail exn) () (-String -Cont-Mark-Set))
@ -65,7 +65,7 @@
;; make-promise
(-poly (a) (-> (-> a) (-Promise a)))
;; language
Sym
-Symbol
;; qq-append
(-poly (a b)
(cl->*

6
collects/typed-scheme/private/base-types.ss
View File

@ -1,10 +1,10 @@
#lang s-exp "type-env-lang.ss"
[Number N]
[Number -Number]
[Integer -Integer]
[Void -Void]
[Boolean B]
[Symbol Sym]
[Boolean -Boolean]
[Symbol -Symbol]
[String -String]
[Any Univ]
[Port -Port]

17
collects/typed-scheme/private/env-lang.ss
View File

@ -2,15 +2,14 @@
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require (for-syntax (private type-effect-convenience)
(require (for-syntax (utils tc-utils)
(env init-envs)
scheme/base
(r:infer infer)
(only-in (r:infer infer-dummy) infer-param)
(except-in (rep effect-rep type-rep) make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"))
(except-in (rep object-rep filter-rep type-rep) make-arr)
(types convenience union)
(only-in (types convenience) [make-arr* make-arr])))
(define-syntax (#%module-begin stx)
(syntax-case stx (require)
@ -32,7 +31,7 @@
(provide #%module-begin
require
(all-from-out scheme/base)
(for-syntax
(all-from-out scheme/base
"type-effect-convenience.ss"
"union.ss")))
types rep private utils
(for-syntax
(types-out convenience union)
(all-from-out scheme/base)))

170
collects/typed-scheme/private/parse-type.ss
View File

@ -1,29 +1,31 @@
#lang scheme/base
(provide parse-type parse-type/id parse-type*)
(require (except-in "../utils/utils.ss" extend id))
(require (except-in "../utils/utils.ss" extend))
(require (except-in (rep type-rep) make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
(utils tc-utils)
"union.ss"
syntax/stx
(rename-in (types convenience union utils) [make-arr* make-arr])
(utils tc-utils stxclass-util)
syntax/stx (prefix-in c: scheme/contract)
stxclass stxclass/util
(env type-environments type-name-env type-alias-env lexical-env)
"type-utils.ss"
(prefix-in t: "base-types-extra.ss")
scheme/match
"stxclass-util.ss"
(for-template scheme/base "base-types-extra.ss"))
(p/c [parse-type (syntax? . c:-> . Type/c)]
[parse-type/id (syntax? c:any/c . c:-> . Type/c)]
[parse-tc-results (syntax? . c:-> . tc-results?)]
[parse-tc-results/id (syntax? c:any/c . c:-> . tc-results?)]
[parse-type* (syntax? . c:-> . Type/c)])
(define enable-mu-parsing (make-parameter #t))
(define (parse-type/id loc datum)
(define ((parse/id p) loc datum)
#;(printf "parse-type/id id : ~a~n ty: ~a~n" (syntax-object->datum loc) (syntax-object->datum stx))
(let* ([stx* (datum->syntax loc datum loc loc)])
(parse-type stx*)))
(p stx*)))
(define (stx-cadr stx) (stx-car (stx-cdr stx)))
@ -276,6 +278,27 @@
(parameterize ([current-orig-stx stx])
(parse/get stx t type)))
(define (parse-all-type stx parse-type)
(syntax-parse stx
[(All (vars ... v dd) t)
#:when (eq? (syntax-e #'dd) '...)
#:when (andmap identifier? (syntax->list #'(v vars ...)))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)]
[v (syntax-e #'v)]
[tv (make-Dotted (make-F v))])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))])
(make-PolyDots (append vars (list v)) (parse-type #'t))))]
[(All (vars ...) t)
#:when (andmap identifier? (syntax->list #'(vars ...)))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env vars tvars (current-tvars))])
(make-Poly vars (parse-type #'t))))]
[(All . rest) (tc-error "All: bad syntax")]))
(define (parse-type stx)
(parameterize ([current-orig-stx stx])
(syntax-case* stx ()
@ -304,7 +327,7 @@
(and (eq? (syntax-e #'Refinement) 'Refinement)
(identifier? #'p?))
(match (lookup-type/lexical #'p?)
[(and t (Function: (list (arr: (list dom) rng #f #f '() _ _))))
[(and t (Function: (list (arr: (list dom) _ #f #f '()))))
(make-Refinement dom #'p? (syntax-local-certifier))]
[t (tc-error "cannot declare refinement for non-predicate ~a" t)])]
[(Instance t)
@ -326,19 +349,21 @@
[(pred t)
(eq? (syntax-e #'pred) 'pred)
(make-pred-ty (parse-type #'t))]
;; function types
[(dom -> rng : pred-ty)
(and
(eq? (syntax-e #'->) '->)
(eq? (syntax-e #':) ':))
(begin
(add-type-name-reference (stx-cadr stx))
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty)))]
[(dom ... rest ::: -> rng)
(and (eq? (syntax-e #'->) '->)
(eq? (syntax-e #':::) '*))
(begin
(add-type-name-reference #'->)
(->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-type #'rng)))]
(->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-values-type #'rng)))]
[(dom ... rest ::: bound -> rng)
(and (eq? (syntax-e #'->) '->)
(eq? (syntax-e #':::) '...)
@ -351,7 +376,7 @@
(make-Function
(list
(make-arr-dots (map parse-type (syntax->list #'(dom ...)))
(parse-type #'rng)
(parse-values-type #'rng)
(parameterize ([current-tvars (extend-env (list (syntax-e #'bound))
(list (make-DottedBoth (make-F (syntax-e #'bound))))
(current-tvars))])
@ -371,7 +396,7 @@
(make-Function
(list
(make-arr-dots (map parse-type (syntax->list #'(dom ...)))
(parse-type #'rng)
(parse-values-type #'rng)
(parameterize ([current-tvars (extend-env (list var)
(list (make-DottedBoth t))
(current-tvars))])
@ -382,40 +407,8 @@
(eq? (syntax-e #'->) '->)
(begin
(add-type-name-reference #'->)
(->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rng)))]
[(values tys ... dty dd bound)
(and (eq? (syntax-e #'dd) '...)
(identifier? #'bound)
(eq? (syntax-e #'values) 'values))
(let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
(if (not (Dotted? var))
(tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound))
(make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
(parameterize ([current-tvars (extend-env (list (syntax-e #'bound))
(list (make-DottedBoth (make-F (syntax-e #'bound))))
(current-tvars))])
(parse-type #'dty))
(syntax-e #'bound))))]
[(values tys ... dty dd)
(and (eq? (syntax-e #'values) 'values)
(eq? (syntax-e #'dd) '...))
(begin
(add-type-name-reference #'values)
(let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))])
(when (null? bounds)
(tc-error/stx stx "No type variable bound with ... in scope for ... type"))
(unless (null? (cdr bounds))
(tc-error/stx stx "Cannot infer bound for ... type"))
(match-let ([(cons var (struct Dotted (t))) (car bounds)])
(make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
(parameterize ([current-tvars (extend-env (list var)
(list (make-DottedBoth t))
(current-tvars))])
(parse-type #'dty))
var))))]
[(values tys ...)
(eq? (syntax-e #'values) 'values)
(-values (map parse-type (syntax->list #'(tys ...))))]
(->* (map parse-type (syntax->list #'(dom ...))) (parse-values-type #'rng)))]
[(case-lambda tys ...)
(eq? (syntax-e #'case-lambda) 'case-lambda)
(make-Function
@ -452,27 +445,10 @@
[(quot t)
(eq? (syntax-e #'quot) 'quote)
(-val (syntax-e #'t))]
[(All (vars ... v dd) t)
(and (or (eq? (syntax-e #'All) 'All)
(eq? (syntax-e #'All) '∀))
(eq? (syntax-e #'dd) '...)
(andmap identifier? (syntax->list #'(v vars ...))))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)]
[v (syntax-e #'v)]
[tv (make-Dotted (make-F v))])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env (cons v vars) (cons tv tvars) (current-tvars))])
(make-PolyDots (append vars (list v)) (parse-type #'t))))]
[(All (vars ...) t)
(and (or (eq? (syntax-e #'All) 'All)
(eq? (syntax-e #'All) '∀))
(andmap identifier? (syntax->list #'(vars ...))))
(let* ([vars (map syntax-e (syntax->list #'(vars ...)))]
[tvars (map make-F vars)])
(add-type-name-reference #'All)
(parameterize ([current-tvars (extend-env vars tvars (current-tvars))])
(make-Poly vars (parse-type #'t))))]
[(All . rest)
(or (eq? (syntax-e #'All) 'All)
(eq? (syntax-e #'All) '∀))
(parse-all-type stx parse-type)]
[(Opaque p?)
(eq? (syntax-e #'Opaque) 'Opaque)
(begin
@ -516,9 +492,7 @@
Err]
[else
(tc-error/delayed "Unbound type name ~a" (syntax-e #'id))
Err])]
[(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")]
Err])]
[(Opaque . rest) (eq? (syntax-e #'Opaque) 'Opqaue) (tc-error "Opaque: bad syntax")]
[(U . rest) (eq? (syntax-e #'U) 'U) (tc-error "Union: bad syntax")]
[(Vectorof . rest) (eq? (syntax-e #'Vectorof) 'Vectorof) (tc-error "Vectorof: bad syntax")]
@ -558,3 +532,53 @@
(string? (syntax-e #'t)))
(-val (syntax-e #'t))]
[_ (tc-error "not a valid type: ~a" (syntax->datum stx))])))
(define (parse-values-type stx)
(parameterize ([current-orig-stx stx])
(syntax-parse stx
[(values tys ... dty :ddd bound:id)
#:when (eq? (syntax-e #'values) 'values)
(let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))])
(if (not (Dotted? var))
(tc-error/stx #'bound "Used a type variable (~a) not bound with ... as a bound on a ..." (syntax-e #'bound))
(make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
(parameterize ([current-tvars (extend-env (list (syntax-e #'bound))
(list (make-DottedBoth (make-F (syntax-e #'bound))))
(current-tvars))])
(parse-type #'dty))
(syntax-e #'bound))))]
[(values tys ... dty :ddd)
#:when (and (eq? (syntax-e #'values) 'values))
(add-type-name-reference #'values)
(let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))])
(when (null? bounds)
(tc-error/stx stx "No type variable bound with ... in scope for ... type"))
(unless (null? (cdr bounds))
(tc-error/stx stx "Cannot infer bound for ... type"))
(match-let ([(cons var (struct Dotted (t))) (car bounds)])
(make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
(parameterize ([current-tvars (extend-env (list var)
(list (make-DottedBoth t))
(current-tvars))])
(parse-type #'dty))
var)))]
[(values tys ...)
#:when (eq? (syntax-e #'values) 'values)
(-values (map parse-type (syntax->list #'(tys ...))))]
[(All . rest)
#:when (or (eq? (syntax-e #'All) 'All)
(eq? (syntax-e #'All) '∀))
(parse-all-type stx parse-values-type)]
[t
(-values (list (parse-type #'t)))])))
(define (parse-tc-results stx)
(syntax-parse stx
[(values t ...)
#:when (eq? 'values (syntax-e #'values))
(ret (map parse-type (syntax->list #'(t ...))))]
[t (ret (parse-type #'t))]))
(define parse-tc-results/id (parse/id parse-tc-results))
(define parse-type/id (parse/id parse-type))

4
collects/typed-scheme/private/prims.ss
View File

@ -33,11 +33,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
syntax/struct
syntax/stx
scheme/struct-info
(except-in (utils utils tc-utils) id)
(except-in (utils utils tc-utils))
(env type-name-env)
"type-contract.ss"))
(require "require-contract.ss"
(require (utils require-contract)
(typecheck internal-forms)
(except-in mzlib/contract ->)
(only-in mzlib/contract [-> c->])

69
collects/typed-scheme/private/remove-intersect.ss
View File

@ -1,69 +0,0 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep)
(private union subtype resolve-type type-effect-convenience type-utils)
scheme/match mzlib/trace)
(provide (rename-out [*remove remove]) overlap)
(define (overlap t1 t2)
(match (list t1 t2)
[(list (Univ:) _) #t]
[(list _ (Univ:)) #t]
[(list (F: _) _) #t]
[(list _ (F: _)) #t]
[(list (Name: n) (Name: n*)) (free-identifier=? n n*)]
[(list (? Mu?) _) (overlap (unfold t1) t2)]
[(list _ (? Mu?)) (overlap t1 (unfold t2))]
[(list (Union: e) t)
(ormap (lambda (t*) (overlap t* t)) e)]
[(list t (Union: e))
(ormap (lambda (t*) (overlap t t*)) e)]
[(or (list _ (? Poly?)) (list (? Poly?) _))
#t] ;; these can have overlap, conservatively
[(list (Base: s1 _) (Base: s2 _)) (eq? s1 s2)]
[(list (Base: _ _) (Value: _)) (subtype t2 t1)] ;; conservative
[(list (Value: _) (Base: _ _)) (subtype t1 t2)] ;; conservative
[(list (Syntax: t) (Syntax: t*))
(overlap t t*)]
[(or (list (Syntax: _) _)
(list _ (Syntax: _)))
#f]
[(list (Base: _ _) _) #f]
[(list _ (Base: _ _)) #f]
[(list (Value: (? pair? v)) (Pair: _ _)) #t]
[(list (Pair: _ _) (Value: (? pair? v))) #t]
[(list (Pair: a b) (Pair: a* b*))
(and (overlap a a*)
(overlap b b*))]
[(or (list (Pair: _ _) _)
(list _ (Pair: _ _)))
#f]
[else #t]))
;(trace restrict)
;; also not yet correct
;; produces old without the contents of rem
(define (*remove old rem)
(define initial
(if (subtype old rem)
(Un) ;; the empty type
(match (list old rem)
[(list (or (App: _ _ _) (Name: _)) t)
;; must be different, since they're not subtypes
;; and n must refer to a distinct struct type
old]
[(list (Union: l) rem)
(apply Un (map (lambda (e) (*remove e rem)) l))]
[(list (? Mu? old) t) (*remove (unfold old) t)]
[(list (Poly: vs b) t) (make-Poly vs (*remove b rem))]
[_ old])))
(if (subtype old initial) old initial))
;(trace *remove)
;(trace restrict)

80
collects/typed-scheme/private/resolve-type.ss
View File

@ -1,80 +0,0 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rep type-rep) (env type-name-env) (utils tc-utils)
"type-utils.ss"
scheme/match
mzlib/trace)
(provide resolve-name resolve-app needs-resolving? resolve-once)
(define (resolve-name t)
(match t
[(Name: n) (lookup-type-name n)]
[_ (int-err "resolve-name: not a name ~a" t)]))
(define (resolve-app rator rands stx)
(parameterize ([current-orig-stx stx])
(match rator
[(Poly: _ _)
(instantiate-poly rator rands)]
[(Name: _) (resolve-app (resolve-name rator) rands stx)]
[(Mu: _ _) (resolve-app (unfold rator) rands)]
[(App: r r* s) (resolve-app (resolve-app r r* s) rands)]
[_ (tc-error "resolve-app: not a proper operator ~a" rator)])))
(define (needs-resolving? t)
(or (Mu? t) (App? t) (Name? t)))
(define (resolve-once t)
(match t
[(Mu: _ _) (unfold t)]
[(App: r r* s) (resolve-app r r* s)]
[(Name: _) (resolve-name t)]))
#|
(define (resolve-tc-result tcr)
(match tcr
[(tc-result: t e1s e2s)
(ret (resolve-type t) (map resolve-effect e1s) (map resolve-effect e2s))]))
(define (resolve-effect* e)
(effect-case resolve-type resolve-effect e))
(define (resolve-type* t)
(define (int t)
(type-case resolve-type t
[#:Name stx (lookup-type-name stx)]
[#:Poly #:matcher Poly: names body (make-Poly names (resolve-type body))]
[#:Mu #:matcher Mu: name body (make-Mu name (resolve-type body))]
[#:App rator rands stx
(let ([rator (resolve-type rator)]
[rands (map resolve-type rands)])
(unless (Poly? rator)
(tc-error/stx stx "Cannot apply non-polymorphic type: ~a, arguments were: ~a" rator rands))
(instantiate-poly rator rands))]))
(let loop ([t (int t)])
(if (or (Name? t) (App? t))
(loop (resolve-type t))
t)))
(define table (make-hash-table))
(define (resolve-type t)
(hash-table-get table t
(lambda () (let ([v (resolve-type* t)])
(hash-table-put! table t v)
v))))
(define (resolve-effect t)
(hash-table-get table t
(lambda () (let ([v (resolve-effect* t)])
(hash-table-put! table t v)
v))))
;(trace resolve-type)
|#

237
collects/typed-scheme/private/type-abbrev.ss
View File

@ -1,237 +0,0 @@
#lang scheme
(require "../utils/utils.ss")
(require (rep type-rep effect-rep)
(utils tc-utils)
scheme/list
scheme/match
"type-effect-printer.ss"
scheme/promise
(for-syntax scheme/base stxclass)
(for-template scheme/base scheme/contract scheme/tcp))
(provide (all-defined-out))
(define top-func (make-Function (list (make-top-arr))))
(define (-vet id) (make-Var-True-Effect id))
(define (-vef id) (make-Var-False-Effect id))
(define -rem make-Remove-Effect)
(define -rest make-Restrict-Effect)
(define (var->type-eff eff)
(match eff
[(Var-True-Effect: v) (make-Remove-Effect (make-Value #f) v)]
[(Var-False-Effect: v) (make-Restrict-Effect (make-Value #f) v)]
[_ eff]))
(define ((add-var v) eff)
(match eff
[(Latent-Var-True-Effect:) (-vet v)]
[(Latent-Var-False-Effect:) (-vef v)]
[(Latent-Restrict-Effect: t) (make-Restrict-Effect t v)]
[(Latent-Remove-Effect: t) (make-Remove-Effect t v)]
[(True-Effect:) eff]
[(False-Effect:) eff]
[_ (int-err "can't add var ~a to effect ~a" v eff)]))
(define-syntax (-> stx)
(syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b)))
[(_ dom ... rng : eff1 eff2)
#'(->* (list dom ...) rng : eff1 eff2)]
[(_ dom ... rng : eff1 eff2)
#'(->* (list dom ...) rng : eff1 eff2)]
[(_ dom ... rng)
#'(->* (list dom ...) rng)]))
(define-syntax ->*
(syntax-rules (:)
[(_ dom rng)
(make-Function (list (make-arr* dom rng)))]
[(_ dom rst rng)
(make-Function (list (make-arr* dom rng rst)))]
[(_ dom rng : eff1 eff2)
(make-Function (list (make-arr* dom rng #f eff1 eff2)))]
[(_ dom rst rng : 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->
(syntax-rules (:)
[(_ [(dom ...) rng] ...)
(make-Function (list (make-arr* (list dom ...) rng) ...))]
[(_ [(dom ...) rng : eff1 eff2] ...)
(make-Function (list (make-arr* (list dom ...) rng #f eff1 eff2) ...))]
[(_ [(dom ...) rng rst : eff1 eff2] ...)
(make-Function (list (make-arr* (list dom ...) rng rst eff1 eff2) ...))]))
(define (cl->* . args)
(define (funty-arities f)
(match f
[(Function: as) as]))
(make-Function (apply append (map funty-arities args))))
(define-syntax (->key stx)
(syntax-parse stx
[(_ ty:expr ... (~or (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 #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 (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))
(define make-promise-ty
(let ([s (string->uninterned-symbol "Promise")])
(lambda (t)
(make-Struct s #f (list t) #f #f #'promise? values))))
(define N (make-Base 'Number #'number?))
(define -Integer (make-Base 'Integer #'exact-integer?))
(define B (make-Base 'Boolean #'boolean?))
(define Sym (make-Base 'Symbol #'symbol?))
(define -Void (make-Base 'Void #'void?))
(define -Bytes (make-Base 'Bytes #'bytes?))
(define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?))))
(define -PRegexp (make-Base 'PRegexp #'(and/c pregexp? (not/c byte-pregexp?))))
(define -Byte-Regexp (make-Base 'Byte-Regexp #'(and/c byte-regexp? (not/c byte-pregexp?))))
(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp?))
(define -String (make-Base 'String #'string?))
(define -Keyword (make-Base 'Keyword #'keyword?))
(define -Char (make-Base 'Char #'char?))
(define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?))
(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?))
(define -Path (make-Base 'Path #'path?))
(define -Namespace (make-Base 'Namespace #'namespace?))
(define -Output-Port (make-Base 'Output-Port #'output-port?))
(define -Input-Port (make-Base 'Input-Port #'input-port?))
(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?))
(define -Syntax make-Syntax)
(define -HT make-Hashtable)
(define -Promise make-promise-ty)
(define Univ (make-Univ))
(define Err (make-Error))
(define -Nat -Integer)
(define-syntax -v
(syntax-rules ()
[(_ x) (make-F 'x)]))
(define-syntax -poly
(syntax-rules ()
[(_ (vars ...) ty)
(let ([vars (-v vars)] ...)
(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
(syntax-rules ()
[(_ var ty)
(let ([var (-v var)])
(make-Mu 'var ty))]))
(define -values make-Values)
(define-syntax *Un
(syntax-rules ()
[(_ . args) (make-Union (list . args))]))
(define -pair make-Pair)
(define -struct make-Struct)
(define -val make-Value)
(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
(define -Listof (-poly (list-elem) (make-Listof list-elem)))
(define -lst make-Listof)
(define -Sexp (-mu x (*Un Sym N B -String (-val null) (-pair x x))))
(define -Port (*Un -Input-Port -Output-Port))
(define (-lst* #:tail [tail (-val null)] . args)
(if (null? args)
tail
(-pair (car args) (apply -lst* #:tail tail (cdr args)))))
#;(define NE (-mu x (Un N (make-Listof x))))
(define -NE (-mu x (*Un N (-pair x (-pair Sym (-pair x (-val null)))))))
(define -Param make-Param)
(define make-pred-ty
(case-lambda
[(in out t)
(->* in out : (list (make-Latent-Restrict-Effect t)) (list (make-Latent-Remove-Effect t)))]
[(t) (make-pred-ty (list Univ) B t)]))
(define -Pathlike (*Un -Path -String))
(define -Pathlike* (*Un (-val 'up) (-val 'same) -Path -String))
(define -Pattern (*Un -String -Bytes -Regexp -Byte-Regexp -PRegexp -Byte-PRegexp))
(define -Byte N)
(define -Real N)
(define (-Tuple l)
(foldr -pair (-val '()) l))
(define (untuple t)
(match t
[(Value: '()) null]
[(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
[else #f])]
[_ #f]))
(define -box make-Box)
(define -vec make-Vector)
(define Any-Syntax ;(-Syntax Univ)
(-mu x
(-Syntax (*Un
(-mu y (*Un (-pair x (*Un x y)) (-val '())))
(make-Vector x)
(make-Box x)
N
B
-Keyword
-String
Sym))))
(define Ident (-Syntax Sym))
;; DO NOT USE if t contains #f
(define (-opt t) (*Un (-val #f) t))

39
collects/typed-scheme/private/type-annotation.ss
View File

@ -4,8 +4,9 @@
(require (rep type-rep)
(utils tc-utils)
(env type-env)
"parse-type.ss" "subtype.ss"
"type-effect-convenience.ss" "resolve-type.ss" "union.ss"
(except-in (types subtype union convenience resolve utils) -> ->*)
(private parse-type)
(only-in scheme/contract listof ->)
scheme/match mzlib/trace)
(provide type-annotation
get-type
@ -58,8 +59,8 @@
(define (pt prop)
#;(print-size prop)
(if (syntax? prop)
(parse-type prop)
(parse-type/id stx prop)))
(parse-tc-results prop)
(parse-tc-results/id stx prop)))
(cond
[(syntax-property stx type-ascrip-symbol) => pt]
[else #f]))
@ -89,40 +90,38 @@
(define (get-types stxs #:default [default #f])
(map (lambda (e) (get-type e #:default default)) stxs))
;; get the type annotations on this list of identifiers
;; if not all identifiers have annotations, return the supplied inferred type
;; list[identifier] type -> list[type]
(define (get-type/infer stxs expr tc-expr tc-expr/check)
;; list[identifier] stx (stx -> tc-results?) (stx tc-results? -> tc-results?) -> tc-results?
(d/c (get-type/infer stxs expr tc-expr tc-expr/check)
((listof identifier?) syntax? (syntax? . -> . tc-results?) (syntax? tc-results? . -> . tc-results?) . -> . tc-results?)
(match stxs
['()
(tc-expr/check expr (-values null))
(list)]
(tc-expr/check expr (ret null))]
[(list stx)
(cond [(type-annotation stx #:infer #t)
=> (lambda (ann)
(list (tc-expr/check expr ann)))]
[else (list (tc-expr expr))])]
(tc-expr/check expr (ret ann)))]
[else (tc-expr expr)])]
[(list stx ...)
(let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))])
(if (for/and ([a anns]) a)
(begin (tc-expr/check expr (-values anns)) anns)
(begin (tc-expr/check expr (ret anns)))
(let ([ty (tc-expr expr)])
(match ty
[(Values: tys)
[(tc-results: tys)
(if (not (= (length stxs) (length tys)))
(begin
(tc-error/delayed
"Expression should produce ~a values, but produces ~a values of types ~a"
(length stxs) (length tys) (stringify tys))
(map (lambda _ (Un)) stxs))
(map (lambda (stx ty a)
(cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)]
[else #;(log/noann stx ty) ty]))
stxs tys anns))]
(ret (map (lambda _ (Un)) stxs)))
(ret
(for/list ([stx stxs] [ty tys] [a anns])
(cond [a => (lambda (ann) (check-type stx ty ann) ann)]
[else ty]))))]
[ty (tc-error/delayed
"Expression should produce ~a values, but produces one values of type ~a"
(length stxs) ty)
(map (lambda _ (Un)) stxs)]))))]))
(ret (map (lambda _ (Un)) stxs))]))))]))
;; check that e-type is compatible with ty in context of stx

28
collects/typed-scheme/private/type-contract.ss
View File

@ -6,14 +6,11 @@
(require
(rep type-rep)
(typecheck internal-forms)
(utils tc-utils)
(utils tc-utils require-contract)
(env type-name-env)
"parse-type.ss"
"require-contract.ss"
"resolve-type.ss"
"type-utils.ss"
(only-in "type-effect-convenience.ss" Any-Syntax)
(prefix-in t: "type-effect-convenience.ss")
(types resolve utils)
(prefix-in t: (types convenience))
(private parse-type)
scheme/match
syntax/struct
syntax/stx
@ -63,7 +60,7 @@
;; we special-case lists:
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
#`(listof #,(t->c elem-ty))]
[(? (lambda (e) (eq? Any-Syntax e))) #'syntax?]
[(? (lambda (e) (eq? t:Any-Syntax e))) #'syntax?]
[(Base: sym cnt) cnt]
[(Refinement: par p? cert)
#`(and/c #,(t->c par) (flat-contract #,(cert p?)))]
@ -73,18 +70,13 @@
#;(printf "~a~n" (syntax-object->datum #'cnts))
#'(or/c . cnts))]
[(Function: arrs)
(let ()
(let ()
(define (f a)
(define-values (dom* rngs* rst)
(match a
[(arr: dom (Values: rngs) #f #f '() _ _)
(values (map t->c/neg dom) (map t->c rngs) #f)]
[(arr: dom rng #f #f '() _ _)
(values (map t->c/neg dom) (list (t->c rng)) #f)]
[(arr: dom (Values: rngs) rst #f '() _ _)
(values (map t->c/neg dom) (map t->c rngs) (t->c/neg rst))]
[(arr: dom rng rst #f '() _ _)
(values (map t->c/neg dom) (list (t->c rng)) (t->c/neg rst))]))
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '())
(values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))]
[_ (exit (fail))]))
(with-syntax
([(dom* ...) dom*]
[rng* (match rngs*
@ -95,7 +87,7 @@
#'((dom* ...) () #:rest (listof rst*) . ->* . rng*)
#'(dom* ... . -> . rng*))))
(unless (no-duplicates (for/list ([t arrs])
(match t [(arr: dom _ _ _ _ _ _) (length dom)])))
(match t [(arr: dom _ _ _ _) (length dom)])))
(exit (fail)))
(match (map f arrs)
[(list e) e]

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

@ -1,80 +0,0 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rep type-rep effect-rep)
(utils tc-utils)
scheme/list
scheme/match
"type-comparison.ss"
"type-effect-printer.ss"
"union.ss"
"subtype.ss"
"type-utils.ss"
"type-abbrev.ss"
scheme/promise
(for-syntax stxclass)
(for-syntax scheme/base)
(for-template scheme/base scheme/contract scheme/tcp))
(provide (all-defined-out)
(all-from-out "type-abbrev.ss")
;; these should all eventually go away
make-Name make-ValuesDots make-Function make-Latent-Restrict-Effect make-Latent-Remove-Effect)
(define (one-of/c . args)
(apply Un (map -val args)))
(define (Un/eff . args)
(apply Un (map tc-result-t args)))
(define-syntax (make-env stx)
(syntax-case stx ()
[(_ e ...)
#`(list
#,@(map (lambda (e)
(syntax-case e ()
[(nm ty)
(identifier? #'nm)
#`(list #'nm ty)]
[(e ty extra-mods ...)
#'(let ([x (list (let ([new-ns
(let* ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace)
'scheme/base
ns)
ns)])
(parameterize ([current-namespace new-ns])
(namespace-require 'scheme/base)
(namespace-require 'extra-mods) ...
e))
ty)])
;(display x) (newline)
x)]))
(syntax->list #'(e ...))))]))
;; if t is of the form (Pair t* (Pair t* ... (Listof t*)))
;; return t*
;; otherwise, return t
;; generalize : Type -> Type
(define (generalize t)
(let/ec exit
(let loop ([t* t])
(match t*
[(Value: '()) (-lst Univ)]
[(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*]
[(Pair: t1 t2)
(let ([t-new (loop t2)])
(if (type-equal? (-lst t1) t-new)
t-new
(exit t)))]
[_ (exit t)]))))
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])
(make-Function (list (make-arr* (append args (take opt-args i)) result))))))
(define-syntax-rule (->opt args ... [opt ...] res)
(opt-fn (list args ...) (list opt ...) res))

17
collects/typed-scheme/private/type-env-lang.ss
View File

@ -2,14 +2,10 @@
(require "../utils/utils.ss")
(require (for-syntax (private type-effect-convenience)
(env init-envs)
(require (for-syntax (env init-envs)
scheme/base
(except-in (rep effect-rep type-rep) make-arr)
(except-in "../rep/type-rep.ss" make-arr)
"type-effect-convenience.ss"
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
"union.ss"))
(except-in (rep filter-rep type-rep) make-arr)
(rename-in (types union convenience) [make-arr* make-arr])))
(define-syntax (#%module-begin stx)
(syntax-case stx (require)
@ -35,7 +31,6 @@
require
(all-from-out scheme/base)
(for-syntax
(all-from-out scheme/base
"type-effect-convenience.ss"
"../rep/type-rep.ss"
"union.ss")))
(types-out convenience union)
(rep-out type-rep)
(all-from-out scheme/base)))

41
collects/typed-scheme/rep/effect-rep.ss
View File

@ -1,41 +0,0 @@
#lang scheme/base
(require mzlib/plt-match)
(require mzlib/etc)
(require "rep-utils.ss" "free-variance.ss")
(de True-Effect () [#:frees #f] [#:fold-rhs #:base])
(de False-Effect () [#:frees #f] [#:fold-rhs #:base])
;; v is an identifier
(de Var-True-Effect (v) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base])
;; v is an identifier
(de Var-False-Effect (v) [#:intern (hash-id v)] [#:frees #f] [#:fold-rhs #:base])
;; t is a Type
;; v is an identifier
(de Restrict-Effect (t v) [#:intern (list t (hash-id v))] [#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Restrict-Effect (type-rec-id t) v)])
;; t is a Type
;; v is an identifier
(de Remove-Effect (t v)
[#:intern (list t (hash-id v))]
[#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Remove-Effect (type-rec-id t) v)])
;; t is a Type
(de Latent-Restrict-Effect (t) [#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Latent-Restrict-Effect (type-rec-id t))])
;; t is a Type
(de Latent-Remove-Effect (t) [#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*Latent-Remove-Effect (type-rec-id t))])
(de Latent-Var-True-Effect () [#:frees #f] [#:fold-rhs #:base])
(de Latent-Var-False-Effect () [#:frees #f] [#:fold-rhs #:base])
;; could also have latent true/false effects, but seems pointless

78
collects/typed-scheme/rep/filter-rep.ss Normal file
View File

@ -0,0 +1,78 @@
#lang scheme/base
(require scheme/match scheme/contract)
(require "rep-utils.ss" "free-variance.ss")
(define Filter/c
(flat-named-contract
'Filter
(λ (e)
(and (Filter? e) (not (FilterSet? e))))))
(define LatentFilter/c
(flat-named-contract
'LatentFilter
(λ (e)
(and (LatentFilter? e) (not (LFilterSet? e))))))
(provide Filter/c LatentFilter/c index/c)
(df Bot () [#:fold-rhs #:base])
(df TypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?])
[#:intern (list t p (hash-id v))]
[#:frees (combine-frees (map free-vars* (cons t p)))
(combine-frees (map free-idxs* (cons t p)))]
[#:fold-rhs (*TypeFilter (type-rec-id t) (map pathelem-rec-id p) v)])
(df NotTypeFilter ([t Type?] [p (listof PathElem?)] [v identifier?])
[#:intern (list t p (hash-id v))]
[#:frees (combine-frees (map free-vars* (cons t p)))
(combine-frees (map free-idxs* (cons t p)))]
[#:fold-rhs (*NotTypeFilter (type-rec-id t) (map pathelem-rec-id p) v)])
(df FilterSet (thn els)
[#:frees (combine-frees (map free-vars* (append thn els)))
(combine-frees (map free-idxs* (append thn els)))]
[#:fold-rhs (*FilterSet (map filter-rec-id thn) (map filter-rec-id els))]
[#:contract (->d ([t (cond [(ormap Bot? t)
(list/c Bot?)]
[(ormap Bot? e)
(list/c)]
[else (listof Filter/c)])]
[e (cond [(ormap Bot? e)
(list/c Bot?)]
[(ormap Bot? t)
(list/c)]
[else (listof Filter/c)])])
()
[result FilterSet?])])
(define index/c (or/c natural-number/c keyword?))
(dlf LBot () [#:fold-rhs #:base])
(dlf LTypeFilter ([t Type?] [p (listof PathElem?)] [idx index/c])
[#:frees (lambda (frees*) (combine-frees (map (compose make-invariant frees*) (cons t p))))]
[#:fold-rhs (*LTypeFilter (type-rec-id t) (map pathelem-rec-id p) idx)])
(dlf LNotTypeFilter ([t Type?] [p (listof PathElem?)] [idx index/c])
[#:frees (lambda (frees*) (combine-frees (map (compose make-invariant frees*) (cons t p))))]
[#:fold-rhs (*LNotTypeFilter (type-rec-id t) (map pathelem-rec-id p) idx)])
(dlf LFilterSet (thn els)
[#:frees (combine-frees (map free-vars* (append thn els)))
(combine-frees (map free-idxs* (append thn els)))]
[#:fold-rhs (*LFilterSet (map latentfilter-rec-id thn) (map latentfilter-rec-id els))]
[#:contract (->d ([t (cond [(ormap LBot? t)
(list/c LBot?)]
[(ormap LBot? e)
(list/c)]
[else (listof LatentFilter/c)])]
[e (cond [(ormap LBot? e)
(list/c LBot?)]
[(ormap LBot? t)
(list/c)]
[else (listof LatentFilter/c)])])
()
[result LFilterSet?])])

10
collects/typed-scheme/rep/interning.ss
View File

@ -1,14 +1,16 @@
#lang scheme/base
(require syntax/boundmap (for-syntax scheme/base stxclass))
(require syntax/boundmap (for-syntax scheme/base stxclass)
#;macro-debugger/stepper)
(provide defintern hash-id)
(define-syntax (defintern stx)
(syntax-parse stx
[(_ name+args make-name key (~or [#:extra-arg e:expr]) ...)
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e ...)]
[(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...)
(if #'e
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)
#'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))]
[(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...)
#'(define *name
(let ([table (make-ht)])

22
collects/typed-scheme/rep/object-rep.ss Normal file
View File

@ -0,0 +1,22 @@
#lang scheme/base
(require scheme/match scheme/contract "rep-utils.ss" "free-variance.ss" "filter-rep.ss")
(dpe CarPE () [#:fold-rhs #:base])
(dpe CdrPE () [#:fold-rhs #:base])
(dpe StructPE ([t Type?] [idx natural-number/c])
[#:frees (free-vars* t) (free-idxs* t)]
[#:fold-rhs (*StructPE (type-rec-id t) idx)])
(do Empty () [#:fold-rhs #:base])
(do Path ([p (listof PathElem?)] [v identifier?])
[#:intern (list p (hash-id v))]
[#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))]
[#:fold-rhs (*Path (map pathelem-rec-id p) v)])
(dlo LEmpty () [#:fold-rhs #:base])
(dlo LPath ([p (listof PathElem?)] [idx index/c])
[#:frees (combine-frees (map free-vars* p)) (combine-frees (map free-idxs* p))]
[#:fold-rhs (*LPath (map pathelem-rec-id p) idx)])

376
collects/typed-scheme/rep/rep-utils.ss
View File

@ -7,125 +7,279 @@
"free-variance.ss"
"interning.ss"
mzlib/etc
scheme/contract
(for-syntax
scheme/list
stxclass/util
scheme/match
stxclass
scheme/base
syntax/struct
syntax/stx
(rename-in (utils utils) [id mk-id])))
scheme/contract
(utils utils)))
(provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq Type-key)
(provide == defintern hash-id (for-syntax fold-target))
;; hash table for defining folds over types
(define-values-for-syntax (type-name-ht effect-name-ht)
(values (make-hasheq) (make-hasheq)))
(provide (for-syntax type-name-ht effect-name-ht))
;; all types are Type?
(define-struct/printer Type (seq key) (lambda (a b c) ((unbox print-type*) a b c)))
(define-struct/printer Effect (seq key) (lambda (a b c) ((unbox print-effect*) a b c)))
;; type/effect definition macro
(define-for-syntax type-rec-id #'type-rec-id)
(define-for-syntax effect-rec-id #'effect-rec-id)
(define-for-syntax fold-target #'fold-target)
(provide (for-syntax type-rec-id effect-rec-id fold-target))
(define-for-syntax (mk par ht-stx key?)
(define-syntax-class opt-cnt-id
#:attributes (i cnt)
(pattern i:id
#:with cnt #'any/c)
(pattern [i:id cnt]))
(define-syntax-class no-provide-kw
(pattern #:no-provide))
(define-syntax-class idlist
#:attributes ((i 1) (cnt 1) fs)
(pattern (oci:opt-cnt-id ...)
#:with (i ...) #'(oci.i ...)
#:with (cnt ...) #'(oci.cnt ...)
#:with fs #'(i ...)))
(define (combiner f flds)
(syntax-parse flds
[() #'empty-hash-table]
[(e) #`(#,f e)]
[(e ...) #`(combine-frees (list (#,f e) ...))]))
(define-syntax-class frees-pat
#:transparent
#:attributes (f1 f2 def)
(pattern (f1:expr f2:expr)
#:with def #'(begin))
(pattern (#f)
#:with f1 #'empty-hash-table
#:with f2 #'empty-hash-table
#:with def #'(begin))
(pattern (e:expr)
#:with id (generate-temporary)
#:with def #'(define id e)
#:with f1 #'(id free-vars*)
#:with f2 #'(id free-idxs*)))
(define-syntax-class fold-pat
#:transparent
#:attributes (e)
(pattern #:base
#:with e fold-target)
(pattern ex:expr
#:with e #'#'ex))
(lambda (stx)
(syntax-parse stx
[(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt
[[#:intern intern?:expr]] #:opt
[[#:frees . frees:frees-pat]] #:opt
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
[[#:contract cnt:expr]] #:opt
[no-provide?:no-provide-kw] #:opt) ...)
(with-syntax*
([ex (mk-id #'nm #'nm ":")]
[fold-name (mk-id #f #'nm "-fold")]
[kw-stx (string->keyword (symbol->string #'nm.datum))]
[parent par]
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
[*maker (mk-id #'nm "*" #'nm)]
[**maker (mk-id #'nm "**" #'nm)]
[*maker-cnt (if enable-contracts?
(or #'cnt #'(flds.cnt ... . -> . pred))
#'any/c)]
[ht-stx ht-stx]
[bfs-fold-rhs (cond [#'fold-rhs #`(procedure-rename
(lambda () #,#'fold-rhs.e)
'fold-name)]
;; otherwise we assume that everything is a type,
;; and recur on all the arguments
[else #'(procedure-rename
(lambda ()
#`(*maker (#,type-rec-id flds.i) ...))
'fold-name)])]
[provides (if #'no-provide?
#'(begin)
#`(begin
(provide #;nm ex pred acc ...)
(p/c (rename *maker maker *maker-cnt))))]
[intern
(let ([mk (lambda (int)
(if key?
#`(defintern (**maker . flds.fs) maker #,int #:extra-arg key-expr)
#`(defintern (**maker . flds.fs) maker #,int)))])
(syntax-parse #'flds.fs
[_ #:when #'intern?
(mk #'intern?)]
[() (mk #'#f)]
[(f) (mk #'f)]
[_ (mk #'(list . flds.fs))]))]
[(ign-pats ...) (if key? #'(_ _) #'(_))]
[frees-def (if #'frees #'frees.def #'(begin))]
[frees
(with-syntax ([(f1 f2) (if #'frees
#'(frees.f1 frees.f2)
(list (combiner #'free-vars* #'flds.fs)
(combiner #'free-idxs* #'flds.fs)))])
(quasisyntax/loc stx
(w/c nm ([*maker *maker-cnt])
(define (*maker . flds.fs)
(define v (**maker . flds.fs))
frees-def
(unless-in-table
var-table v
(define fvs f1)
(define fis f2)
(hash-set! var-table v fvs)
(hash-set! index-table v fis))
v))))])
#`(begin
(define-struct (nm parent) flds.fs #:inspector #f)
(define-match-expander ex
(lambda (s)
(syntax-parse s
[(_ . fs)
#:with pat (syntax/loc s (ign-pats ... . fs))
(syntax/loc s (struct nm pat))])))
(begin-for-syntax
(hash-set! ht-stx 'kw-stx (list #'ex #'flds.fs bfs-fold-rhs #'#,stx)))
intern
provides
frees))])))
(define-syntaxes (dt de)
(let ()
(define-syntax-class no-provide-kw
(pattern #:no-provide))
(define-syntax-class idlist
(pattern (i:id ...)))
(define (combiner f flds)
(syntax-parse flds
[() #'empty-hash-table]
[(e) #`(#,f e)]
[(e ...) #`(combine-frees (list (#,f e) ...))]))
(define-syntax-class frees-pat
#:transparent
#:attributes (f1 f2)
(pattern (f1:expr f2:expr))
(pattern (#f)
#:with f1 #'empty-hash-table
#:with f2 #'empty-hash-table))
(define-syntax-class fold-pat
#:transparent
#:attributes (e)
(pattern #:base
#:with e fold-target)
(pattern ex:expr
#:with e #'#'ex))
(define (mk par ht-stx)
(lambda (stx)
(syntax-parse stx
[(dform nm:id flds:idlist (~or [[#:key key-expr:expr]] #:opt
[[#:intern intern?:expr]] #:opt
[[#:frees . frees:frees-pat]] #:opt
[[#:fold-rhs fold-rhs:fold-pat]] #:opt
[no-provide?:no-provide-kw] #:opt) ...)
(with-syntax*
([ex (mk-id #'nm #'nm ":")]
[kw-stx (string->keyword (symbol->string #'nm.datum))]
[parent par]
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds) #f #t #'nm)]
[*maker (mk-id #'nm "*" #'nm)]
[**maker (mk-id #'nm "**" #'nm)]
[ht-stx ht-stx]
[bfs-fold-rhs (cond [#'fold-rhs #`(lambda (tr er) #,#'fold-rhs.e)]
[else #'(lambda (type-rec-id effect-rec-id)
#`(*maker (#,type-rec-id flds.i) ...))])]
[provides (if #'no-provide?
#'(begin)
#`(begin
(provide ex pred acc ...)
(provide (rename-out [*maker maker]))))]
[intern
(let ([mk (lambda (int) #`(defintern (**maker . flds) maker #,int #:extra-arg key-expr))])
(syntax-parse #'flds
[_ #:when #'intern?
(mk #'intern?)]
[() (mk #'#f)]
[(f) (mk #'f)]
[_ (mk #'(list . flds))]))]
[frees
(with-syntax ([(f1 f2) (if #'frees
#'(frees.f1 frees.f2)
(list (combiner #'free-vars* #'flds)
(combiner #'free-idxs* #'flds)))])
(quasisyntax/loc stx
(define (*maker . flds)
(define v (**maker . flds))
(unless-in-table
var-table v
(define fvs f1)
(define fis f2)
(hash-set! var-table v fvs)
(hash-set! index-table v fis))
v)))])
#`(begin
(define-struct (nm parent) flds #:inspector #f)
(define-match-expander ex
(lambda (s)
(syntax-parse s
[(_ . fs)
#:with pat (syntax/loc s (_ _ . fs))
(syntax/loc s (struct nm pat))])))
(begin-for-syntax
(hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
intern
provides
frees))])))
(values (mk #'Type #'type-name-ht) (mk #'Effect #'effect-name-ht))))
(define-for-syntax (mk-fold ht type-rec-id rec-ids kws)
(lambda (stx)
(define new-ht (hash-copy ht))
(define (mk-matcher kw)
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
(define/contract (put k lst)
(keyword? (list/c syntax?
syntax?
(-> syntax?)
syntax?)
. -> . void?)
(hash-set! new-ht k lst))
(define (add-clause cl)
(syntax-parse cl
[(kw:keyword #:matcher mtch pats ... expr)
(put (syntax-e #'kw) (list #'mtch
(syntax/loc cl (pats ...))
(lambda () #'expr)
cl))]
[(kw:keyword pats ... expr)
(put (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw))
(syntax/loc cl (pats ...))
(lambda () #'expr)
cl))]))
(define-syntax-class clause
(pattern
(k:keyword #:matcher mtch pats ... e:expr)
#:with kw #'k.datum
#:with val (list #'mtch
(syntax/loc this-syntax (pats ...))
(lambda () #'e)
this-syntax))
(pattern
(k:keyword pats ... e:expr)
#:with kw (syntax-e #'k)
#:with val (list (mk-matcher #'kw)
(syntax/loc this-syntax (pats ...))
(lambda () #'e)
this-syntax)))
(define (gen-clause k v)
(match v
[(list match-ex pats body-f src)
(let ([pat (quasisyntax/loc src (#,match-ex . #,pats))])
(quasisyntax/loc src (#,pat #,(body-f))))]))
(define-syntax-class (keyword-in kws)
#:attributes (datum)
(pattern k:keyword
#:when (memq #'k.datum kws)
#:with datum #'k.datum))
(define-syntax-class (sized-list kws)
#:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
(pattern ((~or [k e:expr]) ...)
#:declare k (keyword-in kws)
#:when (equal? (length (attribute k.datum)) (length (remove-duplicates (attribute k.datum))))
#:with mapping (for/hash ([k* (attribute k.datum)]
[e* (attribute e)])
(values k* e*))
))
(syntax-parse stx
[(tc recs ty clauses:clause ...)
#:declare recs (sized-list kws)
(begin
(for ([k (attribute clauses.kw)]
[v (attribute clauses.val)])
(put k v))
(with-syntax ([(let-clauses ...)
(for/list ([rec-id rec-ids]
[k kws])
#`[#,rec-id #,(hash-ref (attribute recs.mapping) k
#'values)])])
#`(let (let-clauses ...
[#,fold-target ty])
;; then generate the fold
#,(quasisyntax/loc stx
(match #,fold-target
#,@(hash-map new-ht gen-clause))))))])))
(define-syntax (make-prim-type stx)
(define default-flds #'(seq))
(define-syntax-class type-name-base
#:attributes (i lower-s first-letter key? (fld-names 1))
#:transparent
(pattern i:id
#:with lower-s (string-downcase (symbol->string #'i.datum))
#:with (fld-names ...) default-flds
#:with key? #'#f
#:with first-letter (string-ref #'lower-s 0))
(pattern [i:id #:d d-name:id]
#:with (fld-names ...) default-flds
#:with lower-s (string-downcase (symbol->string #'i.datum))
#:with key? #'#f
#:with first-letter (symbol->string #'d-name.datum))
(pattern [i:id #:key]
#:with (fld-names ...) (datum->syntax #f (append (syntax->list default-flds)
(syntax->list #'(key))))
#:with lower-s (string-downcase (symbol->string #'i.datum))
#:with key? #'#t
#:with first-letter (string-ref #'lower-s 0)))
(define-syntax-class type-name
#:transparent
(pattern :type-name-base
#:with name #'i
#:with keyword (string->keyword (symbol->string (syntax-e #'i)))
#:with tmp-rec-id (generate-temporary)
#:with case (mk-id #'i #'lower-s "-case")
#:with printer (mk-id #'i "print-" #'lower-s "*")
#:with ht (mk-id #'i #'lower-s "-name-ht")
#:with rec-id (mk-id #'i #'lower-s "-rec-id")
#:with d-id (mk-id #'i "d" #'first-letter)
#:with (_ _ pred? accs ...)
(datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name))))
(syntax-parse stx
[(_ i:type-name ...)
(with-syntax* ([(fresh-ids ...) (generate-temporaries #'(i.name ...))]
[(default-ids ...) (generate-temporaries #'(i.name ...))]
[fresh-ids-list #'(fresh-ids ...)]
[(anys ...) (for/list ([i (syntax->list #'fresh-ids-list)]) #'any/c)])
#'(begin
(provide i.d-id ... i.printer ... i.name ... i.pred? ... i.accs ... ...
(for-syntax i.ht ... i.rec-id ...))
(define-syntax i.d-id (mk #'i.name #'i.ht i.key?)) ...
(define-for-syntax i.ht (make-hasheq)) ...
(define-struct/printer i.name (i.fld-names ...) (lambda (a b c) ((unbox i.printer) a b c))) ...
(define-for-syntax i.rec-id #'i.rec-id) ...
(provide i.case ...)
(define-syntaxes (i.case ...)
(let ()
(apply values
(map (lambda (ht)
(mk-fold ht
(car (list #'i.rec-id ...))
(list #'i.rec-id ...)
'(i.keyword ...)))
(list i.ht ...)))))))]))
(make-prim-type [Type #:key]
Filter
[LatentFilter #:d lf]
Object
[LatentObject #:d lo]
[PathElem #:d pe])

382
collects/typed-scheme/rep/type-rep.ss
View File

@ -2,37 +2,61 @@
(require "../utils/utils.ss")
(require (utils tc-utils)
"rep-utils.ss" "effect-rep.ss" "free-variance.ss"
"rep-utils.ss" "object-rep.ss" "filter-rep.ss" "free-variance.ss"
mzlib/trace scheme/match
scheme/contract
stxclass/util
(for-syntax scheme/base))
(define name-table (make-weak-hasheq))
(define Type/c?
(λ (e)
(and (Type? e)
(not (Scope? e))
(not (arr? e))
(not (Values? e))
(not (ValuesDots? e))
(not (Result? e)))))
(define Type/c
(flat-named-contract 'Type Type/c?))
;; Name = Symbol
;; Type is defined in rep-utils.ss
;; t must be a Type
(dt Scope (t) [#:key (Type-key t)])
(dt Scope ([t (or/c Type/c Scope?)]) [#:key (Type-key t)])
(define (scope-depth k)
(flat-named-contract
(format "Scope of depth ~a" k)
(lambda (sc)
(define (f k sc)
(cond [(= 0 k) (Type/c? sc)]
[(not (Scope? sc)) #f]
[else (f (sub1 k) (Scope-t sc))]))
(f k sc))))
;; this is ONLY used when a type error ocurrs
(dt Error () [#:frees #f] [#:fold-rhs #:base])
;; i is an nat
(dt B (i)
(dt B ([i natural-number/c])
[#:frees empty-hash-table (make-immutable-hasheq (list (cons i Covariant)))]
[#:fold-rhs #:base])
;; n is a Name
(dt F (n) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base])
(dt F ([n symbol?]) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base])
;; id is an Identifier
(dt Name (id) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base])
(dt Name ([id identifier?]) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base])
;; rator is a type
;; rands is a list of types
;; stx is the syntax of the pair of parens
(dt App (rator rands stx)
(dt App ([rator Type/c] [rands (listof Type/c)] [stx (or/c #f syntax?)])
[#:intern (list rator rands)]
[#:frees (combine-frees (map free-vars* (cons rator rands)))
(combine-frees (map free-idxs* (cons rator rands)))]
@ -41,19 +65,19 @@
stx)])
;; left and right are Types
(dt Pair (left right) [#:key 'pair])
(dt Pair ([left Type/c] [right Type/c]) [#:key 'pair])
;; elem is a Type
(dt Vector (elem)
(dt Vector ([elem Type/c])
[#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]
[#:key 'vector])
;; elem is a Type
(dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]
(dt Box ([elem Type/c]) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))]
[#:key 'box])
;; name is a Symbol (not a Name)
(dt Base (name contract) [#:frees #f] [#:fold-rhs #:base] [#:intern name]
(dt Base ([name symbol?] [contract syntax?]) [#:frees #f] [#:fold-rhs #:base] [#:intern name]
[#:key (case name
[(Number Integer) 'number]
[(Boolean) 'boolean]
@ -63,13 +87,17 @@
[else #f])])
;; body is a Scope
(dt Mu (body) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))]
(dt Mu ([body (scope-depth 1)]) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))]
[#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))]
[#:key (Type-key body)])
;; n is how many variables are bound here
;; body is a Scope
(dt Poly (n body) #:no-provide
[#:contract (->d ([n natural-number/c]
[body (scope-depth n)])
()
[result Poly?])]
[#:frees (free-vars* body) (without-below n (free-idxs* body))]
[#:fold-rhs (let ([body* (remove-scopes n body)])
(*Poly n (add-scopes n (type-rec-id body*))))]
@ -79,6 +107,10 @@
;; there are n-1 'normal' vars and 1 ... var
;; body is a Scope
(dt PolyDots (n body) #:no-provide
[#:contract (->d ([n natural-number/c]
[body (scope-depth n)])
()
[result PolyDots?])]
[#:key (Type-key body)]
[#:frees (free-vars* body) (without-below n (free-idxs* body))]
[#:fold-rhs (let ([body* (remove-scopes n body)])
@ -86,7 +118,77 @@
;; pred : identifier
;; cert : syntax certifier
(dt Opaque (pred cert) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred])
(dt Opaque ([pred identifier?] [cert procedure?])
[#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred])
;; kw : keyword?
;; ty : Type
;; required? : Boolean
(dt Keyword ([kw keyword?] [ty Type/c] [required? boolean?])
[#:frees (λ (f) (f ty))]
[#:fold-rhs (*Keyword kw (type-rec-id ty) required?)])
(dt Result ([t Type/c] [f LFilterSet?] [o LatentObject?])
[#:frees (λ (frees) (combine-frees (map frees (list t f o))))]
[#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id o))])
;; types : Listof[Type]
(dt Values ([rs (listof Result?)])
[#:frees (λ (f) (combine-frees (map f rs)))]
[#:fold-rhs (*Values (map type-rec-id rs))])
(dt ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)])
[#:frees (λ (f) (combine-frees (map f (cons dty rs))))]
[#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)])
;; arr is NOT a Type
(dt arr ([dom (listof Type/c)]
[rng (or/c Values? ValuesDots?)]
[rest (or/c #f Type/c)]
[drest (or/c #f (cons/c Type/c (or/c natural-number/c symbol?)))]
[kws (listof Keyword?)])
[#:frees (combine-frees
(append (map (compose flip-variances free-vars*)
(append (if rest (list rest) null)
(map Keyword-ty kws)
dom))
(match drest
[(cons t (? symbol? bnd))
(list (fix-bound (flip-variances (free-vars* t)) bnd))]
[(cons t (? number? bnd))
(list (flip-variances (free-vars* t)))]
[#f null])
(list (free-vars* rng))))
(combine-frees
(append (map (compose flip-variances free-idxs*)
(append (if rest (list rest) null)
(map Keyword-ty kws)
dom))
(match drest
[(cons t (? symbol? bnd))
(list (flip-variances (free-idxs* t)))]
[(cons t (? number? bnd))
(list (fix-bound (flip-variances (free-idxs* t)) bnd))]
[#f null])
(list (free-idxs* rng))))]
[#:fold-rhs (*arr (map type-rec-id dom)
(type-rec-id rng)
(and rest (type-rec-id rest))
(and drest (cons (type-rec-id (car drest)) (cdr drest)))
(map type-rec-id kws))])
;; top-arr is the supertype of all function types
(dt top-arr () [#:fold-rhs #:base])
(define arr/c (or/c top-arr? arr?))
;; arities : Listof[arr]
(dt Function ([arities (listof arr/c)])
[#:key 'procedure]
[#:frees (combine-frees (map free-vars* arities))
(combine-frees (map free-idxs* arities))]
[#:fold-rhs (*Function (map type-rec-id arities))])
;; name : symbol
;; parent : Struct
@ -95,7 +197,13 @@
;; poly? : is this a polymorphic type?
;; pred-id : identifier for the predicate of the struct
;; cert : syntax certifier for pred-id
(dt Struct (name parent flds proc poly? pred-id cert)
(dt Struct ([name symbol?]
[parent (or/c #f Struct? Name?)]
[flds (listof Type/c)]
[proc (or/c #f Function?)]
[poly? boolean?]
[pred-id identifier?]
[cert procedure?])
[#:intern (list name parent flds proc)]
[#:frees (combine-frees (map free-vars* (append (if proc (list proc) null) (if parent (list parent) null) flds)))
(combine-frees (map free-idxs* (append (if proc (list proc) null) (if parent (list parent) null) flds)))]
@ -108,65 +216,6 @@
cert)]
[#:key #f #;(gensym)])
;; kw : keyword?
;; ty : Type
;; required? : Boolean
(dt Keyword (kw ty required?)
[#:frees (free-vars* ty)
(free-idxs* ty)]
[#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]
[#:key 'keyword])
;; dom : Listof[Type]
;; rng : Type
;; rest : Option[Type]
;; drest : Option[Cons[Type,Name or nat]]
;; kws : Listof[Keyword]
;; rest and drest NOT both true
;; thn-eff : Effect
;; els-eff : Effect
;; arr is NOT a Type
(dt arr (dom rng rest drest kws thn-eff els-eff)
[#:key 'procedure]
[#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null)
(map Keyword-ty kws)
dom)))
(match drest
[(cons t (? symbol? bnd))
(list (fix-bound (flip-variances (free-vars* t)) bnd))]
[(cons t bnd) (list (flip-variances (free-vars* t)))]
[_ null])
(list (free-vars* rng))
(map make-invariant
(map free-vars* (append thn-eff els-eff)))))
(combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null)
(map Keyword-ty kws)
dom)))
(match drest
[(cons t (? number? bnd))
(list (fix-bound (flip-variances (free-idxs* t)) bnd))]
[(cons t bnd) (list (flip-variances (free-idxs* t)))]
[_ null])
(list (free-idxs* rng))
(map make-invariant
(map free-idxs* (append thn-eff els-eff)))))]
[#:fold-rhs (*arr (map type-rec-id dom)
(type-rec-id rng)
(and rest (type-rec-id rest))
(and drest (cons (type-rec-id (car drest)) (cdr drest)))
(for/list ([kw kws])
(cons (Keyword-kw kw) (type-rec-id (Keyword-ty kw)) (Keyword-require? kw)))
(map effect-rec-id thn-eff)
(map effect-rec-id els-eff))])
;; top-arr is the supertype of all function types
(dt top-arr ()
[#:frees #f] [#:fold-rhs #:base])
;; arities : Listof[arr]
(dt Function (arities) [#:frees (combine-frees (map free-vars* arities))
(combine-frees (map free-idxs* arities))]
[#:fold-rhs (*Function (map type-rec-id arities))])
;; v : Scheme Value
(dt Value (v) [#:frees #f] [#:fold-rhs #:base] [#:key (cond [(number? v) 'number]
@ -175,8 +224,20 @@
[else #f])])
;; elems : Listof[Type]
(dt Union (elems) [#:frees (combine-frees (map free-vars* elems))
(combine-frees (map free-idxs* elems))]
(dt Union ([elems (and/c (listof Type/c)
(lambda (es)
(let-values ([(sorted? k)
(for/fold ([sorted? #t]
[last -1])
([e es])
(let ([seq (Type-seq e)])
(values
(and sorted?
(< last seq))
seq)))])
sorted?)))])
[#:frees (combine-frees (map free-vars* elems))
(combine-frees (map free-idxs* elems))]
[#:fold-rhs ((get-union-maker) (map type-rec-id elems))]
[#:key (let loop ([res null] [ts elems])
(if (null? ts) res
@ -187,27 +248,13 @@
(dt Univ () [#:frees #f] [#:fold-rhs #:base])
;; types : Listof[Type]
(dt Values (types)
#:no-provide
[#:frees (combine-frees (map free-vars* types))
(combine-frees (map free-idxs* types))]
[#:fold-rhs (*Values (map type-rec-id types))]
[#:key 'values])
(dt ValuesDots (types dty dbound)
[#:frees (combine-frees (map free-vars* (cons dty types)))
(combine-frees (map free-idxs* (cons dty types)))]
[#:fold-rhs (*ValuesDots (map type-rec-id types) (type-rec-id dty) dbound)]
[#:key 'values])
;; in : Type
;; out : Type
(dt Param (in out) [#:key 'parameter])
(dt Param ([in Type/c] [out Type/c]) [#:key 'parameter])
;; key : Type
;; value : Type
(dt Hashtable (key value) [#:key 'hash])
(dt Hashtable ([key Type/c] [value Type/c]) [#:key 'hash])
;; parent : Type
;; pred : Identifier
@ -221,12 +268,14 @@
;; t : Type
(dt Syntax (t) [#:key 'syntax])
(dt Syntax ([t Type/c]) [#:key 'syntax])
;; pos-flds : (Listof Type)
;; name-flds : (Listof (Tuple Symbol Type Boolean))
;; methods : (Listof (Tuple Symbol Function))
(dt Class (pos-flds name-flds methods)
(dt Class ([pos-flds (listof Type/c)]
[name-flds (listof (list/c symbol? Type/c boolean?))]
[methods (listof (list/c symbol? Function?))])
[#:frees (combine-frees
(map free-vars* (append pos-flds
(map cadr name-flds)
@ -249,7 +298,7 @@
(map list mname (map type-rec-id mty)))])])
;; cls : Class
(dt Instance (cls) [#:key 'instance])
(dt Instance ([cls Type/c]) [#:key 'instance])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -274,65 +323,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type/effect fold
(define-syntaxes (type-case effect-case)
(let ()
(define (mk ht)
(lambda (stx)
(let ([ht (hash-copy ht)])
(define (mk-matcher kw)
(datum->syntax stx (string->symbol (string-append (keyword->string kw) ":"))))
(define (add-clause cl)
(syntax-case cl ()
[(kw #:matcher mtch pats ... expr)
(hash-set! ht (syntax-e #'kw) (list #'mtch
(syntax/loc cl (pats ...))
(lambda (tr er) #'expr)
cl))]
[(kw pats ... expr)
(hash-set! ht (syntax-e #'kw) (list (mk-matcher (syntax-e #'kw))
(syntax/loc cl (pats ...))
(lambda (tr er) #'expr)
cl))]))
(define rid #'type-rec-id)
(define erid #'effect-rec-id)
(define (gen-clause k v)
(define match-ex (car v))
(define pats (cadr v))
(define body-f (caddr v))
(define src (cadddr v))
(define pat (quasisyntax/loc src (#,match-ex . #,pats)))
(define cl (quasisyntax/loc src (#,pat #,(body-f rid erid))))
cl)
(syntax-case stx ()
[(tc rec-id ty clauses ...)
(syntax-case #'(clauses ...) ()
[([kw pats ... es] ...) #t]
[_ #f])
(syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))]
[(tc rec-id e-rec-id ty clauses ...)
(begin
(map add-clause (syntax->list #'(clauses ...)))
(with-syntax ([old-rec-id type-rec-id])
#`(let ([#,rid rec-id]
[#,erid e-rec-id]
[#,fold-target ty])
;; then generate the fold
#,(quasisyntax/loc stx
(match #,fold-target
#,@(hash-map ht gen-clause))))))]))))
(values (mk type-name-ht) (mk effect-name-ht))))
(provide type-case effect-case)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sub-eff : (Type -> Type) Eff -> Eff
(define (sub-eff sb eff)
(effect-case sb eff))
(define (add-scopes n t)
(if (zero? n) t
(add-scopes (sub1 n) (*Scope t))))
@ -344,19 +336,50 @@
[(Scope: sc*) (remove-scopes (sub1 n) sc*)]
[_ (int-err "Tried to remove too many scopes: ~a" sc)])))
;; type equality
(define type-equal? eq?)
;; inequality - good
(define (type<? s t)
(< (Type-seq s) (Type-seq t)))
(define (type-compare s t)
(cond [(eq? s t) 0]
[(type<? s t) 1]
[else -1]))
(define ((sub-lf st) e)
(latentfilter-case (#:Type st
#:LatentFilter (sub-lf st))
e))
(define ((sub-lo st) e)
(latentobject-case (#:Type st
#:LatentObject (sub-lo st)
#:PathElem (sub-pe st))
e))
(define ((sub-pe st) e)
(pathelem-case (#:Type st
#:PathElem (sub-pe st))
e))
;; abstract-many : Names Type -> Scope^n
;; where n is the length of names
(define (abstract-many names ty)
(define (nameTo name count type)
(let loop ([outer 0] [ty type])
(define (sb t) (loop outer t))
(define slf (sub-lf sb))
(type-case
sb ty
(#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb))
ty
[#:F name* (if (eq? name name*) (*B (+ count outer)) ty)]
;; necessary to avoid infinite loops
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
;; functions
[#:arr dom rng rest drest kws thn-eff els-eff
[#:arr dom rng rest drest kws
(*arr (map sb dom)
(sb rng)
(if rest (sb rest) #f)
@ -364,11 +387,9 @@
(cons (sb (car drest))
(if (eq? (cdr drest) name) (+ count outer) (cdr drest)))
#f)
(map sb kws)
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))]
[#:ValuesDots tys dty dbound
(*ValuesDots (map sb tys)
(map sb kws))]
[#:ValuesDots rs dty dbound
(*ValuesDots (map sb rs)
(sb dty)
(if (eq? dbound name) (+ count outer) dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
@ -392,16 +413,18 @@
(define (instantiate-many images sc)
(define (replace image count type)
(let loop ([outer 0] [ty type])
(define (sb t) (loop outer t))
(define (sb t) (loop outer t))
(define slf (sub-lf sb))
(type-case
sb ty
(#:Type sb #:LatentFilter slf #:LatentObject (sub-lo sb))
ty
[#:B idx (if (= (+ count outer) idx)
image
ty)]
;; necessary to avoid infinite loops
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
;; functions
[#:arr dom rng rest drest kws thn-eff els-eff
[#:arr dom rng rest drest kws
(*arr (map sb dom)
(sb rng)
(if rest (sb rest) #f)
@ -409,12 +432,10 @@
(cons (sb (car drest))
(if (eqv? (cdr drest) (+ count outer)) (F-n image) (cdr drest)))
#f)
(map sb kws)
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))]
[#:ValuesDots tys dty dbound
(*ValuesDots (map sb tys)
(sb dty)
(map sb kws))]
[#:ValuesDots rs dty dbound
(*ValuesDots (map sb rs)
(sb dty)
(if (eqv? dbound (+ count outer)) (F-n image) dbound))]
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
[#:PolyDots n body*
@ -566,43 +587,25 @@
(list syms (PolyDots-body* syms t))))
(list nps bp)))])))
;; type equality
(define type-equal? eq?)
;; inequality - good
(define (type<? s t)
(< (Type-seq s) (Type-seq t)))
(define (type-compare s t)
(cond [(eq? s t) 0]
[(type<? s t) 1]
[else -1]))
(define (Values* l)
(if (and (pair? l) (null? (cdr l)))
(car l)
(*Values l)))
;(trace subst subst-all)
(provide
Mu-name: Poly-names:
PolyDots-names:
Type-seq Effect-seq
Type-seq
Mu-unsafe: Poly-unsafe:
PolyDots-unsafe:
Mu? Poly? PolyDots?
arr
Type? Effect?
Type? Filter? LatentFilter? Object? LatentObject?
Type/c
Poly-n
PolyDots-n
free-vars*
type-equal? type-compare type<?
remove-dups
sub-eff
Values: Values? Values-types
(rename-out [Values* make-Values])
sub-lf sub-lo sub-pe
Values: Values? Values-rs
(rename-out [Mu:* Mu:]
[Poly:* Poly:]
[PolyDots:* PolyDots:]
@ -614,4 +617,3 @@
[PolyDots-body* PolyDots-body]))
;(trace unfold)

10
collects/typed-scheme/typecheck/check-subforms-unit.ss
View File

@ -3,8 +3,8 @@
(require (except-in "../utils/utils.ss" extend))
(require syntax/kerncase
scheme/match
"signatures.ss"
(private type-utils type-effect-convenience union subtype)
"signatures.ss" "tc-metafunctions.ss"
(types utils convenience union subtype)
(utils tc-utils)
(rep type-rep))
@ -18,7 +18,7 @@
(define body-ty #f)
(define (get-result-ty t)
(match t
[(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)]
[(Function: (list (arr: _ (Values: (list (Result: rngs _ _))) #f _ '()) ...)) (apply Un rngs)]
[_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)]))
(let loop ([form form])
(parameterize ([current-orig-stx form])
@ -61,7 +61,7 @@
[stx
;; this is a hander function
(syntax-property form 'typechecker:exn-handler)
(tc-expr/check form (-> (Un) expected))]
(tc-expr/check form (ret (-> (Un) (tc-results->values expected))))]
[stx
;; this is the body of the with-handlers
(syntax-property form 'typechecker:exn-body)
@ -71,7 +71,7 @@
(loop #'a)
(loop #'b))]
[_ (void)])))
(ret expected))
expected)
;; typecheck the expansion of a with-handlers form
;; syntax -> any

21
collects/typed-scheme/typecheck/defstruct-unit.ss
View File

@ -1,21 +0,0 @@
#lang scheme/base
(require mzlib/struct mzlib/unit)
(provide #;(all-defined))
(define-syntax defstructs/sig/unit
(syntax-rules (define-struct/properties)
[(_ signame unitname (imps ...)
def
(define-struct/properties nm1 (flds1 ...) props #f)
(define-struct/properties (nm par) (flds ...) () #f) ...)
(begin
(define-signature signame
((struct nm1 (flds1 ...))
(struct nm (flds ...)) ...))
(define-unit unitname
(import imps ...)
(export signame)
def
(define-struct/properties nm1 (flds1 ...) props #f)
(define-struct (nm par) (flds ...) #f) ...))]))

65
collects/typed-scheme/typecheck/find-annotation.ss Normal file
View File

@ -0,0 +1,65 @@
#lang scheme/base
(require "../utils/utils.ss" stxclass
scheme/contract
(rep type-rep)
(private type-annotation))
(p/c [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))])
(define-syntax-class lv-clause
#:transparent
(pattern [(v:id ...) e:expr]))
(define-syntax-class lv-clauses
#:transparent
(pattern (cl:lv-clause ...)
#:with (e ...) #'(cl.e ...)
#:with (vs ...) #'((cl.v ...) ...)))
(define-syntax-class core-expr
#:literals (reverse letrec-syntaxes+values let-values #%plain-app
if letrec-values begin #%plain-lambda set! case-lambda
begin0 with-continuation-mark)
#:transparent
(pattern (let-values cls:lv-clauses body)
#:with (expr ...) #'(cls.e ... body))
(pattern (letrec-values cls:lv-clauses body)
#:with (expr ...) #'(cls.e ... body))
(pattern (letrec-syntaxes+values _ cls:lv-clauses body)
#:with (expr ...) #'(cls.e ... body))
(pattern (#%plain-app expr ...))
(pattern (if expr ...))
(pattern (with-continuation-mark expr ...))
(pattern (begin expr ...))
(pattern (begin0 expr ...))
(pattern (#%plain-lambda _ e)
#:with (expr ...) #'(e))
(pattern (case-lambda [_ expr] ...))
(pattern (set! _ e)
#:with (expr ...) #'(e))
(pattern _
#:with (expr ...) #'()))
;; expr id -> type or #f
;; if there is a binding in stx of the form:
;; (let ([x (reverse name)]) e)
;; where x has a type annotation, return that annotation, otherwise #f
(define (find-annotation stx name)
(define (find s) (find-annotation s name))
(define (match? b)
(syntax-parse b
#:literals (#%plain-app reverse)
[c:lv-clause
#:with (#%plain-app reverse n:id) #'c.e
#:with (v) #'(c.v ...)
#:when (free-identifier=? name #'n)
(type-annotation #'v)]
[_ #f]))
(syntax-parse stx
#:literals (let-values)
[(let-values cls:lv-clauses body)
(or (ormap match? (syntax->list #'cls))
(find #'body))]
[e:core-expr
(ormap find (syntax->list #'(e.expr ...)))]))

50
collects/typed-scheme/typecheck/signatures.ss
View File

@ -1,8 +1,9 @@
#lang scheme/base
(require scheme/unit scheme/contract "../utils/utils.ss")
(require (rep type-rep)
(require scheme/unit scheme/contract
"../utils/utils.ss"
(rep type-rep)
(utils unit-utils)
(private type-utils))
(types utils))
(provide (all-defined-out))
(define-signature typechecker^
@ -10,40 +11,39 @@
[cnt tc-toplevel-form (syntax? . -> . any)]))
(define-signature tc-expr^
([cnt tc-expr (syntax? . -> . tc-result?)]
[cnt tc-expr/check (syntax? Type? . -> . tc-result?)]
[cnt tc-expr/check/t (syntax? Type? . -> . Type?)]
[cnt check-below (->d ([s (or/c Type? tc-result?)] [t Type?]) () [_ (if (Type? s) Type? tc-result?)])]
[cnt tc-literal (any/c . -> . Type?)]
[cnt tc-exprs ((listof syntax?) . -> . tc-result?)]
[cnt tc-exprs/check ((listof syntax?) Type? . -> . tc-result?)]
[cnt tc-expr/t (syntax? . -> . Type?)]))
([cnt tc-expr (syntax? . -> . tc-results?)]
[cnt tc-literal (->* (syntax?) ((or/c #f Type/c)) Type/c)]
[cnt tc-expr/check (syntax? tc-results? . -> . tc-results?)]
[cnt tc-expr/check/t (syntax? tc-results? . -> . Type/c)]
[cnt check-below (->d ([s (or/c Type/c tc-results?)] [t (or/c Type/c tc-results?)]) () [_ (if (Type? s) Type/c tc-results?)])]
[cnt tc-exprs ((listof syntax?) . -> . tc-results?)]
[cnt tc-exprs/check ((listof syntax?) tc-results? . -> . tc-results?)]
[cnt tc-expr/t (syntax? . -> . Type/c)]
[cnt single-value ((syntax?) ((or/c tc-results? #f)) . ->* . tc-results?)]))
(define-signature check-subforms^
([cnt check-subforms/ignore (syntax? . -> . any)]
[cnt check-subforms/with-handlers (syntax? . -> . any)]
[cnt check-subforms/with-handlers/check (syntax? Type? . -> . any)]))
[cnt check-subforms/with-handlers/check (syntax? tc-results? . -> . any)]))
(define-signature tc-if^
([cnt tc/if-twoarm (syntax? syntax? syntax? . -> . tc-result?)]
[cnt tc/if-twoarm/check (syntax? syntax? syntax? Type? . -> . tc-result?)]))
([cnt tc/if-twoarm ((syntax? syntax? syntax?) (tc-results?) . ->* . tc-results?)]))
(define-signature tc-lambda^
([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-result?)]
[cnt tc/lambda/check (syntax? syntax? syntax? Type? . -> . tc-result?)]
[cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type?) Type? . -> . Type?)]))
([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-results?)]
[cnt tc/lambda/check (syntax? syntax? syntax? tc-results? . -> . tc-results?)]
[cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) tc-results? . -> . tc-results?)]))
(define-signature tc-app^
([cnt tc/app (syntax? . -> . tc-result?)]
[cnt tc/app/check (syntax? Type? . -> . tc-result?)]
[cnt tc/funapp (syntax? syntax? tc-result? (listof tc-result?) (or/c #f Type?) . -> . tc-result?)]))
([cnt tc/app (syntax? . -> . tc-results?)]
[cnt tc/app/check (syntax? tc-results? . -> . tc-results?)]
[cnt tc/funapp (syntax? syntax? tc-results? (listof tc-results?) (or/c #f tc-results?) . -> . tc-results?)]))
(define-signature tc-let^
([cnt tc/let-values (syntax? syntax? syntax? syntax? . -> . tc-result?)]
[cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-result?)]
[cnt tc/let-values/check (syntax? syntax? syntax? syntax? Type? . -> . tc-result?)]
[cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? Type? . -> . tc-result?)]))
([cnt tc/let-values ((syntax? syntax? syntax? syntax?) ((or/c #f tc-results?)) . ->* . tc-results?)]
[cnt tc/letrec-values (syntax? syntax? syntax? syntax? . -> . tc-results?)]
[cnt tc/letrec-values/check (syntax? syntax? syntax? syntax? tc-results? . -> . tc-results?)]))
(define-signature tc-dots^
([cnt tc/dots (syntax? . -> . (values Type? symbol?))]))
([cnt tc/dots (syntax? . -> . (values Type/c symbol?))]))

68
collects/typed-scheme/typecheck/tc-app-helper.ss Normal file
View File

@ -0,0 +1,68 @@
#lang scheme/base
(require "../utils/utils.ss" scheme/match
(utils tc-utils) (rep type-rep) (types utils union))
(provide (all-defined-out))
(define (make-printable t)
(match t
[(tc-result1: t) t]
[_ t]))
(define (stringify-domain dom rst drst [rng #f])
(let ([doms-string (if (null? dom) "" (string-append (stringify (map make-printable dom)) " "))]
[rng-string (if rng (format " -> ~a" rng) "")])
(cond [drst
(format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)]
[rst
(format "~a~a *~a" doms-string rst rng-string)]
[else (string-append (stringify (map make-printable dom)) rng-string)])))
(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f])
(define arguments-str
(stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))
(cond
[(null? doms)
(int-err "How could doms be null: ~a ~a" ty)]
[(= 1 (length doms))
(format "Domain: ~a~nArguments: ~a~n~a"
(stringify-domain (car doms) (car rests) (car drests))
arguments-str
(if expected
(format "Result type: ~a~nExpected result: ~a~n"
(car rngs) (make-printable expected))
""))]
[else
(format "~a: ~a~nArguments: ~a~n~a"
(if expected "Types" "Domains")
(stringify (if expected
(map stringify-domain (map make-printable doms) rests drests rngs)
(map stringify-domain (map make-printable doms) rests drests))
"~n\t")
arguments-str
(if expected
(format "Expected result: ~a~n" (make-printable expected))
""))]))
(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f])
(match t
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '()) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '()) ...))))
(let ([fcn-string (if name
(format "function ~a" (syntax->datum name))
"function")])
(if (and (andmap null? msg-doms)
(null? argtypes))
(tc-error/expr #:return (ret (Un))
(string-append
"Could not infer types for applying polymorphic "
fcn-string
"\n"))
(tc-error/expr #:return (ret (Un))
(string-append
"Polymorphic " fcn-string " could not be applied to arguments:~n"
(domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected)
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
"")))))]))

834
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

@ -1,834 +0,0 @@
#lang scheme/unit
(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer]))
(require "signatures.ss"
stxclass
(for-syntax stxclass)
(rep type-rep effect-rep)
(utils tc-utils)
(private subtype type-utils union type-effect-convenience type-effect-printer resolve-type
type-annotation)
(r:infer infer)
(env type-environments)
(only-in srfi/1 alist-delete)
(only-in scheme/private/class-internal make-object do-make-object)
mzlib/trace mzlib/pretty syntax/kerncase scheme/match
(prefix-in c: scheme/contract)
(for-syntax scheme/base)
(for-template
(only-in '#%kernel [apply k:apply])
"internal-forms.ss" scheme/base
(only-in scheme/private/class-internal make-object do-make-object)))
(require (r:infer constraint-structs))
(import tc-expr^ tc-lambda^ tc-dots^ tc-let^)
(export tc-app^)
;; comparators that inform the type system
(define (comparator? i)
(or (free-identifier=? i #'eq?)
(free-identifier=? i #'equal?)
(free-identifier=? i #'eqv?)
(free-identifier=? i #'=)
(free-identifier=? i #'string=?)))
;; typecheck eq? applications
;; identifier identifier expression expression expression
;; identifier expr expr expr expr -> tc-result
(define (tc/eq comparator v1 v2)
(define (e? i) (free-identifier=? i comparator))
(define (do id val)
(define-syntax alt (syntax-rules () [(_ nm pred ...)
(and (e? #'nm) (or (pred val) ...))]))
(if (or (alt symbol=? symbol?)
(alt string=? string?)
(alt = number?)
(alt eq? boolean? keyword? symbol?)
(alt eqv? boolean? keyword? symbol? number?)
(alt equal? (lambda (x) #t)))
(values (list (make-Restrict-Effect (-val val) id))
(list (make-Remove-Effect (-val val) id)))
(values (list) (list))))
(match (list (tc-expr v1) (tc-expr v2))
[(list (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2))) (tc-result: (Value: val)))
(do id1 val)]
[(list (tc-result: (Value: val)) (tc-result: id-t (list (Var-True-Effect: id1)) (list (Var-False-Effect: id2))))
(do id1 val)]
[_ (values (list) (list))]))
;; typecheck an application:
;; arg-types: the types of the actual parameters
;; arg-effs: the effects of the arguments
;; dom-types: the types of the function's fixed arguments
;; rest-type: the type of the functions's rest parameter, or #f
;; latent-eff: the latent effect of the function
;; arg-stxs: the syntax for each actual parameter, for error reporting
;; [Type] [Type] Maybe[Type] [Syntax] -> (values Listof[Effect] Listof[Effect])
(define (tc-args arg-types arg-thn-effs arg-els-effs dom-types rest-type latent-thn-eff latent-els-eff arg-stxs)
(define (var-true-effect-v e) (match e
[(Var-True-Effect: v) v]))
(define (var-false-effect-v e) (match e
[(Var-False-Effect: v) v]))
;; special case for predicates:
(if (and (not (null? latent-thn-eff))
(not (null? latent-els-eff))
(not rest-type)
;(printf "got to =~n")
(= (length arg-types) (length dom-types) 1)
;(printf "got to var preds~n")
(= (length (car arg-thn-effs)) (length (car arg-els-effs)) 1)
(Var-True-Effect? (caar arg-thn-effs)) ;; thn-effs is a list for each arg
(Var-False-Effect? (caar arg-els-effs)) ;; same with els-effs
(free-identifier=? (var-true-effect-v (caar arg-thn-effs))
(var-false-effect-v (caar arg-els-effs)))
(subtype (car arg-types) (car dom-types)))
;; then this was a predicate application, so we construct the appropriate type effect
(values (map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-thn-eff)
(map (add-var (var-true-effect-v (caar arg-thn-effs))) latent-els-eff))
;; otherwise, we just ignore the effects.
(let loop ([args arg-types] [doms dom-types] [stxs arg-stxs] [arg-count 1])
(cond
[(and (null? args) (null? doms)) (values null null)] ;; here, we just return the empty effect
[(null? args)
(tc-error/delayed
"Insufficient arguments to function application, expected ~a, got ~a"
(length dom-types) (length arg-types))
(values null null)]
[(and (null? doms) rest-type)
(if (subtype (car args) rest-type)
(loop (cdr args) doms (cdr stxs) (add1 arg-count))
(begin
(tc-error/delayed #:stx (car stxs)
"Rest argument had wrong type, expected: ~a and got: ~a"
rest-type (car args))
(values null null)))]
[(null? doms)
(tc-error/delayed "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types))
(values null null)]
[(subtype (car args) (car doms))
(loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))]
[else
(tc-error/delayed
#:stx (car stxs)
"Wrong function argument type, expected ~a, got ~a for argument ~a"
(car doms) (car args) arg-count)
(loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))]))))
;(trace tc-args)
(define (stringify-domain dom rst drst [rng #f])
(let ([doms-string (if (null? dom) "" (string-append (stringify dom) " "))]
[rng-string (if rng (format " -> ~a" rng) "")])
(cond [drst
(format "~a~a ... ~a~a" doms-string (car drst) (cdr drst) rng-string)]
[rst
(format "~a~a *~a" doms-string rst rng-string)]
[else (string-append (stringify dom) rng-string)])))
(define (domain-mismatches ty doms rests drests rngs arg-tys tail-ty tail-bound #:expected [expected #f])
(define arguments-str
(stringify-domain arg-tys (if (not tail-bound) tail-ty #f) (if tail-bound (cons tail-ty tail-bound) #f)))
(cond
[(null? doms)
(int-err "How could doms be null: ~a ~a" ty)]
[(= 1 (length doms))
(format "Domain: ~a~nArguments: ~a~n~a"
(stringify-domain (car doms) (car rests) (car drests))
arguments-str
(if expected
(format "Result type: ~a~nExpected result: ~a~n"
(car rngs) expected)
""))]
[else
(format "~a: ~a~nArguments: ~a~n~a"
(if expected "Types" "Domains")
(stringify (if expected
(map stringify-domain doms rests drests rngs)
(map stringify-domain doms rests drests))
"~n\t")
arguments-str
(if expected
(format "Expected result: ~a~n" expected)
""))]))
(define (do-apply-log subst fun arg)
(match* (fun arg)
[('star 'list) (printf/log "Polymorphic apply called with uniform rest arg, list argument\n")]
[('star 'dots) (printf/log "Polymorphic apply called with uniform rest arg, dotted argument\n")]
[('dots 'dots) (printf/log "Polymorphic apply called with non-uniform rest arg, dotted argument\n")])
(log-result subst))
(define (tc/apply f args)
(define f-ty (tc-expr f))
;; produces the first n-1 elements of the list, and the last element
(define (split l)
(let loop ([l l] [acc '()])
(if (null? (cdr l))
(values (reverse acc) (car l))
(loop (cdr l) (cons (car l) acc)))))
(define-values (fixed-args tail) (split (syntax->list args)))
(match f-ty
[(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...)))
(when (null? doms)
(tc-error/expr #:return (ret (Un))
"empty case-lambda given as argument to apply"))
(let ([arg-tys (map tc-expr/t fixed-args)])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to function in apply:~n"
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))]
[(and (car rests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
(tc/dots tail))])
(and tail-ty
(subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty))
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(printf/log "Non-poly apply, ... arg\n")
(ret (car rngs*))]
[(and (car rests*)
(let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)])
(tc-expr/t tail))])
(and tail-ty
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(printf/log (if (memq (syntax->datum f) '(+ - * / max min))
"Simple arithmetic non-poly apply\n"
"Simple non-poly apply\n"))
(ret (car rngs*))]
[(and (car drests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
(tc/dots tail))])
(and tail-ty
(eq? (cdr (car drests*)) tail-bound)
(subtypes arg-tys (car doms*))
(subtype tail-ty (car (car drests*))))))
(printf/log "Non-poly apply, ... arg\n")
(ret (car rngs*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
#;(for-each (lambda (x) (unless (not (Poly? x))
(tc-error "Polymorphic argument of type ~a to polymorphic function in apply not allowed" x)))
(cons tail-ty arg-tys))
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
;; the actual work, when we have a * function and a list final argument
[(and (car rests*)
(not tail-bound)
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons tail-ty arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution) (ret (subst-all substitution (car rngs*))))]
;; actual work, when we have a * function and ... final arg
[(and (car rests*)
tail-bound
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons (make-Listof tail-ty) arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution) (ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg
[(and (car drests*)
tail-bound
(eq? tail-bound (cdr (car drests*)))
(= (length (car doms*))
(length arg-tys))
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))
=> (lambda (substitution) (ret (subst-all substitution (car rngs*))))]
;; if nothing matches, around the loop again
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result: (Poly: vars (Function: '())))
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
[(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
;; the actual work, when we have a * function and a list final argument
[(and (car rests*)
(not tail-bound)
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons tail-ty arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution)
(do-apply-log substitution 'star 'list)
(ret (subst-all substitution (car rngs*))))]
;; actual work, when we have a * function and ... final arg
[(and (car rests*)
tail-bound
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons (make-Listof tail-ty) arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution)
(do-apply-log substitution 'star 'dots)
(ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg, same bound on ...
[(and (car drests*)
tail-bound
(eq? tail-bound (cdr (car drests*)))
(= (length (car doms*))
(length arg-tys))
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))
=> (lambda (substitution)
(do-apply-log substitution 'dots 'dots)
(ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg, different bound on ...
[(and (car drests*)
tail-bound
(not (eq? tail-bound (cdr (car drests*))))
(= (length (car doms*))
(length arg-tys))
(parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*)))
(list (make-DottedBoth (make-F tail-bound))
(make-DottedBoth (make-F (cdr (car drests*)))))
(current-tvars))])
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))))
=> (lambda (substitution)
(define drest-bound (cdr (car drests*)))
(do-apply-log substitution 'dots 'dots)
(ret (substitute-dotted (cadr (assq drest-bound substitution))
tail-bound
drest-bound
(subst-all (alist-delete drest-bound substitution eq?)
(car rngs*)))))]
;; ... function, (List A B C etc) arg
[(and (car drests*)
(not tail-bound)
(eq? (cdr (car drests*)) dotted-var)
(= (length (car doms*))
(length arg-tys))
(untuple tail-ty)
(infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*)
(car (car drests*)) (car rngs*) (fv (car rngs*))))
=> (lambda (substitution)
(define drest-bound (cdr (car drests*)))
(do-apply-log substitution 'dots 'dots)
(ret (subst-all substitution (car rngs*))))]
;; if nothing matches, around the loop again
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result: (PolyDots: vars (Function: '())))
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
[(tc-result: f-ty) (tc-error/expr #:return (ret (Un))
"Type of argument to apply is not a function type: ~n~a" f-ty)]))
(define (log-result subst)
(define (dmap-length d)
(match d
[(struct dcon (fixed rest)) (length fixed)]
[(struct dcon-exact (fixed rest)) (length fixed)]))
(define (dmap-rest? d)
(match d
[(struct dcon (fixed rest)) rest]
[(struct dcon-exact (fixed rest)) rest]))
(if (list? subst)
(for ([s subst])
(match s
[(list v (list imgs ...) starred)
(printf/log "Instantiated ... variable ~a with ~a types\n" v (length imgs))]
[_ (void)]))
(for* ([(cmap dmap) (in-pairs (cset-maps subst))]
[(k v) (dmap-map dmap)])
(printf/log "Instantiated ... variable ~a with ~a types~a\n" k (dmap-length v)
(if (dmap-rest? v)
" and a starred type"
"")))))
(define-syntax (handle-clauses stx)
(syntax-parse stx
[(_ (lsts ... rngs) f-stx pred infer t argtypes expected)
(with-syntax ([(vars ... rng) (generate-temporaries #'(lsts ... rngs))])
(syntax/loc stx
(or (for/or ([vars lsts] ... [rng rngs]
#:when (pred vars ... rng))
(let ([substitution (infer vars ... rng)])
(and substitution
(log-result substitution)
(ret (or expected
(subst-all substitution rng))))))
(poly-fail t argtypes #:name (and (identifier? f-stx) f-stx) #:expected expected))))]))
(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f])
(match t
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))
(PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))))
(let ([fcn-string (if name
(format "function ~a" (syntax->datum name))
"function")])
(if (and (andmap null? msg-doms)
(null? argtypes))
(tc-error/expr #:return (ret (Un))
(string-append
"Could not infer types for applying polymorphic "
fcn-string
"\n"))
(tc-error/expr #:return (ret (Un))
(string-append
"Polymorphic " fcn-string " could not be applied to arguments:~n"
(domain-mismatches t msg-doms msg-rests msg-drests msg-rngs argtypes #f #f #:expected expected)
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
"")))))]))
(define (tc/funapp f-stx args-stx ftype0 argtys expected)
(match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys])
(let outer-loop ([ftype ftype0]
[argtypes argtypes]
[arg-thn-effs arg-thn-effs]
[arg-els-effs arg-els-effs]
[args args-stx])
(match ftype
;; procedural structs
[(tc-result: (and sty (Struct: _ _ _ (? Type? proc-ty) _ _ _)) thn-eff els-eff)
(outer-loop (ret proc-ty thn-eff els-eff)
(cons (tc-result-t ftype0) argtypes)
(cons (list) arg-thn-effs)
(cons (list) arg-els-effs)
#`(#,(syntax/loc f-stx dummy) #,@args))]
;; mu types, etc
[(tc-result: (? needs-resolving? t) thn-eff els-eff)
(outer-loop (ret (resolve-once t) thn-eff els-eff) argtypes arg-thn-effs arg-els-effs args)]
;; parameters
[(tc-result: (Param: in out))
(match argtypes
[(list) (ret out)]
[(list t)
(if (subtype t in)
(ret -Void)
(tc-error/expr #:return (ret (Un))
"Wrong argument to parameter - expected ~a and got ~a" in t))]
[_ (tc-error/expr #:return (ret (Un))
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtypes))])]
;; single clause functions
;; FIXME - error on non-optional keywords
[(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs))))
thn-eff els-eff)
(let-values ([(thn-eff els-eff)
(tc-args argtypes arg-thn-effs arg-els-effs dom rest
latent-thn-effs latent-els-effs
(syntax->list args))])
(ret rng thn-eff els-eff))]
;; non-polymorphic case-lambda functions
[(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1)))
thn-eff els-eff)
(let loop ([doms* doms] [rngs rngs] [rests* rests])
(cond [(null? doms*)
(tc-error/expr
#:return (ret (Un))
(string-append "No function domains matched in function application:\n"
(domain-mismatches t doms rests drests rngs argtypes #f #f)))]
[(subtypes/varargs argtypes (car doms*) (car rests*))
(when (car rests*)
(printf/log "Simple varargs function application (~a)\n" (syntax->datum f-stx)))
(ret (car rngs))]
[else (loop (cdr doms*) (cdr rngs) (cdr rests*))]))]
;; simple polymorphic functions, no rest arguments
[(tc-result: (and t
(or (Poly: vars
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))
(PolyDots: (list vars ...)
(Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))))))
(handle-clauses (doms rngs) f-stx
(lambda (dom _) (= (length dom) (length argtypes)))
(lambda (dom rng) (infer vars argtypes dom rng (fv rng) expected))
t argtypes expected)]
;; polymorphic varargs
[(tc-result: (and t
(or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))
;; we want to infer the dotted-var here as well, and we don't use these separately
;; so we can just use "vars" instead of (list fixed-vars ... dotted-var)
(PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))))))
(printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms rests rngs) f-stx
(lambda (dom rest rng) (<= (length dom) (length argtypes)))
(lambda (dom rest rng) (infer/vararg vars argtypes dom rest rng (fv rng) expected))
t argtypes expected)]
;; polymorphic ... type
[(tc-result: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...)))))
(printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx))
(handle-clauses (doms dtys dbounds rngs) f-stx
(lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes))
(eq? dotted-var dbound)))
(lambda (dom dty dbound rng)
(infer/dots fixed-vars dotted-var argtypes dom dty rng (fv rng) #:expected expected))
t argtypes expected)]
;; Union of function types works if we can apply all of them
[(tc-result: (Union: (list (and fs (Function: _)) ...)) e1 e2)
(match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop
(ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)])
(ret (apply Un ts)))]
;; error type is a perfectly good fcn type
[(tc-result: (Error:)) (ret (make-Error))]
[(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" f-ty)]))))
;(trace tc/funapp)
(define (tc/app form) (tc/app/internal form #f))
(define (tc/app/check form expected)
(define t (tc/app/internal form expected))
(check-below t expected)
(ret expected))
(define-syntax-class lv-clause
#:transparent
(pattern [(v:id ...) e:expr]))
(define-syntax-class lv-clauses
#:transparent
(pattern (cl:lv-clause ...)
#:with (e ...) #'(cl.e ...)
#:with (vs ...) #'((cl.v ...) ...)))
(define-syntax-class core-expr
#:literals (reverse letrec-syntaxes+values let-values #%plain-app
if letrec-values begin #%plain-lambda set! case-lambda
begin0 with-continuation-mark)
#:transparent
(pattern (let-values cls:lv-clauses body)
#:with (expr ...) #'(cls.e ... body))
(pattern (letrec-values cls:lv-clauses body)
#:with (expr ...) #'(cls.e ... body))
(pattern (letrec-syntaxes+values _ cls:lv-clauses body)
#:with (expr ...) #'(cls.e ... body))
(pattern (#%plain-app expr ...))
(pattern (if expr ...))
(pattern (with-continuation-mark expr ...))
(pattern (begin expr ...))
(pattern (begin0 expr ...))
(pattern (#%plain-lambda _ e)
#:with (expr ...) #'(e))
(pattern (case-lambda [_ expr] ...))
(pattern (set! _ e)
#:with (expr ...) #'(e))
(pattern _
#:with (expr ...) #'()))
;; expr id -> type or #f
;; if there is a binding in stx of the form:
;; (let ([x (reverse name)]) e)
;; where x has a type annotation, return that annotation, otherwise #f
(define (find-annotation stx name)
(define (find s) (find-annotation s name))
(define (match? b)
(syntax-parse b
#:literals (#%plain-app reverse)
[c:lv-clause
#:with (#%plain-app reverse n:id) #'c.e
#:with (v) #'(c.v ...)
#:when (free-identifier=? name #'n)
(type-annotation #'v)]
[_ #f]))
(syntax-parse stx
#:literals (let-values)
[(let-values cls:lv-clauses body)
(or (ormap match? (syntax->list #'cls))
(find #'body))]
[e:core-expr
(ormap find (syntax->list #'(e.expr ...)))]))
(define (check-do-make-object cl pos-args names named-args)
(let* ([names (map syntax-e (syntax->list names))]
[name-assoc (map list names (syntax->list named-args))])
(let loop ([t (tc-expr cl)])
(match t
[(tc-result: (? Mu? t)) (loop (ret (unfold t)))]
[(tc-result: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _)))
(unless (= (length pos-tys)
(length (syntax->list pos-args)))
(tc-error/delayed "expected ~a positional arguments, but got ~a"
(length pos-tys) (length (syntax->list pos-args))))
;; use for, since they might be different lengths in error case
(for ([pa (in-syntax pos-args)]
[pt (in-list pos-tys)])
(tc-expr/check pa pt))
(for ([n names]
#:when (not (memq n tnames)))
(tc-error/delayed
"unknown named argument ~a for class~nlegal named arguments are ~a"
n (stringify tnames)))
(for-each (match-lambda
[(list tname tfty opt?)
(let ([s (cond [(assq tname name-assoc) => cadr]
[(not opt?)
(tc-error/delayed "value not provided for named init arg ~a" tname)
#f]
[else #f])])
(if s
;; this argument was present
(tc-expr/check s tfty)
;; this argument wasn't provided, and was optional
#f))])
tnflds)
(ret (make-Instance c))]
[(tc-result: t)
(tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)]))))
(define (tc-keywords form arities kws kw-args pos-args expected)
(match arities
[(list (arr: dom rng rest #f ktys _ _))
;; assumes that everything is in sorted order
(let loop ([actual-kws kws]
[actuals (map tc-expr/t (syntax->list kw-args))]
[formals ktys])
(match* (actual-kws formals)
[('() '())
(void)]
[(_ '())
(tc-error/expr #:return (ret (Un))
"Unexpected keyword argument ~a" (car actual-kws))]
[('() (cons fst rst))
(match fst
[(Keyword: k _ #t)
(tc-error/expr #:return (ret (Un))
"Missing keyword argument ~a" k)]
[_ (loop actual-kws actuals rst)])]
[((cons k kws-rest) (cons (Keyword: k* t req?) form-rest))
(cond [(eq? k k*) ;; we have a match
(unless (subtype (car actuals) t)
(tc-error/delayed
"Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
t (car actuals) k))
(loop kws-rest (cdr actuals) form-rest)]
[req? ;; this keyword argument was required
(tc-error/delayed "Missing keyword argument ~a" k*)
(loop kws-rest (cdr actuals) form-rest)]
[else ;; otherwise, ignore this formal param, and continue
(loop actual-kws actuals form-rest)])]))
(tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)]
[_ (int-err "case-lambda w/ keywords not supported")]))
(define (type->list t)
(match t
[(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))]
[(Value: '()) null]
[_ (int-err "bad value in type->list: ~a" t)]))
;; id: identifier
;; sym: a symbol
;; mod: a quoted require spec like 'scheme/base
;; is id the name sym defined in mod?
(define (id-from? id sym mod)
(and (eq? (syntax-e id) sym)
(eq? (module-path-index-resolve (syntax-source-module id))
((current-module-name-resolver) mod #f #f #f))))
(define (tc/app/internal form expected)
(kernel-syntax-case* form #f
(values apply k:apply not list list* call-with-values do-make-object make-object cons
andmap ormap) ;; the special-cased functions
;; special case for delay
[(#%plain-app
mp1
(#%plain-lambda ()
(#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
(and (id-from? #'mp1 'make-promise 'scheme/promise)
(id-from? #'mp2 'make-promise 'scheme/promise))
(ret (-Promise (tc-expr/t #'e)))]
;; special cases for classes
[(#%plain-app make-object cl . args)
(check-do-make-object #'cl #'args #'() #'())]
[(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...))
(check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
[(#%plain-app do-make-object . args)
(int-err "bad do-make-object : ~a" (syntax->datum #'args))]
;; call-with-values
[(#%plain-app call-with-values prod con)
(match-let* ([(tc-result: prod-t) (tc-expr #'prod)])
(define (values-ty->list t)
(match t
[(Values: ts) ts]
[_ (list t)]))
(match prod-t
[(Function: (list (arr: (list) vals _ #f '() _ _)))
(tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)]
[_ (tc-error/expr #:return (ret (Un))
"First argument to call with values must be a function that can accept no arguments, got: ~a"
prod-t)]))]
;; special cases for `values'
;; special case the single-argument version to preserve the effects
[(#%plain-app values arg) (tc-expr #'arg)]
[(#%plain-app values . args)
(let ([tys (map tc-expr/t (syntax->list #'args))])
(ret (-values tys)))]
;; special case for `list'
[(#%plain-app list . args)
(let ([tys (map tc-expr/t (syntax->list #'args))])
(ret (apply -lst* tys)))]
;; special case for `list*'
[(#%plain-app list* . args)
(match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))]
[tys (reverse tys-r)])
(ret (foldr make-Pair last tys)))]
;; in eq? cases, call tc/eq
[(#%plain-app eq? v1 v2)
(and (identifier? #'eq?) (comparator? #'eq?))
(begin
;; make sure the whole expression is type correct
(tc/funapp #'eq? #'(v1 v2) (tc-expr #'eq?) (map tc-expr (syntax->list #'(v1 v2))) expected)
;; check thn and els with the eq? info
(let-values ([(thn-eff els-eff) (tc/eq #'eq? #'v1 #'v2)])
(ret B thn-eff els-eff)))]
;; special case for `not'
[(#%plain-app not arg)
(match (tc-expr #'arg)
;; if arg was a predicate application, we swap the effects
[(tc-result: t thn-eff els-eff)
(ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])]
[(#%plain-app k:apply . args)
(tc/app/internal #'(#%plain-app apply . args) expected)]
;; special-er case for (apply values (list x y z))
[(#%plain-app apply values e)
(cond [(with-handlers ([exn:fail? (lambda _ #f)])
(untuple (tc-expr/t #'e)))
=> (lambda (t) (ret (-values t)))]
[else (tc/apply #'values #'(e))])]
;; special case for `apply'
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
;; special case for keywords
[(#%plain-app
(#%plain-app kpe kws num fn)
kw-list
(#%plain-app list . kw-arg-list)
. pos-args)
(eq? (syntax-e #'kpe) 'keyword-procedure-extract)
(match (tc-expr #'fn)
[(tc-result: (Function: arities))
(tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)]
[(tc-result: t) (tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" t)])]
;; even more special case for match
[(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
(and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))
(let-loop-check form #'lp #'actuals #'args #'body expected)]
;; or/andmap of ... argument
[(#%plain-app or/andmap f arg)
(and
(identifier? #'or/andmap)
(or (free-identifier=? #'or/andmap #'ormap)
(free-identifier=? #'or/andmap #'andmap))
(with-handlers ([exn:fail? (lambda _ #f)])
(tc/dots #'arg)
#t))
(let-values ([(ty bound) (tc/dots #'arg)])
(parameterize ([current-tvars (extend-env (list bound)
(list (make-DottedBoth (make-F bound)))
(current-tvars))])
(match-let* ([ft (tc-expr #'f)]
[(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)])
(ret (Un (-val #f) t)))))]
;; infer for ((lambda
[(#%plain-app (#%plain-lambda (x ...) . body) args ...)
(= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...))))
(tc/let-values/check #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body)
expected)]
;; default case
[(#%plain-app f args ...)
(tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)]))
(define (let-loop-check form lp actuals args body expected)
(kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?)
[((val acc ...)
((if (#%plain-app null? val*) thn els))
(actual actuals ...))
(and (free-identifier=? #'val #'val*)
(ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a))
(syntax->list #'(acc ...))))
(let* ([ts1 (generalize (tc-expr/t #'actual))]
[ann-ts (for/list ([a (in-syntax #'(acc ...))]
[ac (in-syntax #'(actuals ...))])
(or (find-annotation #'(if (#%plain-app null? val*) thn els) a)
(generalize (tc-expr/t ac))))]
[ts (cons ts1 ann-ts)])
;; check that the actual arguments are ok here
(map tc-expr/check (syntax->list #'(actuals ...)) ann-ts)
;; then check that the function typechecks with the inferred types
(tc/rec-lambda/check form args body lp ts expected)
(ret expected))]
;; special case when argument needs inference
[_
(let ([ts (for/list ([ac (syntax->list actuals)]
[f (syntax->list args)])
(or
(type-annotation f #:infer #t)
(generalize (tc-expr/t ac))))])
(tc/rec-lambda/check form args body lp ts expected)
(ret expected))]))
(define (matches? stx)
(let loop ([stx stx] [ress null] [acc*s null])
(syntax-case stx (#%plain-app reverse)
[([(res) (#%plain-app reverse acc*)] . more)
(loop #'more (cons #'res ress) (cons #'acc* acc*s))]
[rest
(syntax->list #'rest)
(begin
;(printf "ress: ~a~n" (map syntax-e ress))
(list (reverse ress) (reverse acc*s) #'rest))]
[_ #f])))
;(trace tc/app/internal)

641
collects/typed-scheme/typecheck/tc-app.ss Normal file
View File

@ -0,0 +1,641 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer])
"signatures.ss" "tc-metafunctions.ss"
"tc-app-helper.ss" "find-annotation.ss"
stxclass scheme/match mzlib/trace scheme/list
(for-syntax stxclass scheme/base)
(private type-annotation)
(types utils abbrev union subtype resolve convenience)
(utils tc-utils)
(only-in srfi/1 alist-delete)
(except-in (env type-environments) extend)
(rep type-rep filter-rep object-rep)
(r:infer infer)
(for-template
(only-in '#%kernel [apply k:apply])
"internal-forms.ss" scheme/base
(only-in scheme/private/class-internal make-object do-make-object)))
(import tc-expr^ tc-lambda^ tc-dots^ tc-let^)
(export tc-app^)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Comparators
;; comparators that inform the type system
(define-syntax-class comparator
#:literals (eq? equal? eqv? = string=? symbol=?)
(pattern eq?) (pattern equal?) (pattern eqv?) (pattern =) (pattern string=?) (pattern symbol=?))
;; typecheck eq? applications
;; identifier identifier expression expression expression
;; identifier expr expr -> tc-results
(define (tc/eq comparator v1 v2)
(define (ok? val)
(define-syntax-rule (alt nm pred ...) (and (free-identifier=? #'nm comparator) (or (pred val) ...)))
(or (alt symbol=? symbol?)
(alt string=? string?)
(alt = number?)
(alt eq? boolean? keyword? symbol?)
(alt eqv? boolean? keyword? symbol? number?)
(alt equal? (lambda (x) #t))))
(match* ((single-value v1) (single-value v2))
[((tc-result1: t _ o) (tc-result1: (Value: (? ok? val))))
(ret -Boolean (apply-filter (make-LFilterSet (list (make-LTypeFilter (-val val) null 0)) (list (make-LNotTypeFilter (-val val) null 0))) t o))]
[((tc-result1: (Value: (? ok? val))) (tc-result1: t _ o))
(ret -Boolean (apply-filter (make-LFilterSet (list (make-LTypeFilter (-val val) null 0)) (list (make-LNotTypeFilter (-val val) null 0))) t o))]
[(_ _) (ret -Boolean)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Keywords
(define (tc-keywords form arities kws kw-args pos-args expected)
(match arities
[(list (arr: dom rng rest #f ktys))
;; assumes that everything is in sorted order
(let loop ([actual-kws kws]
[actuals (map tc-expr/t (syntax->list kw-args))]
[formals ktys])
(match* (actual-kws formals)
[('() '())
(void)]
[(_ '())
(tc-error/expr #:return (ret (Un))
"Unexpected keyword argument ~a" (car actual-kws))]
[('() (cons fst rst))
(match fst
[(Keyword: k _ #t)
(tc-error/expr #:return (ret (Un))
"Missing keyword argument ~a" k)]
[_ (loop actual-kws actuals rst)])]
[((cons k kws-rest) (cons (Keyword: k* t req?) form-rest))
(cond [(eq? k k*) ;; we have a match
(unless (subtype (car actuals) t)
(tc-error/delayed
"Wrong function argument type, expected ~a, got ~a for keyword argument ~a"
t (car actuals) k))
(loop kws-rest (cdr actuals) form-rest)]
[req? ;; this keyword argument was required
(tc-error/delayed "Missing keyword argument ~a" k*)
(loop kws-rest (cdr actuals) form-rest)]
[else ;; otherwise, ignore this formal param, and continue
(loop actual-kws actuals form-rest)])]))
(tc/funapp (car (syntax-e form)) kw-args (ret (make-Function (list (make-arr* dom rng #:rest rest)))) (map tc-expr (syntax->list pos-args)) expected)]
[_ (int-err "case-lambda w/ keywords not supported")]))
(define (type->list t)
(match t
[(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))]
[(Value: '()) null]
[_ (int-err "bad value in type->list: ~a" t)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Objects
(define (check-do-make-object cl pos-args names named-args)
(let* ([names (map syntax-e (syntax->list names))]
[name-assoc (map list names (syntax->list named-args))])
(let loop ([t (tc-expr cl)])
(match t
[(tc-result1: (? Mu? t*)) (loop (ret (unfold t*)))]
[(tc-result1: (Union: '())) (ret (Un))]
[(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _)))
(unless (= (length pos-tys)
(length (syntax->list pos-args)))
(tc-error/delayed "expected ~a positional arguments, but got ~a"
(length pos-tys) (length (syntax->list pos-args))))
;; use for, since they might be different lengths in error case
(for ([pa (in-syntax pos-args)]
[pt (in-list pos-tys)])
(tc-expr/check pa (ret pt)))
(for ([n names]
#:when (not (memq n tnames)))
(tc-error/delayed
"unknown named argument ~a for class~nlegal named arguments are ~a"
n (stringify tnames)))
(for-each (match-lambda
[(list tname tfty opt?)
(let ([s (cond [(assq tname name-assoc) => cadr]
[(not opt?)
(tc-error/delayed "value not provided for named init arg ~a" tname)
#f]
[else #f])])
(if s
;; this argument was present
(tc-expr/check s (ret tfty))
;; this argument wasn't provided, and was optional
#f))])
tnflds)
(ret (make-Instance c))]
[(tc-result1: t)
(tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; let loop
(define (let-loop-check form lp actuals args body expected)
(syntax-parse #`(#,args #,body #,actuals)
#:literals (#%plain-app if null?)
[((val acc ...)
((if (#%plain-app null? val*) thn els))
(actual actuals ...))
(and (free-identifier=? #'val #'val*)
(ormap (lambda (a) (find-annotation #'(if (#%plain-app null? val*) thn els) a))
(syntax->list #'(acc ...))))
(let* ([ts1 (generalize (tc-expr/t #'actual))]
[ann-ts (for/list ([a (in-syntax #'(acc ...))]
[ac (in-syntax #'(actuals ...))])
(or (find-annotation #'(if (#%plain-app null? val*) thn els) a)
(generalize (tc-expr/t ac))))]
[ts (cons ts1 ann-ts)])
;; check that the actual arguments are ok here
(for/list ([a (syntax->list #'(actuals ...))]
[t ann-ts])
(tc-expr/check a (ret t)))
;; then check that the function typechecks with the inferred types
(tc/rec-lambda/check form args body lp ts expected)
expected)]
;; special case when argument needs inference
[_
(let ([ts (for/list ([ac (syntax->list actuals)]
[f (syntax->list args)])
(or
(type-annotation f #:infer #t)
(generalize (tc-expr/t ac))))])
(tc/rec-lambda/check form args body lp ts expected)
expected)]))
(define (tc/apply f args)
(define (do-ret t)
(match t
[(Values: (list (Result: ts _ _) ...)) (ret ts)]
[(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)]))
(define f-ty (single-value f))
;; produces the first n-1 elements of the list, and the last element
(define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))])
(values f (car r))))
(define-values (fixed-args tail) (split (syntax->list args)))
(match f-ty
[(tc-result1: (Function: (list (arr: doms rngs rests drests '()) ...)))
(when (null? doms)
(tc-error/expr #:return (ret (Un))
"empty case-lambda given as argument to apply"))
(let ([arg-tys (map tc-expr/t fixed-args)])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to function in apply:~n"
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound))))]
[(and (car rests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda _ (values #f #f))])
(tc/dots tail))])
(and tail-ty
(subtype (apply -lst* arg-tys #:tail (make-Listof tail-ty))
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(printf/log "Non-poly apply, ... arg\n")
(do-ret (car rngs*))]
[(and (car rests*)
(let ([tail-ty (with-handlers ([exn:fail? (lambda _ #f)])
(tc-expr/t tail))])
(and tail-ty
(subtype (apply -lst* arg-tys #:tail tail-ty)
(apply -lst* (car doms*) #:tail (make-Listof (car rests*)))))))
(printf/log (if (memq (syntax->datum f) '(+ - * / max min))
"Simple arithmetic non-poly apply\n"
"Simple non-poly apply\n"))
(do-ret (car rngs*))]
[(and (car drests*)
(let-values ([(tail-ty tail-bound)
(with-handlers ([exn:fail? (lambda (e) (values #f #f))])
(tc/dots tail))])
(and tail-ty
(eq? (cdr (car drests*)) tail-bound)
(subtypes arg-tys (car doms*))
(subtype tail-ty (car (car drests*))))))
(printf/log "Non-poly apply, ... arg\n")
(do-ret (car rngs*))]
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result1: (Poly: vars (Function: (list (arr: doms rngs rests drests '()) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result1: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
;; the actual work, when we have a * function and a list final argument
[(and (car rests*)
(not tail-bound)
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons tail-ty arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; actual work, when we have a * function and ... final arg
[(and (car rests*)
tail-bound
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons (make-Listof tail-ty) arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg
[(and (car drests*)
tail-bound
(eq? tail-bound (cdr (car drests*)))
(= (length (car doms*))
(length arg-tys))
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; if nothing matches, around the loop again
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result1: (Poly: vars (Function: '())))
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
[(tc-result1: (PolyDots: (and vars (list fixed-vars ... dotted-var))
(Function: (list (arr: doms rngs rests drests '()) ..1))))
(let*-values ([(arg-tys) (map tc-expr/t fixed-args)]
[(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))])
(tc/dots tail))])
(let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests])
(cond [(null? doms*)
(match f-ty
[(tc-result1: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '()) ..1))))
(tc-error/expr #:return (ret (Un))
(string-append
"Bad arguments to polymorphic function in apply:~n"
(domain-mismatches f-ty doms rests drests rngs arg-tys tail-ty tail-bound)))])]
;; the actual work, when we have a * function and a list final argument
[(and (car rests*)
(not tail-bound)
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons tail-ty arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution) (do-ret (subst-all substitution (car rngs*))))]
;; actual work, when we have a * function and ... final arg
[(and (car rests*)
tail-bound
(<= (length (car doms*))
(length arg-tys))
(infer/vararg vars
(cons (make-Listof tail-ty) arg-tys)
(cons (make-Listof (car rests*))
(car doms*))
(car rests*)
(car rngs*)
(fv (car rngs*))))
=> (lambda (substitution)
(do-ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg, same bound on ...
[(and (car drests*)
tail-bound
(eq? tail-bound (cdr (car drests*)))
(= (length (car doms*))
(length arg-tys))
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*))))
=> (lambda (substitution)
(do-ret (subst-all substitution (car rngs*))))]
;; ... function, ... arg, different bound on ...
[(and (car drests*)
tail-bound
(not (eq? tail-bound (cdr (car drests*))))
(= (length (car doms*))
(length arg-tys))
(parameterize ([current-tvars (extend-env (list tail-bound (cdr (car drests*)))
(list (make-DottedBoth (make-F tail-bound))
(make-DottedBoth (make-F (cdr (car drests*)))))
(current-tvars))])
(infer vars (cons tail-ty arg-tys) (cons (car (car drests*)) (car doms*)) (car rngs*) (fv (car rngs*)))))
=> (lambda (substitution)
(define drest-bound (cdr (car drests*)))
(do-ret (substitute-dotted (cadr (assq drest-bound substitution))
tail-bound
drest-bound
(subst-all (alist-delete drest-bound substitution eq?)
(car rngs*)))))]
;; ... function, (List A B C etc) arg
[(and (car drests*)
(not tail-bound)
(eq? (cdr (car drests*)) dotted-var)
(= (length (car doms*))
(length arg-tys))
(untuple tail-ty)
(infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*)
(car (car drests*)) (car rngs*) (fv (car rngs*))))
=> (lambda (substitution)
(define drest-bound (cdr (car drests*)))
(do-ret (subst-all substitution (car rngs*))))]
;; if nothing matches, around the loop again
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))]
[(tc-result1: (PolyDots: vars (Function: '())))
(tc-error/expr #:return (ret (Un))
"Function has no cases")]
[(tc-result1: f-ty) (tc-error/expr #:return (ret (Un))
"Type of argument to apply is not a function type: ~n~a" f-ty)]))
;; the main dispatching function
;; syntax tc-results? -> tc-results?
(define (tc/app/internal form expected)
(syntax-parse form
#:literals (#%plain-app #%plain-lambda letrec-values quote
values apply k:apply not list list* call-with-values do-make-object make-object cons
andmap ormap)
;; call-with-values
[(#%plain-app call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)
[(tc-results: ts fs os)
(tc/funapp #'con #'prod (single-value #'con) (map ret ts fs os) expected)])]
;; in eq? cases, call tc/eq
[(#%plain-app eq?:comparator v1 v2)
;; make sure the whole expression is type correct
(tc/funapp #'eq? #'(v1 v2) (single-value #'eq?) (map single-value (syntax->list #'(v1 v2))) expected)
;; check thn and els with the eq? info
(tc/eq #'eq? #'v1 #'v2)]
;; special-case for not - flip the filters
[(#%plain-app not arg)
(match (single-value #'arg)
[(tc-result1: t (FilterSet: f+ f-) _)
(ret -Boolean (make-FilterSet f- f+))])]
;; (apply values l) gets special handling
[(#%plain-app apply values e)
(cond [(with-handlers ([exn:fail? (lambda _ #f)])
(untuple (tc-expr/t #'e)))
=> ret]
[else (tc/apply #'values #'(e))])]
;; rewrite this so that it takes advantages of all the special cases
[(#%plain-app k:apply . args) (tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)]
;; handle apply specially
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
;; special case for `values' with single argument - we just ignore the values, except that it forces arg to return one value
[(#%plain-app values arg) (single-value #'arg expected)]
;; handle `values' specially
[(#%plain-app values . args)
(match expected
[(tc-results: ets efs eos)
(match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)]
[et ets] [ef efs] [eo eos])
(single-value arg (ret et ef eo)))])
(if (= (length ts) (length ets) (length (syntax->list #'args)))
(ret ts fs os)
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a"
(length ets) (length (syntax->list #'args)))))]
[_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)])
(single-value arg))])
(ret ts fs os))])]
;; special case for keywords
[(#%plain-app
(#%plain-app kpe kws num fn)
kw-list
(#%plain-app list . kw-arg-list)
. pos-args)
#:declare kpe (id-from 'keyword-procedure-extract 'scheme/private/kw)
(match (tc-expr #'fn)
[(tc-result1: (Function: arities))
(tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)]
[(tc-result1: t) (tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" t)])]
;; even more special case for match
[(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals)
#:when expected
#:when (not (andmap type-annotation (syntax->list #'args)))
#:when (free-identifier=? #'lp #'lp*)
(let-loop-check form #'lp #'actuals #'args #'body expected)]
;; special cases for classes
[(#%plain-app make-object cl . args)
(check-do-make-object #'cl #'args #'() #'())]
[(#%plain-app do-make-object cl (#%plain-app list . pos-args) (#%plain-app list (#%plain-app cons 'names named-args) ...))
(check-do-make-object #'cl #'pos-args #'(names ...) #'(named-args ...))]
;; ormap/andmap of ... argument
[(#%plain-app or/andmap:id f arg)
#:when (or (free-identifier=? #'or/andmap #'ormap)
(free-identifier=? #'or/andmap #'andmap))
#:when (with-handlers ([exn:fail? (lambda _ #f)])
(tc/dots #'arg)
#t)
(let-values ([(ty bound) (tc/dots #'arg)])
(parameterize ([current-tvars (extend-env (list bound)
(list (make-DottedBoth (make-F bound)))
(current-tvars))])
(match-let* ([ft (tc-expr #'f)]
[(tc-result1: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)])
(ret (Un (-val #f) t)))))]
;; special case for `delay'
[(#%plain-app
mp1
(#%plain-lambda ()
(#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
#:declare mp1 (id-from 'make-promise 'scheme/promise)
#:declare mp2 (id-from 'make-promise 'scheme/promise)
(ret (-Promise (tc-expr/t #'e)))]
;; special case for `list'
[(#%plain-app list . args)
(let ([tys (map tc-expr/t (syntax->list #'args))])
(ret (apply -lst* tys)))]
;; special case for `list*'
[(#%plain-app list* . args)
(match-let* ([(list last tys-r ...) (reverse (map tc-expr/t (syntax->list #'args)))]
[tys (reverse tys-r)])
(ret (foldr make-Pair last tys)))]
;; inference for ((lambda
[(#%plain-app (#%plain-lambda (x ...) . body) args ...)
#:when (= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...))))
(tc/let-values #'((x) ...) #'(args ...) #'body
#'(let-values ([(x) args] ...) . body)
expected)]
;; inference for ((lambda with dotted rest
[(#%plain-app (#%plain-lambda (x ... . rst:id) . body) args ...)
#:when (<= (length (syntax->list #'(x ...)))
(length (syntax->list #'(args ...))))
;; FIXME - remove this restriction - doesn't work because the annotation
;; on rst is not a normal annotation, may have * or ...
#:when (not (type-annotation #'rst))
(let-values ([(fixed-args varargs) (split-at (syntax->list #'(args ...)) (length (syntax->list #'(x ...))))])
(with-syntax ([(fixed-args ...) fixed-args]
[varg #`(#%plain-app list #,@varargs)])
(tc/let-values #'((x) ... (rst)) #`(fixed-args ... varg) #'body
#'(let-values ([(x) fixed-args] ... [(rst) varg]) . body)
expected)))]
[(#%plain-app f . args)
(let* ([f-ty (single-value #'f)]
[arg-tys (map single-value (syntax->list #'args))])
(tc/funapp #'f #'args f-ty arg-tys expected))]))
;(trace tc/app/internal)
;; syntax -> tc-results
(define (tc/app form) (tc/app/internal form #f))
;; syntax tc-results? -> tc-results?
(define (tc/app/check form expected)
(define t (tc/app/internal form expected))
(check-below t expected)
expected)
(define (object-index os i)
(unless (number? i)
(int-err "object-index for keywords NYI"))
(list-ref os i))
;; in-indexes : Listof[Type] -> Sequence[index/c]
(define (in-indexes dom)
(in-range (length dom)))
(define-syntax (handle-clauses stx)
(syntax-parse stx
[(_ (lsts ... arrs) f-stx args-stx pred infer t argtys expected)
(with-syntax ([(vars ... a) (generate-temporaries #'(lsts ... arrs))])
(syntax/loc stx
(or (for/or ([vars lsts] ... [a arrs]
#:when (pred vars ... a))
(let ([substitution (infer vars ... a)])
(and substitution
(tc/funapp1 f-stx args-stx (subst-all substitution a) argtys expected #:check #f))))
(poly-fail t argtys #:name (and (identifier? f-stx) f-stx) #:expected expected))))]))
(define (tc/funapp f-stx args-stx ftype0 argtys expected)
(match* (ftype0 argtys)
;; we special-case this (no case-lambda) for improved error messages
[((tc-result1: (and t (Function: (list (and a (arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f kws))))))
argtys)
(tc/funapp1 f-stx args-stx a argtys expected)]
[((tc-result1: (and t (Function: (and arrs (list (arr: doms rngs rests (and drests #f) kws) ...)))))
(and argtys (list (tc-result1: argtys-t) ...)))
(or
;; find the first function where the argument types match
(for/first ([dom doms] [rng rngs] [rest rests] [a arrs]
#:when (subtypes/varargs argtys-t dom rest))
;; then typecheck here
;; we call the separate function so that we get the appropriate filters/objects
(tc/funapp1 f-stx args-stx a argtys expected #:check #f))
;; if nothing matched, error
(tc-error/expr
#:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n"
(domain-mismatches t doms rests drests rngs argtys-t #f #f))))]
;; polymorphic functions without dotted rest
[((tc-result1: (and t
(or (Poly: vars
(Function: (list (and arrs (arr: doms rngs rests (and drests #f) '())) ...)))
(PolyDots: vars
(Function: (list (and arrs (arr: doms rngs rests (and drests #f) '())) ...))))))
(list (tc-result1: argtys-t) ...))
(handle-clauses (doms rngs rests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
(lambda (dom _ rest a) ((if rest <= =) (length dom) (length argtys)))
;; only try to infer the free vars of the rng (which includes the vars in filters/objects)
;; note that we have to use argtys-t here, since argtys is a list of tc-results
(lambda (dom rng rest a) (infer/vararg vars argtys-t dom rest rng (fv rng) (and expected (tc-results->values expected))))
t argtys expected)]
;; polymorphic ... type
[((tc-result1: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var))
(Function: (list (and arrs (arr: doms rngs (and #f rests) (cons dtys dbounds) '())) ...)))))
(list (tc-result1: argtys-t) ...))
(handle-clauses (doms dtys dbounds rngs arrs) f-stx args-stx
(lambda (dom dty dbound rng arr) (and (<= (length dom) (length argtys))
(eq? dotted-var dbound)))
(lambda (dom dty dbound rng arr)
(infer/dots fixed-vars dotted-var argtys-t dom dty rng (fv rng) #:expected (and expected (tc-results->values expected))))
t argtys expected)]
;; procedural structs
[((tc-result1: (and sty (Struct: _ _ _ (? Function? proc-ty) _ _ _))) _)
(tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) (ret proc-ty) (cons ftype0 argtys) expected)]
;; parameters are functions too
[((tc-result1: (Param: in out)) (list)) (ret out)]
[((tc-result1: (Param: in out)) (list (tc-result1: t)))
(if (subtype t in)
(ret -Void true-filter)
(tc-error/expr #:return (ret -Void true-filter)
"Wrong argument to parameter - expected ~a and got ~a" in t))]
[((tc-result1: (Param: _ _)) _)
(tc-error/expr #:return (ret (Un))
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtys))]
;; resolve names, polymorphic apps, mu, etc
[((tc-result1: (? needs-resolving? t) f o) _)
(tc/funapp f-stx args-stx (ret (resolve-once t) f o) argtys expected)]
;; a union of functions can be applied if we can apply all of the elements
[((tc-result1: (Union: (and ts (list (Function: _) ...)))) _)
(ret (for/fold ([result (Un)]) ([fty ts])
(match (tc/funapp f-stx args-stx (ret fty) argtys expected)
[(tc-result1: t) (Un result t)])))]
;; error type is a perfectly good fcn type
[((tc-result1: (Error:)) _) (ret (make-Error))]
;; otherwise fail
[((tc-result1: f-ty) _)
;(printf "ft: ~a argt: ~a~n" ftype0 argtys)
(tc-error/expr #:return (ret (Un))
"Cannot apply expression of type ~a, since it is not a function type" f-ty)]))
;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results?
(define (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t])
(match* (ftype0 argtys)
;; we check that all kw args are optional
[((arr: dom (Values: (list (Result: t-r lf-r lo-r) ...)) rest #f (list (Keyword: _ _ #f) ...))
(list (tc-result1: t-a phi-a o-a) ...))
(when check?
(cond [(and (not rest) (not (= (length dom) (length t-a))))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected ~a and got ~a" (length dom) (length t-a))]
[(and rest (< (length t-a) (length dom)))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
(for ([dom-t (if rest (in-list-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* (;; Listof[Listof[LFilterSet]]
[lfs-f (for/list ([lf lf-r])
(for/list ([i (in-indexes dom)])
(split-lfilters lf i)))]
;; Listof[FilterSet]
[f-r (for/list ([lfs lfs-f])
(merge-filter-sets
(for/list ([lf lfs] [t t-a] [o o-a])
(apply-filter lf t o))))]
;; Listof[Object]
[o-r (for/list ([lo lo-r])
(match lo
[(LPath: pi* i)
(match (object-index o-a i)
[(Path: pi x) (make-Path (append pi* pi) x)]
[_ (make-Empty)])]
[_ (make-Empty)]))])
(ret t-r f-r o-r))]
[((arr: _ _ _ drest '()) _)
(int-err "funapp with drest args NYI")]
[((arr: _ _ _ _ kws) _)
(int-err "funapp with keyword args NYI")]))

6
collects/typed-scheme/typecheck/tc-dots-unit.ss
View File

@ -4,7 +4,7 @@
(require "signatures.ss"
(utils tc-utils)
(env type-environments)
(private type-utils)
(types utils)
(rep type-rep)
syntax/kerncase
scheme/match)
@ -35,8 +35,8 @@
(parameterize ([current-tvars (extend-env (list lbound)
(list (make-DottedBoth (make-F lbound)))
(current-tvars))])
(match-let* ([ft (tc-expr #'f)]
[(tc-result: t) (tc/funapp #'f #'(l) ft (list (ret lty)) #f)])
(match-let* ([ft (single-value #'f)]
[(tc-result1: t) (tc/funapp #'f #'(l) ft (list (ret lty)) #f)])
(values t lbound))))]
[_
(tc-error "form cannot be used where a term of ... type is expected")])))

66
collects/typed-scheme/typecheck/tc-envops.ss Normal file
View File

@ -0,0 +1,66 @@
#lang scheme/base
(require (rename-in "../utils/utils.ss" [infer infer-in]))
(require (rename-in (types subtype convenience remove-intersect union)
[-> -->]
[->* -->*]
[one-of/c -one-of/c])
(infer-in infer)
(rep type-rep)
(utils tc-utils)
(types resolve)
(only-in (env type-environments lexical-env) env? update-type/lexical env-map)
scheme/contract scheme/match
stxclass/util mzlib/trace
(for-syntax scheme/base))
(provide env+)
(define (replace-nth l i f)
(cond [(null? l) (error 'replace-nth "list not long enough" l i f)]
[(zero? i) (cons (f (car l)) (cdr l))]
[else (cons (car l) (replace-nth (cdr l) (sub1 i) f))]))
(trace replace-nth)
(define/contract (update t lo)
(Type/c Filter/c . -> . Type/c)
(match* ((resolve t) lo)
;; pair ops
[((Pair: t s) (TypeFilter: u (list rst ... (CarPE:)) x))
(make-Pair (update t (make-TypeFilter u rst x)) s)]
[((Pair: t s) (NotTypeFilter: u (list rst ... (CarPE:)) x))
(make-Pair (update t (make-NotTypeFilter u rst x)) s)]
[((Pair: t s) (TypeFilter: u (list rst ... (CdrPE:)) x))
(make-Pair t (update s (make-TypeFilter u rst x)))]
[((Pair: t s) (NotTypeFilter: u (list rst ... (CdrPE:)) x))
(make-Pair t (update s (make-NotTypeFilter u rst x)))]
;; struct ops
[((Struct: nm par flds proc poly pred cert)
(TypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-TypeFilter u rst x)))) proc poly pred cert)]
[((Struct: nm par flds proc poly pred cert)
(NotTypeFilter: u (list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)) x))
(make-Struct nm par (replace-nth flds idx (lambda (e) (update e (make-NotTypeFilter u rst x)))) proc poly pred cert)]
;; otherwise
[(t (TypeFilter: u (list) _))
(restrict t u)]
[(t (NotTypeFilter: u (list) _))
(remove t u)]
[(t* lo)
(int-err "update along ill-typed path: ~a ~a ~a" t t* lo)]))
;; sets the flag box to #f if anything becomes (U)
(d/c (env+ env fs flag)
(env? (listof Filter/c) (box/c #t). -> . env?)
(for/fold ([Γ env]) ([f fs])
(match f
[(Bot:) (set-box! flag #f) (env-map (lambda (x) (cons (car x) (Un))) Γ)]
[(or (TypeFilter: _ _ x) (NotTypeFilter: _ _ x))
(update-type/lexical (lambda (x t) (let ([new-t (update t f)])
(when (type-equal? new-t (Un))
(set-box! flag #f))
new-t))
x Γ)])))

220
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -1,14 +1,14 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [private r:private]))
(require (rename-in "../utils/utils.ss" [private private-in]))
(require syntax/kerncase
scheme/match
scheme/match (prefix-in - scheme/contract)
"signatures.ss"
(r:private type-utils type-effect-convenience union subtype
parse-type type-annotation stxclass-util)
(rep type-rep effect-rep)
(utils tc-utils)
(types utils convenience union subtype)
(private-in parse-type type-annotation)
(rep type-rep)
(utils tc-utils stxclass-util)
(env lexical-env)
(only-in (env type-environments) lookup current-tvars extend-env)
scheme/private/class-internal
@ -23,12 +23,18 @@
;; return the type of a literal value
;; scheme-value -> type
(define (tc-literal v-stx)
(define (tc-literal v-stx [expected #f])
(define-syntax-class exp
(pattern i
#:when expected
#:with datum (syntax-e #'i)
#:when (subtype (-val #'datum) expected)))
(syntax-parse v-stx
[i:exp expected]
[i:boolean (-val #'i.datum)]
[i:identifier (-val #'i.datum)]
[i:exact-integer -Integer]
[i:number N]
[i:number -Number]
[i:str -String]
[i:char -Char]
[i:keyword (-val #'i.datum)]
@ -39,7 +45,7 @@
[(i ...)
(-Tuple (map tc-literal (syntax->list #'(i ...))))]
[i #:declare i (3d vector?)
(make-Vector (apply Un (map tc-literal (vector->list #'i.datum))))]
(make-Vector (apply Un (map tc-literal (vector->list #'i.datum))))]
[_ Univ]))
@ -55,75 +61,113 @@
[#f null]
[(cons a b) (cons a (loop b))]
[e (list e)])))
(for/fold ([ty ty])
([inst (in-improper-stx inst)])
(cond [(not inst) ty]
[(not (or (Poly? ty) (PolyDots? ty)))
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
[(and (Poly? ty)
(not (= (length (syntax->list inst)) (Poly-n ty))))
(match ty
[(list ty)
(list
(for/fold ([ty ty])
([inst (in-improper-stx inst)])
(cond [(not inst) ty]
[(not (or (Poly? ty) (PolyDots? ty)))
(tc-error/expr #:return (Un) "Cannot instantiate non-polymorphic type ~a" ty)]
[(and (Poly? ty)
(not (= (length (syntax->list inst)) (Poly-n ty))))
(tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
ty (Poly-n ty) (length (syntax->list inst)))]
[(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty)))))
;; we can provide 0 arguments for the ... var
(tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a"
ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))]
[(PolyDots? ty)
;; In this case, we need to check the last thing. If it's a dotted var, then we need to
;; use instantiate-poly-dotted, otherwise we do the normal thing.
(let-values ([(all-but-last last-stx) (split-last (syntax->list inst))])
(match (syntax-e last-stx)
[(cons last-ty-stx (? identifier? last-id-stx))
(unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f)))
(tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx)))
(if (= (length all-but-last) (sub1 (PolyDots-n ty)))
(let* ([last-id (syntax-e last-id-stx)]
[last-ty
(parameterize ([current-tvars (extend-env (list last-id)
(list (make-DottedBoth (make-F last-id)))
(current-tvars))])
(parse-type last-ty-stx))])
(instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id))
(tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
ty (sub1 (PolyDots-n ty)) (length all-but-last)))]
[_
(instantiate-poly ty (map parse-type (syntax->list inst)))]))]
[else
(instantiate-poly ty (map parse-type (syntax->list inst)))])))]
[_ (if inst
(tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
ty (Poly-n ty) (length (syntax->list inst)))]
[(and (PolyDots? ty) (not (>= (length (syntax->list inst)) (sub1 (PolyDots-n ty)))))
;; we can provide 0 arguments for the ... var
(tc-error/expr #:return (Un)
"Wrong number of type arguments to polymorphic type ~a:~nexpected at least: ~a~ngot: ~a"
ty (sub1 (PolyDots-n ty)) (length (syntax->list inst)))]
[(PolyDots? ty)
;; In this case, we need to check the last thing. If it's a dotted var, then we need to
;; use instantiate-poly-dotted, otherwise we do the normal thing.
(let-values ([(all-but-last last-stx) (split-last (syntax->list inst))])
(match (syntax-e last-stx)
[(cons last-ty-stx (? identifier? last-id-stx))
(unless (Dotted? (lookup (current-tvars) (syntax-e last-id-stx) (lambda _ #f)))
(tc-error/stx last-id-stx "~a is not a type variable bound with ..." (syntax-e last-id-stx)))
(if (= (length all-but-last) (sub1 (PolyDots-n ty)))
(let* ([last-id (syntax-e last-id-stx)]
[last-ty
(parameterize ([current-tvars (extend-env (list last-id)
(list (make-DottedBoth (make-F last-id)))
(current-tvars))])
(parse-type last-ty-stx))])
(instantiate-poly-dotted ty (map parse-type all-but-last) last-ty last-id))
(tc-error/expr #:return (Un) "Wrong number of fixed type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
ty (sub1 (PolyDots-n ty)) (length all-but-last)))]
[_
(instantiate-poly ty (map parse-type (syntax->list inst)))]))]
[else
(instantiate-poly ty (map parse-type (syntax->list inst)))])))
"Cannot instantiate expression that produces ~a values"
(if (null? ty) 0 "multiple"))
ty)]))
;; typecheck an identifier
;; the identifier has variable effect
;; tc-id : identifier -> tc-result
(define (tc-id id)
(let* ([ty (lookup-type/lexical id)])
(ret ty (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id)))))
(ret ty
(make-FilterSet (list (make-NotTypeFilter (-val #f) null id))
(list (make-TypeFilter (-val #f) null id)))
(make-Path null id))))
;; typecheck an expression, but throw away the effect
;; tc-expr/t : Expr -> Type
(define (tc-expr/t e) (match (tc-expr e)
[(tc-result: t) t]
[t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))]))
[(tc-result1: t _ _) t]
[t (int-err "tc-expr returned ~a, not a single tc-result, for ~a" t (syntax->datum e))]))
(define (tc-expr/check/t e t)
(match (tc-expr/check e t)
[(tc-result: t) t]))
[(tc-result1: t) t]))
;; check-below : (/\ (Result Type -> Result)
;; check-below : (/\ (Results Type -> Result)
;; (Results Results -> Result)
;; (Type Results -> Type)
;; (Type Type -> Type))
(define (check-below tr1 expected)
(match* (tr1 expected)
[((tc-result: t1 te1 ee1) t2)
[((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _)
expected]
[((tc-results: t1) (tc-results: t2))
(unless (= (length t1) (length t2))
(tc-error/expr "Expected ~a values, but got ~a" (length t2) (length t1)))
(unless (for/and ([t t1] [s t2]) (subtype t s))
(tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
expected]
[((tc-results: t1 f o dty dbound) (tc-results: t2 f o dty dbound))
(unless (andmap subtype t1 t2)
(tc-error/expr "Expected ~a, but got ~a" (stringify t2) (stringify t1)))
expected]
[((tc-result1: t1 f o) (? Type? t2))
(unless (subtype t1 t2)
(tc-error/expr "Expected ~a, but got ~a" t2 t1))
(ret expected)]
[(t1 t2)
(ret t2 f o)]
[((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:)))
(unless (subtype t1 t2)
(tc-error/expr "Expected ~a, but got ~a" t2 t1))
t1]
[((? Type? t1) (tc-result1: t2 f o))
(if (subtype t1 t2)
(tc-error/expr "Expected result with filter ~a and object ~a, got ~a" f o t1)
(tc-error/expr "Expected ~a, but got ~a" t2 t1))
t1]
[((? Type? t1) (? Type? t2))
(unless (subtype t1 t2)
(tc-error/expr "Expected ~a, but got ~a" t2 t1))
expected]))
(define (tc-expr/check/type form expected)
#;(syntax? Type/c . -> . tc-results?)
(tc-expr/check form (ret expected)))
;; tc-expr/check : syntax tc-results -> tc-results
(define (tc-expr/check form expected)
(parameterize ([current-orig-stx form])
;(printf "form: ~a~n" (syntax-object->datum form))
@ -134,8 +178,7 @@
[ret
(lambda args
(define te (apply ret args))
(check-below te expected)
(ret expected))])
(check-below te expected))])
(kernel-syntax-case* form #f
(letrec-syntaxes+values find-method/who) ;; letrec-syntaxes+values is not in kernel-syntax-case literals
[stx
@ -148,15 +191,17 @@
(int-err "internal error: ignore-some"))
(check-below ty expected))]
;; data
[(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))]
[(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))]
[(quote val) (ret (tc-literal #'val))]
[(quote #f) (ret (-val #f) false-filter)]
[(quote #t) (ret (-val #t) true-filter)]
[(quote val) (match expected
[(tc-result1: t)
(ret (tc-literal #'val t) true-filter)])]
;; syntax
[(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))]
[(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)) true-filter)]
;; mutation!
[(set! id val)
(match-let* ([(tc-result: id-t) (tc-expr #'id)]
[(tc-result: val-t) (tc-expr #'val)])
(match-let* ([(tc-result1: id-t) (single-value #'id)]
[(tc-result1: val-t) (single-value #'val)])
(unless (subtype val-t id-t)
(tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t))
(ret -Void))]
@ -170,8 +215,8 @@
(check-below (tc-id #'x) expected)]
;; w-c-m
[(with-continuation-mark e1 e2 e3)
(begin (tc-expr/check #'e1 Univ)
(tc-expr/check #'e2 Univ)
(begin (tc-expr/check/type #'e1 Univ)
(tc-expr/check/type #'e2 Univ)
(tc-expr/check #'e3 expected))]
;; application
[(#%plain-app . _) (tc/app/check form expected)]
@ -187,7 +232,7 @@
(begin (tc-exprs/check (syntax->list #'es) Univ)
(tc-expr/check #'e expected))]
;; if
[(if tst thn els) (tc/if-twoarm/check #'tst #'thn #'els expected)]
[(if tst thn els) (tc/if-twoarm #'tst #'thn #'els expected)]
;; lambda
[(#%plain-lambda formals . body)
(tc/lambda/check form #'(formals) #'(body) expected)]
@ -200,7 +245,7 @@
(tc/send #'rcvr #'meth #'(args ...) expected)]
;; let
[(let-values ([(name ...) expr] ...) . body)
(tc/let-values/check #'((name ...) ...) #'(expr ...) #'body form expected)]
(tc/let-values #'((name ...) ...) #'(expr ...) #'body form expected)]
[(letrec-values ([(name ...) expr] ...) . body)
(tc/letrec-values/check #'((name ...) ...) #'(expr ...) #'body form expected)]
;; other
@ -232,16 +277,16 @@
ty)]
;; data
[(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))]
[(quote #t) (ret (-val #t) (list (make-True-Effect)) (list (make-True-Effect)))]
[(quote #f) (ret (-val #f) false-filter)]
[(quote #t) (ret (-val #t) true-filter)]
[(quote val) (ret (tc-literal #'val))]
[(quote val) (ret (tc-literal #'val) true-filter)]
;; syntax
[(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)))]
[(quote-syntax datum) (ret (-Syntax (tc-literal #'datum)) true-filter)]
;; w-c-m
[(with-continuation-mark e1 e2 e3)
(begin (tc-expr/check #'e1 Univ)
(tc-expr/check #'e2 Univ)
(begin (tc-expr/check/type #'e1 Univ)
(tc-expr/check/type #'e2 Univ)
(tc-expr #'e3))]
;; lambda
[(#%plain-lambda formals . body)
@ -260,8 +305,8 @@
(tc/letrec-values #'((name ...) ...) #'(expr ...) #'body form)]
;; mutation!
[(set! id val)
(match-let* ([(tc-result: id-t) (tc-expr #'id)]
[(tc-result: val-t) (tc-expr #'val)])
(match-let* ([(tc-result1: id-t) (tc-expr #'id)]
[(tc-result1: val-t) (tc-expr #'val)])
(unless (subtype val-t id-t)
(tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t))
(ret -Void))]
@ -277,7 +322,6 @@
;; application
[(#%plain-app . _) (tc/app form)]
;; if
[(if tst body) (tc/if-twoarm #'tst #'body #'(#%app void))]
[(if tst thn els) (tc/if-twoarm #'tst #'thn #'els)]
@ -305,23 +349,29 @@
(tc-expr/check form ann))]
[else (internal-tc-expr form)])])
(match ty
[(tc-result: t eff1 eff2)
(let ([ty* (do-inst form t)])
(ret ty* eff1 eff2))]))))
[(tc-results: ts fs os)
(let ([ts* (do-inst form ts)])
(ret ts* fs os))]))))
(define (tc/send rcvr method args [expected #f])
(match (tc-expr rcvr)
[(tc-result: (Instance: (and c (Class: _ _ methods))))
[(tc-result1: (Instance: (and c (Class: _ _ methods))))
(match (tc-expr method)
[(tc-result: (Value: (? symbol? s)))
[(tc-result1: (Value: (? symbol? s)))
(let* ([ftype (cond [(assq s methods) => cadr]
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
[ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)) expected)])
(if expected
(begin (check-below ret-ty expected) (ret expected))
(begin (check-below ret-ty expected) expected)
ret-ty))]
[(tc-result: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])]
[(tc-result: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)]))
[(tc-result1: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])]
[(tc-result1: t) (tc-error/expr #:return (or expected (ret (Un))) "send: expected a class instance, got ~a" t)]))
(define (single-value form [expected #f])
(define t (if expected (tc-expr/check form expected) (tc-expr form)))
(match t
[(tc-result1: _ _ _) t]
[_ (tc-error/stx form "expected single value, got multiple (or zero) values")]))
;; type-check a list of exprs, producing the type of the last one.
;; if the list is empty, the type is Void.
@ -329,11 +379,11 @@
(define (tc-exprs exprs)
(cond [(null? exprs) (ret -Void)]
[(null? (cdr exprs)) (tc-expr (car exprs))]
[else (tc-expr/check (car exprs) Univ)
[else (tc-expr/check/type (car exprs) Univ)
(tc-exprs (cdr exprs))]))
(define (tc-exprs/check exprs expected)
(cond [(null? exprs) (check-below (ret -Void) expected)]
[(null? (cdr exprs)) (tc-expr/check (car exprs) expected)]
[else (tc-expr/check (car exprs) Univ)
[else (tc-expr/check/type (car exprs) Univ)
(tc-exprs/check (cdr exprs) expected)]))

233
collects/typed-scheme/typecheck/tc-if-unit.ss
View File

@ -1,233 +0,0 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require "signatures.ss"
(rep type-rep effect-rep)
(private type-effect-convenience subtype union type-utils type-comparison mutated-vars)
(env lexical-env)
(only-in (private remove-intersect)
[remove *remove])
(r:infer infer)
(utils tc-utils)
syntax/kerncase
mzlib/trace
mzlib/plt-match)
;; if typechecking
(import tc-expr^)
(export tc-if^)
;; combinators for typechecking in the context of effects
;; t/f tells us whether this is the true or the false branch of an if
;; neccessary for handling true/false effects
;; Boolean Expr listof[Effect] option[type] -> TC-Result
(define (tc-expr/eff t/f expr effs expected)
#;(printf "tc-expr/eff : ~a~n" (syntax-object->datum expr))
;; this flag represents whether the refinement proves that this expression cannot be executed
(let ([flag (box #f)])
;; this does the operation on the old type
;; type-op : (Type Type -> Type) Type -> _ Type -> Type
(define ((type-op f t) _ old)
(let ([new-t (f old t)])
;(printf "f old t new: ~a\n" (list f old t new-t))
;; if this operation produces an uninhabitable type, then this expression can't be executed
(when (type-equal? new-t (Un))
;(printf "setting flag!~n")
(set-box! flag #t))
;; have to return something here, so that we can continue typechecking
new-t))
;; loop : listof[effect] -> tc-result
(let loop ([effs effs])
;; convenience macro for checking the rest of the list
(define-syntax check-rest
(syntax-rules ()
[(check-rest f v)
(with-update-type/lexical f v (loop (cdr effs)))]
[(check-rest f t v)
(check-rest (type-op f t) v)]))
(if (null? effs)
;; base case
(let* ([reachable? (not (unbox flag))])
(unless reachable?
(warn-unreachable expr))
(cond
;; if flag is true, then we don't want to verify that this branch has the appropriate type
;; in particular, it might be (void)
[(and expected reachable?)
(tc-expr/check expr expected)]
;; this code is reachable, but we have no expected type
[reachable?
(tc-expr expr)]
;; otherwise, this code is unreachable
;; and the resulting type should be the empty type
[(check-unreachable-code?)
(tc-expr/check expr Univ)
(ret (Un))]
[else
(ret (Un))]))
;; recursive case
(match (car effs)
;; these effects have no consequence for the typechecking
[(True-Effect:)
(or t/f (set-box! flag #t))
(loop (cdr effs))]
[(False-Effect:)
(and t/f (set-box! flag #t))
(loop (cdr effs))]
;; restrict v to have a type that's a subtype of t
[(Restrict-Effect: t v)
(check-rest restrict t v)]
;; remove t from the type of v
[(Remove-Effect: t v) (check-rest *remove t v)]
;; just replace the type of v with (-val #f)
[(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)]
;; v cannot have type (-val #f)
[(Var-True-Effect: v)
(check-rest *remove (-val #f) v)])))))
;; the main function
(define (tc/if-twoarm tst thn els)
#;(printf "tc-if/twoarm~n")
;; check in the context of the effects, and return
(match-let* ([(tc-result: tst-ty tst-thn-eff tst-els-eff) (tc-expr tst)]
[(tc-result: thn-ty thn-thn-eff thn-els-eff) (tc-expr/eff #t thn tst-thn-eff #f)]
#;[_ (printf "v is ~a~n" v)]
#;[c (current-milliseconds)]
[(tc-result: els-ty els-thn-eff els-els-eff) (tc-expr/eff #f els tst-els-eff #f)])
#;(printf "tst thn-eff: ~a~ntst els-eff: ~a~n" tst-thn-eff tst-els-eff)
#;(printf "thn ty:~a thn-eff: ~a thn els-eff: ~a~n" thn-ty thn-thn-eff thn-els-eff)
#;(printf "els ty:~a thn-eff: ~a els els-eff: ~a~n" els-ty els-thn-eff els-els-eff)
(match* (els-ty thn-thn-eff thn-els-eff els-thn-eff els-els-eff)
;; this is the case for `or'
;; the then branch has to be #t
;; the else branch has to be a simple predicate
;; FIXME - can something simpler be done by using demorgan's law?
;; note that demorgan's law doesn't hold for scheme `and' and `or' because they can produce arbitrary values
;; FIXME - mzscheme's or macro doesn't match this!
[(_ (list (True-Effect:)) (list (True-Effect:)) (list (Restrict-Effect: t v)) (list (Remove-Effect: t v*)))
(=> unmatch)
#;(printf "or branch~n")
(match (list tst-thn-eff tst-els-eff)
;; check that the test was also a simple predicate
[(list (list (Restrict-Effect: s u)) (list (Remove-Effect: s u*)))
(if (and
;; check that all the predicates are for the for the same identifier
(free-identifier=? u u*)
(free-identifier=? v v*)
(free-identifier=? v u))
;; this is just a very simple or
(ret (Un (-val #t) els-ty)
;; the then and else effects are just the union of the two types
(list (make-Restrict-Effect (Un s t) v))
(list (make-Remove-Effect (Un s t) v)))
;; otherwise, something complicated is happening and we bail
(unmatch))]
;; similarly, bail here
[_ (unmatch)])]
;; this is the case for `and'
[(_ _ _ (list (False-Effect:)) (list (False-Effect:)))
#;(printf "and branch~n")
(ret (Un (-val #f) thn-ty)
;; we change variable effects to type effects in the test,
;; because only the boolean result of the test is used
;; whereas, the actual value of the then branch is returned, not just the boolean result
(append (map var->type-eff tst-thn-eff) thn-thn-eff)
;; no else effects for and, because any branch could have been false
(list))]
;; if the else branch can never happen, just use the effect of the then branch
[((Union: (list)) _ _ _ _)
#;(printf "and branch~n")
(ret thn-ty
;; we change variable effects to type effects in the test,
;; because only the boolean result of the test is used
;; whereas, the actual value of the then branch is returned, not just the boolean result
(append #;(map var->type-eff tst-thn-eff) thn-thn-eff)
;; no else effects for and, because any branch could have been false
(append #;(map var->type-eff tst-els-eff) thn-els-eff))]
;; otherwise this expression has no effects
[(_ _ _ _ _)
#;(printf "if base case:~a ~n" (syntax-object->datum tst))
#;(printf "els-ty ~a ~a~n"
els-ty c)
#;(printf "----------------------~nels-ty ~a ~nUn~a~n ~a~n"
els-ty (Un thn-ty els-ty) c)
(ret (Un thn-ty els-ty))])))
;; checking version
(define (tc/if-twoarm/check tst thn els expected)
#;(printf "tc-if/twoarm/check~n")
;; check in the context of the effects, and return
(match-let* ([(tc-result: tst-ty tst-thn-eff tst-els-eff) (tc-expr tst)]
#;[_ (printf "got to here 0~n")]
[(tc-result: thn-ty thn-thn-eff thn-els-eff) (tc-expr/eff #t thn tst-thn-eff expected)]
#;[_ (printf "v is ~a~n" v)]
#;[c (current-milliseconds)]
#;[_ (printf "got to here 1~n")]
[(tc-result: els-ty els-thn-eff els-els-eff) (tc-expr/eff #f els tst-els-eff expected)]
#;[_ (printf "got to here 2~n")])
#;(printf "check: v now is ~a~n" (ret els-ty els-thn-eff els-els-eff))
#;(printf "els-ty ~a ~a~n"
els-ty c)
#;(printf "tst/check thn-eff: ~a~ntst els-eff: ~a~n" tst-thn-eff tst-els-eff)
#;(printf "thn/check thn-eff: ~a~nthn els-eff: ~a~n" thn-thn-eff thn-els-eff)
#;(printf "els/check thn-eff: ~a~nels els-eff: ~a~n" els-thn-eff els-els-eff)
(match* (els-ty thn-thn-eff thn-els-eff els-thn-eff els-els-eff)
;; this is the case for `or'
;; the then branch has to be #t
;; the else branch has to be a simple predicate
;; FIXME - can something simpler be done by using demorgan's law?
;; note that demorgan's law doesn't hold for scheme `and' and `or' because they can produce arbitrary values
;; FIXME - mzscheme's or macro doesn't match this!
[(_ (list (True-Effect:)) (list (True-Effect:)) (list (Restrict-Effect: t v)) (list (Remove-Effect: t v*)))
(=> unmatch)
;(printf "or branch~n")
(match (list tst-thn-eff tst-els-eff)
;; check that the test was also a simple predicate
[(list (list (Restrict-Effect: s u)) (list (Remove-Effect: s u*)))
(if (and
;; check that all the predicates are for the for the same identifier
(free-identifier=? u u*)
(free-identifier=? v v*)
(free-identifier=? v u))
;; this is just a very simple or
(let ([t (Un (-val #t) els-ty)])
(check-below t expected)
(ret t
;; the then and else effects are just the union of the two types
(list (make-Restrict-Effect (Un s t) v))
(list (make-Remove-Effect (Un s t) v))))
;; otherwise, something complicated is happening and we bail
(unmatch))]
;; similarly, bail here
[_ (unmatch)])]
;; this is the case for `and'
[(_ _ _ (list (False-Effect:)) (list (False-Effect:)))
#;(printf "and branch~n")
(let ([t (Un thn-ty (-val #f))])
(check-below t expected)
(ret t
;; we change variable effects to type effects in the test,
;; because only the boolean result of the test is used
;; whereas, the actual value of the then branch is returned, not just the boolean result
(append (map var->type-eff tst-thn-eff) thn-thn-eff)
;; no else effects for and, because any branch could have been false
(list)))]
;; if the else branch can never happen, just use the effect of the then branch
[((Union: (list)) _ _ _ _)
(ret thn-ty
;; we change variable effects to type effects in the test,
;; because only the boolean result of the test is used
;; whereas, the actual value of the then branch is returned, not just the boolean result
thn-thn-eff
;; no else effects for and, because any branch could have been false
thn-els-eff)]
;; otherwise this expression has no effects
[(_ _ _ _ _)
(let ([t (Un thn-ty els-ty)])
(check-below t expected)
(ret t))])))
;)

53
collects/typed-scheme/typecheck/tc-if.ss Normal file
View File

@ -0,0 +1,53 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend]))
(require "signatures.ss"
(rep type-rep filter-rep object-rep)
(rename-in (types convenience subtype union utils comparison remove-intersect)
[remove *remove])
(env lexical-env type-environments)
(r:infer infer)
(utils tc-utils mutated-vars)
(typecheck tc-envops tc-metafunctions)
syntax/kerncase
mzlib/trace
mzlib/plt-match)
;; if typechecking
(import tc-expr^)
(export tc-if^)
(define (tc/if-twoarm tst thn els [expected #f])
(define (tc expr reachable?)
(unless reachable? (warn-unreachable expr))
(cond
;; if reachable? is #f, then we don't want to verify that this branch has the appropriate type
;; in particular, it might be (void)
[(and expected reachable?)
(tc-expr/check expr expected)]
;; this code is reachable, but we have no expected type
[reachable? (tc-expr expr)]
;; otherwise, this code is unreachable
;; and the resulting type should be the empty type
[(check-unreachable-code?)
(tc-expr/check expr Univ)
(ret (Un))]
[else (ret (Un))]))
(match (single-value tst)
[(tc-result1: _ (and f1 (FilterSet: fs+ fs-)) _)
(let-values ([(flag+ flag-) (values (box #t) (box #t))])
(match-let ([(tc-results: ts fs2 os2) (with-lexical-env (env+ (lexical-env) fs+ flag+) (tc thn (unbox flag+)))]
[(tc-results: us fs3 os3) (with-lexical-env (env+ (lexical-env) fs- flag-) (tc els (unbox flag-)))])
;; if we have the same number of values in both cases
(cond [(= (length ts) (length us))
(combine-results
(for/list ([t ts] [u us] [o2 os2] [o3 os3] [f2 fs2] [f3 fs3])
(combine-filter f1 f2 f3 t u o2 o3)))]
[else
(tc-error/expr #:return (ret Err)
"Expected the same number of values from both branches of if expression, but got ~a and ~a"
(length ts) (length us))])))]
[(tc-results: t _ _)
(tc-error/expr #:return (ret (or expected Err))
"Test expression expects one value, given ~a" t)]))

248
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

@ -1,31 +1,43 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend]))
(require "signatures.ss"
(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])
"signatures.ss"
"tc-metafunctions.ss"
mzlib/trace
scheme/list
(except-in (rep type-rep effect-rep) make-arr) ;; doesn't need tests
(private type-effect-convenience type-annotation union type-utils)
stxclass/util syntax/stx
(rename-in scheme/contract [-> -->] [->* -->*] [one-of/c -one-of/c])
(except-in (rep type-rep) make-arr)
(rename-in (types convenience utils union)
[make-arr* make-arr])
(private type-annotation)
(types abbrev utils)
(env type-environments lexical-env)
(utils tc-utils)
mzlib/plt-match
(only-in (private type-effect-convenience) [make-arr* make-arr]))
mzlib/plt-match)
(require (for-template scheme/base "internal-forms.ss"))
(import tc-expr^)
(export tc-lambda^)
(define (remove-var id thns elss)
(let/ec exit
(define (fail) (exit #f))
(define (rv e)
(match e
[(Var-True-Effect: v) (if (free-identifier=? v id) (make-Latent-Var-True-Effect) (fail))]
[(Var-False-Effect: v) (if (free-identifier=? v id) (make-Latent-Var-False-Effect) (fail))]
[(or (True-Effect:) (False-Effect:)) e]
[(Restrict-Effect: t v) (if (free-identifier=? v id) (make-Latent-Restrict-Effect t) (fail))]
[(Remove-Effect: t v) (if (free-identifier=? v id) (make-Latent-Remove-Effect t) (fail))]))
(cons (map rv thns) (map rv elss))))
(d-s/c lam-result ([args (listof (list/c identifier? Type/c))]
[kws (listof (list/c keyword? identifier? Type/c boolean?))]
[rest (or/c #f Type/c)]
[drest (or/c #f (cons/c Type/c symbol?))]
[body tc-results?])
#:transparent)
(define (lam-result->type lr)
(match lr
[(struct lam-result ((list (list arg-ids arg-tys) ...) (list (list kw kw-id kw-ty req?) ...) rest drest body))
(make-arr
arg-tys
(abstract-filters (append (for/list ([i (in-naturals)] [_ arg-ids]) i) kw)
(append arg-ids kw-id)
body)
#:kws (map make-Keyword kw kw-ty req?)
#:rest rest
#:drest drest)]))
(define (expected-str tys-len rest-ty drest arg-len rest)
(format "Expected function with ~a argument~a~a, but got function with ~a argument~a~a"
@ -39,7 +51,7 @@
(if (= arg-len 1) "" "s")
(if rest " and a rest arg" "")))
;; listof[id] option[id] block listof[type] option[type] option[(cons type var)] type
;; listof[id] option[id] block listof[type] option[type] option[(cons type var)] tc-result -> lam-result
(define (check-clause arg-list rest body arg-tys rest-ty drest ret-ty)
(let* ([arg-len (length arg-list)]
[tys-len (length arg-tys)]
@ -50,21 +62,12 @@
[(< arg-len tys-len) (take arg-tys arg-len)]
[(> arg-len tys-len) (append arg-tys
(map (lambda _ (or rest-ty (Un)))
(drop arg-list tys-len)))]))])
(drop arg-list tys-len)))]))])
(define (check-body)
(with-lexical-env/extend
arg-list arg-types
(match (tc-exprs/check (syntax->list body) ret-ty)
[(tc-result: t thn els)
(cond
;; this is T-AbsPred
;; if this function takes only one argument, and all the effects are about that one argument
[(and (not rest-ty) (not drest) (= 1 (length arg-list)) (remove-var (car arg-list) thn els))
=> (lambda (thn/els) (make-arr arg-types t rest-ty drest (car thn/els) (cdr thn/els)))]
;; otherwise, the simple case
[else (make-arr arg-types t rest-ty drest null null)])]
[t (int-err "bad match - not a tc-result: ~a ~a ~a" t ret-ty (syntax->datum body))])))
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
(make lam-result (map list arg-list arg-types) null rest-ty drest
(tc-exprs/check (syntax->list body) ret-ty))))
(when (or (not (= arg-len tys-len))
(and rest (and (not rest-ty)
(not drest))))
@ -95,7 +98,7 @@
;; typecheck a single lambda, with argument list and body
;; drest-ty and drest-bound are both false or not false
;; syntax-list[id] block listof[type] type option[type] option[(cons type var)] -> arr
;; syntax-list[id] block listof[type] tc-result option[type] option[(cons type var)] -> lam-result
(define (tc/lambda-clause/check args body arg-tys ret-ty rest-ty drest)
(syntax-case args ()
[(args* ...)
@ -103,29 +106,23 @@
[(args* ... . rest)
(check-clause (syntax->list #'(args* ...)) #'rest body arg-tys rest-ty drest ret-ty)]))
;; syntax-list[id] block -> arr
;; syntax-list[id] block -> lam-result
(define (tc/lambda-clause args body)
(syntax-case args ()
[(args ...)
(let* ([arg-list (syntax->list #'(args ...))]
[arg-types (get-types arg-list #:default Univ)])
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
(with-lexical-env/extend
arg-list arg-types
(match (tc-exprs (syntax->list body))
[(tc-result: t thn els)
(cond
;; this is T-AbsPred
;; if this function takes only one argument, and all the effects are about that one argument
[(and (= 1 (length arg-list)) (remove-var (car arg-list) thn els))
=> (lambda (thn/els) (make-arr arg-types t #f (car thn/els) (cdr thn/els)))]
;; otherwise, the simple case
[else (make-arr arg-types t)])]
[t (int-err "bad match - not a tc-result: ~a no ret-ty" t)])))]
(make lam-result
(map list arg-list arg-types)
null
#f
#f
(tc-exprs (syntax->list body)))))]
[(args ... . rest)
(let* ([arg-list (syntax->list #'(args ...))]
[arg-types (get-types arg-list #:default Univ)])
#;(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) (cons #'rest arg-list))
(cond
[(dotted? #'rest)
=>
@ -145,19 +142,31 @@
(parameterize ([dotted-env (extend-env (list #'rest)
(list (cons rest-type bound))
(dotted-env))])
(match-let ([(tc-result: t thn els) (tc-exprs (syntax->list body))])
(make-arr-dots arg-types t rest-type bound))))))]
(make lam-result
(map list arg-list arg-types)
null
#f
(cons rest-type bound)
(tc-exprs (syntax->list body)))))))]
[else
(let ([rest-type (get-type #'rest #:default Univ)])
(with-lexical-env/extend
(cons #'rest arg-list)
(cons (make-Listof rest-type) arg-types)
(match-let ([(tc-result: t thn els) (tc-exprs (syntax->list body))])
(make-arr arg-types t rest-type))))]))]))
(make lam-result
(map list arg-list arg-types)
null
rest-type
#f
(tc-exprs (syntax->list body)))))]))]))
;(trace tc-args)
(define (formals->list l)
(let loop ([l (syntax-e l)])
(cond [(stx-pair? l) (cons (stx-car l) (loop (stx-cdr l)))]
[(pair? l) (cons (car l) (loop (cdr l)))]
[else null])))
;; tc/mono-lambda : syntax-list syntax-list -> Funty
;; tc/mono-lambda : syntax-list syntax-list (or/c #f tc-results) -> (listof lam-result)
;; typecheck a sequence of case-lambda clauses
(define (tc/mono-lambda formals bodies expected)
(define (syntax-len s)
@ -169,61 +178,52 @@
[(pair? (syntax-e s))
(+ 1 (loop (cdr (syntax-e s))))]
[else 1]))]))
(if (and expected
(= 1 (length (syntax->list formals))))
;; special case for not-case-lambda
(let loop ([expected expected])
(match expected
[(Mu: _ _) (loop (unfold expected))]
[(Function: (list (arr: argss rets rests drests '() _ _) ...))
(for ([args argss] [ret rets] [rest rests] [drest drests])
(tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))
expected]
[t (let ([t (tc/mono-lambda formals bodies #f)])
(check-below t expected))]))
(let loop ([formals (syntax->list formals)]
[bodies (syntax->list bodies)]
[formals* null]
[bodies* null]
[nums-seen null])
(cond
[(null? formals)
(make-Function (map tc/lambda-clause (reverse formals*) (reverse bodies*)))]
[(memv (syntax-len (car formals)) nums-seen)
;; we check this clause, but it doesn't contribute to the overall type
(tc/lambda-clause (car formals) (car bodies))
(loop (cdr formals) (cdr bodies) formals* bodies* nums-seen)]
[else
(loop (cdr formals) (cdr bodies)
(cons (car formals) formals*)
(cons (car bodies) bodies*)
(cons (syntax-len (car formals)) nums-seen))]))))
(define (go formals bodies formals* bodies* nums-seen)
(cond
[(null? formals)
(map tc/lambda-clause (reverse formals*) (reverse bodies*))]
[(memv (syntax-len (car formals)) nums-seen)
;; we check this clause, but it doesn't contribute to the overall type
(tc/lambda-clause (car formals) (car bodies))
(go (cdr formals) (cdr bodies) formals* bodies* nums-seen)]
[else
(go (cdr formals) (cdr bodies)
(cons (car formals) formals*)
(cons (car bodies) bodies*)
(cons (syntax-len (car formals)) nums-seen))]))
(cond
;; special case for not-case-lambda
[(and expected
(= 1 (length (syntax->list formals))))
(let loop ([expected expected])
(match expected
[(tc-result1: (and t (Mu: _ _))) (loop (ret (unfold t)))]
[(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...)))
(for/list ([args argss] [ret rets] [rest rests] [drest drests])
(tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies))
args (values->tc-results ret (formals->list (car (syntax->list formals)))) rest drest))]
[_ (go (syntax->list formals) (syntax->list bodies) null null null)]))]
;; otherwise
[else (go (syntax->list formals) (syntax->list bodies) null null null)]))
;; tc/lambda : syntax syntax-list syntax-list -> tc-result
(define (tc/lambda form formals bodies)
(tc/lambda/internal form formals bodies #f))
;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic
;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result
(define (tc/lambda/internal form formals bodies expected)
(if (or (syntax-property form 'typechecker:plambda) (Poly? expected) (PolyDots? expected))
(tc/plambda form formals bodies expected)
(ret (tc/mono-lambda formals bodies expected))))
;; tc/lambda : syntax syntax-list syntax-list Type -> tc-result
(define (tc/lambda/check form formals bodies expected)
(tc/lambda/internal form formals bodies expected))
(define (tc/mono-lambda/type formals bodies expected)
(define t (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))
(if expected
(and (check-below (ret t true-filter) expected) t)
t))
;; tc/plambda syntax syntax-list syntax-list type -> Poly
;; formals and bodies must by syntax-lists
(define (tc/plambda form formals bodies expected)
(define (maybe-loop form formals bodies expected)
(d/c (tc/plambda form formals bodies expected)
(syntax? syntax? syntax? (or/c tc-results? #f) . --> . Type/c)
(d/c (maybe-loop form formals bodies expected)
(syntax? syntax? syntax? tc-results? . --> . Type/c)
(match expected
[(Function: _) (tc/mono-lambda formals bodies expected)]
[(or (Poly: _ _) (PolyDots: _ _))
[(tc-result1: (Function: _)) (tc/mono-lambda/type formals bodies expected)]
[(tc-result1: (or (Poly: _ _) (PolyDots: _ _)))
(tc/plambda form formals bodies expected)]))
(match expected
[(Poly-names: ns expected*)
[(tc-result1: (and t (Poly-names: ns expected*)))
(let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)])
(when (and (pair? p) (eq? '... (car (last p))))
(tc-error "Expected a polymorphic function without ..., but given function had ..."))
@ -232,10 +232,10 @@
[literal-tvars tvars]
[new-tvars (map make-F literal-tvars)]
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(maybe-loop form formals bodies expected*))])
(maybe-loop form formals bodies (ret expected*)))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret expected))]
[(PolyDots-names: (list ns ... dvar) expected*)
t)]
[(tc-result1: (and t (PolyDots-names: (list ns ... dvar) expected*)))
(let-values
([(tvars dotted)
(let ([p (syntax-property form 'typechecker:plambda)])
@ -251,8 +251,8 @@
(cons (make-Dotted (make-F dotted))
new-tvars)
(current-tvars))])
(maybe-loop form formals bodies expected*))])
(ret expected)))]
(maybe-loop form formals bodies (ret expected*)))])
t))]
[#f
(match (map syntax-e (syntax->list (syntax-property form 'typechecker:plambda)))
[(list tvars ... dotted-var '...)
@ -261,20 +261,37 @@
[ty (parameterize ([current-tvars (extend-env (cons dotted-var literal-tvars)
(cons (make-Dotted (make-F dotted-var)) new-tvars)
(current-tvars))])
(tc/mono-lambda formals bodies #f))])
(ret (make-PolyDots (append literal-tvars (list dotted-var)) ty)))]
(tc/mono-lambda/type formals bodies #f))])
(make-PolyDots (append literal-tvars (list dotted-var)) ty))]
[tvars
(let* ([literal-tvars tvars]
[new-tvars (map make-F literal-tvars)]
[ty (parameterize ([current-tvars (extend-env literal-tvars new-tvars (current-tvars))])
(tc/mono-lambda formals bodies #f))])
(tc/mono-lambda/type formals bodies #f))])
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
(ret (make-Poly literal-tvars ty)))])]
(make-Poly literal-tvars ty))])]
[_
(unless (check-below (tc/plambda form formals bodies #f) expected)
(tc-error/expr #:return (ret expected) "Expected a value of type ~a, but got a polymorphic function." expected))
(ret expected)]))
(tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected))
expected]))
;; typecheck a sequence of case-lambda clauses, which is possibly polymorphic
;; tc/lambda/internal syntax syntax-list syntax-list option[type] -> tc-result
(define (tc/lambda/internal form formals bodies expected)
(if (or (syntax-property form 'typechecker:plambda)
(match expected
[(tc-result1: t) (or (Poly? t) (PolyDots? t))]
[_ #f]))
(ret (tc/plambda form formals bodies expected) true-filter)
(ret (tc/mono-lambda/type formals bodies expected) true-filter)))
;; tc/lambda : syntax syntax-list syntax-list -> tc-result
(define (tc/lambda form formals bodies)
(tc/lambda/internal form formals bodies #f))
;; tc/lambda/check : syntax syntax-list syntax-list Type -> tc-result
(define (tc/lambda/check form formals bodies expected)
(tc/lambda/internal form formals bodies expected))
;; form : a syntax object for error reporting
;; formals : the formal arguments to the loop
@ -282,14 +299,15 @@
;; name : the name of the loop
;; args : the types of the actual arguments to the loop
;; ret : the expected return type of the whole expression
(define (tc/rec-lambda/check form formals body name args ret)
(define (tc/rec-lambda/check form formals body name args return)
(with-lexical-env/extend
(syntax->list formals) args
(let ([t (->* args ret)])
(let* ([r (tc-results->values return)]
[t (make-arr args r)]
[ft (make-Function (list t))])
(with-lexical-env/extend
(list name) (list t)
(begin (tc-exprs/check (syntax->list body) ret)
(make-Function (list t)))))))
(list name) (list ft)
(begin (tc-exprs/check (syntax->list body) return) (ret ft))))))
;(trace tc/mono-lambda)

64
collects/typed-scheme/typecheck/tc-let-unit.ss
View File

@ -1,13 +1,14 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require "signatures.ss"
(private type-effect-convenience type-annotation parse-type type-utils)
(require "signatures.ss" "tc-metafunctions.ss"
(types utils convenience)
(private type-annotation parse-type)
(env lexical-env type-alias-env type-env)
syntax/free-vars
mzlib/trace
scheme/match
syntax/kerncase
syntax/kerncase stxclass
(for-template
scheme/base
"internal-forms.ss"))
@ -28,32 +29,11 @@
(for-each expr->type
clauses
exprs
(map -values types))
(map ret types))
(if expected
(tc-exprs/check (syntax->list body) expected)
(tc-exprs (syntax->list body)))))
#|
;; this is more abstract, but sucks
(define ((mk f) namess exprs body form)
(let* ([names (map syntax->list (syntax->list namess))]
[exprs (syntax->list exprs)])
(f (lambda (e->t namess types exprs) (do-check e->t namess types form exprs body)) names exprs)))
(define tc/letrec-values
(mk (lambda (do names exprs)
(let ([types (map (lambda (l) (map get-type l)) names)])
(do tc-expr/t names types exprs)))))
(define tc/let-values
(mk (lambda (do names exprs)
(let* (;; the types of the exprs
[inferred-types (map tc-expr/t exprs)]
;; the annotated types of the name (possibly using the inferred types)
[types (map get-type/infer names inferred-types)])
(do (lambda (x) x) names types inferred-types)))))
|#
(define (tc/letrec-values/check namess exprs body form expected)
(tc/letrec-values/internal namess exprs body form expected))
@ -71,8 +51,7 @@
(andmap values expecteds)
(tc-expr/check e (mk expecteds))
(tc-expr e)))
(match tcr
[(tc-result: t) t]))
tcr)
(define (tc/letrec-values/internal namess exprs body form expected)
(let* ([names (map syntax->list (syntax->list namess))]
@ -99,25 +78,25 @@
;; then check this expression separately
(with-lexical-env/extend
(list (car names))
(list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names))) tc-expr/check/t))
(list (match (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names)))
tc-expr/check)
[(tc-results: ts) ts]))
(loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))]
[else
;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names)
(do-check (lambda (stx e t) (tc-expr/check/t e t))
(do-check (lambda (stx e t) (tc-expr/check e t))
names (map (lambda (l) (map get-type l)) names) form exprs body clauses expected)]))))
;; this is so match can provide us with a syntax property to
;; say that this binding is only called in tail position
(define ((tc-expr-t/maybe-expected expected) e)
(kernel-syntax-case e #f
(syntax-parse e #:literals (#%plain-lambda)
[(#%plain-lambda () _)
(and expected (syntax-property e 'typechecker:called-in-tail-position))
(begin
(tc-expr/check e (-> expected))
(-> expected))]
[_ (tc-expr/t e)]))
#:when (and expected (syntax-property e 'typechecker:called-in-tail-position))
(tc-expr/check e (ret (-> (tc-results->values expected))))]
[_ (tc-expr e)]))
(define (tc/let-values/internal namess exprs body form expected)
(define (tc/let-values namess exprs body form [expected #f])
(let* (;; a list of each name clause
[names (map syntax->list (syntax->list namess))]
;; all the trailing expressions - the ones actually bound to the names
@ -125,17 +104,12 @@
;; the types of the exprs
#;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)]
;; the annotated types of the name (possibly using the inferred types)
[types (for/list ([name names] [e exprs]) (get-type/infer name e (tc-expr-t/maybe-expected expected) tc-expr/check/t))]
[types (for/list ([name names] [e exprs])
(match (get-type/infer name e (tc-expr-t/maybe-expected expected)
tc-expr/check)
[(tc-results: ts) ts]))]
;; the clauses for error reporting
[clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])])
(do-check void names types form types body clauses expected)))
(define (tc/let-values/check namess exprs body form expected)
(tc/let-values/internal namess exprs body form expected))
(define (tc/let-values namess exprs body form)
(tc/let-values/internal namess exprs body form #f))
;(trace tc/letrec-values/internal)

191
collects/typed-scheme/typecheck/tc-metafunctions.ss Normal file
View File

@ -0,0 +1,191 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rename-in (types subtype convenience remove-intersect union utils)
[-> -->]
[->* -->*]
[one-of/c -one-of/c])
(rep type-rep)
scheme/contract scheme/match
stxclass/util
(for-syntax scheme/base))
(provide combine-filter apply-filter abstract-filter abstract-filters
split-lfilters merge-filter-sets values->tc-results tc-results->values)
;; this implements the sequence invariant described on the first page relating to Bot
(define (lcombine l1 l2)
(cond [(memq (make-LBot) l1)
(make-LFilterSet (list (make-LBot)) null)]
[(memq (make-LBot) l2)
(make-LFilterSet null (list (make-LBot)))]
[else (make-LFilterSet l1 l2)]))
(define (combine l1 l2)
(cond [(memq (make-Bot) l1)
(make-FilterSet (list (make-Bot)) null)]
[(memq (make-Bot) l2)
(make-FilterSet null (list (make-Bot)))]
[else (make-FilterSet l1 l2)]))
(d/c (abstract-filters keys ids results)
((listof index/c) (listof identifier?) tc-results? . -> . (or/c Values? ValuesDots?))
(define (mk l [drest #f])
(if drest (make-ValuesDots l (car drest) (cdr drest)) (make-Values l)))
(match results
[(tc-results: ts fs os dty dbound)
(make-ValuesDots
(for/list ([t ts]
[f fs]
[o os])
(make-Result t (abstract-filter ids keys f) (abstract-object ids keys o)))
dty dbound)]
[(tc-results: ts fs os)
(make-Values
(for/list ([t ts]
[f fs]
[o os])
(make-Result t (abstract-filter ids keys f) (abstract-object ids keys o))))]))
(define/contract (abstract-object ids keys o)
(-> (listof identifier?) (listof index/c) Object? LatentObject?)
(define (lookup y)
(for/first ([x ids] [i keys] #:when (free-identifier=? x y)) i))
(define-match-expander lookup:
(syntax-rules ()
[(_ i) (app lookup (? values i))]))
(match o
[(Path: p (lookup: idx)) (make-LPath p idx)]
[_ (make-LEmpty)]))
(d/c (abstract-filter ids keys fs)
(-> (listof identifier?) (listof index/c) FilterSet? LFilterSet?)
(match fs
[(FilterSet: f+ f-)
(lcombine
(apply append (for/list ([f f+]) (abo ids keys f)))
(apply append (for/list ([f f-]) (abo ids keys f))))]))
(d/c (abo xs idxs f)
(-> (listof identifier?) (listof index/c) Filter/c (or/c '() (list/c LatentFilter/c)))
(define (lookup y)
(for/first ([x xs] [i idxs] #:when (free-identifier=? x y)) i))
(define-match-expander lookup:
(syntax-rules ()
[(_ i) (app lookup (? values i))]))
(match f
[(Bot:) (list (make-LBot))]
[(TypeFilter: t p (lookup: idx)) (list (make-LTypeFilter t p idx))]
[(NotTypeFilter: t p (lookup: idx)) (list (make-LNotTypeFilter t p idx))]
[_ null]))
(define (merge-filter-sets fs)
(match fs
[(list (FilterSet: f+ f-) ...)
(make-FilterSet (apply append f+) (apply append f-))]))
(d/c (apply-filter lfs t o)
(-> LFilterSet? Type/c Object? FilterSet?)
(match lfs
[(LFilterSet: lf+ lf-)
(combine
(apply append (for/list ([lf lf+]) (apo lf t o)))
(apply append (for/list ([lf lf-]) (apo lf t o))))]))
(d/c (apo lf s o)
(-> LatentFilter/c Type/c Object? (or/c '() (list/c Filter/c)))
(match* (lf s o)
[((LBot:) _ _) (list (make-Bot))]
[((LNotTypeFilter: (? (lambda (t) (subtype s t)) t) (list) _) _ _) (list (make-Bot))]
[((LTypeFilter: (? (lambda (t) (not (overlap s t))) t) (list) _) _ _) (list (make-Bot))]
[(_ _ (Empty:)) null]
[((LTypeFilter: t pi* _) _ (Path: pi x)) (list (make-TypeFilter t (append pi* pi) x))]
[((LNotTypeFilter: t pi* _) _ (Path: pi x)) (list (make-NotTypeFilter t (append pi* pi) x))]))
(define/contract (split-lfilters lf idx)
(LFilterSet? index/c . -> . LFilterSet?)
(define (idx= lf)
(match lf
[(LBot:) #t]
[(LNotTypeFilter: _ _ idx*) (type-equal? idx* idx)]
[(LTypeFilter: _ _ idx*) (type-equal? idx* idx)]))
(match lf
[(LFilterSet: lf+ lf-)
(make-LFilterSet (filter idx= lf+) (filter idx= lf-))]))
(define-match-expander T-FS:
(lambda (stx) #'(FilterSet: _ (list (Bot:)))))
(define-match-expander F-FS:
(lambda (stx) #'(FilterSet: (list (Bot:)) _)))
(d/c (combine-filter f1 f2 f3 t2 t3 o2 o3)
(FilterSet? FilterSet? FilterSet? Type? Type? Object? Object? . -> . tc-results?)
(define (mk f) (ret (Un t2 t3) f (make-Empty)))
(match* (f1 f2 f3)
[((T-FS:) f _) (ret t2 f o2)]
[((F-FS:) _ f) (ret t3 f o3)]
;; skipping the general or/predicate rule because it's really complicated
;; or/predicate special case for one elem lists
;; note that we are relying on equal? on identifiers here
[((FilterSet: (list (TypeFilter: t pi x)) (list (NotTypeFilter: t pi x)))
(T-FS:)
(FilterSet: (list (TypeFilter: s pi x)) (list (NotTypeFilter: s pi x))))
(mk (make-FilterSet (list (make-TypeFilter (Un t s) pi x)) (list (make-NotTypeFilter (Un t s) pi x))))]
;; or
[((FilterSet: f1+ f1-) (T-FS:) (FilterSet: f3+ f3-)) (mk (combine null (append f1- f3-)))]
;; and
[((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:))
(mk (combine (append f1+ f2+) null))]
[(f f* f*) (mk f*)]
;; the student expansion
[(f (T-FS:) (F-FS:)) (mk f)]
[(_ _ _)
;; could intersect f2 and f3 here
(mk (make-FilterSet null null))]))
;; (or/c Values? ValuesDots?) listof[identifier] -> tc-results?
(define (values->tc-results tc formals)
(match tc
[(ValuesDots: (list (Result: ts lfs los) ...) dty dbound)
(ret ts
(for/list ([lf lfs])
(or
(and (null? formals)
(match lf
[(LFilterSet: lf+ lf-)
(combine (if (memq (make-LBot) lf+) (list (make-Bot)) (list))
(if (memq (make-LBot) lf-) (list (make-Bot)) (list)))]))
(merge-filter-sets
(for/list ([x formals] [i (in-naturals)])
(apply-filter (split-lfilters lf i) Univ (make-Path null x))))))
(for/list ([lo los])
(or
(for/or ([x formals] [i (in-naturals)])
(match lo
[(LEmpty:) #f]
[(LPath: p (== i)) (make-Path p x)]))
(make-Empty)))
dty dbound)]
[(Values: (list (Result: ts lfs los) ...))
(ret ts
(for/list ([lf lfs])
(or
(and (null? formals)
(match lf
[(LFilterSet: lf+ lf-)
(combine (if (memq (make-LBot) lf+) (list (make-Bot)) (list))
(if (memq (make-LBot) lf-) (list (make-Bot)) (list)))]))
(merge-filter-sets
(for/list ([x formals] [i (in-naturals)])
(apply-filter (split-lfilters lf i) Univ (make-Path null x))))))
(for/list ([lo los])
(or
(for/or ([x formals] [i (in-naturals)])
(match lo
[(LEmpty:) #f]
[(LPath: p (== i)) (make-Path p x)]))
(make-Empty))))]))
(define (tc-results->values tc)
(match tc
[(tc-results: ts) (-values ts)]))

13
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -2,9 +2,8 @@
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep)
(private type-effect-convenience
type-utils parse-type
union resolve-type)
(private parse-type)
(types convenience utils union resolve abbrev)
(env type-env type-environments type-name-env)
(utils tc-utils)
"def-binding.ss"
@ -130,7 +129,13 @@
(wrapper (->* external-fld-types (if cret cret name))))
(cons pred
(make-pred-ty (pred-wrapper name))))
(map (lambda (g t) (cons g (wrapper (->* (list name) t)))) getters external-fld-types/no-parent)
(for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
(let ([func (if setters?
(->* (list name) t)
(make-Function
(list (make-arr* (list name) t
#:object (make-LPath (list (make-StructPE name i)) 0)))))])
(cons g (wrapper func))))
(if setters?
(map (lambda (g t) (cons g (wrapper (->* (list name t) -Void)))) setters external-fld-types/no-parent)
null)))

25
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -8,10 +8,11 @@
"signatures.ss"
"tc-structs.ss"
(rep type-rep)
(private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract)
(env type-env init-envs type-name-env type-alias-env lexical-env)
(utils tc-utils)
"provide-handling.ss"
(types utils convenience)
(private parse-type type-annotation type-contract)
(env type-env init-envs type-name-env type-alias-env lexical-env)
(utils tc-utils mutated-vars)
"provide-handling.ss"
"def-binding.ss"
(for-template
"internal-forms.ss"
@ -40,13 +41,14 @@
(list)]
;; declare-refinement
;; FIXME - this sucks and should die
[(define-values () (begin (quote-syntax (declare-refinement-internal pred)) (#%plain-app values)))
(match (lookup-type/lexical #'pred)
[(and t (Function: (list (arr: (list dom) rng #f #f '() _ _))))
(register-type #'pred
(make-pred-ty (list dom)
rng
(make-Refinement dom #'pred (syntax-local-certifier))))
[(and t (Function: (list (arr: (list dom) (Values: (list (Result: rng _ _))) #f #f '()))))
(let ([new-t (make-pred-ty (list dom)
rng
(make-Refinement dom #'pred (syntax-local-certifier)))])
(register-type #'pred new-t))
(list)]
[t (tc-error "cannot declare refinement for non-predicate ~a" t)])]
@ -112,7 +114,7 @@
(begin0 (tc-expr #'expr)
(restore-errors!))))
=> (match-lambda
[(tc-result: t)
[(tc-result1: t)
(register-type (car vars) t)
(list (make-def-binding (car vars) t))]
[t (int-err "~a is not a tc-result" t)])]
@ -159,6 +161,7 @@
[(define-syntaxes . _) (void)]
[(define-values-for-syntax . _) (void)]
;; FIXME - we no longer need these special cases
;; these forms are handled in pass1
[(define-values () (begin (quote-syntax (require/typed-internal . rest)) (#%plain-app values)))
(void)]
@ -171,7 +174,7 @@
[(define-values (var ...) expr)
(let* ([vars (syntax->list #'(var ...))]
[ts (map lookup-type vars)])
(tc-expr/check #'expr (-values ts)))
(tc-expr/check #'expr (ret ts)))
(void)]
;; to handle the top-level, we have to recur into begins

4
collects/typed-scheme/typecheck/typechecker.ss
View File

@ -6,8 +6,8 @@
(only-in scheme/unit
provide-signature-elements
define-values/invoke-unit/infer link)
"signatures.ss" "tc-toplevel.ss"
"tc-if-unit.ss" "tc-lambda-unit.ss" "tc-app-unit.ss"
"signatures.ss" "tc-toplevel.ss"
"tc-if.ss" "tc-lambda-unit.ss" "tc-app.ss"
"tc-let-unit.ss" "tc-dots-unit.ss"
"tc-expr-unit.ss" "check-subforms-unit.ss")

53
collects/typed-scheme/typed-scheme.ss
View File

@ -2,10 +2,12 @@
(require (rename-in "utils/utils.ss" [infer r:infer]))
(require (private #;base-env base-types)
(require (private base-types)
(for-syntax
(except-in stxclass id)
scheme/base
(private type-utils type-contract type-effect-convenience)
(private type-contract)
(types utils convenience)
(typecheck typechecker provide-handling)
(env type-environments type-name-env type-alias-env)
(r:infer infer)
@ -46,7 +48,9 @@
[with-handlers
([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e))))
(lambda (e) (tc-error "Internal error: ~a" e))])]
[parameterize (;; a cheat to avoid units
[parameterize (;; disable fancy printing
[custom-printer #t]
;; a cheat to avoid units
[infer-param infer]
;; do we report multiple errors
[delay-errors? #t]
@ -116,28 +120,29 @@
[expanded-module-stx body2])]
;; typecheck the body, and produce syntax-time code that registers types
[let ([type (tc-toplevel-form body2)])])
(kernel-syntax-case body2 #f
[(head . _)
(or (free-identifier=? #'head #'define-values)
(free-identifier=? #'head #'define-syntaxes)
(free-identifier=? #'head #'require)
(free-identifier=? #'head #'provide)
(free-identifier=? #'head #'begin)
(void? type)
(type-equal? -Void (tc-result-t type)))
(define-syntax-class invis-kw
#:literals (define-values define-syntaxes #%require #%provide begin)
(pattern define-values)
(pattern define-syntaxes)
(pattern #%require)
(pattern #%provide)
(pattern begin))
(syntax-parse body2
[(head:invis-kw . _)
body2]
;; construct code to print the type
[_
(nest
([with-syntax ([b body2]
[ty-str (match type
[(tc-result: t)
(format "- : ~a\n" t)]
[x (int-err "bad type result: ~a" x)])])])
#`(let ([v b] [type 'ty-str])
(begin0
v
(printf type))))]))]))
[_ (let ([ty-str (match type
[(tc-result1: (? (lambda (t) (type-equal? t -Void)))) #f]
[(tc-result1: t)
(format "- : ~a\n" t)]
[(tc-results: t)
(format "- : ~a\n" (cons 'Values t))]
[x (int-err "bad type result: ~a" x)])])
(if ty-str
#`(let ([type '#,ty-str])
(begin0
#,body2
(display type)))
body2))]))]))

270
collects/typed-scheme/types/abbrev.ss Normal file
View File

@ -0,0 +1,270 @@
#lang scheme
(require "../utils/utils.ss")
(require (rep type-rep object-rep filter-rep)
"printer.ss" "utils.ss"
(utils tc-utils)
scheme/list
scheme/match
scheme/promise
(prefix-in c: scheme/contract)
(for-syntax scheme/base stxclass)
(for-template scheme/base scheme/contract scheme/tcp))
(provide (all-defined-out)
(rename-out [make-Listof -lst]))
;; convenient constructors
(define -pair make-Pair)
(define -val make-Value)
(define -Param make-Param)
(define -box make-Box)
(define -vec make-Vector)
(define -LFS make-LFilterSet)
(define -FS make-FilterSet)
(define-syntax *Un
(syntax-rules ()
[(_ . args) (make-Union (list . args))]))
(define (make-Listof elem) (-mu list-rec (*Un (-val null) (-pair elem list-rec))))
(define (-lst* #:tail [tail (-val null)] . args)
(if (null? args)
tail
(-pair (car args) (apply -lst* #:tail tail (cdr args)))))
(define (-Tuple l)
(foldr -pair (-val '()) l))
(define (untuple t)
(match t
[(Value: '()) null]
[(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]
[else #f])]
[_ #f]))
(d/c (-result t [f -no-lfilter] [o -no-lobj])
(c:->* (Type/c) (LFilterSet? LatentObject?) Result?)
(make-Result t f o))
(d/c (-values args)
(c:-> (listof Type/c) Values?)
(make-Values (for/list ([i args]) (-result i))))
;; basic types
(define make-promise-ty
(let ([s (string->uninterned-symbol "Promise")])
(lambda (t)
(make-Struct s #f (list t) #f #f #'promise? values))))
(define -Listof (-poly (list-elem) (make-Listof list-elem)))
(define -Number (make-Base 'Number #'number?))
(define -Integer (make-Base 'Integer #'exact-integer?))
(define -Boolean (make-Base 'Boolean #'boolean?))
(define -Symbol (make-Base 'Symbol #'symbol?))
(define -Void (make-Base 'Void #'void?))
(define -Bytes (make-Base 'Bytes #'bytes?))
(define -Regexp (make-Base 'Regexp #'(and/c regexp? (not/c pregexp?) (not/c byte-regexp?))))
(define -PRegexp (make-Base 'PRegexp #'(and/c pregexp? (not/c byte-pregexp?))))
(define -Byte-Regexp (make-Base 'Byte-Regexp #'(and/c byte-regexp? (not/c byte-pregexp?))))
(define -Byte-PRegexp (make-Base 'Byte-PRegexp #'byte-pregexp?))
(define -String (make-Base 'String #'string?))
(define -Keyword (make-Base 'Keyword #'keyword?))
(define -Char (make-Base 'Char #'char?))
(define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?))
(define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?))
(define -Path (make-Base 'Path #'path?))
(define -Namespace (make-Base 'Namespace #'namespace?))
(define -Output-Port (make-Base 'Output-Port #'output-port?))
(define -Input-Port (make-Base 'Input-Port #'input-port?))
(define -TCP-Listener (make-Base 'TCP-Listener #'tcp-listener?))
(define -Syntax make-Syntax)
(define -HT make-Hashtable)
(define -Promise make-promise-ty)
(define Univ (make-Univ))
(define Err (make-Error))
(define -Nat -Integer)
(define -Real -Number)
(define Any-Syntax
(-mu x
(-Syntax (*Un
-Number
-Boolean
-Symbol
-String
-Keyword
(-mu y (*Un (-val '()) (-pair x (*Un x y))))
(make-Vector x)
(make-Box x)))))
(define Ident (-Syntax -Symbol))
(define -Sexp (-mu x (*Un (-val null) -Number -Boolean -Symbol -String (-pair x x))))
(define -Port (*Un -Output-Port -Input-Port))
(define -Pathlike (*Un -String -Path))
(define -Pathlike* (*Un -String -Path (-val 'up) (-val 'same)))
(define -Pattern (*Un -Bytes -Regexp -PRegexp -Byte-Regexp -Byte-PRegexp -String))
(define -Byte -Number)
(define -no-lfilter (make-LFilterSet null null))
(define -no-filter (make-FilterSet null null))
(define -no-lobj (make-LEmpty))
(define -no-obj (make-Empty))
(define -car (make-CarPE))
(define -cdr (make-CdrPE))
;; convenient syntax
(define-syntax -v
(syntax-rules ()
[(_ x) (make-F 'x)]))
(define-syntax -poly
(syntax-rules ()
[(_ (vars ...) ty)
(let ([vars (-v vars)] ...)
(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
(syntax-rules ()
[(_ var ty)
(let ([var (-v var)])
(make-Mu 'var ty))]))
;; function type constructors
(define top-func (make-Function (list (make-top-arr))))
(d/c (make-arr* dom rng
#:rest [rest #f] #:drest [drest #f] #:kws [kws null]
#:filters [filters -no-lfilter] #:object [obj -no-lobj])
(c:->* ((listof Type/c) (or/c Values? ValuesDots? Type/c))
(#:rest (or/c #f Type/c)
#:drest (or/c #f (cons/c Type/c symbol?))
#:kws (listof Keyword?)
#:filters LFilterSet?
#:object LatentObject?)
arr?)
(make-arr dom (if (or (Values? rng) (ValuesDots? rng))
rng
(make-Values (list (-result rng filters obj))))
rest drest (sort #:key Keyword-kw kws keyword<?)))
(define-syntax (->* stx)
(define-syntax-class c
(pattern x:id #:when (eq? ': (syntax-e #'x))))
(syntax-parse stx
[(_ dom rng)
#'(make-Function (list (make-arr* dom rng)))]
[(_ dom rst rng)
#'(make-Function (list (make-arr* dom rng #:rest rst)))]
[(_ dom rng :c filters)
#'(make-Function (list (make-arr* dom rng #:filters filters)))]
[(_ dom rng _:c filters _:c object)
#'(make-Function (list (make-arr* dom rng #:filters filters #:object object)))]
[(_ dom rst rng _:c filters)
#'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))]
[(_ dom rst rng _:c filters : object)
#'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))]))
(define-syntax (-> stx)
(define-syntax-class c
(pattern x:id #:when (eq? ': (syntax-e #'x))))
(syntax-parse stx
[(_ dom ... rng _:c filters _:c objects)
#'(->* (list dom ...) rng : filters : objects)]
[(_ dom ... rng :c filters)
#'(->* (list dom ...) rng : filters)]
[(_ dom ... rng)
#'(->* (list dom ...) rng)]))
(define-syntax ->...
(syntax-rules (:)
[(_ dom rng)
(->* dom rng)]
[(_ dom (dty dbound) rng)
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound))))]
[(_ dom rng : filters)
(->* dom rng : filters)]
[(_ dom (dty dbound) rng : filters)
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))]))
(define (->acc dom rng path)
(make-Function (list (make-arr* dom rng
#:filters (-LFS (list (-not-filter (-val #f) path))
(list (-filter (-val #f) path)))
#:object (make-LPath path 0)))))
(define (cl->* . args)
(define (funty-arities f)
(match f
[(Function: as) as]))
(make-Function (apply append (map funty-arities args))))
(define-syntax cl->
(syntax-parser
[(_ [(dom ...) rng] ...)
#'(cl->* (dom ... . -> . rng) ...)]))
(define-syntax (->key stx)
(syntax-parse stx
[(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng)
#'(make-Function
(list
(make-arr* (list ty ...)
rng
#:kws (list (make-Keyword 'k kty opt) ...))))]))
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #:drest (cons dty dbound)))
(define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values])
(make-Struct name parent flds proc poly pred cert))
(define (-filter t [p null] [i 0])
(make-LTypeFilter t p i))
(define (-not-filter t [p null] [i 0])
(make-LNotTypeFilter t p i))
(d/c make-pred-ty
(case-> (c:-> Type/c Type/c)
(c:-> (listof Type/c) Type/c Type/c Type/c))
(case-lambda
[(in out t)
(->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))]
[(t) (make-pred-ty (list Univ) -Boolean t)]))
(define true-filter (-FS (list) (list (make-Bot))))
(define false-filter (-FS (list (make-Bot)) (list)))
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])
(make-Function (list (make-arr* (append args (take opt-args i)) result))))))
(define-syntax-rule (->opt args ... [opt ...] res)
(opt-fn (list args ...) (list opt ...) res))

2
collects/typed-scheme/private/type-comparison.ss → collects/typed-scheme/types/comparison.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rep type-rep) "type-utils.ss")
(require (rep type-rep) (types utils))
(provide type-equal? tc-result-equal? type<? type-compare effects-equal?)

47
collects/typed-scheme/types/convenience.ss Normal file
View File

@ -0,0 +1,47 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rep type-rep filter-rep object-rep)
(utils tc-utils)
"abbrev.ss"
(types comparison printer union subtype utils)
scheme/list
scheme/match
scheme/promise
(for-syntax stxclass)
(for-syntax scheme/base)
(for-template scheme/base))
(provide (all-defined-out)
(all-from-out "abbrev.ss")
;; these should all eventually go away
make-Name make-ValuesDots make-Function
(rep-out filter-rep object-rep))
(define (one-of/c . args)
(apply Un (map -val args)))
(define (Un/eff . args)
(apply Un (map tc-result-t args)))
;; if t is of the form (Pair t* (Pair t* ... (Listof t*)))
;; return t*
;; otherwise, return t
;; generalize : Type -> Type
(define (generalize t)
(let/ec exit
(let loop ([t* t])
(match t*
[(Value: '()) (-lst Univ)]
[(Mu: var (Union: (list (Value: '()) (Pair: _ (F: var))))) t*]
[(Pair: t1 t2)
(let ([t-new (loop t2)])
(if (type-equal? (-lst t1) t-new)
t-new
(exit t)))]
[_ (exit t)]))))
;; DO NOT USE if t contains #f
(define (-opt t) (Un (-val #f) t))

100
collects/typed-scheme/private/type-effect-printer.ss → collects/typed-scheme/types/printer.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rep type-rep effect-rep rep-utils)
(require (rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
scheme/match)
@ -9,7 +9,7 @@
;; FIXME - currently broken
(define print-poly-types? #f)
;; do we use simple type aliases in printing
(define print-aliases #t)
(define print-aliases #f)
;; does t have a type name associated with it currently?
;; has-name : Type -> Maybe[Symbol]
@ -27,20 +27,46 @@
;; print out an effect
;; print-effect : Effect Port Boolean -> Void
(define (print-effect c port write?)
(define (fp . args) (apply fprintf port args))
(define (print-latentfilter c port write?)
(define (fp . args) (apply fprintf port args))
(match c
[(Restrict-Effect: t v) (fp "(restrict ~a ~a)" t (syntax-e v))]
[(Remove-Effect: t v) (fp "(remove ~a ~a)" t (syntax-e v))]
[(Latent-Restrict-Effect: t) (fp "(restrict ~a)" t)]
[(Latent-Remove-Effect: t) (fp "(remove ~a)" t)]
[(Latent-Var-True-Effect:) (fp "(var #t)")]
[(Latent-Var-False-Effect:) (fp "(var #f)")]
[(True-Effect:) (fp "T")]
[(False-Effect:) (fp "F")]
[(Var-True-Effect: v) (fp "(var #t ~a)" (syntax-e v))]
[(Var-False-Effect: v) (fp "(var #f ~a)" (syntax-e v))]))
[(LFilterSet: thn els) (fp "(")
(for ([i thn]) (fp "~a " i)) (fp "|")
(for ([i els]) (fp " ~a" i))
(fp")")]
[(LNotTypeFilter: type path idx) (fp "(! ~a @ ~a ~a)" type path idx)]
[(LTypeFilter: type path idx) (fp "(~a @ ~a ~a)" type path idx)]
[(LBot:) (fp "LBot")]))
(define (print-filter c port write?)
(define (fp . args) (apply fprintf port args))
(match c
[(FilterSet: thn els) (fp "(")
(for ([i thn]) (fp "~a " i)) (fp "|")
(for ([i els]) (fp " ~a" i))
(fp")")]
[(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))]
[(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path (syntax-e id))]
[(Bot:) (fp "Bot")]))
(define (print-pathelem c port write?)
(define (fp . args) (apply fprintf port args))
(match c
[(CarPE:) (fp "car")]
[(CdrPE:) (fp "cdr")]
[(StructPE: t i) (fp "(~a ~a)" t i)]))
(define (print-latentobject c port write?)
(define (fp . args) (apply fprintf port args))
(match c
[(LEmpty:) (fp "")]
[(LPath: pes i) (fp "~a" (append pes (list i)))]))
(define (print-object c port write?)
(define (fp . args) (apply fprintf port args))
(match c
[(Empty:) (fp "")]
[(Path: pes i) (fp "~a" (append pes (list (syntax-e i))))]))
;; print out a type
;; print-type : Type Port Boolean -> Void
@ -50,7 +76,7 @@
(match a
[(top-arr:)
(fp "Procedure")]
[(arr: dom rng rest drest kws thn-eff els-eff)
[(arr: dom rng rest drest kws)
(fp "(")
(for-each (lambda (t) (fp "~a " t)) dom)
(for ([kw kws])
@ -63,12 +89,20 @@
(fp "~a* " rest))
(when drest
(fp "~a ... ~a " (car drest) (cdr drest)))
(fp "-> ~a" rng)
(match* (thn-eff els-eff)
[((list) (list)) (void)]
[((list (Latent-Restrict-Effect: t)) (list (Latent-Remove-Effect: t))) (fp " : ~a" t)]
[((list (Latent-Restrict-Effect: t)) (list (Latent-Remove-Effect: t))) (fp " : ~a" t)]
[(_ _) (fp " : ~a ~a" thn-eff els-eff)])
(match rng
[(Values: (list (Result: t (LFilterSet: (list) (list)) (LEmpty:))))
(fp "-> ~a" t)]
[(Values: (list (Result: t
(LFilterSet: (list (LTypeFilter: ft '() 0))
(list (LNotTypeFilter: ft '() 0)))
(LEmpty:))))
(fp "-> ~a : ~a" t ft)]
[(Values: (list (Result: t fs (LEmpty:))))
(fp "-> ~a : ~a" t fs)]
[(Values: (list (Result: t lf lo)))
(fp "-> ~a : ~a ~a" t lf lo)]
[_
(fp "-> ~a" rng)])
(fp ")")]))
(define (tuple? t)
(match t
@ -85,7 +119,7 @@
;; names are just the printed as the original syntax
[(Name: stx) (fp "~a" (syntax-e stx))]
[(App: rator rands stx)
(fp "~a" (cons rator rands))]
(fp "~a" (list* rator rands))]
;; special cases for lists
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
(fp "(Listof ~a)" elem-ty)]
@ -115,16 +149,16 @@
(lambda (e) (fp " ") (print-arr e))
b)
(fp ")")]))]
[(arr: _ _ _ _ _ _ _) (print-arr c)]
[(arr: _ _ _ _ _) (print-arr c)]
[(Vector: e) (fp "(Vectorof ~a)" e)]
[(Box: e) (fp "(Box ~a)" e)]
[(Union: elems) (fp "~a" (cons 'U elems))]
[(Pair: l r) (fp "(Pair ~a ~a)" l r)]
[(F: nm) (fp "~a" nm)]
[(F: nm) (fp "~a" nm)]
;; FIXME
[(Values: (list v)) (fp "~a" v)]
[(Values: (list v ...)) (fp "~a" (cons 'values v))]
[(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))]
[(Refinement: parent p? _)
(fp "(Refinement ~a ~a)" parent (syntax-e p?))]
[(Param: in out)
(if (equal? in out)
(fp "(Parameter ~a)" in)
@ -150,7 +184,7 @@
(Vector: (F: x))
(Box: (F: x))))))
(fp "SyntaxObject")]
[(Mu-name: name body) (fp "(mu ~a ~a ~a)" (Type-seq c) name body)]
[(Mu-name: name body) (fp "(Rec ~a ~a)" name body)]
;; FIXME - this should not be used
#;
[(Scope: sc) (fp "(Scope ~a)" sc)]
@ -159,8 +193,18 @@
[(Syntax: t) (fp "(Syntax ~a)" t)]
[(Instance: t) (fp "(Instance ~a)" t)]
[(Class: pf nf ms) (fp "(Class)")]
[(Result: t (LFilterSet: (list) (list)) (LEmpty:)) (fp "~a" t)]
[(Result: t fs (LEmpty:)) (fp "(~a : ~a)" t fs)]
[(Result: t fs lo) (fp "(~a : ~a : ~a)" t fs lo)]
[(Refinement: parent p? _)
(fp "(Refinement ~a ~a)" parent (syntax-e p?))]
[(Error:) (fp "Error")]
[else (fp "Unknown Type: ~a" (struct->vector c))]
))
(set-box! print-type* print-type)
(set-box! print-effect* print-effect)
(set-box! print-filter* print-filter)
(set-box! print-latentfilter* print-latentfilter)
(set-box! print-object* print-object)
(set-box! print-latentobject* print-latentobject)
(set-box! print-pathelem* print-pathelem)

90
collects/typed-scheme/types/remove-intersect.ss Normal file
View File

@ -0,0 +1,90 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep rep-utils)
(types union subtype resolve convenience utils)
scheme/match mzlib/trace)
(provide (rename-out [*remove remove]) overlap)
(define (overlap t1 t2)
(let ([ks (Type-key t1)] [kt (Type-key t2)])
(cond
[(and (symbol? ks) (symbol? kt) (not (eq? ks kt))) #f]
[(and (symbol? ks) (pair? kt) (not (memq ks kt))) #f]
[(and (symbol? kt) (pair? ks) (not (memq kt ks))) #f]
[(and (pair? ks) (pair? kt)
(for/and ([i (in-list ks)]) (not (memq i kt))))
#f]
[else
(match (list t1 t2)
[(list (Univ:) _) #t]
[(list _ (Univ:)) #t]
[(list (F: _) _) #t]
[(list _ (F: _)) #t]
[(list (Name: n) (Name: n*)) (free-identifier=? n n*)]
[(list (? Mu?) _) (overlap (unfold t1) t2)]
[(list _ (? Mu?)) (overlap t1 (unfold t2))]
[(list (Union: e) t)
(ormap (lambda (t*) (overlap t* t)) e)]
[(list t (Union: e))
(ormap (lambda (t*) (overlap t t*)) e)]
[(or (list _ (? Poly?)) (list (? Poly?) _))
#t] ;; these can have overlap, conservatively
[(list (Base: s1 _) (Base: s2 _)) (or (subtype t1 t2) (subtype t2 t1))]
[(list (Base: _ _) (Value: _)) (subtype t2 t1)] ;; conservative
[(list (Value: _) (Base: _ _)) (subtype t1 t2)] ;; conservative
[(list (Syntax: t) (Syntax: t*))
(overlap t t*)]
[(or (list (Syntax: _) _)
(list _ (Syntax: _)))
#f]
[(list (Base: _ _) _) #f]
[(list _ (Base: _ _)) #f]
[(list (Value: (? pair? v)) (Pair: _ _)) #t]
[(list (Pair: _ _) (Value: (? pair? v))) #t]
[(list (Pair: a b) (Pair: a* b*))
(and (overlap a a*)
(overlap b b*))]
[(or (list (Pair: _ _) _)
(list _ (Pair: _ _)))
#f]
[(list (Struct: n _ flds _ _ _ _)
(Struct: n _ flds* _ _ _ _))
(for/and ([f flds] [f* flds*]) (overlap f f*))]
;; n and n* must be different, so there's no overlap
[(list (Struct: n #f flds _ _ _ _)
(Struct: n* #f flds* _ _ _ _))
#f]
[(list (Struct: n p flds _ _ _ _)
(Struct: n* p* flds* _ _ _ _))
(and (= (length flds) (length flds*)) (for/and ([f flds] [f* flds*]) (overlap f f*)))]
[else #t])])))
;(trace overlap)
;(trace restrict)
;; also not yet correct
;; produces old without the contents of rem
(define (*remove old rem)
(define initial
(if (subtype old rem)
(Un) ;; the empty type
(match (list old rem)
[(list (or (App: _ _ _) (Name: _)) t)
;; must be different, since they're not subtypes
;; and n must refer to a distinct struct type
old]
[(list (Union: l) rem)
(apply Un (map (lambda (e) (*remove e rem)) l))]
[(list (? Mu? old) t) (*remove (unfold old) t)]
[(list (Poly: vs b) t) (make-Poly vs (*remove b rem))]
[_ old])))
(if (subtype old initial) old initial))
;(trace *remove)
;(trace restrict)

47
collects/typed-scheme/types/resolve.ss Normal file
View File

@ -0,0 +1,47 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (rep type-rep)
(env type-name-env)
(utils tc-utils)
(types utils)
scheme/match
scheme/contract
mzlib/trace)
(provide resolve-name resolve-app needs-resolving? resolve)
(p/c [resolve-once (Type/c . -> . (or/c Type/c #f))])
(define (resolve-name t)
(match t
[(Name: n) (let ([t (lookup-type-name n)])
(if (Type? t) t #f))]
[_ (int-err "resolve-name: not a name ~a" t)]))
(define (resolve-app rator rands stx)
(parameterize ([current-orig-stx stx])
(match rator
[(Poly-unsafe: n _)
(unless (= n (length rands))
(tc-error "wrong number of arguments to polymorphic type: expected ~a and got ~a"
n (length rands)))
(instantiate-poly rator rands)]
[(Name: _) (let ([r (resolve-name rator)])
(and r (resolve-app r rands stx)))]
[(Mu: _ _) (resolve-app (unfold rator) rands)]
[(App: r r* s) (resolve-app (resolve-app r r* s) rands)]
[_ (tc-error "cannot apply a non-polymorphic type: ~a" rator)])))
(define (needs-resolving? t)
(or (Mu? t) (App? t) (Name? t)))
(define (resolve-once t)
(match t
[(Mu: _ _) (unfold t)]
[(App: r r* s) (resolve-app r r* s)]
[(Name: _) (resolve-name t)]))
(define (resolve t)
(if (needs-resolving? t) (resolve-once t) t))
;(trace resolve-app)

201
collects/typed-scheme/private/subtype.ss → collects/typed-scheme/types/subtype.ss
View File

@ -1,38 +1,27 @@
#lang scheme/base
(require "../utils/utils.ss")
(require (except-in (rep type-rep effect-rep rep-utils) sub-eff)
(require (rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
"type-utils.ss"
"type-comparison.ss"
"resolve-type.ss"
"type-abbrev.ss"
(types utils comparison resolve abbrev)
(env type-name-env)
(only-in (infer infer-dummy) unify)
scheme/match
mzlib/trace)
mzlib/trace
(for-syntax scheme/base stxclass))
;; exn representing failure of subtyping
;; s,t both types
(define-struct (exn:subtype exn:fail) (s t))
#;
(define-values (fail-sym exn:subtype?)
(let ([sym (gensym)])
(values sym (lambda (s) (eq? s sym)))))
;; inference failure - masked before it gets to the user program
(define-syntax fail!
(syntax-rules ()
[(_ s t) #;(raise fail-sym)
(raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))
#;(error "inference failed" s t)]))
[(_ s t) (raise (make-exn:subtype "subtyping failed" (current-continuation-marks) s t))]))
;; data structures for remembering things on recursive calls
(define (empty-set) '())
(define (empty-set) '())
(define current-seen (make-parameter (empty-set)))
@ -94,52 +83,82 @@
(define (supertype-of-one/arr A s ts)
(ormap (lambda (e) (arr-subtype*/no-fail A e s)) ts))
(define (sub-eff e1 e2)
(match* (e1 e2)
[(e e) #t]
[((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: t*))
(and (subtype t t*)
(subtype t* t))]
[((Latent-Remove-Effect: t) (Latent-Remove-Effect: t*))
(and (subtype t t*)
(subtype t* t))]
[(_ _) #f]))
;(trace sub-eff)
(define-syntax (subtype-seq stx)
(define-syntax-class sub*
(pattern e:expr))
(syntax-parse stx
[(_ init (s1:sub* . args1) (s:sub* . args) ...)
(with-syntax ([(A* ... A-last) (generate-temporaries #'(s1 s ...))])
(with-syntax ([(clauses ...)
(for/list ([s (syntax->list #'(s1 s ...))]
[args (syntax->list #'(args1 args ...))]
[A (syntax->list #'(init A* ...))]
[A-next (syntax->list #'(A* ... A-last))])
#`[#,A-next (#,s #,A . #,args)])])
#'(let* (clauses ...)
A-last)))]))
(define (kw-subtypes* A0 t-kws s-kws)
(let loop ([A A0] [t t-kws] [s s-kws])
(match* (t s)
[((list (Keyword: kt tt rt) rest-t) (list (Keyword: ks ts rs) rest-s))
(cond [(eq? kt ks)
(if
;; if s is optional, t must be as well
(or rs (not rt))
(loop (subtype A tt ts) rest-t rest-s)
(fail! t s))]
;; extra keywords in t are ok
;; we just ignore them
[(keyword<? kt ks) (loop A rest-t s)]
;; extra keywords in s are a problem
[else (fail! t s)])]
;; no more keywords to satisfy
[(_ '()) A]
;; we failed to satisfy all the keyword
[(_ _) (fail! s t)])))
;; simple co/contra-variance for ->
(define (arr-subtype*/no-fail A0 s t)
(with-handlers
([exn:subtype? (lambda _ #f)])
(match (list s t)
(match* (s t)
;; top for functions is above everything
[(list _ (top-arr:)) A0]
[(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff)
(arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff els-eff))
(let* ([A1 (subtypes* A0 t1 s1)]
[A2 (subtypes* A1 t-kw-ty s-kw-ty)])
(subtype* A1 s2 t2))]
[(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff)
(arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*))
(unless
(or (and (null? thn-eff*) (null? els-eff*))
(and (effects-equal? thn-eff thn-eff*)
(effects-equal? els-eff els-eff*))
(and
(= (length thn-eff) (length thn-eff*))
(= (length els-eff) (length els-eff*))
(andmap sub-eff thn-eff thn-eff*)
(andmap sub-eff els-eff els-eff*)))
(fail! s t))
;; either the effects have to be the same, or the supertype can't have effects
(let* ([A2 (subtypes*/varargs A0 t1 s1 s3)]
[A3 (subtypes* A2 t-kw-ty s-kw-ty)])
(if (not t3)
(subtype* A3 s2 t2)
(let ([A1 (subtype* A3 t3 s3)])
(subtype* A1 s2 t2))))]
[else
[(_ (top-arr:)) A0]
;; the really simple case
[((arr: s1 s2 #f #f '())
(arr: t1 t2 #f #f '()))
(subtype-seq A0
(subtypes* t1 s1)
(subtype* s2 t2))]
[((arr: s1 s2 #f #f s-kws)
(arr: t1 t2 #f #f t-kws))
(subtype-seq A0
(subtypes* t1 s1)
(kw-subtypes* t-kws s-kws)
(subtype* s2 t2))]
[((arr: s-dom s-rng s-rest #f s-kws)
(arr: t-dom t-rng #f #f t-kws))
(subtype-seq A0
(subtypes*/varargs t-dom s-dom s-rest)
(kw-subtypes* t-kws s-kws)
(subtype* s-rng t-rng))]
[((arr: s-dom s-rng s-rest #f s-kws)
(arr: t-dom t-rng t-rest #f t-kws))
(subtype-seq A0
(subtypes*/varargs t-dom s-dom s-rest)
(subtype* t-rest s-rest)
(kw-subtypes* t-kws s-kws)
(subtype* s-rng t-rng))]
;; handle ... varargs when the bounds are the same
[((arr: s-dom s-rng #f (cons s-drest dbound) s-kws)
(arr: t-dom t-rng #f (cons t-drest dbound) t-kws))
(subtype-seq A0
(subtype* t-drest s-drest)
(subtypes* t-dom s-dom)
(kw-subtypes* t-kws s-kws)
(subtype* s-rng t-rng))]
[(_ _)
(fail! s t)])))
(define (subtypes/varargs args dom rst)
@ -220,8 +239,7 @@
(unmatch))
;(printf "Poly: ~n~a ~n~a~n" b1 (subst-all (map list ms (map make-F ns)) b2))
(subtype* A0 b1 (subst-all (map list ms (map make-F ns)) b2))]
;; A refinement is a subtype of its parent
[(list (Refinement: par _ _) t)
[(list (Refinement: par _ _) t)
(subtype* A0 par t)]
;; use unification to see if we can use the polytype here
[(list (Poly: vs b) s)
@ -230,15 +248,17 @@
[(list s (Poly: vs b))
(=> unmatch)
(if (null? (fv b)) (subtype* A0 s b) (unmatch))]
;; names are compared for equality:
[(list (Name: n) (Name: n*))
(=> unmatch)
(if (free-identifier=? n n*)
A0
(unmatch))]
;; just unfold the recursive types
[(list _ (? Mu?)) (subtype* A0 s (unfold t))]
[(list (? Mu?) _) (subtype* A0 (unfold s) t)]
;; rec types, applications and names (that aren't the same
[(list (? needs-resolving? s) other)
(let ([s* (resolve-once s)])
(if (Type? s*) ;; needed in case this was a name that hasn't been resolved yet
(subtype* A0 s* other)
(fail! s t)))]
[(list other (? needs-resolving? t))
(let ([t* (resolve-once t)])
(if (Type? t*) ;; needed in case this was a name that hasn't been resolved yet
(subtype* A0 other t*)
(fail! s t)))]
;; for unions, we check the cross-product
[(list (Union: es) t) (and (andmap (lambda (elem) (subtype* A0 elem t)) es) A0)]
[(list s (Union: es)) (and (ormap (lambda (elem) (subtype*/no-fail A0 s elem)) es) A0)]
@ -251,51 +271,16 @@
[(list (Struct: nm (? Type? parent) flds proc _ _ _) other)
;(printf "subtype - hierarchy : ~a ~a ~a~n" nm parent other)
(subtype* A0 parent other)]
;; applications and names are structs too
[(list (App: (Name: n) args stx) other)
(let ([t (lookup-type-name n)])
(unless (Type? t)
(fail! s t))
#;(printf "subtype: app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other
(instantiate-poly t args))
(unless (Poly? t)
(tc-error/stx stx "cannot apply non-polymorphic type ~a" t))
(match t [(Poly-unsafe: n _)
(unless (= n (length args))
(tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a"
n (length args)))])
(let ([v (subtype* A0 (instantiate-poly t args) other)])
#;(printf "val: ~a~n" v)
v))]
[(list other (App: (Name: n) args stx))
(let ([t (lookup-type-name n)])
(unless (Type? t)
(fail! s t))
#;(printf "subtype: 2 app-name: name: ~a type: ~a other: ~a ~ninst: ~a~n" (syntax-e n) t other
(instantiate-poly t args))
(unless (Poly? t)
(tc-error/stx stx "cannot apply non-polymorphic type ~a" t))
(match t [(Poly-unsafe: n _)
(unless (= n (length args))
(tc-error/stx stx "wrong number of arguments to polymorphic type: expected ~a and got ~a"
n (length args)))])
;(printf "about to call subtype with: ~a ~a ~n" other (instantiate-poly t args))
(let ([v (subtype* A0 other (instantiate-poly t args))])
#;(printf "2 val: ~a~n" v)
v))]
[(list (Name: n) other)
(let ([t (lookup-type-name n)])
;(printf "subtype: name: ~a ~a ~a~n" (syntax-e n) t other)
(if (Type? t)
(subtype* A0 t other)
(fail! s t)))]
;; Promises are covariant
[(list (Struct: 'Promise _ (list t) _ _ _ _) (Struct: 'Promise _ (list t*) _ _ _ _)) (subtype* A0 t t*)]
;; subtyping on values is pointwise
[(list (Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)]
;; single values shouldn't actually happen, but they're just like the type
[(list t (Values: (list t*))) (int-err "BUG - singleton values type~a" (make-Values (list t*)))]
[(list (Values: (list t)) t*) (int-err "BUG - singleton values type~a" (make-Values (list t)))]
;; trivial case for Result
[(list (Result: t f o) (Result: t* f o))
(subtype* A0 t t*)]
;; we can ignore interesting results
[(list (Result: t f o) (Result: t* (LFilterSet: (list) (list)) (LEmpty:)))
(subtype* A0 t t*)]
;; subtyping on other stuff
[(list (Syntax: t) (Syntax: t*))
(subtype* A0 t t*)]

22
collects/typed-scheme/private/union.ss → collects/typed-scheme/types/union.ss
View File

@ -4,14 +4,10 @@
(require (rep type-rep rep-utils)
(utils tc-utils)
"type-utils.ss"
"subtype.ss"
"type-abbrev.ss"
"type-effect-printer.ss"
"type-comparison.ss"
(types utils subtype abbrev printer comparison)
scheme/match mzlib/trace)
(provide Un #;(rename *Un Un))
(provide Un)
(define (make-union* set)
(match set
@ -44,25 +40,13 @@
[(subtype a b*) (list b*)]
[(subtype b* a) (list a)]
[else (cons a b)]))
#;(union-count!)
(let ([types (remove-dups (sort (apply append (map flat args)) type<?))])
(cond
[(null? types) (make-union* null)]
[(null? (cdr types)) (car types)]
[(ormap Values? types)
(if (andmap Values? types)
(make-Values (apply map Un (map Values-types types)))
(int-err "Un: should not take the union of multiple values with some other type: ~a" types))]
[else (make-union* #;(remove-subtypes types) (foldr union2 '() (remove-subtypes types)))]))]))
#;(defintern (Un-intern args) (lambda (_ args) (apply Un args)) args)
#;(define (*Un . args) (Un-intern args))
;(trace Un)
[else (make-union* (foldr union2 '() (remove-subtypes types)))]))]))
(define (u-maker args) (apply Un args))
;(trace u-maker)
(set-union-maker! u-maker)

144
collects/typed-scheme/private/type-utils.ss → collects/typed-scheme/types/utils.ss
View File

@ -2,13 +2,14 @@
(require "../utils/utils.ss")
(require (rep type-rep effect-rep rep-utils)
(require (rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
(only-in (rep free-variance) combine-frees)
scheme/match
scheme/list
mzlib/trace
(for-syntax scheme/base))
scheme/contract
(for-syntax scheme/base stxclass))
(provide fv fv/list
substitute
@ -16,10 +17,9 @@
substitute-dotted
subst-all
subst
ret
;ret
instantiate-poly
instantiate-poly-dotted
tc-result:
tc-result?
tc-result-equal?
effects-equal?
@ -30,17 +30,19 @@
just-Dotted?
tc-error/expr
lookup-fail
lookup-type-fail)
lookup-type-fail
combine-results)
;; substitute : Type Name Type -> Type
(define (substitute image name target #:Un [Un (get-union-maker)])
(define (sb t) (substitute image name t))
(if (hash-ref (free-vars* target) name #f)
(type-case sb target
[#:Union tys (Un (map sb tys))]
(type-case (#:Type sb #:LatentFilter (sub-lf sb) #:LatentObject (sub-lo sb))
target
[#:Union tys (Un (map sb tys))]
[#:F name* (if (eq? name* name) image target)]
[#:arr dom rng rest drest kws thn-eff els-eff
[#:arr dom rng rest drest kws
(begin
(when (and (pair? drest)
(eq? name (cdr drest))
@ -50,10 +52,7 @@
(sb rng)
(and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest)))
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff)))]
(map sb kws)))]
[#:ValuesDots types dty dbound
(begin
(when (eq? name dbound)
@ -65,7 +64,7 @@
(define (substitute-dots images rimage name target)
(define (sb t) (substitute-dots images rimage name t))
(if (hash-ref (free-vars* target) name #f)
(type-case sb target
(type-case (#:Type sb #:LatentFilter (sub-lf sb)) target
[#:ValuesDots types dty dbound
(if (eq? name dbound)
(make-Values
@ -73,31 +72,29 @@
(map sb types)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sb dty)])
(map (lambda (img) (substitute img name expanded)) images))))
(for/list ([img images])
(make-Result
(substitute img name expanded)
(make-LFilterSet null null)
(make-LEmpty))))))
(make-ValuesDots (map sb types) (sb dty) dbound))]
[#:arr dom rng rest drest kws thn-eff els-eff
[#:arr dom rng rest drest kws
(if (and (pair? drest)
(eq? name (cdr drest)))
(make-arr (append
(map sb dom)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sb (car drest))])
(map (lambda (img) (substitute img name expanded)) images)))
(map (lambda (img) (substitute img name expanded)) images)))
(sb rng)
rimage
#f
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))
(map sb kws))
(make-arr (map sb dom)
(sb rng)
(and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest)))
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff)))])
(map sb kws)))])
target))
;; implements sd from the formalism
@ -105,7 +102,8 @@
(define (substitute-dotted image image-bound name target)
(define (sb t) (substitute-dotted image image-bound name t))
(if (hash-ref (free-vars* target) name #f)
(type-case sb target
(type-case (#:Type sb #:LatentFilter (sub-lf sb))
target
[#:ValuesDots types dty dbound
(make-ValuesDots (map sb types)
(sb dty)
@ -114,17 +112,14 @@
(if (eq? name* name)
image
target)]
[#:arr dom rng rest drest kws thn-eff els-eff
[#:arr dom rng rest drest kws
(make-arr (map sb dom)
(sb rng)
(and rest (sb rest))
(and drest
(cons (sb (car drest))
(if (eq? name (cdr drest)) image-bound (cdr drest))))
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))])
(map sb kws))])
target))
;; substitute many variables
@ -173,18 +168,91 @@
;; this structure represents the result of typechecking an expression
(define-struct tc-result (t thn els) #:inspector #f)
(d-s/c tc-result ([t Type/c] [f FilterSet?] [o Object?]) #:transparent)
(d-s/c tc-results ([ts (listof tc-result?)] [drest (or/c (cons/c Type/c symbol?) #f)]) #:transparent)
(define-match-expander tc-result:
(lambda (stx)
(syntax-case stx ()
[(form pt) #'(struct tc-result (pt _ _))]
[(form pt pe1 pe2) #'(struct tc-result (pt pe1 pe2))])))
(syntax-parser
[(_ tp fp op) #'(struct tc-result (tp fp op))]
[(_ tp) #'(struct tc-result (tp _ _))]))
(define-match-expander tc-results:
(syntax-parser
[(_ tp fp op) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) #f))]
[(_ tp fp op dty dbound) #'(struct tc-results ((list (struct tc-result (tp fp op)) (... ...)) (cons dty dbound)))]
[(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _)) (... ...)) #f))]))
(define-match-expander tc-result1:
(syntax-parser
[(_ tp fp op) #'(struct tc-results ((list (struct tc-result (tp fp op))) #f))]
[(_ tp) #'(struct tc-results ((list (struct tc-result (tp _ _))) #f))]))
(define (tc-results-t tc)
(match tc
[(tc-results: t) t]))
(provide tc-result: tc-results: tc-result1: tc-result? tc-results? tc-results-t Result1: Results:)
(define-match-expander Result1:
(syntax-parser
[(_ tp) #'(Values: (list (Result: tp _ _)))]
[(_ tp fp op) #'(Values: (list (Result: tp fp op)))]))
(define-match-expander Results:
(syntax-parser
[(_ tp) #'(Values: (list (Result: tp _ _) (... ...)))]
[(_ tp fp op) #'(Values: (list (Result: tp fp op) (... ...)))]))
;; convenience function for returning the result of typechecking an expression
(define ret
(case-lambda [(t) (make-tc-result t (list) (list))]
[(t thn els) (make-tc-result t thn els)]))
(case-lambda [(t)
(let ([mk (lambda (t) (make-FilterSet null null))])
(make-tc-results
(cond [(Type? t)
(list (make-tc-result t (mk t) (make-Empty)))]
[else
(for/list ([i t])
(make-tc-result i (mk t) (make-Empty)))])
#f))]
[(t f)
(make-tc-results
(if (Type? t)
(list (make-tc-result t f (make-Empty)))
(for/list ([i t] [f f])
(make-tc-result i f (make-Empty))))
#f)]
[(t f o)
(make-tc-results
(if (and (list? t) (list? f) (list? o))
(map make-tc-result t f o)
(list (make-tc-result t f o)))
#f)]
[(t f o dty)
(int-err "ret used with dty without dbound")]
[(t f o dty dbound)
(make-tc-results
(if (and (list? t) (list? f) (list? o))
(map make-tc-result t f o)
(list (make-tc-result t f o)))
(cons dty dbound))]))
(p/c
[ret
(->d ([t (or/c Type/c (listof Type/c))])
([f (if (list? t)
(listof FilterSet?)
FilterSet?)]
[o (if (list? t)
(listof Object?)
Object?)]
[dty Type/c]
[dbound symbol?])
[_ tc-results?])])
(define (combine-results tcs)
(match tcs
[(list (tc-result1: t f o) ...)
(ret t f o)]))
(define (subst v t e) (substitute t v e))
@ -222,7 +290,7 @@
(define (lookup-fail e)
(match (identifier-binding e)
['lexical (int-err "untyped lexical variable ~a" (syntax-e e))]
[#f (int-err "untyped top-level variable ~a" (syntax-e e))]
[#f (tc-error/expr "untyped top-level identifier ~a" (syntax-e e))]
[(list _ _ nominal-source-mod nominal-source-id _ _ _)
(let-values ([(x y) (module-path-index-split nominal-source-mod)])
(cond [(and (not x) (not y))

0
collects/typed-scheme/private/mutated-vars.ss → collects/typed-scheme/utils/mutated-vars.ss
View File

2
collects/typed-scheme/private/require-contract.ss → collects/typed-scheme/utils/require-contract.ss
View File

@ -2,7 +2,7 @@
(require scheme/contract (for-syntax scheme/base syntax/kerncase
"../utils/tc-utils.ss"
(prefix-in tr: "typed-renaming.ss")))
(prefix-in tr: "../private/typed-renaming.ss")))
(provide require/contract define-ignored)

0
collects/typed-scheme/private/stxclass-util.ss → collects/typed-scheme/utils/stxclass-util.ss
View File

41
collects/typed-scheme/utils/tc-utils.ss
View File

@ -1,6 +1,12 @@
#lang scheme/base
#|
This file is for utilities that are only useful for Typed Scheme, but
don't depend on any other portion of the system
|#
(provide (all-defined-out))
(require "syntax-traversal.ss" (for-syntax scheme/base) scheme/match)
(require "syntax-traversal.ss" stxclass (for-syntax scheme/base stxclass) scheme/match)
;; a parameter representing the original location of the syntax being currently checked
(define current-orig-stx (make-parameter #'here))
@ -142,4 +148,37 @@
(define (add-type-name-reference t)
(type-name-references (cons t (type-name-references))))
;; environment constructor
(define-syntax (make-env stx)
(define-syntax-class spec
#:transparent
#:attributes (ty id)
(pattern [nm:identifier ty]
#:with id #'#'nm)
(pattern [e:expr ty extra-mods ...]
#:with id #'(let ([new-ns
(let* ([ns (make-empty-namespace)])
(namespace-attach-module (current-namespace)
'scheme/base
ns)
ns)])
(parameterize ([current-namespace new-ns])
(namespace-require 'scheme/base)
(namespace-require 'extra-mods) ...
e))))
(syntax-parse stx
[(_ e:spec ...)
#'(list (list e.id e.ty) ...)]))
;; id: identifier
;; sym: a symbol
;; mod: a quoted require spec like 'scheme/base
;; is id the name sym defined in mod?
(define (id-from? id sym mod)
(and (eq? (syntax-e id) sym)
(eq? (module-path-index-resolve (syntax-source-module id))
((current-module-name-resolver) mod #f #f #f))))
(define-syntax-class (id-from sym mod)
(pattern i:id
#:when (id-from? #'i sym mod)))

8
collects/typed-scheme/utils/unit-utils.ss
View File

@ -2,13 +2,5 @@
(require scheme/unit (for-syntax scheme/base))
(provide cnt)
(define-signature-form (cnt stx)
(syntax-case stx ()
[(_ nm cnt)
(list #'nm)
#;(list #'[contracted (nm cnt)])]))

180
collects/typed-scheme/utils/utils.ss
View File

@ -1,17 +1,19 @@
#lang scheme/base
(require (for-syntax scheme/base)
mzlib/plt-match
scheme/require-syntax
mzlib/struct
#|
This file is for utilities that are of general interest,
at least theoretically.
|#
(require (for-syntax scheme/base stxclass)
scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax
mzlib/struct scheme/unit
(except-in stxclass id))
(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
with-logging-to-file log-file-name ==
print-type*
print-effect*
define-struct/printer
id
(rename-out [id mk-id])
filter-multiple
hash-union
in-pairs
@ -20,39 +22,62 @@
debug
in-syntax
symbol-append
;; require macros
rep utils typecheck infer env private)
custom-printer
rep utils typecheck infer env private
hashof)
(define-syntax (define-requirer stx)
(syntax-case stx ()
[(_ nm)
(syntax-parse stx
[(_ nm:id nm-out:id)
#`(...
(define-require-syntax nm
(lambda (stx)
(syntax-case stx ()
[(_ id ...)
(andmap identifier? (syntax->list #'(id ...)))
(with-syntax ([(id* ...)
(begin
(define-require-syntax (nm stx)
(syntax-parse stx
[(form id:identifier ...)
(with-syntax ([(id* ...)
(map (lambda (id)
(datum->syntax
id
(string->symbol
(string-append
"typed-scheme/"
#,(symbol->string (syntax-e #'nm))
"/"
(symbol->string (syntax-e id))))
id
`(file
,(datum->syntax
#f
(path->string
(build-path (collection-path "typed-scheme"
#,(symbol->string (syntax-e #'nm)))
(string-append (symbol->string (syntax-e id))
".ss")))
id id))
id id))
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-in id* ...)))]))))]))
(syntax-property (syntax/loc stx (combine-in id* ...))
'disappeared-use
#'form))]))
(define-provide-syntax (nm-out stx)
(syntax-parse stx
[(_ id:identifier ...)
(with-syntax ([(id* ...)
(map (lambda (id)
(datum->syntax
id
`(file
,(path->string
(build-path (collection-path "typed-scheme"
#,(symbol->string (syntax-e #'nm)))
(string-append (symbol->string (syntax-e id))
".ss"))))
id id))
(syntax->list #'(id ...)))])
(syntax/loc stx (combine-out (all-from-out id*) ...)))]))
(provide nm nm-out)))]))
(define-requirer rep)
(define-requirer infer)
(define-requirer typecheck)
(define-requirer utils)
(define-requirer env)
(define-requirer private)
(define-requirer rep rep-out)
(define-requirer infer infer-out)
(define-requirer typecheck typecheck-out)
(define-requirer utils utils-out)
(define-requirer env env-out)
(define-requirer private private-out)
(define-requirer types types-out)
(define-sequence-syntax in-syntax
(lambda () #'syntax->list)
@ -169,9 +194,27 @@
(define-for-syntax printing? #t)
(define print-type* (box (lambda _ (error "print-type* not yet defined"))))
(define print-effect* (box (lambda _ (error "print-effect* not yet defined"))))
(define-syntax-rule (defprinter t ...)
(begin
(define t (box (lambda _ (error (format "~a not yet defined" 't))))) ...
(provide t ...)))
(defprinter
print-type* print-filter* print-latentfilter* print-object* print-latentobject*
print-pathelem*)
(define pseudo-printer
(lambda (s port mode)
(parameterize ([current-output-port port]
[show-sharing #f]
[booleans-as-true/false #f]
[constructor-style-printing #t])
(newline)
(pretty-print (print-convert s))
(newline))))
(define custom-printer (make-parameter #t))
(require scheme/pretty mzlib/pconvert)
(define-syntax (define-struct/printer stx)
@ -179,21 +222,15 @@
[(form name (flds ...) printer)
#`(define-struct/properties name (flds ...)
#,(if printing?
#'([prop:custom-write printer])
#'([prop:custom-write (lambda (s port mode)
(parameterize ([current-output-port port]
[show-sharing #f]
[booleans-as-true/false #f]
[constructor-style-printing #t])
(newline)
(pretty-print (print-convert s))
(newline)))]))
#'([prop:custom-write (lambda (a b c) (if (custom-printer) (printer a b c) (pseudo-printer a b c)))])
#'([prop:custom-write pseudo-printer]))
#f)]))
(define (id kw . args)
(define (f v)
(cond [(string? v) v]
[(symbol? v) (symbol->string v)]
[(char? v) (string v)]
[(identifier? v) (symbol->string (syntax-e v))]))
(datum->syntax kw (string->symbol (apply string-append (map f args)))))
@ -236,3 +273,62 @@
(define (extend s t extra)
(append t (build-list (- (length s) (length t)) (lambda _ extra))))
(define-for-syntax enable-contracts? #f)
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
(define-syntax p/c
(if enable-contracts?
(make-rename-transformer #'provide/contract)
(lambda (stx)
(define-syntax-class clause
#:literals ()
#:attributes (i)
(pattern [rename out:id in:id cnt:expr]
#:when (eq? (syntax-e #'rename) 'rename)
#:with i #'(rename-out [out in]))
(pattern [i:id cnt:expr]))
(syntax-parse stx
[(_ c:clause ...)
#'(provide c.i ...)]))))
(define-syntax w/c
(if enable-contracts?
(make-rename-transformer #'with-contract)
(lambda (stx)
(syntax-parse stx
[(_ name specs . body)
#'(begin . body)]))))
(define-syntax d/c
(if enable-contracts?
(make-rename-transformer #'define/contract)
(lambda (stx)
(syntax-parse stx
[(_ head cnt . body)
#'(define head . body)]))))
(define-syntax d-s/c
(if enable-contracts?
(make-rename-transformer #'define-struct/contract)
(syntax-rules ()
[(_ hd ([i c] ...) . opts)
(define-struct hd (i ...) . opts)])))
(define-signature-form (cnt stx)
(syntax-case stx ()
[(_ nm cnt)
(if enable-contracts?
(list #'[contracted (nm cnt)])
(list #'nm))]))
(define (hashof k/c v/c)
(flat-named-contract
(format "#<hashof ~a ~a>" k/c v/c)
(lambda (h)
(define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c))
(define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c))
(and (hash? h)
(for/and ([(k v) h])
(and (k/c? k)
(v/c? v)))))))