24c64e9de0
This is a major to some of the internal representation of things within Typed Racket (mostly affecting structs that inherited from Rep (see rep/rep-utils.rkt)), and lots of tweaks and bug fixes that happened along the way. This PR includes the following major changes: A new rep-utils implementation, which uses struct properties for the generic operations and properties of the various Reps (see rep-utils.rkt) More specific Rep inheritance (i.e. arr no longer inherits from Type, because it is not a Type, etc ...) (see type-rep.rkt, core-rep.rkt, values-rep.rkt), and thus things like Type/c no longer exist New Rep's to classify the things that are no longer Type or Prop, (such as PropSets, SomeValues, Results, etc -- see core-rep.rkt and values-rep.rkt) uses of type-case now replaced by uses of Rep-fold and Rep-walk structural types can specify their fields' variance and operations like subtyping and free-vars can generically operate over these types (see type-rep.rkt) type-mask replaces types key -- types masks are described in detail in (rep/type-mask.rkt) Types can specify a predicate to recognize their "top type" via [#:top pred]) There is an explicit 'Bottom' type now (i.e. neither union or intersection are used) subtyping re-organized, slight tweaking to inference various environments got for-each functions in addition to the map functions they had (e.g. type-name-env.rkt) Empty is no longer an Object? -- the OptObject? predicate checks for either Object or Empty, and so it is easier to be clear about where Empty makes sense appearing and where it does not Previously signatures were created with promises in their fields, now we create a promise around each signature (this way the contracts for Signature fields are cleaner) Names for structs now use the args field to describe how many type arguments they take (Note: this could use further tidying for sure!) simplified the propositional logic code in several places, got rid of escape continuations, etc (see prop-ops.rkt, tc-envops.rkt, tc-metafunctions.rkt) we now use subsumption more to simplify type results from type checking, e.g. if the type does not overlap w/ false, it's false proposition is FalseProp, etc (see tc-expr-unit.rkt and prop-ops.rkt, the function is called reduce-tc-results/subsumption) updating along a path will now intersect with the expected structural type if it is not encountered (e.g. updating Any with (Int @ car) now produces (Pairof Int Any) instead of Any -- see update.rkt) lots of tests were tweaked to match up w/ the new prop subsumption that occurs remove was renamed subtract (so as to not conflict w/ racket/base's remove) a restrict function was added, which acts like intersect but is never additive (i.e. it will never create an intersection if it can't figure out how the two types relate -- see intersect.rkt) tc-subst was modified to substitute out all the variables leaving scope at once (and I simplified/tweaked some of the logic in there a little, see tc-subst.rkt) Type checking function applications now propagates information learned why type checking the arguments, (e.g. (begin (f (assert x boolean?)) ...)) ; the remainder of the begin is aware that x is a boolean)
221 lines
7.9 KiB
Racket
221 lines
7.9 KiB
Racket
#lang racket/base
|
|
|
|
(require "test-utils.rkt"
|
|
rackunit racket/list racket/match racket/format
|
|
syntax/srcloc syntax/location
|
|
(types abbrev union tc-result)
|
|
(utils tc-utils)
|
|
(rep prop-rep object-rep type-rep)
|
|
(typecheck check-below)
|
|
(for-syntax racket/base syntax/parse))
|
|
|
|
(provide tests)
|
|
(gen-test-main)
|
|
|
|
;; Ensure that we never return a prop or object of #f.
|
|
(define (check-prop f)
|
|
(match f
|
|
[#f (fail-check "Result has no prop (instead of a top prop).")]
|
|
[_ (void)]))
|
|
|
|
(define (check-object o)
|
|
(match o
|
|
[#f (fail-check "Result has no object (instead of an empty object).")]
|
|
[_ (void)]))
|
|
|
|
(define (check-result result)
|
|
(match result
|
|
[(tc-results: ts fs os)
|
|
(for-each check-prop fs)
|
|
(for-each check-object os) ]
|
|
[(tc-results: ts fs os dty bound)
|
|
(for-each check-prop fs)
|
|
(for-each check-object os)]
|
|
[(tc-any-results: f)
|
|
(check-prop f)]
|
|
[(? Type?)
|
|
(void)]))
|
|
|
|
|
|
(define-syntax (test-below stx)
|
|
(syntax-parse stx
|
|
[(_ t1:expr t2:expr (~optional (~seq #:result expected-result:expr)
|
|
#:defaults [(expected-result #'t2)]))
|
|
#`(test-case (~a 't1 " <: " 't2)
|
|
(with-check-info (['location (build-source-location-list (quote-srcloc #,stx))]
|
|
['expected expected-result])
|
|
(define result (check-below t1 t2))
|
|
(with-check-info (['actual result])
|
|
(check-result result)
|
|
(unless (equal? expected-result result)
|
|
(fail-check "Check below did not return expected result.")))))]
|
|
[(_ #:fail (~optional message:expr #:defaults [(message #'#rx"type mismatch")])
|
|
t1:expr t2:expr
|
|
(~optional (~seq #:result expected-result:expr)
|
|
#:defaults [(expected-result #'t2)]))
|
|
#`(test-case (~a 't1 " !<: " 't2)
|
|
(with-check-info (['location (build-source-location-list (quote-srcloc #,stx))]
|
|
['expected expected-result])
|
|
(define result
|
|
(parameterize ([delay-errors? #t])
|
|
(check-below t1 t2)))
|
|
(with-check-info (['actual result])
|
|
(define exn
|
|
(let/ec exit
|
|
(with-handlers [(exn:fail? exit)]
|
|
(report-all-errors)
|
|
(fail-check "Check below did not fail."))))
|
|
(check-result result)
|
|
(unless (equal? expected-result result)
|
|
(fail-check "Check below did not return expected result."))
|
|
(check-regexp-match message (exn-message exn)))))]))
|
|
|
|
|
|
(define tests
|
|
(test-suite "Check Below"
|
|
(test-below -Bottom Univ)
|
|
(test-below #:fail -Symbol -String)
|
|
|
|
(test-below
|
|
(ret -Bottom)
|
|
(ret (list Univ Univ) (list -true-propset #f) (list #f -empty-obj))
|
|
#:result (ret (list Univ Univ) (list -true-propset -ff-propset) (list -empty-obj -empty-obj)))
|
|
|
|
(test-below
|
|
(ret -Bottom)
|
|
(ret (list Univ) (list #f) (list #f) Univ 'B)
|
|
#:result (ret (list Univ) (list -ff-propset) (list -empty-obj) Univ 'B))
|
|
|
|
;; Bottom is not below everything if the number of values doesn't match up.
|
|
(test-below #:fail
|
|
(ret (list -Bottom -Bottom))
|
|
(ret (list Univ) (list -true-propset) (list #f))
|
|
#:result (ret (list Univ) (list -true-propset) (list -empty-obj)))
|
|
|
|
(test-below #:fail
|
|
(ret (list))
|
|
(ret (list Univ) (list -true-propset) (list #f))
|
|
#:result (ret (list Univ) (list -true-propset) (list -empty-obj)))
|
|
|
|
(test-below
|
|
(ret (list -Symbol) (list -tt-propset) (list -empty-obj))
|
|
(ret (list Univ) (list #f) (list #f))
|
|
#:result (ret (list Univ) (list -tt-propset) (list -empty-obj)))
|
|
|
|
(test-below
|
|
(ret (list -Symbol) (list -true-propset) (list -empty-obj))
|
|
(ret (list Univ) (list -tt-propset) (list -empty-obj)))
|
|
|
|
(test-below #:fail
|
|
(ret (list -Symbol) (list -tt-propset) (list -empty-obj))
|
|
(ret (list Univ) (list -true-propset) (list #f))
|
|
#:result (ret (list Univ) (list -true-propset) (list -empty-obj)))
|
|
|
|
(test-below #:fail #rx"no object"
|
|
(ret (list -Symbol) (list -tt-propset) (list -empty-obj))
|
|
(ret (list Univ) (list -tt-propset) (list (make-Path empty #'x))))
|
|
|
|
(test-below #:fail #rx"no object"
|
|
(ret (list -Symbol) (list -tt-propset) (list -empty-obj))
|
|
(ret (list Univ) (list -true-propset) (list (make-Path empty #'x))))
|
|
|
|
(test-below (ret -Bottom) (tc-any-results #f) #:result (tc-any-results -ff))
|
|
(test-below (ret Univ) (tc-any-results -tt) #:result (tc-any-results -tt))
|
|
(test-below (tc-any-results -ff) (tc-any-results #f) #:result (tc-any-results -ff))
|
|
(test-below
|
|
(ret (list -Symbol -String) (list -true-propset -ff-propset))
|
|
(tc-any-results #f)
|
|
#:result (tc-any-results -ff))
|
|
(test-below (ret -Symbol -ff-propset) (tc-any-results #f) #:result (tc-any-results -ff))
|
|
|
|
(test-below (ret -Symbol -true-propset -empty-obj) (tc-any-results #f)
|
|
#:result (tc-any-results -tt))
|
|
(test-below (ret (list -Symbol -String)) (tc-any-results #f)
|
|
#:result (tc-any-results -tt))
|
|
(test-below
|
|
(ret (list -Symbol -String) (list -true-propset -false-propset) (list -empty-obj -empty-obj))
|
|
(tc-any-results #f)
|
|
#:result (tc-any-results -tt))
|
|
|
|
|
|
(test-below #:fail
|
|
(ret -Symbol)
|
|
(ret (list -Symbol -Symbol) (list -tt-propset #f) (list #f -empty-obj))
|
|
#:result (ret (list -Symbol -Symbol) (list -tt-propset -tt-propset) (list -empty-obj -empty-obj)))
|
|
|
|
(test-below #:fail
|
|
(tc-any-results -tt)
|
|
(ret -Symbol))
|
|
|
|
|
|
(test-below #:fail
|
|
(ret -Symbol -true-propset -empty-obj)
|
|
(ret -Symbol -true-propset -empty-obj Univ 'B))
|
|
|
|
(test-below #:fail
|
|
(ret -Symbol -true-propset -empty-obj Univ 'B)
|
|
(ret -Symbol -true-propset -empty-obj))
|
|
|
|
(test-below #:fail
|
|
(ret -Symbol)
|
|
(ret -Symbol #f -empty-obj Univ 'B)
|
|
#:result (ret -Symbol -tt-propset -empty-obj Univ 'B))
|
|
|
|
(test-below #:fail
|
|
(tc-any-results -tt)
|
|
(ret -Symbol #f -empty-obj Univ 'B)
|
|
#:result (ret (list -Symbol) (list -tt-propset) (list -empty-obj) Univ 'B))
|
|
|
|
(test-below #:fail
|
|
(ret -Symbol -tt-propset -empty-obj Univ 'B)
|
|
(ret (list -Symbol -Symbol) (list -tt-propset -tt-propset) (list -empty-obj -empty-obj) Univ 'B))
|
|
|
|
(test-below (ret -Symbol -true-propset -empty-obj Univ 'B)
|
|
(tc-any-results #f)
|
|
#:result (tc-any-results -tt))
|
|
|
|
(test-below
|
|
(ret -Symbol)
|
|
(ret -Symbol #f -empty-obj)
|
|
#:result (ret -Symbol -tt-propset -empty-obj))
|
|
|
|
(test-below
|
|
(ret -Symbol -true-propset)
|
|
(ret -Symbol #f -empty-obj)
|
|
#:result (ret -Symbol -true-propset -empty-obj))
|
|
|
|
(test-below #:fail
|
|
(ret -Symbol -true-propset)
|
|
(ret (list Univ -Symbol) (list #f -tt-propset))
|
|
#:result (ret (list Univ -Symbol) (list -tt-propset -tt-propset)))
|
|
|
|
|
|
(test-below
|
|
(ret (list Univ) (list -true-propset) (list -empty-obj))
|
|
(ret Univ #f)
|
|
#:result (ret (list Univ) (list -true-propset) (list -empty-obj)))
|
|
|
|
;; Enable these once check-below is fixed
|
|
;; Currently does not fail
|
|
#;
|
|
(test-below #:fail
|
|
(ret (list Univ) (list -tt-propset) (list -empty-obj) Univ 'B)
|
|
(ret (list Univ) (list -false-propset) (list #f) Univ 'B)
|
|
#:result (ret (list Univ) (list -false-propset) (list -empty-obj) Univ 'B))
|
|
|
|
;; Currently does not fail
|
|
#;
|
|
(test-below #:fail
|
|
(ret (list Univ) (list -tt-propset) (list -empty-obj))
|
|
(ret (list Univ) (list -false-propset) (list #f) Univ 'B)
|
|
#:result (ret (list Univ) (list -false-propset) (list -empty-obj) Univ 'B))
|
|
|
|
;; Currently does not fail
|
|
#;
|
|
(test-below #:fail
|
|
(ret (list Univ Univ) (list -tt-propset -tt-propset) (list -empty-obj -empty-obj))
|
|
(ret (list Univ Univ) (list -false-propset -false-propset) (list #f #f))
|
|
#:result (ret (list Univ Univ) (list -false-propset -false-propset) (list -empty-obj -empty-obj)))
|
|
|
|
))
|