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
175 lines
7.4 KiB
Racket
175 lines
7.4 KiB
Racket
#lang racket/base
|
|
|
|
(require "test-utils.rkt"
|
|
rackunit racket/format
|
|
(typecheck tc-metafunctions tc-subst)
|
|
(rep prop-rep type-rep object-rep)
|
|
(types abbrev union prop-ops tc-result numeric-tower)
|
|
(for-syntax racket/base syntax/parse))
|
|
|
|
(provide tests)
|
|
(gen-test-main)
|
|
|
|
(define-syntax (test-combine-props stx)
|
|
(syntax-parse stx
|
|
[(_ new:expr existing:expr expected:expr box-v:expr)
|
|
(quasisyntax/loc stx
|
|
(test-case (~a '(new + existing = expected))
|
|
(define success
|
|
(let/ec exit
|
|
(define-values (res-formulas res-props) (combine-props new existing exit))
|
|
#,(syntax/loc stx (check-equal? (append res-formulas res-props) expected))
|
|
#t))
|
|
#,(syntax/loc stx (check-equal? success box-v))))]))
|
|
|
|
|
|
(define tests
|
|
(test-suite "Metafunctions"
|
|
|
|
(test-suite "combine-props"
|
|
|
|
(test-combine-props
|
|
(list (-or (-not-type #'x -String) (-not-type #'y -String)))
|
|
(list (-is-type #'x (Un -String -Symbol)) (-is-type #'y (Un -String -Symbol)))
|
|
(list (-or (-not-type #'y -String) (-not-type #'x -String))
|
|
(-is-type #'y (Un -String -Symbol)) (-is-type #'x (Un -String -Symbol)))
|
|
#t)
|
|
|
|
(test-combine-props
|
|
(list (-or (-is-type #'x -String) (-is-type #'y -String)))
|
|
(list (-is-type #'x (Un -String -Symbol)) (-is-type #'y (Un -String -Symbol)))
|
|
(list (-or (-is-type #'y -String) (-is-type #'x -String))
|
|
(-is-type #'y (Un -String -Symbol)) (-is-type #'x (Un -String -Symbol)))
|
|
#t)
|
|
)
|
|
|
|
(test-suite "merge-tc-results"
|
|
(check-equal?
|
|
(merge-tc-results (list))
|
|
(ret -Bottom))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret Univ)))
|
|
(ret Univ))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret Univ -tt-propset (make-Path null #'x))))
|
|
(ret Univ -tt-propset (make-Path null #'x)))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret -Bottom) (ret -Symbol -tt-propset (make-Path null #'x))))
|
|
(ret -Symbol -tt-propset (make-Path null #'x)))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret -String) (ret -Symbol)))
|
|
(ret (Un -Symbol -String)))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret -String -true-propset) (ret -Symbol -true-propset)))
|
|
(ret (Un -Symbol -String) -true-propset))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret (-val #f) -false-propset) (ret -Symbol -true-propset)))
|
|
(ret (Un -Symbol (-val #f)) -tt-propset))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret (list (-val 0) (-val 1))) (ret (list (-val 1) (-val 2)))))
|
|
(ret (list (Un (-val 0) (-val 1)) (Un (-val 1) (-val 2)))))
|
|
(check-equal?
|
|
(merge-tc-results (list (ret null null null -Symbol 'x) (ret null null null -String 'x)))
|
|
(ret null null null (Un -Symbol -String) 'x))
|
|
)
|
|
|
|
|
|
(test-suite "values->tc-results"
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result -Symbol))) (list -empty-obj) (list Univ))
|
|
(ret -Symbol))
|
|
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result -Symbol) (-result -String)))
|
|
(list -empty-obj -empty-obj) (list Univ Univ))
|
|
(ret (list -Symbol -String)))
|
|
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result -Symbol (-PS -tt -ff)))) (list -empty-obj) (list Univ))
|
|
(ret -Symbol (-PS -tt -ff)))
|
|
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result -Symbol (-PS -tt -ff) (make-Path null '(0 0)))))
|
|
(list -empty-obj) (list Univ))
|
|
(ret -Symbol (-PS -tt -ff)))
|
|
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result (-opt -Symbol) (-PS (-is-type '(0 0) -String) -tt))))
|
|
(list -empty-obj) (list Univ))
|
|
(ret (-opt -Symbol) -tt-propset))
|
|
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result (-opt -Symbol) (-PS (-not-type '(0 0) -String) -tt))))
|
|
(list -empty-obj) (list Univ))
|
|
(ret (-opt -Symbol) -tt-propset))
|
|
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result (-opt -Symbol) (-PS (-not-type '(0 0) -String) -tt)
|
|
(make-Path null '(0 0)))))
|
|
(list (make-Path null #'x)) (list Univ))
|
|
(ret (-opt -Symbol) (-PS (-not-type #'x -String) -tt) (make-Path null #'x)))
|
|
|
|
;; Check additional props
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result (-opt -String) (-PS -tt (-not-type '(0 0) -String))
|
|
(make-Path null '(0 0)))))
|
|
(list (make-Path null #'x)) (list -String))
|
|
(ret -String -true-propset (make-Path null #'x)))
|
|
|
|
;; Substitute into ranges correctly
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result (-opt (-> Univ -Boolean : (-PS (-is-type '(0 0) -Symbol) -tt))))))
|
|
(list (make-Path null #'x)) (list Univ))
|
|
(ret (-opt (-> Univ -Boolean : (-PS (-is-type '(0 0) -Symbol) -tt)))))
|
|
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result (-opt (-> Univ -Boolean : (-PS (-is-type '(1 0) -Symbol) -tt))))))
|
|
(list (make-Path null #'x)) (list Univ))
|
|
(ret (-opt (-> Univ -Boolean : (-PS (-is-type #'x -Symbol) -tt)))))
|
|
|
|
;; Substitute into prop of any values
|
|
(check-equal?
|
|
(values->tc-results (make-AnyValues (-is-type '(0 0) -String))
|
|
(list (make-Path null #'x)) (list Univ))
|
|
(tc-any-results (-is-type #'x -String)))
|
|
|
|
|
|
(check-equal?
|
|
(values->tc-results (-values-dots null (-> Univ -Boolean : (-PS (-is-type '(1 0) -String) -tt)) 'b)
|
|
(list (make-Path null #'x)) (list Univ))
|
|
(ret null null null (-> Univ -Boolean : (-PS (-is-type #'x -String) -tt)) 'b))
|
|
|
|
;; Prop is restricted by type of object
|
|
(check-equal?
|
|
(values->tc-results (make-Values (list (-result -Boolean (-PS (-is-type '(0 0) -PosReal) (-is-type '(0 0) -NonPosReal)))))
|
|
(list (make-Path null #'x)) (list -Integer))
|
|
(ret -Boolean (-PS (-is-type #'x -PosInt) (-is-type #'x -NonPosInt))))
|
|
|
|
;; Prop restriction accounts for paths
|
|
(check-equal?
|
|
(values->tc-results
|
|
(make-Values
|
|
(list (-result -Boolean
|
|
(-PS (make-TypeProp (make-Path (list -car) '(0 0))
|
|
-PosReal)
|
|
(make-TypeProp (make-Path (list -car) '(0 0))
|
|
-NonPosReal)))))
|
|
(list (make-Path null #'x))
|
|
(list (-lst -Integer)))
|
|
(ret -Boolean
|
|
(-PS (make-TypeProp (make-Path (list -car) #'x) -PosInt)
|
|
(make-TypeProp (make-Path (list -car) #'x) -NonPosInt))))
|
|
)
|
|
|
|
(test-suite "replace-names"
|
|
(check-equal?
|
|
(replace-names (list (list #'x (make-Path null (list 0 0))))
|
|
(ret Univ -tt-propset (make-Path null #'x)))
|
|
(ret Univ -tt-propset (make-Path null (list 0 0))))
|
|
(check-equal?
|
|
(replace-names (list (list #'x (make-Path null (list 0 0))))
|
|
(ret (-> Univ Univ : -tt-propset : (make-Path null #'x))))
|
|
(ret (-> Univ Univ : -tt-propset : (make-Path null (list 1 0)))))
|
|
)
|
|
))
|