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

Add failing test to xfail.

Browse Source 
Remove old dead code.

svn: r16479
This commit is contained in:
Sam Tobin-Hochstadt 2009-10-30 16:26:48 +00:00
parent d48bc1f1c1
commit 93a504a817
3 changed files with 23 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
collects/tests/typed-scheme/unit-tests/new-fv-tests.ss
View File

@ -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)
)

70
collects/tests/typed-scheme/unit-tests/random-testing.ss
View File

@ -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))

23
collects/tests/typed-scheme/xfail/applicative.ss Normal file
View File

@ -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))