From 93a504a8173309922e087142ca191d76c6885032 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 30 Oct 2009 16:26:48 +0000 Subject: [PATCH] Add failing test to xfail. Remove old dead code. svn: r16479 --- .../typed-scheme/unit-tests/new-fv-tests.ss | 101 ------------------ .../typed-scheme/unit-tests/random-testing.ss | 70 ------------ .../tests/typed-scheme/xfail/applicative.ss | 23 ++++ 3 files changed, 23 insertions(+), 171 deletions(-) delete mode 100644 collects/tests/typed-scheme/unit-tests/new-fv-tests.ss delete mode 100644 collects/tests/typed-scheme/unit-tests/random-testing.ss create mode 100644 collects/tests/typed-scheme/xfail/applicative.ss diff --git a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss b/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss deleted file mode 100644 index d9ca47239b..0000000000 --- a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss +++ /dev/null @@ -1,101 +0,0 @@ -(module new-fv-tests mzscheme - (require "test-utils.ss" "planet-requires.ss") - (require/private type-rep rep-utils type-effect-convenience meet-join subtype union) - (require-schemeunit) - - (define variance-gen (random-uniform Covariant Contravariant Invariant Constant)) - - (define alpha-string (random-string (random-char (random-int-between 65 90)) (random-size 1))) - - (define (free-gen var) (random-apply make-immutable-hash-table (random-list-of (random-apply cons var variance-gen) (random-size 1)))) - (define free-var-gen (free-gen (random-symbol alpha-string))) - (define free-idx-gen (free-gen (random-size))) - - (define free-vars-gen (free-gen free-var-gen)) - (define free-idxs-gen (free-gen free-idx-gen)) - - (define type-gen - (random-recursive - t - [10 Univ] - [10 N] - [10 B] - [2 (random-apply make-Pair t t)] - [2 (random-apply make-Vector t)] - [2 (random-apply -lst t)] - [2 (random-apply -Promise t)] - [1 (random-apply apply Un (random-list-of t))])) - - (define values-gen - (random-weighted 1 type-gen 6 (random-apply -values (random-list-of type-gen (random-weighted 1 0 3 (random-size 2)))))) - - - (define (fvars frees) (hash-table-map frees (lambda (k v) k))) - (define (subset a b) (andmap (lambda (e) (memq e b)) a)) - - (define (var-below v w) - (or (eq? v w) (eq? v Invariant) (eq? w Constant))) - - (define (free-var-from frees) - (let ([keys (map car (generate (random-apply hash-table-map frees list)))]) - (apply choose-uniform keys))) - - (define (fv-tests) - (test-suite "random tests" - (test-randomly "combine includes all the elements" - 100 - ([A free-vars-gen] - [B free-vars-gen] - [C free-idxs-gen] - [D free-idxs-gen]) - (let ([C1 (combine-frees (list A B))] - [C2 (combine-frees (list C D))]) - (check-not-false (subset (fvars A) (fvars C1))) - (check-not-false (subset (fvars B) (fvars C1))) - (check-not-false (subset (fvars C) (fvars C2))) - (check-not-false (subset (fvars D) (fvars C2))))) - (test-randomly "combine produces lower variance" - 100 - ([A free-vars-gen] - [B free-vars-gen] - [key (free-var-from A)]) - (let* ([comb (combine-frees (list A B))] - [var1 (hash-table-get A key)] - [var2 (hash-table-get comb key)]) - (check-not-false (var-below var2 var1)))))) - - - (define (meet-join-tests) - (test-suite - "meet join" - (test-randomly "join of two types is above them" - 10 - ([A type-gen] - [B type-gen] - [A+B (join A B)]) - (check-not-false (subtype A A+B)) - (check-not-false (subtype B A+B))) - (test-randomly "meet of two types is below them" - 10 - ([A type-gen] - [B type-gen] - [A+B (meet A B)]) - (check-not-false (subtype A+B A)) - (check-not-false (subtype A+B B))) - (test-randomly "promote/demote" - 10 - ([t type-gen] - [V (random-list-of (random-symbol alpha-string))] - [p (promote t V)] - [d (demote t V)] - [fv-p (fv p)] - [fv-d (fv d)]) - (check-false (ormap (lambda (e) (memq e V)) fv-p)) - (check-false (ormap (lambda (e) (memq e V)) fv-d)) - (check-not-false (subtype t p)) - (check-not-false (subtype p d))))) - - (define-go fv-tests meet-join-tests) - - - ) diff --git a/collects/tests/typed-scheme/unit-tests/random-testing.ss b/collects/tests/typed-scheme/unit-tests/random-testing.ss deleted file mode 100644 index 4b64b15bda..0000000000 --- a/collects/tests/typed-scheme/unit-tests/random-testing.ss +++ /dev/null @@ -1,70 +0,0 @@ -#lang scheme/base - -(require (planet cce/fasttest/random) - "test-utils.ss") -(require (private type-effect-convenience type-rep) - scheme/match) - - - -(define base (random-uniform (random-apply (lambda (n) #`(quote #,n)) (random-int-between 1 100)))) - -(define (N? t) - (match t - [(Base: 'Number) #t] - [_ #f])) - -(define (make-lam formals body) - #`(#%plain-lambda #,formals #,body)) - - -(define random-id - (random-apply datum->syntax #f (random-symbol))) - -(define (make-app f . args) - #`(#%plain-app #,f #,@args)) - -;; ty-gen : size -> generator[type] -(define-generator (ty-gen max-depth) - [3 N] - [(if (< max-depth 1) 0 1) - (random-apply (lambda (args ret) (args . ->* . ret)) - (random-list-of (ty-gen (sub1 max-depth)) (random-int-between 0 3)) - (ty-gen (sub1 max-depth)))]) - -;; base-gen : number -> generator[syntax] -(define-generator (base-gen max-depth) - [10 base] - [(if (< max-depth 1) 0 1) - (let*-random ([arg-tys (random-list-of (ty-gen (sub1 max-depth)) (random-int-between 0 (max 0 3 max-depth)))]) - (let* ([args (map (lambda (t) (term-gen t (sub1 max-depth))) arg-tys)]) - (random-apply - apply - make-app - (term-gen (arg-tys . ->* . N) (sub1 max-depth)) - (map generate args))))]) - - - -;; term-gen : type size -> generator[syntax] -(define-generator (term-gen ty max-depth) - [1 - (match ty - [(? N?) (base-gen (sub1 max-depth))] - [(Function: (list (arr: args ret _ _ _ _))) - (cond [(and (> (length args) 0) (andmap N? args)) - (random-uniform #'+ #'- #'* #'-)] - [(andmap N? args) - (random-uniform #'+ #'*)] - [else - (random-apply make-lam - (random-list-of random-id (length args)) - (term-gen ret (sub1 max-depth)))])] - [_ (error "epic fail")])]) - -(define (go [n 3]) - (generate (random-apply term-gen (ty-gen n) n))) - -(go 0) - -;(generate (base-gen 1)) diff --git a/collects/tests/typed-scheme/xfail/applicative.ss b/collects/tests/typed-scheme/xfail/applicative.ss new file mode 100644 index 0000000000..a3a5d85d71 --- /dev/null +++ b/collects/tests/typed-scheme/xfail/applicative.ss @@ -0,0 +1,23 @@ +#lang typed-scheme + +(: id (All (a) (a -> a))) +(define (id x) x) + +(: pure (All (a) (a -> (All (Env) (Env -> a))))) +(define (pure c) + (plambda: (Env) ([env : Env]) c)) + +(pure 4) +; REPL reports type (Any -> Integer) +; Shouldn't it be (All (Env) (Env -> Integer))? + +(pure id) +; REPL reports type (Any -> (All (a) (a -> a))) +; Shouldn't it be (All (Env) (Env -> (All (a) (a -> a))))? + +(: ap (All (Env a b) ((Env -> (a -> b)) (Env -> a) -> (Env -> b)))) +(define (ap f x) + (λ (env) + ((f env) (x env)))) + +(ap (pure id) (pure 4)) \ No newline at end of file