diff --git a/collects/tests/typed-scheme/succeed/dot-intro.ss b/collects/tests/typed-scheme/succeed/dot-intro.ss index 50c87e353b..1d0dd5337b 100644 --- a/collects/tests/typed-scheme/succeed/dot-intro.ss +++ b/collects/tests/typed-scheme/succeed/dot-intro.ss @@ -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) diff --git a/collects/tests/typed-scheme/succeed/little-schemer.ss b/collects/tests/typed-scheme/succeed/little-schemer.ss index 2233e8d244..ea7bd5e509 100644 --- a/collects/tests/typed-scheme/succeed/little-schemer.ss +++ b/collects/tests/typed-scheme/succeed/little-schemer.ss @@ -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) diff --git a/collects/tests/typed-scheme/succeed/struct-exec.ss b/collects/tests/typed-scheme/succeed/struct-exec.ss index 23fb3d0641..0964a5d9e4 100644 --- a/collects/tests/typed-scheme/succeed/struct-exec.ss +++ b/collects/tests/typed-scheme/succeed/struct-exec.ss @@ -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)) diff --git a/collects/tests/typed-scheme/succeed/test.ss b/collects/tests/typed-scheme/succeed/test.ss new file mode 100644 index 0000000000..f9fb4a81db --- /dev/null +++ b/collects/tests/typed-scheme/succeed/test.ss @@ -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) diff --git a/collects/tests/typed-scheme/succeed/test2.ss b/collects/tests/typed-scheme/succeed/test2.ss new file mode 100644 index 0000000000..f590a5d788 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/test2.ss @@ -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) + diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index ec859fed7f..7643cc07f9 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -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)))) diff --git a/collects/tests/typed-scheme/unit-tests/contract-tests.ss b/collects/tests/typed-scheme/unit-tests/contract-tests.ss new file mode 100644 index 0000000000..a8b0f5ce4b --- /dev/null +++ b/collects/tests/typed-scheme/unit-tests/contract-tests.ss @@ -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) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index f792b1efb7..0e60fbc341 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -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) ...) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index c14f64d80a..b55ba90022 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -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) diff --git a/collects/tests/typed-scheme/unit-tests/planet-requires.ss b/collects/tests/typed-scheme/unit-tests/planet-requires.ss index 038b3fb17e..96b80f4ee2 100644 --- a/collects/tests/typed-scheme/unit-tests/planet-requires.ss +++ b/collects/tests/typed-scheme/unit-tests/planet-requires.ss @@ -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 diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index e18cd04b91..88b6b7f055 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -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) diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 91d42cd426..c51fad89d1 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -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) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 9c3c7d34e7..3725582e68 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -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))) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index 9c40943939..b0b3f782ee 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -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 () diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 9f5398e72a..76de434647 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -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) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 30462350d1..57aaa47822 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -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) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ff39c7f171..848b2f8778 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -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]) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/env/init-envs.ss index 71a8707f36..73d1a9a1da 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -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)])) diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 659cd8b814..51b7d22e68 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -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 diff --git a/collects/typed-scheme/env/type-alias-env.ss b/collects/typed-scheme/env/type-alias-env.ss index dd9183d32c..f8506de824 100644 --- a/collects/typed-scheme/env/type-alias-env.ss +++ b/collects/typed-scheme/env/type-alias-env.ss @@ -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)))]) diff --git a/collects/typed-scheme/env/type-env.ss b/collects/typed-scheme/env/type-env.ss index fd2b65db49..34da01ba0d 100644 --- a/collects/typed-scheme/env/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -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 diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 42eb02c9db..12c570c27e 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -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?)]) diff --git a/collects/typed-scheme/env/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss index f5656c13be..69b9882579 100644 --- a/collects/typed-scheme/env/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -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)))) \ No newline at end of file diff --git a/collects/typed-scheme/infer/constraint-structs.ss b/collects/typed-scheme/infer/constraint-structs.ss index ef2bccc281..604c8caa53 100644 --- a/collects/typed-scheme/infer/constraint-structs.ss +++ b/collects/typed-scheme/infer/constraint-structs.ss @@ -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 "#" 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?])) diff --git a/collects/typed-scheme/infer/constraints.ss b/collects/typed-scheme/infer/constraints.ss index 3dff2c088a..cacc1863b2 100644 --- a/collects/typed-scheme/infer/constraints.ss +++ b/collects/typed-scheme/infer/constraints.ss @@ -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" diff --git a/collects/typed-scheme/infer/infer-dummy.ss b/collects/typed-scheme/infer/infer-dummy.ss index e87f744f21..1088e741bc 100644 --- a/collects/typed-scheme/infer/infer-dummy.ss +++ b/collects/typed-scheme/infer/infer-dummy.ss @@ -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) diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index dfc1c980c4..bb9f7b0b01 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -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) diff --git a/collects/typed-scheme/infer/infer.ss b/collects/typed-scheme/infer/infer.ss index c660783ed0..8222f69f43 100644 --- a/collects/typed-scheme/infer/infer.ss +++ b/collects/typed-scheme/infer/infer.ss @@ -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)) diff --git a/collects/typed-scheme/infer/promote-demote.ss b/collects/typed-scheme/infer/promote-demote.ss index 8705122937..1eb261f135 100644 --- a/collects/typed-scheme/infer/promote-demote.ss +++ b/collects/typed-scheme/infer/promote-demote.ss @@ -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)))])])) diff --git a/collects/typed-scheme/infer/restrict.ss b/collects/typed-scheme/infer/restrict.ss index 4d2d26380c..d4ef3cd463 100644 --- a/collects/typed-scheme/infer/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -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*) diff --git a/collects/typed-scheme/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss index a3b85665f3..b9b9be1286 100644 --- a/collects/typed-scheme/infer/signatures.ss +++ b/collects/typed-scheme/infer/signatures.ss @@ -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?) diff --git a/collects/typed-scheme/no-check.ss b/collects/typed-scheme/no-check.ss index bd104f6110..a1a7601c59 100644 --- a/collects/typed-scheme/no-check.ss +++ b/collects/typed-scheme/no-check.ss @@ -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)) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index b6e34edfdb..c70355ae16 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -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)] diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index beb9051328..76a692136c 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -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->* diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index 0cbae61e0b..0d3d23acde 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -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] diff --git a/collects/typed-scheme/private/env-lang.ss b/collects/typed-scheme/private/env-lang.ss index c047e3a61d..434b5f5a1b 100644 --- a/collects/typed-scheme/private/env-lang.ss +++ b/collects/typed-scheme/private/env-lang.ss @@ -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))) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 187db130a5..ad172a1df5 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -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)) \ No newline at end of file diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index b3a36458e0..097d6d6808 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -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->]) diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss deleted file mode 100644 index ca2b264c01..0000000000 --- a/collects/typed-scheme/private/remove-intersect.ss +++ /dev/null @@ -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) diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss deleted file mode 100644 index 28ec18a488..0000000000 --- a/collects/typed-scheme/private/resolve-type.ss +++ /dev/null @@ -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) - -|# diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss deleted file mode 100644 index ea41573036..0000000000 --- a/collects/typed-scheme/private/type-abbrev.ss +++ /dev/null @@ -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 keyworduninterned-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)) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index 637574b4b2..e63b943c4e 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -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 diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index aedd0f9257..a4f22f20b6 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -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] diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss deleted file mode 100644 index e8a8849f61..0000000000 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ /dev/null @@ -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)) diff --git a/collects/typed-scheme/private/type-env-lang.ss b/collects/typed-scheme/private/type-env-lang.ss index d12fc33cc0..4d74faf309 100644 --- a/collects/typed-scheme/private/type-env-lang.ss +++ b/collects/typed-scheme/private/type-env-lang.ss @@ -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))) diff --git a/collects/typed-scheme/rep/effect-rep.ss b/collects/typed-scheme/rep/effect-rep.ss deleted file mode 100644 index 96f8768c9b..0000000000 --- a/collects/typed-scheme/rep/effect-rep.ss +++ /dev/null @@ -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 diff --git a/collects/typed-scheme/rep/filter-rep.ss b/collects/typed-scheme/rep/filter-rep.ss new file mode 100644 index 0000000000..33d095532e --- /dev/null +++ b/collects/typed-scheme/rep/filter-rep.ss @@ -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?])]) diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/rep/interning.ss index fa696eb829..83551c46b2 100644 --- a/collects/typed-scheme/rep/interning.ss +++ b/collects/typed-scheme/rep/interning.ss @@ -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)]) diff --git a/collects/typed-scheme/rep/object-rep.ss b/collects/typed-scheme/rep/object-rep.ss new file mode 100644 index 0000000000..afd87e320e --- /dev/null +++ b/collects/typed-scheme/rep/object-rep.ss @@ -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)]) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 1d97957d70..de7ae4316b 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -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]) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index bd0338c5ce..1365b5cd18 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -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 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 (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 diff --git a/collects/typed-scheme/typecheck/defstruct-unit.ss b/collects/typed-scheme/typecheck/defstruct-unit.ss deleted file mode 100644 index 3fed9fb241..0000000000 --- a/collects/typed-scheme/typecheck/defstruct-unit.ss +++ /dev/null @@ -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) ...))])) - diff --git a/collects/typed-scheme/typecheck/find-annotation.ss b/collects/typed-scheme/typecheck/find-annotation.ss new file mode 100644 index 0000000000..8ac74b4d78 --- /dev/null +++ b/collects/typed-scheme/typecheck/find-annotation.ss @@ -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 ...)))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index 530ad0094c..a1031cf6f9 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -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?))])) diff --git a/collects/typed-scheme/typecheck/tc-app-helper.ss b/collects/typed-scheme/typecheck/tc-app-helper.ss new file mode 100644 index 0000000000..170c7ee2bc --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-app-helper.ss @@ -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") + "")))))])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss deleted file mode 100644 index e0a64c4c64..0000000000 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ /dev/null @@ -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) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss new file mode 100644 index 0000000000..341f2ae4d6 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -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")])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-dots-unit.ss b/collects/typed-scheme/typecheck/tc-dots-unit.ss index 2aa1b38220..ddffd4d724 100644 --- a/collects/typed-scheme/typecheck/tc-dots-unit.ss +++ b/collects/typed-scheme/typecheck/tc-dots-unit.ss @@ -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")]))) diff --git a/collects/typed-scheme/typecheck/tc-envops.ss b/collects/typed-scheme/typecheck/tc-envops.ss new file mode 100644 index 0000000000..380010a754 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-envops.ss @@ -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 Γ)]))) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 8eb69ebab2..3fac723045 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -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)])) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss deleted file mode 100644 index e8537c6507..0000000000 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ /dev/null @@ -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))]))) - - -;) diff --git a/collects/typed-scheme/typecheck/tc-if.ss b/collects/typed-scheme/typecheck/tc-if.ss new file mode 100644 index 0000000000..6ebe28c2c7 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-if.ss @@ -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)])) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 66ce896383..aaceea3d68 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -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) diff --git a/collects/typed-scheme/typecheck/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss index 9bf2bf3fa7..32d7e217a2 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -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) - diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss new file mode 100644 index 0000000000..bda76ab6c1 --- /dev/null +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -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)])) \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index e48ff90b77..47bcd92a23 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -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))) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index c415f38b1b..24f16702d7 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -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 diff --git a/collects/typed-scheme/typecheck/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss index f398b18c23..4c186cd5a2 100644 --- a/collects/typed-scheme/typecheck/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -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") diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index c5054fce78..323d7713e9 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -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))]))])) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss new file mode 100644 index 0000000000..d95a254bbe --- /dev/null +++ b/collects/typed-scheme/types/abbrev.ss @@ -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* 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)) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-comparison.ss b/collects/typed-scheme/types/comparison.ss similarity index 74% rename from collects/typed-scheme/private/type-comparison.ss rename to collects/typed-scheme/types/comparison.ss index dbc70e5f46..0ca075439e 100644 --- a/collects/typed-scheme/private/type-comparison.ss +++ b/collects/typed-scheme/types/comparison.ss @@ -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 +(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)) \ No newline at end of file diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/types/printer.ss similarity index 63% rename from collects/typed-scheme/private/type-effect-printer.ss rename to collects/typed-scheme/types/printer.ss index 5ee756b025..55aefcd2fa 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/types/printer.ss @@ -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) diff --git a/collects/typed-scheme/types/remove-intersect.ss b/collects/typed-scheme/types/remove-intersect.ss new file mode 100644 index 0000000000..02c77acb93 --- /dev/null +++ b/collects/typed-scheme/types/remove-intersect.ss @@ -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) diff --git a/collects/typed-scheme/types/resolve.ss b/collects/typed-scheme/types/resolve.ss new file mode 100644 index 0000000000..a558255bbd --- /dev/null +++ b/collects/typed-scheme/types/resolve.ss @@ -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) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/types/subtype.ss similarity index 63% rename from collects/typed-scheme/private/subtype.ss rename to collects/typed-scheme/types/subtype.ss index ccfc78c818..26a08fe78c 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/types/subtype.ss @@ -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 (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*)] diff --git a/collects/typed-scheme/private/union.ss b/collects/typed-scheme/types/union.ss similarity index 63% rename from collects/typed-scheme/private/union.ss rename to collects/typed-scheme/types/union.ss index 816dbe7eb9..5019cada22 100644 --- a/collects/typed-scheme/private/union.ss +++ b/collects/typed-scheme/types/union.ss @@ -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 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)) diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/utils/mutated-vars.ss similarity index 100% rename from collects/typed-scheme/private/mutated-vars.ss rename to collects/typed-scheme/utils/mutated-vars.ss diff --git a/collects/typed-scheme/private/require-contract.ss b/collects/typed-scheme/utils/require-contract.ss similarity index 95% rename from collects/typed-scheme/private/require-contract.ss rename to collects/typed-scheme/utils/require-contract.ss index fe767085d0..eb9bbff4ca 100644 --- a/collects/typed-scheme/private/require-contract.ss +++ b/collects/typed-scheme/utils/require-contract.ss @@ -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) diff --git a/collects/typed-scheme/private/stxclass-util.ss b/collects/typed-scheme/utils/stxclass-util.ss similarity index 100% rename from collects/typed-scheme/private/stxclass-util.ss rename to collects/typed-scheme/utils/stxclass-util.ss diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 75e5ac4740..b92a4bafdb 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -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))) \ No newline at end of file diff --git a/collects/typed-scheme/utils/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss index ff6d04b8d5..77b19a08ca 100644 --- a/collects/typed-scheme/utils/unit-utils.ss +++ b/collects/typed-scheme/utils/unit-utils.ss @@ -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)])])) - diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index d90e27ee33..4baf94b36d 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -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 "#" 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))))))) \ No newline at end of file