8e7f39025a
Prior to this change (which was Typed Racket PR 469) all internal TR objects (Reps) were interned and kept around for the entire duration of type checking. Because of this, frequent operations that rebuilt types were particularly costly (e.g. various forms of substitution). To recoup some of this cost, caching was being used in a lot of places. This PR sought to remove interning as the default behavior for Reps and allow for more flexibility in how we approach time/space performance needs going forward. The following changes were included in this overhaul: Interning: All Reps are no longer interned. Right now we only intern unions and some propositions. Rep generic operations: we now use racket/generic so we're not reinventing this wheel. Singletons: Reps (e.g. TrueProp, Univ, etc) can be declared singleton, which creates a single instance of the rep that all visible operations (even within the declaring module) are defined in terms of (e.g. predicates are defined as (λ (x) (eq? x singleton-instance)), etc). Custom constructors: Custom constructors can be specified for Reps, which allows for simple normalization, interning, or other invariants to be enfored whenever a Rep is created. Union: Unions used to try to ensure no obviously overlaping types would inhabit the same Union (e.g. (U String (Pairof Any Any) (Pairof Int Int)) would be simplified to (U String (Pairof Any Any))). This, however, required frequent calls to subtyping every time a Union was modified and working with Unions thus had a high cost (another thing that caching was used to reduce). Instead of this, Unions now enforce a much simpler set of invariants on their members: (1) No duplicates (by virtue of using a hash-based set), (2) Any and Nothing do not appear in unions, and (3) Nested unions are flattened. Also, using a hashset as the internal data structure meant that we could easily intern unions w.r.t. equal? equality. NOTE: we do reduce unions to not contain obviously overlapping terms when printing to users and when generating contracts (so obviously and avoidable inneficient contracts are not generated – See union.rkt for 'normalize-type'). Subtyping changes: Subtyping has been designed to reduce dispatch time w/ a switch since we no longer cache _all_ subtyping calls (we only cache subtyping results for unions since they have some costly subtyping). prop-ops changes: AndProps now are careful to sort OrProps by length before building the resulting proposition. This is done because OrProp implication only checks if one Or is a subset of another Or. By ordering Or props by size, we only ever check if an OrProp implies another if its size is <= the other OrProp. This also makes the smart constructor '-and' more robust, since the order the props appear does not affect if some Ors are kept or not. Testing: More subtype tests have been added (we are still probably relying too much on typecheck-tests.rkt and not the more granular unit tests in general). Also, typecheck-tests.rkt has been changed to check for type-equivalence (i.e. subtyping in both directions) instead of equal? equivalence.
323 lines
12 KiB
Racket
323 lines
12 KiB
Racket
#lang racket/base
|
|
(require
|
|
"test-utils.rkt"
|
|
rackunit
|
|
racket/list
|
|
(for-syntax racket/base syntax/parse)
|
|
syntax/location syntax/srcloc
|
|
(rep rep-utils type-rep free-variance values-rep)
|
|
(r:infer infer promote-demote)
|
|
|
|
(types substitute numeric-tower utils abbrev))
|
|
|
|
(provide tests)
|
|
(gen-test-main)
|
|
|
|
|
|
(begin-for-syntax
|
|
(define-splicing-syntax-class result
|
|
(pattern (~seq) #:with v #'#f #:with exp #'#f)
|
|
(pattern (~seq #:result [v:expr exp:expr])))
|
|
(define-splicing-syntax-class vars
|
|
(pattern (~seq) #:with vars #'empty)
|
|
(pattern (~seq #:vars vars:expr)))
|
|
(define-splicing-syntax-class indices
|
|
(pattern (~seq) #:with indices #'empty)
|
|
(pattern (~seq #:indices indices:expr)))
|
|
(define-splicing-syntax-class pass
|
|
(pattern (~seq) #:with pass #'#t)
|
|
(pattern #:pass #:with pass #'#t)
|
|
(pattern #:fail #:with pass #'#f)))
|
|
|
|
|
|
(define N -Number)
|
|
(define B -Boolean)
|
|
|
|
(define-syntax-rule (fv-t ty [elems variances] ...)
|
|
(let ([ty* ty])
|
|
(test-check
|
|
(format "~a" 'ty)
|
|
equal?
|
|
(free-vars-hash (free-vars* ty*))
|
|
(make-immutable-hasheq (list (cons (quote elems) variances) ...)))))
|
|
|
|
(define-syntax-rule (fi-t ty [elems variances] ...)
|
|
(let ([ty* ty])
|
|
(test-check
|
|
(format "~a" 'ty)
|
|
equal?
|
|
(free-vars-hash (free-idxs* ty*))
|
|
(make-immutable-hasheq (list (cons (quote elems) variances) ...)))))
|
|
|
|
(define fv-tests
|
|
(test-suite
|
|
"Tests for fv"
|
|
[fv-t N]
|
|
[fv-t (-v a) [a variance:co]]
|
|
[fv-t (-pair (-v a) (-v b)) [a variance:co] [b variance:co]]
|
|
[fv-t (-pair (-HT (-v a) (-v b)) (-v c)) [a variance:inv] [b variance:inv] [c variance:co]]
|
|
[fv-t (-poly (a) a)]
|
|
[fv-t (-poly (a) (-v b)) [b variance:co]]
|
|
[fv-t (-poly (a b c d e) a)]
|
|
[fv-t (-poly (b) (-v a)) [a variance:co]]
|
|
[fv-t (-poly (b c d e) (-v a)) [a variance:co]]
|
|
[fv-t (-mu a (-lst a))]
|
|
[fv-t (-mu a (-lst (-pair a (-v b)))) [b variance:co]]
|
|
[fv-t (-vec (-lst (-v a))) [a variance:inv]]
|
|
[fv-t (->* null (-v a) N) [a variance:contra]]
|
|
))
|
|
|
|
(define fi-tests
|
|
(test-suite
|
|
"Test suite for fi"
|
|
[fi-t (make-ValuesDots null (-v a) 'a) [a variance:co]]
|
|
[fi-t (->... (list) ((-v a) (-v a)) (make-ValuesDots null (-v a) 'a))
|
|
[a variance:co]]))
|
|
|
|
(define-syntax (pd-t stx)
|
|
(syntax-parse stx
|
|
([_ S:expr (vars:id ...) D:expr P:expr]
|
|
(quasisyntax/loc stx
|
|
(test-case (format "~a => ~a < ~a < ~a" '(vars ...) 'D 'S 'P)
|
|
(define S-v S)
|
|
(define promoted (var-promote S-v '(vars ...)))
|
|
(define demoted (var-demote S-v '(vars ...)))
|
|
#,(syntax/loc stx
|
|
(check-equal? promoted P "Promoted value doesn't match expected."))
|
|
#,(syntax/loc stx
|
|
(check-equal? demoted D "Demoted value doesn't match expected.")))))))
|
|
|
|
(define pd-tests
|
|
(test-suite
|
|
"Tests for var-promote/var-demote"
|
|
(pd-t Univ () Univ Univ)
|
|
(pd-t (-v a) () (-v a) (-v a))
|
|
(pd-t (-v a) (a) -Bottom Univ)
|
|
(pd-t (-v a) (b) (-v a) (-v a))
|
|
(pd-t (-vec (-v a)) (a) (-vec -Bottom) (-vec Univ))
|
|
(pd-t (-vec (-lst (-v a))) (a) (-vec -Bottom) (-vec Univ))
|
|
(pd-t (-vec (-v a)) (b) (-vec (-v a)) (-vec (-v a)))
|
|
|
|
(pd-t (-box (-v a)) (a) (-box -Bottom) (-box Univ))
|
|
(pd-t (-box (-lst (-v a))) (a) (-box -Bottom) (-box Univ))
|
|
(pd-t (-box (-v a)) (b) (-box (-v a)) (-box (-v a)))
|
|
|
|
(pd-t (-channel (-v a)) (a) (-channel -Bottom) (-channel Univ))
|
|
(pd-t (-channel (-lst (-v a))) (a) (-channel -Bottom) (-channel Univ))
|
|
(pd-t (-channel (-v a)) (b) (-channel (-v a)) (-channel (-v a)))
|
|
|
|
(pd-t (-thread-cell (-v a)) (a) (-thread-cell -Bottom) (-thread-cell Univ))
|
|
(pd-t (-thread-cell (-lst (-v a))) (a) (-thread-cell -Bottom) (-thread-cell Univ))
|
|
(pd-t (-thread-cell (-v a)) (b) (-thread-cell (-v a)) (-thread-cell (-v a)))
|
|
|
|
(pd-t (-HT (-v a) (-v a)) (a) (-HT -Bottom -Bottom) (-HT Univ Univ))
|
|
(pd-t (-HT (-lst (-v a)) (-lst (-v a))) (a) (-HT -Bottom -Bottom) (-HT Univ Univ))
|
|
(pd-t (-HT (-v a) (-v a)) (b) (-HT (-v a) (-v a)) (-HT (-v a) (-v a)))
|
|
|
|
(pd-t (-Param (-v a) (-v b)) (a b) (-Param Univ -Bottom) (-Param -Bottom Univ))
|
|
(pd-t (-Param (-lst (-v a)) (-lst (-v b))) (a b)
|
|
(-Param (-lst Univ) (-lst -Bottom))
|
|
(-Param (-lst -Bottom) (-lst Univ)))
|
|
|
|
(pd-t (->* (list (-lst (-v a))) (-lst (-v a)) (-lst (-v a))) (a)
|
|
(->* (list (-lst Univ)) (-lst Univ) (-lst -Bottom))
|
|
(->* (list (-lst -Bottom)) (-lst -Bottom) (-lst Univ)))
|
|
|
|
(pd-t (->key #:a (-lst (-v a)) #t #:b (-lst (-v a)) #f -Symbol) (a)
|
|
(->key #:a (-lst Univ) #t #:b (-lst Univ) #f -Symbol)
|
|
(->key #:a (-lst -Bottom) #t #:b (-lst -Bottom) #f -Symbol))
|
|
|
|
(pd-t (->... (list) ((-lst (-v a)) b) -Symbol) (a)
|
|
(->... (list) ((-lst Univ) b) -Symbol)
|
|
(->... (list) ((-lst -Bottom) b) -Symbol))))
|
|
|
|
|
|
(define-syntax (infer-t stx)
|
|
(syntax-parse stx
|
|
([_ S:expr T:expr . rest]
|
|
(syntax/loc stx
|
|
(infer-l (list S) (list T) . rest)))))
|
|
|
|
(define-syntax (infer-l stx)
|
|
(syntax-parse stx
|
|
([_ S:expr T:expr :vars :indices R:result :pass]
|
|
(quasisyntax/loc stx
|
|
(test-case (format "~a ~a~a" S T (if pass "" " should fail"))
|
|
(with-check-info (['location (build-source-location-list (quote-srcloc #,stx))])
|
|
(define substitution (infer vars indices S T R.v))
|
|
(define result (and substitution R.v (subst-all substitution R.v)))
|
|
(cond
|
|
[pass
|
|
(unless substitution
|
|
(fail-check "Could not infer a substitution"))
|
|
(when result
|
|
(with-check-info (['actual result] ['expected R.exp])
|
|
(unless (equal? result R.exp)
|
|
(fail-check "Did not infer the expected result."))))]
|
|
[fail
|
|
(when substitution
|
|
(fail-check "Inferred an unexpected substitution."))])))))))
|
|
|
|
|
|
(define-syntax-rule (i2-t t1 t2 (a b) ...)
|
|
(test-equal? (format "~a ~a" t1 t2)
|
|
(infer (fv t1) null (list t2) (list t1) (-lst* (make-F a) ...) #f)
|
|
(make-immutable-hash (list (cons a (t-subst b)) ...))))
|
|
|
|
(define-syntax-rule (i2-l t1 t2 fv (a b) ...)
|
|
(test-equal? (format "~a ~a" t2 t1)
|
|
(infer fv null t2 t1 (-lst* (make-F a) ...) #f)
|
|
(make-immutable-hash (list (cons a (t-subst b)) ...))))
|
|
|
|
(define (f t1 t2) (infer (fv t1) null (list t1) (list t2) #f))
|
|
|
|
(define-syntax-rule (i2-f t1 t2)
|
|
(infer-t t2 t1 #:vars (fv t2) #:fail))
|
|
|
|
|
|
(define infer-tests
|
|
(test-suite
|
|
"Tests for infer"
|
|
(infer-t Univ Univ)
|
|
(infer-t (-v a) Univ)
|
|
(infer-t (-v a) (-v a) #:result [(-v a) (-v a)])
|
|
(infer-t Univ (-v a) #:fail)
|
|
(infer-t Univ (-v a) #:vars '(a))
|
|
(infer-t (-v a) Univ #:vars '(a))
|
|
(infer-t (-v a) -Bottom #:vars '(a))
|
|
(infer-t (-v a) (-v b) #:fail)
|
|
(infer-t (-v a) (-v b) #:vars '(a))
|
|
(infer-t (-v a) (-v b) #:vars '(b))
|
|
|
|
(infer-t (make-ListDots -Symbol 'b) (-lst -Symbol) #:indices '(b)
|
|
#:result [(make-ListDots (-v b) 'b) -Null])
|
|
(infer-t (make-ListDots (-v a) 'b) (-lst -Symbol) #:vars '(a) #:indices '(b)
|
|
#:result [(-lst* (make-ListDots (-v b) 'b) (-v a))
|
|
(-lst* (-lst -Bottom) -Bottom)])
|
|
(infer-t (make-ListDots (-v b) 'b) (-lst -Symbol) #:indices '(b)
|
|
#:result [(make-ListDots (-v b) 'b) (-lst -Bottom)])
|
|
|
|
(infer-t (-lst -Symbol) (make-ListDots -Symbol 'b) #:indices '(b)
|
|
#:result [(make-ListDots (-v b) 'b) (-lst -Bottom)])
|
|
(infer-t (-lst -Symbol) (make-ListDots (-v b) 'b) #:indices '(b)
|
|
#:result [(make-ListDots (-v b) 'b) (-lst -Symbol)])
|
|
(infer-t (make-ListDots (-v b) 'b) (-lst Univ) #:indices '(b))
|
|
(infer-t (make-ListDots (-v a) 'a) (-lst Univ))
|
|
(infer-t (make-ListDots (-lst (-v a)) 'a) (-lst (-lst Univ)))
|
|
(infer-t (make-ListDots (-vec (-v a)) 'a) (-lst (-vec Univ)) #:fail)
|
|
|
|
(infer-t (make-ListDots (-v a) 'b) (make-ListDots -Symbol 'b) #:vars '(a))
|
|
(infer-t (make-ListDots (-v b) 'b) (make-ListDots -Symbol 'b) #:indices '(b))
|
|
(infer-t (make-ListDots -Symbol 'b) (make-ListDots (-v b) 'b) #:indices '(b))
|
|
(infer-t (make-ListDots -Symbol 'b) (make-ListDots Univ 'b) #:indices '(b))
|
|
(infer-t (make-ListDots (-v b) 'b) (make-ListDots (-v b) 'b) #:indices '(b))
|
|
(infer-t (make-ListDots (-v b) 'b) (make-ListDots Univ 'b) #:indices '(b))
|
|
(infer-t (-pair (-v a) (make-ListDots (-v b) 'b))
|
|
(-pair (-v a) (make-ListDots (-v b) 'b))
|
|
#:result [(-v a) (-v a)])
|
|
|
|
[infer-t (->... null ((-v a) a) (-v b)) (-> -Symbol -String) #:vars '(b) #:indices '(a)]
|
|
[infer-t (->... null ((-v a) a) (make-ListDots (-v a) 'a)) (-> -String -Symbol (-lst* -String -Symbol)) #:indices '(a)]
|
|
[infer-t (->... (list (-v b)) ((-v a) a) (-v b)) (-> -String -Symbol -String) #:vars '(b) #:indices '(a)]
|
|
[infer-t (->... (list (-v b)) ((-v a) a) (-v b))
|
|
(->... (list -Symbol) (-String a) (-v b))
|
|
#:vars '(b) #:indices '(a)
|
|
#:result [(-lst* (make-ListDots (-v a) 'a) (-v b))
|
|
(-lst* (-lst -String) -Symbol)]]
|
|
[infer-t (->* (list -Symbol) -String -Void)
|
|
(->... (list) ((-v a) a) -Void)
|
|
#:indices '(a)
|
|
#:result [(-lst* (make-ListDots (-v a) 'a))
|
|
(-lst* (-lst* -Bottom #:tail (-lst -Bottom)))]]
|
|
[infer-t (->* (list) -String -Void) (->... (list) (-String a) -Void)]
|
|
|
|
[infer-l (list (->... null ((-v b) b) (-v a)) (-> (-v a) -Boolean))
|
|
(list (-> -String -Symbol) (-> -Symbol -Boolean))
|
|
#:vars '(a)
|
|
#:indices '(b)]
|
|
[infer-l (list (->... null ((-v a) a) (-v b)) (make-ListDots (-v a) 'a))
|
|
(list (-> -Symbol -Symbol -String) (-lst* -Symbol -Symbol))
|
|
#:vars '(b)
|
|
#:indices '(a)]
|
|
|
|
[infer-t (-> (-values (list -String))) (-> (-values-dots (list) -Symbol 'b)) #:indices '(b) #:fail]
|
|
[infer-t (make-ListDots -String 'a) (make-ListDots -Symbol 'b) #:indices '(b) #:fail]
|
|
[infer-t (make-ListDots -String 'a) (make-ListDots -Symbol 'b) #:indices '(a) #:fail]
|
|
[infer-t (-lst* -String) (make-ListDots -Symbol 'b) #:indices '(b) #:fail]
|
|
[infer-t (->* (list -Symbol) -Symbol -Void) (->* (list) (-v a) -Void) #:vars '(a) #:fail]
|
|
|
|
[infer-t (-> (-values (list -Bottom))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
|
|
[infer-t (-> (-values (list (-v a)))) (-> (-values (list (-v b) (-v b)))) #:vars '(a)]
|
|
|
|
[infer-t
|
|
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
|
|
(-lst* (-> Univ Univ))
|
|
#:indices '(b) #:fail]
|
|
[infer-t
|
|
(-lst* (-> Univ Univ))
|
|
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-lst (-v b)) 'b))
|
|
#:indices '(b) #:fail]
|
|
[infer-t
|
|
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
|
|
(-pair (-> -Symbol Univ) (-lst -String))
|
|
#:indices '(b) #:fail]
|
|
[infer-t
|
|
(-pair (-> -Symbol Univ) (-lst -String))
|
|
(-pair (->... (list) ((-v b) b) Univ) (make-ListDots (-v b) 'b))
|
|
#:indices '(b) #:fail]
|
|
|
|
[infer-t
|
|
(-lst (-mu A (Un (-v b) (-lst A))))
|
|
(-mu C (Un (-v b2) (-lst C)))
|
|
#:vars '(b2)
|
|
#:result [(-vec (-v b2)) (-vec (-lst (-mu A (Un (-v b) (-lst A)))))]]
|
|
|
|
[infer-t
|
|
(-mlst (-val 'b))
|
|
(-mlst (-v a))
|
|
#:vars '(a)
|
|
#:result [(-seq (-v a)) (-seq (-val 'b))]]
|
|
|
|
[infer-t
|
|
(-lst (-val (-v a)))
|
|
(Un (-pair (-v a) Univ) -Null)
|
|
#:vars '(a)]
|
|
|
|
;; Currently Broken
|
|
;(infer-t (make-ListDots -Symbol 'b) (-pair -Symbol (-lst -Symbol)) #:indices '(b))
|
|
[i2-t (-v a) N ('a N)]
|
|
[i2-t (-pair (-v a) (-v a)) (-pair N (Un N B)) ('a (Un N B))]
|
|
[i2-t (-lst (-v a)) (-lst* N N) ('a N)]
|
|
[i2-t (-lst (-v a)) (-lst* N B) ('a (Un N B))]
|
|
[i2-t Univ (Un N B)]
|
|
[i2-t ((-v a) . -> . (-v b)) (-> N N) ('b N) ('a (Un))]
|
|
[i2-t (-> (-v a) (-v a)) (->* null B B) ('a B)]
|
|
|
|
|
|
[i2-l (list (-v a) (-v a) (-v b))
|
|
(list (Un (-val 1) (-val 2)) N N)
|
|
'(a b) ('b N) ('a (Un (-val 2) N))]
|
|
[i2-l (list (-> (-v a) Univ) (-lst (-v a)))
|
|
(list (-> N (Un N B)) (-lst N))
|
|
'(a) ('a N)]
|
|
[i2-l (list (-> (-v a) (-v b)) (-lst (-v a)))
|
|
(list (-> N N) (-lst (Un (-val 1) (-val 2))))
|
|
'(a b) ('b N) ('a (Un (-val 1) (-val 2)))]
|
|
[i2-l (list (-lst (-v a)))
|
|
(list (-lst (Un B N)))
|
|
'(a) ('a (Un N B))]
|
|
;; error tests
|
|
[i2-f (-lst (-v a)) Univ]
|
|
[i2-f (->* null B B) (-> (-v a) (-v b))]
|
|
))
|
|
|
|
|
|
(define tests
|
|
(test-suite
|
|
"All inference tests"
|
|
fv-tests
|
|
fi-tests
|
|
pd-tests
|
|
infer-tests
|
|
))
|