suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
9a6c1ba63d
typed-racket/typed-racket-test/unit-tests/subtype-tests.rkt
Ben Greenman fae58e140d add types for Immutable-HashTable, Mutable-HashTable, Weak-HashTable (#559) 
The old 'HashTable' type is now the union of the other 3 hash types.

- all operations that used to work on 'HashTable's still work,
  but some now have more specific outputs
- `#hash` literals have type `ImmutableHash`
- `immutable?` and `hash-weak?` are filters
- `Mutable-` and `Weak-` hashes have corresponding `Top` types, `HashTableTop` is now a union
- the contact for `(U (Immutable-Hash K1 V1) (Mutable-Hash K2 V2))` is ONE `hash/c`

Minor notes:

- renamed internal identifiers containing 'Hashtable' to all use 'HashTable'
- add Racket guide/reference 'secref' functions
2017-06-26 18:00:19 -04:00

723 lines
29 KiB
Racket
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#lang racket/base
(require "test-utils.rkt"
(types subtype numeric-tower utils abbrev prop-ops)
(rep type-rep values-rep)
(env lexical-env init-envs type-env-structs)
rackunit
(for-syntax racket/base))
(provide tests)
(gen-test-main)
(define-for-syntax (single-subtype-test stx)
(syntax-case stx (FAIL ENV ENV/FAIL)
[(FAIL t s) (syntax/loc stx (test-check (format "FAIL ~a" '(t s))
(λ (a b) (not (subtype a b))) t s))]
[(ENV ps t s) (syntax/loc stx (with-naively-extended-lexical-env [#:props ps]
(test-check (format "ENV ~a" '(ps t s)) subtype t s)))]
[(ENV/FAIL ps t s) (syntax/loc stx (with-naively-extended-lexical-env [#:props ps]
(test-check (format "ENV/FAIL ~a" '(ps t s))
(λ (a b) (not (subtype a b))) t s)))]
[(t s) (syntax/loc stx (test-check (format "~a" '(t s)) subtype t s))]))
(define-syntax (subtyping-tests stx)
(syntax-case stx ()
[(_ str cl ...)
(with-syntax ([(new-cl ...) (map single-subtype-test (syntax->list #'(cl ...)))])
(syntax/loc stx
(begin (test-suite (format "Tests for subtyping (~a)" str)
new-cl ...))))]))
(define x1 #'x)
(define x2 #'x)
(define x #'x)
(define y #'y)
(define z #'z)
(define A (make-F (gensym 'A)))
(define B (make-F (gensym 'B)))
(define AorB (Un A B))
(define t1a (-mu T (-lst (Un (-v a) T))))
(define t1b (unfold t1a))
(define t2 -Number)
(define-for-syntax (covariant-test stx)
(syntax-case stx ()
[(mk []) (syntax/loc stx
(subtyping-tests
(format "covariant tests for ~a" mk)
[(mk A) (mk A)]
[(mk t1a) (mk t1b)]
[(mk A) (mk AorB)]
[FAIL (mk AorB) (mk A)]
[FAIL (mk Univ) A]
[FAIL A (mk Univ)]))]
[(mk [] [])
(syntax/loc stx
(subtyping-tests
(format "covariant tests for ~a" mk)
[(mk A B) (mk A B)]
[(mk A B) (mk AorB B)]
[(mk A B) (mk A AorB)]
[(mk A B) (mk AorB AorB)]
[(mk t1a t1a) (mk t1b t1b)]
[FAIL (mk AorB B) (mk A B)]
[FAIL (mk A AorB) (mk A B)]
[FAIL (mk AorB AorB) (mk A B)]
[FAIL (mk Univ Univ) A]
[FAIL A (mk Univ Univ)]))]))
(define-syntax (covariant-tests stx)
(syntax-case stx ()
[(_ cl ...)
(with-syntax ([(co-tests ...) (map covariant-test (syntax->list #'(cl ...)))])
(syntax/loc stx
(begin co-tests ...)))]))
(define-for-syntax (invariant-test stx)
(syntax-case stx ()
[(mk () #:top top)
(syntax/loc stx
(subtyping-tests
(format "invariant tests for ~a" mk)
[(mk A) (mk A)]
[(mk t1a) (mk t1b)]
[(mk A) top]
[FAIL top (mk A)]
[FAIL (mk A) (mk AorB)]
[FAIL (mk AorB) (mk A)]
[FAIL (mk Univ) A]
[FAIL A (mk Univ)]))]
[(mk () () #:top top)
(syntax/loc stx
(subtyping-tests
(format "invariant tests for ~a" mk)
[(mk A B) (mk A B)]
[(mk t1a t1a) (mk t1b t1b)]
[(mk A B) top]
[FAIL top (mk A B)]
[FAIL (mk A B) (mk AorB B)]
[FAIL (mk A B) (mk A AorB)]
[FAIL (mk A B) (mk AorB AorB)]
[FAIL (mk AorB B) (mk A B)]
[FAIL (mk A AorB) (mk A B)]
[FAIL (mk AorB AorB) (mk A B)]
[FAIL (mk Univ Univ) A]
[FAIL A (mk Univ Univ)]))]))
(define-syntax (invariant-tests stx)
(syntax-case stx ()
[(_ cl ...)
(with-syntax ([(inv-tests ...) (map invariant-test (syntax->list #'(cl ...)))])
(syntax/loc stx
(begin inv-tests ...)))]))
(define simple-tests
(subtyping-tests
"Simple Subtyping Tests"
;; trivial (⊤) examples
[Univ Univ]
[-Bottom Univ]
[-Number Univ]
[-Boolean Univ]
[-Symbol Univ]
[-Void Univ]
[FAIL Univ -Symbol]
[FAIL Univ -Number]
;; Reflexivity
[(-val 6) (-val 6)]
[-Symbol -Symbol]
;; Error
[Err -Number]
[-Number Err]
;; B
[(make-B 0) (make-B 0)]
[FAIL (make-B 0) (make-B 1)]
;; F
[(-v a) (-v a)]
[FAIL (-v a) (-v b)]
;; Value
[(-val 'a) (-val 'a)]
[(-val 'a) -Symbol]
[FAIL -Symbol (-val 'a)]
[FAIL (-val 'a) (-val 'b)]
;; Base
[-String -String]
[FAIL -Symbol -String]
;; Opaque
[(make-Opaque x1) (make-Opaque x2)]
[FAIL (make-Opaque #'a) (make-Opaque #'b)]
;; Refinement
[(make-Refinement A x1) (make-Refinement A x2)]
;[(make-Refinement t1a x1) (make-Refinement t1b x1)]
;[(make-Refinement t1a x1) t1b]
[FAIL (make-Refinement t2 x1) t1b]
[FAIL (make-Refinement A #'a) (make-Refinement A #'b)]
[FAIL (make-Refinement A x1) (make-Refinement B x1)]
;; Distinction
[(-Distinction 'a 'b A) A]
[(-Distinction 'a 'b A) AorB]
[FAIL (-Distinction 'a 'b AorB) A]
))
(define structural-tests
(test-suite
"Structural Subtyping tests"
(covariant-tests
[make-Pair () ()]
[make-Promise ()]
[make-Ephemeron ()]
[make-CustodianBox ()]
[make-Set ()]
[make-Evt ()]
[make-Syntax ()]
[make-Future ()])
(invariant-tests
[make-MPair () () #:top -MPairTop]
[make-Vector () #:top -VectorTop]
[make-Box () #:top -BoxTop]
[make-Channel () #:top -ChannelTop]
[make-Async-Channel () #:top -Async-ChannelTop]
[make-ThreadCell () #:top -ThreadCellTop]
[make-Weak-Box () #:top -Weak-BoxTop]
[make-Immutable-HashTable () () #:top -HashTableTop]
[make-Mutable-HashTable () () #:top -HashTableTop]
[make-Mutable-HashTable () () #:top -Mutable-HashTableTop]
[make-Weak-HashTable () () #:top -HashTableTop]
[make-Weak-HashTable () () #:top -Weak-HashTableTop]
[make-HashTable () () #:top -HashTableTop]
[make-Prompt-Tagof () () #:top -Prompt-TagTop]
[make-Continuation-Mark-Keyof () #:top -Continuation-Mark-KeyTop])
(subtyping-tests
"Param"
[(make-Param A B) (make-Param A B)]
[(make-Param A B) (make-Param A AorB)]
[(make-Param AorB B) (make-Param A B)]
[FAIL (make-Param A B) (make-Param AorB B)]
[FAIL (make-Param A AorB) (make-Param A B)])
(subtyping-tests
"Evt special cases"
;; evts
[(-evt t1a) (-evt t1b)]
[FAIL (-evt -Byte) (-evt -String)]
[-Semaphore (-evt -Semaphore)]
[FAIL -Semaphore (-evt -Int)]
[-Output-Port (-evt -Output-Port)]
[FAIL -Output-Port (-evt -Int)]
[-Input-Port (-evt -Input-Port)]
[FAIL -Input-Port (-evt -Int)]
[-TCP-Listener (-evt -TCP-Listener)]
[FAIL -TCP-Listener (-evt -Int)]
[-Thread (-evt -Thread)]
[FAIL -Thread (-evt -Int)]
[-Subprocess (-evt -Subprocess)]
[FAIL -Subprocess (-evt -Int)]
[-Will-Executor (-evt -Will-Executor)]
[FAIL -Will-Executor (-evt -Int)]
[(make-CustodianBox -String) (-evt (make-CustodianBox -String))]
[FAIL (make-CustodianBox -String) (-evt -String)]
[(-channel -String) (-evt -String)]
[FAIL (-channel -String) (-evt -Int)]
[-Log-Receiver (-evt (make-HeterogeneousVector
(list -Symbol -String Univ
(Un -False -Symbol))))]
[FAIL -Log-Receiver (-evt -Int)])
(subtyping-tests
"Sequence special cases"
[(-set -Number) (make-Sequence (list -Number))]
[-FlVector (make-Sequence (list -Flonum))]
[-FlVector (make-Sequence (list -Number))]
[-FxVector (make-Sequence (list -Fixnum))]
[-FxVector (make-Sequence (list -Number))]
[(-val 5) (-seq -Nat)]
[(-val 5) (-seq -Byte)]
[-Index (-seq -Index)]
[-NonNegFixnum (-seq -NonNegFixnum)]
[-Index (-seq -Nat)]
[FAIL (-val -5) (-seq -Nat)]
[FAIL -Fixnum (-seq -Fixnum)]
[FAIL -NonNegFixnum (-seq -Index)]
[FAIL (-val 5.0) (-seq -Nat)]
[(-pair -String (-lst -String)) (-seq -String)]
[FAIL (-pair -String (-lst -Symbol)) (-seq -String)]
[FAIL (-pair -String (-vec -String)) (-seq -String)]
[-Null (-seq -String)]
[(-mpair -String -Null) (-seq -String)]
[(-mlst -String) (-seq -String)]
[(-mpair -String (-mlst -String)) (-seq -String)]
[FAIL (-mpair -String (-mlst -Symbol)) (-seq -String)]
[FAIL (-mpair -String (-vec -String)) (-seq -String)]
[(-mpair -String (-mlst (-val "hello"))) (-seq -String)])
(subtyping-tests
"Other Structural Cases"
[(-Param -String -Symbol) (cl->* (-> -Symbol) (-> -String -Void))]
[(-lst* -Number -Number (-val 'foo)) (-lst (Un -Number -Symbol))])))
(define other-tests
(subtyping-tests
"Other Subtyping Tests"
;; recursive types and unions
[(Un (-pair Univ (-lst Univ)) -Null) (-lst Univ)]
[(-lst* -Number -Number (-val 'foo)) (-lst Univ)]
[(Un (-val #f) (Un (-val 6) (-val 7))) (-mu x (Un -Number (Un -Boolean -Symbol)))]
[(-mu x (Un -Zero (make-Listof x)))
(-mu x (Un -Number (make-Listof x)))]
[(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 -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
[(-mu x (Un -Number (-lst* x -Symbol x))) -Sexp]
[t1a (unfold t1a)]
[(unfold t1a) t1a]
;; simple list types
[(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 -Number -Number) (-pair Univ -Number)]
[(-pair -Number -Number) (-pair -Number -Number)]
;; from page 7 (my favorite page! But seriously, page 7 of... what???)
[(-mu t (-> t t)) (-mu s (-> s s))]
[(-mu s (-> -Number s)) (-mu t (-> -Number (-> -Number t)))]
;; not subtypes
[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
[(-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))]
;; HeterogeneousVector
[(make-HeterogeneousVector (list t1a)) (-vec t1b)]
[(make-HeterogeneousVector (list t1a t1a)) (-vec t1b)]
[FAIL (-vec t1b) (make-HeterogeneousVector (list t1a t1a))]
[FAIL (make-HeterogeneousVector (list t2)) (-vec t1b)]
[FAIL (make-HeterogeneousVector (list t1a t2)) (-vec t1b)]
[(make-HeterogeneousVector (list t1a t1b)) (make-HeterogeneousVector (list t1b t1a))]
[(make-HeterogeneousVector (list t1a t1b)) (make-HeterogeneousVector (list t1b t1a))]
[FAIL (make-HeterogeneousVector (list t1a)) (make-HeterogeneousVector (list t1b t1a))]
[FAIL (make-HeterogeneousVector (list t1a t2)) (make-HeterogeneousVector (list t1b t1a))]
[FAIL (make-HeterogeneousVector (list t2 t1a)) (make-HeterogeneousVector (list t1b t1a))]
))
(define set-theoretic-type-tests
(subtyping-tests
"Set-theoretic Subtyping"
;; Unions
[(-val 0.0f0) -SingleFlonum]
[(-val -0.0f0) -SingleFlonum]
[(-val 1.0f0) -SingleFlonum]
[(-val -34.2f0) -NegSingleFlonum]
[(-val 6) -Number]
[(Un (-val 'foo) (-val 6)) (Un (-val 'foo) (-val 6))]
[(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 -Number (-pair -Number -Number)) (Un -Number -Symbol (-pair Univ Univ))]
[(Un -Number -Symbol (-pair -Number -Number)) (Un -Number -Symbol (-pair Univ Univ))]
;; intersections
[(-unsafe-intersect -Number) -Number]
[(-unsafe-intersect -Number -Symbol) -Number]
[(-unsafe-intersect -Boolean -Number) -Number]
[(-unsafe-intersect -Number -Number) -Number]
[FAIL -Number (-unsafe-intersect -Boolean -Number)]
[(-unsafe-intersect -Boolean -Number) (-unsafe-intersect -Boolean -Number)]
[(-unsafe-intersect -Sexp
(Un -Null (-pair -Sexp (-unsafe-intersect (make-Listof Univ) -Sexp))))
(make-Listof Univ)]
[(-unsafe-intersect (-v A) (-v B))
(Un -String (-unsafe-intersect (-v A) (-v B)))]
))
(define poly-tests
(subtyping-tests
"Polymorphic Subtyping"
[(-poly (t) (-> t t)) (-poly (s) (-> s s))]
[FAIL (make-Listof -Number) (-poly (t) (make-Listof t))]
[(-poly (a) (make-Listof (-v a))) (make-Listof -Number)] ;;
[(-poly (a) -Number) -Number]
[FAIL (-poly (a) (-poly (b) (-pair a b))) (-poly (a) (-poly (b) (-pair b a)))]
;; The following currently are not subtypes, because they are not replaceable
;; in an instantiation context. It may be sound for them to be subtypes but
;; the implications of that change are unknown.
[FAIL (-poly (x) (-lst x)) (-poly (x y) (-lst x))]
[FAIL (-poly (y z) (-lst y)) (-poly (z y) (-lst y))]
[FAIL (-poly (y) (-poly (z) (-pair y z))) (-poly (y z) (-pair y z))]
[FAIL (-poly (y z) (-pair y z)) (-poly (y) (-poly (z) (-pair y z)))]))
(define function-tests
(subtyping-tests
"Function Subtyping"
;; simple function types
[((Un -Symbol -Number) . -> . -Number) (-> -Number -Number)]
[(-poly (t) (-> -Number t)) (-mu t (-> -Number t))]
((Univ . -> . -Number) (-Number . -> . Univ))
[(Univ Univ Univ . -> . -Number) (Univ Univ -Number . -> . -Number)]
;; case-lambda
[(cl-> [(-Number) -Number] [(-Boolean) -Boolean]) (-Number . -> . -Number)]
;; special case for unused variables
[-Number (-poly (a) -Number)]
[FAIL (cl-> [(-Number) -Boolean] [(-Boolean) -Number]) (-Number . -> . -Number)]
;; varargs
[(->* (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]
[(-Number) a]))
(cl-> [() (-pair -Number (-v b))]
[(-Number) (-pair -Number (-v b))])]
;; polymorphic function types should be subtypes of the function top
[(-poly (a) (a . -> . a)) top-func]
[FAIL (-> Univ) (null Univ . ->* . Univ)]
[(-poly (b) ((Un (make-Opaque #'dummy)
(-struct #'bar #f
(list (make-fld -Number #'values #f) (make-fld b #'values #f))))
. -> . (-lst b)))
((Un (make-Opaque #'dummy) (-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f))))
. -> . (-lst (-pair -Number (-v a))))]
[(-poly (b) ((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld b #'values #f))) . -> . (-lst b)))
((-struct #'bar #f (list (make-fld -Number #'values #f) (make-fld (-pair -Number (-v a)) #'values #f)))
. -> .
(-lst (-pair -Number (-v a))))]
[(-poly (a) (a . -> . (make-Listof a))) ((-v b) . -> . (make-Listof (-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))]
[(cl->* (-Number . -> . -String) (-Boolean . -> . -String)) ((Un -Boolean -Number) . -> . -String)]
[(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))
(-> Univ -Boolean : -tt-propset)]
[(-> Univ -Boolean : -ff-propset)
(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))]
[(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))
(-> (Un -Symbol -String) -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))]
[FAIL
(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))
(-> Univ -Boolean : (-PS (-is-type 0 -String) (-not-type 0 -String)))]
;; subtyping for types inside propositions
[(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))
(-> Univ -Boolean : (-PS (-is-type 0 (-opt -Symbol)) (-not-type 0 -Symbol)))]
[(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 (-opt -Symbol))))
(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))]
[FAIL
(-> Univ -Boolean : (-PS (-is-type 0 (-opt -Symbol)) (-not-type 0 (-opt -Symbol))))
(-> Univ -Boolean : (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol)))]
[FAIL (make-ListDots (-box (make-F 'a)) 'a) (-lst (-box Univ))]
[(make-ListDots (-> -Symbol (make-F 'a)) 'a) (-lst (-> -Symbol Univ))]
[(-> Univ -Bottom) (-> Univ (-values (list -String -Symbol)))]
[(-> Univ -Bottom) (-> Univ (-values-dots null -String 'x))]
[FAIL (make-pred-ty -String) (-> Univ (-AnyValues (-is-type 0 -String)))]
;; keyword function types
[(->key #:x -Symbol #f Univ) (->key Univ)]
[FAIL (->key #:x -Symbol #t Univ) (->key Univ)]
[FAIL (->key Univ) (->key #:x -Symbol #t Univ)]
[(->key #:x -Symbol #f #:y -Symbol #f Univ) (->key Univ)]
[FAIL (->key #:x -Symbol #f #:y -Symbol #t Univ) (->key Univ)]
[(->key #:x -Symbol #f #:y -Symbol #f Univ) (->key #:x -Symbol #f Univ)]
[(->key #:x -Symbol #f #:y -Symbol #f Univ) (->key #:x -Symbol #t Univ)]
[FAIL (->key #:x -Symbol #f Univ) (->key #:x -Symbol #f #:y -Symbol #f Univ)]
[(->key #:x -Symbol #f #:y -Symbol #f Univ)
(->key #:x -Symbol #t #:y -Symbol #t Univ)]
[FAIL
(->key #:x -Symbol #t #:y -Symbol #f Univ)
(->key #:x -Symbol #f #:y -Symbol #t Univ)]
[(->key #:x (-opt -String) #f #:y -Symbol #f Univ)
(->key #:x -String #t Univ)]
[FAIL
(->key #:x -String #f #:y -Symbol #f Univ)
(->key #:x (-opt -String) #t Univ)]
[(->key -String #:x -Symbol #f #:y -Symbol #f Univ)
(->key -String #:x -Symbol #t Univ)]
[FAIL
(->key -String #:x -Symbol #f #:y -Symbol #f Univ)
(->key -Void #:x -Symbol #t Univ)]
[(->optkey -String [-String] #:x -Symbol #f #:y -Symbol #f Univ)
(->key -String #:x -Symbol #t Univ)]
[(->optkey -String [-String] #:x -Symbol #f #:y -Symbol #f Univ)
(->optkey -String [-String] #:x -Symbol #t Univ)]
[FAIL
(->optkey -String [-String] #:x -Symbol #f #:y -Symbol #f Univ)
(->optkey -String [-Void] #:x -Symbol #t Univ)]
[FAIL
(->key -String #:x -Symbol #f #:y -Symbol #f Univ)
(->optkey -String [-Void] #:x -Symbol #t Univ)]
;; Proposition subtyping
[(make-pred-ty (list -Real) -Boolean (Un (-val 0.0) (-val 0)))
(make-pred-ty (list -Int) -Boolean (-val 0))]
[(-polydots (a) (->... (list Univ) (a a) (make-ValuesDots null a 'a)))
(-polydots (a) (->... (list -String) (a a) (make-ValuesDots null a 'a)))]
[(-polydots (a) (->... null (Univ a) (make-ValuesDots (list (-result a)) a 'a)))
(-polydots (a) (->... null (-String a) (make-ValuesDots (list (-result a)) a 'a)))]
[(-polydots (a) (->... null (a a) (make-ValuesDots (list (-result -String)) -String 'a)))
(-polydots (a) (->... null (a a) (make-ValuesDots (list (-result Univ)) Univ 'a)))]
[(-polydots (a) (->... null (Univ a) (-values (list Univ))))
(->* null Univ Univ)]
;; ListDots
[(-polydots (a) (->... null (a a) (make-ListDots a 'a)))
(-> -String -Symbol (-Tuple (list -String -Symbol)))]
[(-> -String -Symbol (-Tuple (list -String -Symbol)))
(-polydots (a) (-> -String -Symbol (-lst (Un -String -Symbol))))]
[(-polydots (a) (->... null (a a) (make-ListDots a 'a)))
(-poly (a b) (-> a b (-Tuple (list a b))))]
[(-polydots (b a) (-> (->... (list b) (a a) (make-ValuesDots (list (-result b)) a 'a)) Univ))
(-polydots (a) (-> (->... (list) (a a) (make-ValuesDots null a 'a)) Univ))]
[(-polydots (a) (->... (list) (a a) (make-ListDots a 'a)))
(-polydots (b a) (->... (list b) (a a) (-pair b (make-ListDots a 'a))))]
[FAIL
(-polydots (c a b) (->... (list (->... (list a) (b b) c) (-vec a)) ((-vec b) b) (-vec c)))
(->* (list (->* (list) -Symbol -Symbol)) (-vec -Symbol) (-vec -Symbol))]))
(define struct-tests
(subtyping-tests
"Struct Subtyping"
[(-struct x1 #f null) (-struct x2 #f null)]
[(-struct #'a #f (list (make-fld -String #'values #f))) (-struct #'a #f (list (make-fld -String #'values #f)))]
[(-struct #'a #f (list (make-fld -String #'values #f))) (-struct #'a #f (list (make-fld Univ #'values #f)))]
;; prefab structs
[(-prefab 'foo -String) (-prefab 'foo -String)]
[(-prefab 'foo -String) (-prefab 'foo (-opt -String))]
[(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo -String)]
[(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo (-opt -String))]
[FAIL
(-prefab '(foo #(0)) -String) (-prefab '(foo #(0)) (-opt -String))]
[(-prefab '(foo 1 #(0)) -String -Symbol)
(-prefab '(foo #(0)) -String)]
[(-prefab '(bar foo 1 #(0)) -String -Symbol)
(-prefab '(foo #(0)) -String)]
[FAIL
(-prefab '(foo #()) -String) (-prefab '(foo #(0)) (-opt -String))]
;; TODO StructType ?
))
(define oo-tests
(subtyping-tests
"Object Oriented Subtyping"
[(-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))
(-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))]
[(-object #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))
(-object #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))]
[(-object #:method ((m (-> -Nat)) (n (-> -Nat))))
(-object #:method ((m (-> -Nat))))]
[(-object #:method ((f (-> -Nat))) #:augment ((m (-> -Nat)) (n (-> -Nat))))
(-object #:augment ((m (-> -Nat))))]
[(-object #:field ((a -Nat)) #:method ((m (-> -Nat)) (n (-> -Nat))))
(-object #:method ((m (-> -Nat))))]
[(-object #:field ((x -Symbol)))
(-object #:field ((x -Symbol)))]
[(-object #:field ((x -Symbol)))
(-object #:field ((x (Un -Symbol (-val #f)))))]
[FAIL
(-object #:field ((a -Symbol)))
(-object #:field ((x -Symbol)))]
[FAIL
(-object #:field ((a -Symbol)))
(-object #:field ((x -String)))]
[FAIL
(-object #:field ((x -Symbol)))
(-object #:field ((x -String)))]
[FAIL
(-object #:method ((m (-> -String)) (n (-> -String))))
(-object #:method ((x (-> -String))))]
[(-object #:method ((m (-> -String)) (n (-> -String))))
(-object #:method ((m (-> -String))))]
[FAIL
(-object #:method ())
(-object #:method ((m (-> -String))))]
[FAIL
(-object #:method ((m (-> -Nat)) (n (-> -Nat))))
(-object #:method ((l (-> -Nat)) (m (-> -Nat))))]
[(-object #:method ((m (-> -Nat)) (n (-> -Nat))))
(-object #:method ((n (-> -Nat)) (m (-> -Nat))))]
[FAIL
(-class #:method ((m (-> -Nat))))
(-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))]
[FAIL
(-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))
(-class #:method ((m (-> -Nat))))]))
(define-for-syntax (single-subval-test stx)
(syntax-case stx (FAIL)
[(FAIL t s) (syntax/loc stx (test-check (format "FAIL ~a" '(t s)) (lambda (a b) (not (subval a b))) t s))]
[(t s) (syntax/loc stx (test-check (format "~a" '(t s)) subval t s))]))
(define-syntax (subval-tests stx)
(syntax-case stx ()
[(_ str cl ...)
(with-syntax ([(new-cl ...) (map single-subval-test (syntax->list #'(cl ...)))])
(syntax/loc stx
(begin (test-suite (format "Tests for subval (~a)" str)
new-cl ...))))]))
(define values-tests
(subval-tests
"SomeValues"
[(-values (list -Number))
(-values (list Univ))]
[FAIL (make-ValuesDots (list) -Symbol 'a)
(make-ValuesDots (list (-result -String)) -String 'a)]
[(-values (list -Bottom))
(-values (list -String -Symbol))]
))
(define refinement-tests
(subtyping-tests
"Refinement Subtyping"
;; weakening
[(-refine/fresh x -Int (-leq (-lexp x) (-lexp 42)))
-Int]
;; τ not a subtype of refined τ
[FAIL -Int
(-refine/fresh x -Int (-leq (-lexp x) (-lexp 42)))]
;; prop implies w/ leqs
[(-refine/fresh x -Int (-leq (-lexp x) (-lexp 99)))
(-refine/fresh x -Int (-leq (-lexp x) (-lexp 100)))]
;; prop doesn't imply
[FAIL
(-refine/fresh x -Int (-leq (-lexp x) (-lexp 99)))
(-refine/fresh x -Nat (-leq (-lexp x) (-lexp 100)))]
[FAIL
(-refine/fresh x -Int (-is-type y -String))
(-refine/fresh x -Nat (-is-type y -String))]
;; logical implication w/ types
[(-refine/fresh x -Int (-is-type y -Int))
(-refine/fresh x -Int (-is-type y -Number))]
[(-refine/fresh x -Int (-and (-is-type y -Nat)
(-is-type z -Nat)))
(-refine/fresh x -Int (-or (-is-type y -Int)
(-is-type z -Int)))]
[(-refine/fresh x -Int (-or (-is-type y -Nat)
(-is-type z -Nat)))
(-refine/fresh x -Int (-or (-is-type y -Int)
(-is-type z -Int)))]
[FAIL
(-refine/fresh x -Int (-or (-is-type y -Nat)
(-is-type z -String)))
(-refine/fresh x -Int (-or (-is-type y -Int)
(-is-type z -Int)))]
[(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 99))
(-leq (-lexp 1) (-lexp x))))
(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x))))]
[FAIL
(-refine/fresh x -Int (-or (-leq (-lexp x) (-lexp 99))
(-leq (-lexp 1) (-lexp x))))
(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x))))]
;; refinements in unions
[(Un -String (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 99))
(-leq (-lexp 1) (-lexp x)))))
(Un -String (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x)))))]
[(Un (-refine/fresh x -String (-and (-is-type y -Nat)
(-is-type z -Nat)))
(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 99))
(-leq (-lexp 1) (-lexp x)))))
(Un (-refine/fresh x -String (-or (-is-type y -Int)
(-is-type z -Int)))
(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x)))))]
[FAIL
(Un (-refine/fresh x -String (-or (-is-type y -Int)
(-is-type z -Int)))
(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 99))
(-leq (-lexp 1) (-lexp x)))))
(Un (-refine/fresh x -String (-and (-is-type y -Nat)
(-is-type z -Nat)))
(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x)))))]
;; refinements with "structural" types
[(-pair -String (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 99))
(-leq (-lexp 1) (-lexp x)))))
(-pair -String (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x)))))]
[(-pair (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 99))
(-leq (-lexp 1) (-lexp x))))
-String)
(-pair (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x))))
-String)]
[(-refine/fresh x (-pair -Int -Int)
(-and (-leq (-lexp (-car-of (-id-path x))) (-lexp 99))
(-leq (-lexp 1) (-lexp (-car-of (-id-path x))))))
(-pair (-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x))))
-Number)]
[(-refine/fresh x (-pair -Int -Int)
(-and (-leq (-lexp (-cdr-of (-id-path x))) (-lexp 99))
(-leq (-lexp 1) (-lexp (-cdr-of (-id-path x))))))
(-pair -Number
(-refine/fresh x -Int (-and (-leq (-lexp x) (-lexp 100))
(-leq (-lexp 0) (-lexp x)))))]
[FAIL
(-refine/fresh x -Int (-leq (-lexp x) (-lexp y)))
(-refine/fresh x -Int (-leq (-lexp x) (-lexp z)))]
;; some tests w/ environments
[ENV
(list (-leq (-lexp y) (-lexp z)))
(-refine/fresh x -Int (-leq (-lexp x) (-lexp y)))
(-refine/fresh x -Int (-leq (-lexp x) (-lexp z)))]
[ENV
(list (-not-type z -String))
(-refine/fresh x -Int (-or (-is-type y -Nat)
(-is-type z -String)))
(-refine/fresh x -Int (-or (-is-type y -Int)
(-is-type z -Int)))]
[ENV/FAIL
(list (-leq (-lexp z) (-lexp y)))
(-refine/fresh x -Int (-leq (-lexp x) (-lexp y)))
(-refine/fresh x -Int (-leq (-lexp x) (-lexp z)))]))
(define tests
(test-suite
"All Subtype Tests"
simple-tests
structural-tests
set-theoretic-type-tests
struct-tests
poly-tests
function-tests
oo-tests
values-tests
other-tests
refinement-tests))
Reference in New Issue View Git Blame Copy Permalink