f9c5a534d0
This pull request is largely a renaming effort to clean up the TR codebase. There are two primary things I wanted to change: 1. Replace all occurrences of "filter" with "prop" or "proposition" - The word "filter" is a meaningless opaque term at this point in the Typed Racket implementation. If anything, it just adds confusion to why things are the way the are. We should use "proposition" instead, since that's what they actually are. 2. Avoid using "Top" and "Bottom" in both the type and proposition realm. - Currently the top type is called Univ and the bottom type is called bottom, while the top proposition is called Top and the bottom proposition is called Bot. This is just unnecessarily confusing, doesn't really line up w/ the user-space names, and doesn't line up with the names we use in TR formalisms. Worse, all of the top types of primitive types---e.g. the type of all structs, StructTop--- use Top, so it is really easy to get confused about what name to use for these sorts of things. With these issues in mind, I made the following changes to names: Top -> TrueProp Bot -> FalseProp TypeFilter -> TypeProp NotTypeFilter -> NotTypeProp AndFilter -> AndProp OrFilter -> OrProp -filter t o -> -is-type o t -not-filter t o -> -not-type o t FilterSet -> PropSet NoFilter -> #f NoObject -> #f -FS -> -PS -top -> -tt -bot -> -ff implied-atomic? q p -> implies-atomic? p q filter-rec-id -> prop-rec-id -no-filter -> -no-propset -top-filter -> -tt-propset -bot-filter -> -ff-propset -true-filter -> -true-propset -false-filter -> -false-propset PredicateFilter: -> PredicateProp: add-unconditional-filter-all-args add-unconditional-prop-all-args
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/c?)
|
|
(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)))
|
|
|
|
))
|