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)
176 lines
7.5 KiB
Racket
176 lines
7.5 KiB
Racket
#lang racket/base
|
|
|
|
(require "test-utils.rkt"
|
|
rackunit racket/format
|
|
(typecheck tc-metafunctions tc-subst)
|
|
(rep prop-rep type-rep object-rep values-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-values ([(res-formulas res-props) (combine-props new existing)])
|
|
#,(syntax/loc stx (check-equal? (and res-formulas
|
|
(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 #'x) (list (make-Path null '(0 . 0)))
|
|
(ret Univ -tt-propset (make-Path null #'x)))
|
|
(ret Univ -tt-propset (make-Path null '(0 . 0))))
|
|
(check-equal?
|
|
(replace-names (list #'x) (list (make-Path null '(0 . 0)))
|
|
(ret (-> Univ Univ : -tt-propset : (make-Path null #'x))))
|
|
(ret (-> Univ Univ : -tt-propset : (make-Path null '(1 . 0)))))
|
|
)
|
|
))
|