From dcc2ff72d9ba3f2fb21c1485cc86c59246be9dae Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 8 May 2009 21:38:30 +0000 Subject: [PATCH] all tests now compile svn: r14753 --- .../typed-scheme/unit-tests/all-tests.ss | 2 +- .../typed-scheme/unit-tests/infer-tests.ss | 4 +- .../unit-tests/parse-type-tests.ss | 1 + .../typed-scheme/unit-tests/subst-tests.ss | 12 +-- .../unit-tests/type-annotation-test.ss | 29 +++---- .../unit-tests/typecheck-tests.ss | 80 ++++++++++--------- 6 files changed, 69 insertions(+), 59 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 32f70592d1..9821f9c72d 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -3,7 +3,7 @@ (require "test-utils.ss" "planet-requires.ss" - ;"typecheck-tests.ss" ;; doesn't compile yet + "typecheck-tests.ss" ;; doesn't compile yet "subtype-tests.ss" ;; pass "type-equal-tests.ss" ;; pass "remove-intersect-tests.ss" ;; pass diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index 8bcbd305a3..5159f9baee 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -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 c451af0bb4..0c6de8152f 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -102,6 +102,7 @@ )) +;; FIXME - add tests for parse-values-type, parse-tc-results (define-go parse-type-tests) diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 02a018c787..c51fad89d1 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -13,12 +13,12 @@ (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/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 12992f649c..76de434647 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -2,7 +2,7 @@ (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (private type-annotation parse-type base-types) - (types convenience) + (types convenience utils) (env type-environments type-name-env init-envs) (utils tc-utils) (rep type-rep) @@ -11,25 +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) - (namespace-require 'typed-scheme/private/base-types) - (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/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ff39c7f171..2f142e237c 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -3,10 +3,11 @@ (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)) @@ -20,10 +21,20 @@ (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 @@ -45,11 +56,11 @@ ;; 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 #: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)) @@ -76,8 +87,6 @@ (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" @@ -111,10 +120,10 @@ [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 (let: ([x : Number 5]) x) #:ret (-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)] + #:ret (ret -Boolean (-FS (list (make-TypeFilter (-val #f) #'y)) null))] [tc-e (values 3) -Integer] [tc-e (values) (-values (list))] [tc-e (values 3 #f) (-values (list -Integer (-val #f)))] @@ -149,13 +158,13 @@ [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 (begin #t) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e (begin0 #t) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e (begin0 #t 3) #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e #t #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e #f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))] + [tc-e '#t #:ret (ret (-val #t) (-FS null (list (make-Bot))))] + [tc-e '#f #:ret (ret (-val #f) (-FS (list (make-Bot)) null))] [tc-e (if #f 'a 3) -Integer] [tc-e (if #f #f #t) (Un (-val #t))] [tc-e (when #f 3) -Void] @@ -178,7 +187,7 @@ [tc-e (let: ([x : Number 3]) (when (number? x) #t)) - (-val #t) (list (make-True-Effect)) (list (make-True-Effect))] + #:ret (ret (-val #t) (-FS null (list (make-Bot))))] [tc-e (let: ([x : Number 3]) (when (boolean? x) #t)) -Void] @@ -195,13 +204,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) #:ret (-path -Integer #'x)] + [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean (-FS ))] + [tc-e (boolean? number?) #:ret (-path -Boolean #'number?)] - [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) (-path (Un N (-val #f)) #'x)] + [tc-e (let: ([x : Any 12]) (not (not x))) + #:ret (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) @@ -261,13 +270,12 @@ N] - [tc-e null (-val null) (-vet #'null) (-vef #'null)] + [tc-e null (-path (-val null) #'null)] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) x) - (Un (-val 'squarf) -Integer) - (-vet #'x) (-vef #'x)] + #:ret (-path (Un (-val 'squarf) -Integer) #'x)] [tc-e (if #t 1 2) -Integer] @@ -343,12 +351,12 @@ ;;; 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 (number? x) (boolean? x))) + #:ret (ret B (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter B null #'x)) null))] + [tc-e (let: ([x : Any 1]) (and (number? x) x)) (Un N (-val #f)) + #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter (-val #f) null #'x)) null))] [tc-e (let: ([x : Any 1]) (and x (boolean? x))) B - (list (-rem (-val #f) #'x) (-rest B #'x)) (list)] + #:ret (ret (Un N (-val #f)) (-FS (list (make-TypeFilter N null #'x) (make-TypeFilter (-val #f) null #'x)) null))] [tc-e (let: ([x : Any 3]) (if (and (list? x) (not (null? x))) @@ -572,7 +580,7 @@ (-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)))] + (make-Function (list (make-arr (list -Integer) -Integer #:filter (-LFS (list (-not-filter (-val #f))) (list (-filter (-val #f)))))))] [tc-e (inst (plambda: (a) [x : a *] (apply list x)) Integer) ((list) -Integer . ->* . (-lst -Integer))] @@ -668,7 +676,7 @@ (fact 20))] #;[tc-err ] - )) + ) (test-suite "check-type tests" (test-exn "Fails correctly" exn:fail:syntax? (lambda () (parameterize ([orig-module-stx #'here])