suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

new representation scheme for typed racket internals

Browse Source 
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)
This commit is contained in:
Andrew Kent 2016-09-09 08:42:28 -04:00 committed by Andrew Kent
parent efecd24e9d
commit 24c64e9de0
97 changed files with 5105 additions and 4210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
typed-racket-lib/typed-racket/base-env/ann-inst.rkt
View File

@ -17,9 +17,7 @@
(add-ann #'arg #'ty)]))
(define-for-syntax (add-ann expr-stx ty-stx)
(quasisyntax/loc expr-stx
(#,(type-ascription-property #'#%expression ty-stx)
#,expr-stx)))
(type-ascription-property (quasisyntax/loc expr-stx (#%expression #,expr-stx)) ty-stx))
(define-syntax (inst stx)
(syntax-parse stx #:literals (:)

2
typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt
View File

@ -3,7 +3,7 @@
(begin
(require
(for-syntax racket/base racket/syntax syntax/parse)
(only-in (rep type-rep) Type/c? make-Values)
(only-in (rep type-rep values-rep) Type? make-Values)
racket/list racket/math racket/flonum racket/extflonum racket/unsafe/ops racket/sequence racket/match
(for-template racket/flonum racket/extflonum racket/fixnum racket/math racket/unsafe/ops racket/base
(only-in "../types/numeric-predicates.rkt" index?))

2
typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -23,7 +23,7 @@
(only-in racket/private/pre-base new-apply-proc)
(only-in (types abbrev) [-Boolean B] [-Symbol Sym] -Flat)
(only-in (types numeric-tower) [-Number N])
(only-in (rep type-rep)
(only-in (rep type-rep values-rep)
make-ClassTop
make-UnitTop
make-Name

8
typed-racket-lib/typed-racket/base-env/top-interaction.rkt
View File

@ -64,7 +64,7 @@
[current-type-names
(if (attribute verbose-kw) '() (current-type-names))]
[current-print-unexpanded (box '())])
(define type (pretty-format-type (parse-type #'ty)))
(define type (pretty-format-rep (parse-type #'ty)))
(define unexpanded
(remove-duplicates (unbox (current-print-unexpanded))))
(define cue (if (null? unexpanded)
@ -92,7 +92,7 @@
(define-repl-op :print-type-impl (_ e) #'e
(λ (type)
#`(displayln
#,(pretty-format-type
#,(pretty-format-rep
(match type
[(tc-result1: t f o) t]
[(tc-results: t) (-values t)]
@ -108,7 +108,7 @@
(op dummy-arg ...)))
(λ (type)
#`(display
#,(pretty-format-type
#,(pretty-format-rep
(match type
[(tc-result1: (and t (Function: _)) f o) t]))))
"must be applied to at least one argument" )
@ -124,6 +124,6 @@
[(Function: '())
"Desired return type not in the given function's range.\n"]
[(Function: arrs)
(pretty-format-type cleaned)])))]
(pretty-format-rep cleaned)])))]
[_ (error (format "~a: not a function" (syntax->datum #'op)))]))
"must be applied to exactly two arguments"))

1
typed-racket-lib/typed-racket/core.rkt
View File

@ -12,7 +12,6 @@
(rep type-rep)
(for-template (base-env top-interaction))
(utils utils tc-utils arm)
(only-in (types printer) pretty-format-type)
"standard-inits.rkt"
"tc-setup.rkt")

8
typed-racket-lib/typed-racket/env/env-utils.rkt vendored
View File

@ -1,14 +1,18 @@
#lang racket/base
(require racket/dict racket/sequence)
(provide id< sorted-dict-map in-sorted-dict)
(provide id< sorted-dict-map sorted-dict-for-each in-sorted-dict)
(define (id< a b) (symbol<? (syntax-e a) (syntax-e b)))
(define (sorted-dict-map dict f <)
(define sorted (sort #:key car (dict-map dict cons) <))
(define sorted (sort (dict-map dict cons) (λ (x y) (< (car x) (car y)))))
(map (lambda (a) (f (car a) (cdr a))) sorted))
(define (sorted-dict-for-each dict f <)
(define sorted (sort (dict-map dict cons) (λ (x y) (< (car x) (car y)))))
(for-each (lambda (a) (f (car a) (cdr a))) sorted))
(define (in-sorted-dict dict <)
(define sorted (sort #:key car (dict-map dict cons) <))
(in-dict sorted))

12
typed-racket-lib/typed-racket/env/global-env.rkt vendored
View File

@ -18,9 +18,10 @@
register-types
unregister-type
check-all-registered-types
type-env-map)
type-env-map
type-env-for-each)
(lazy-require ["../rep/type-rep.rkt" (Type/c? type-equal?)])
(lazy-require ["../rep/type-rep.rkt" (Type? type-equal?)])
;; free-id-table from id -> type or Box[type]
;; where id is a variable, and type is the type of the variable
@ -36,7 +37,7 @@
(cond [(free-id-table-ref the-mapping id (lambda _ #f))
=> (lambda (e)
(define t (if (box? e) (unbox e) e))
(unless (and (Type/c? t) (type-equal? t type))
(unless (and (Type? t) (type-equal? t type))
(tc-error/delayed #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t))
(when (box? e)
(free-id-table-set! the-mapping id t)))]
@ -50,7 +51,7 @@
=>
(λ (t) ;; it's ok to annotate with the same type
(define t* (if (box? t) (unbox t) t))
(unless (and (Type/c? t*) (type-equal? type t*))
(unless (and (Type? t*) (type-equal? type t*))
(tc-error/delayed #:stx id "Duplicate type annotation of ~a for ~a, previous was ~a" type (syntax-e id) t*)))]
[else (free-id-table-set! the-mapping id (box type))]))
@ -104,3 +105,6 @@
;; (id type -> T) -> listof[T]
(define (type-env-map f)
(sorted-dict-map the-mapping f id<))
(define (type-env-for-each f)
(sorted-dict-for-each the-mapping f id<))

48
typed-racket-lib/typed-racket/env/init-envs.rkt vendored
View File

@ -10,7 +10,10 @@
"mvar-env.rkt"
"signature-env.rkt"
(rename-in racket/private/sort [sort raw-sort])
(rep type-rep object-rep prop-rep rep-utils free-variance)
(rep core-rep type-rep
prop-rep rep-utils
object-rep values-rep
free-variance)
(for-syntax syntax/parse racket/base)
(types abbrev struct-table union utils)
data/queue
@ -57,10 +60,10 @@
;; Compute for a given type how many times each type inside of it
;; is referenced
(define (compute-popularity ty)
(hash-update! pop-table ty add1 0)
(define (count ty) (compute-popularity ty) ty)
(type-case (#:Type count #:Prop (sub-f count) #:Object (sub-o count))
ty))
(when (Type? ty)
(hash-update! pop-table ty add1 0))
(when (walkable? ty)
(Rep-walk compute-popularity ty)))
(define (popular? ty)
(> (hash-ref pop-table ty 0) 5))
@ -98,7 +101,7 @@
(define-values (nums others) (partition numeric? ts))
(cond [(or (null? nums) (null? others))
;; nothing interesting to do in this case
`(make-Union (,#'raw-sort (list ,@(map type->sexp ts)) < Type-seq #f))]
`(make-Union (list ,@(map type->sexp ts)))]
[else
;; we do a little more work to hopefully save a bunch in serialization space
;; if we get a hit in the predefined-type-table
@ -175,11 +178,11 @@
,(type->sexp t)
,(type->sexp ft)
,(object->sexp pth))]
[(Function: (list (arr: dom (Values: (list (Result: t (PropSet: (NotTypeProp: (Path: pth (list 0 0))
[(Function: (list (arr: dom (Values: (list (Result: t (PropSet: (NotTypeProp: (Path: pth (cons 0 0))
(== -False))
(TypeProp: (Path: pth (list 0 0))
(TypeProp: (Path: pth (cons 0 0))
(== -False)))
(Path: pth (list 0 0)))))
(Path: pth (cons 0 0)))))
#f #f '())))
`(->acc (list ,@(map type->sexp dom))
,(type->sexp t)
@ -217,8 +220,7 @@
`(quote ,v)))]
[(Union: elems) (split-union elems)]
[(Intersection: elems)
`(make-Intersection (set ,@(for/list ([elem (in-immutable-set elems)])
(type->sexp elem))))]
`(make-Intersection (list ,@(map type->sexp elems)))]
[(Name: stx 0 #t)
`(-struct-name (quote-syntax ,stx))]
[(Name: stx args struct?)
@ -316,7 +318,7 @@
;; Helper for class/row clauses
(define (convert-row-clause members [inits? #f])
(for/list ([m members])
(for/list ([m (in-list members)])
`(list (quote ,(car m))
,(type->sexp (cadr m))
,@(if inits? (cddr m) '()))))
@ -343,15 +345,15 @@
(define (object->sexp obj)
(match obj
[(Empty:) `(make-Empty)]
[(Path: null (list 0 arg))
[(Path: null (cons 0 arg))
`(-arg-path ,arg)]
[(Path: null (list depth arg))
[(Path: null (cons depth arg))
`(-arg-path ,arg ,depth)]
[(Path: pes i)
`(make-Path (list ,@(map path-elem->sexp pes))
,(if (identifier? i)
`(quote-syntax ,i)
`(list ,(car i) ,(cadr i))))]))
`(cons ,(car i) ,(cdr i))))]))
;; Path-Element -> SExp
;; Convert a path element in an object to an s-expression
@ -383,16 +385,16 @@
;; the type serialization pass. Only walks the environments that
;; actually track types.
(define (compute-all-popularities)
(define (count-env map)
(define (count-env for-each)
(define (count id ty) (compute-popularity ty))
(define (bound-f id v)
(and (bound-in-this-module id) (count id v)))
(map bound-f))
(for-each bound-f))
(count-env type-name-env-map)
(count-env type-alias-env-map)
(count-env type-env-map)
(count-env signature-env-map))
(count-env type-name-env-for-each)
(count-env type-alias-env-for-each)
(count-env type-env-for-each)
(count-env signature-env-for-each))
(define (tname-env-init-code)
(make-init-code
@ -419,10 +421,12 @@
(λ (f) (dict-map mvar-env f))
(lambda (id v) (and v #`(register-mutated-var #'#,id)))))
;; see 'finalize-signatures!' in 'env/signature-env.rkt',
;; which forces these delays after all the signatures are parsed
(define (signature-env-init-code)
(make-init-code
signature-env-map
(lambda (id sig) #`(register-signature! #'#,id #,(quote-type sig)))))
(lambda (id sig) #`(register-signature! #'#,id (delay #,(quote-type sig))))))
(define (make-struct-table-code)
(make-init-code

37
typed-racket-lib/typed-racket/env/lexical-env.rkt vendored
View File

@ -10,21 +10,20 @@
racket/keyword-transform racket/list
(for-syntax syntax/parse racket/base)
(contract-req)
(env type-env-structs global-env mvar-env)
(env type-env-structs global-env)
(utils tc-utils)
(only-in (rep type-rep) Type/c)
(only-in (rep type-rep) Type?)
(typecheck renamer)
(except-in (types utils abbrev kw-types) -> ->* one-of/c))
(require-for-cond-contract (rep object-rep))
(require-for-cond-contract (rep object-rep core-rep))
(provide lexical-env
with-lexical-env
with-lexical-env/extend-types
with-lexical-env/extend-types+aliases
update-type/lexical)
with-lexical-env/extend-types+aliases)
(provide/cond-contract
[lookup-type/lexical ((identifier?) (env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type/c #f))]
[lookup-type/lexical ((identifier?) (env? #:fail (or/c #f (-> any/c #f))) . ->* . (or/c Type? #f))]
[lookup-alias/lexical ((identifier?) (env?) . ->* . (or/c Path? Empty?))])
;; the current lexical environment
@ -74,28 +73,4 @@
;; looks up the representative object for an id (i.e. itself or an alias if one exists)
(define (lookup-alias/lexical i [env (lexical-env)])
(lookup-alias env i -id-path))
;; refine the type of i in the lexical env
;; (identifier type -> type) identifier -> environment
;; a macro for inlining :(
(define-syntax (update-type/lexical stx)
(syntax-parse stx
[(_ f i env)
#:declare f (expr/c #'(identifier? Type/c . -> . Type/c))
#:declare i (expr/c #'identifier?)
#:declare env (expr/c #'prop-env?)
;; check if i is ever the target of a set!
;; or is a top-level variable
#'(if (or (is-var-mutated? i)
(not (identifier-binding i)))
;; if it is, we do nothing
env
;; otherwise, refine the type
(parameterize
([current-orig-stx i])
(let* ([v (lookup-type/lexical i env #:fail (lambda _ Univ))]
[new-v (f i v)]
[new-env (extend env i new-v)])
new-env)))]))
(lookup-alias env i -id-path))

26
typed-racket-lib/typed-racket/env/signature-env.rkt vendored
View File

@ -8,6 +8,7 @@
lookup-signature
lookup-signature/check
signature-env-map
signature-env-for-each
with-signature-env/extend)
(require syntax/id-table
@ -45,27 +46,15 @@
;; Iterate over the signature environment forcing the types of bindings
;; in each signature
(define (finalize-signatures!)
(signature-env
(make-immutable-free-id-table
(signature-env-map
(lambda (id sig)
(cons
id
(match sig
[(Signature: name extends mapping)
(make-Signature
name
extends
(map
(match-lambda [(cons id ty) (cons id (force ty))])
mapping))]
[_ #f])))))))
(sorted-dict-for-each (signature-env) (λ (id sig) (force sig)) id<))
;; lookup-signature : identifier? -> (or/c #f Signature?)
;; look up the signature corresponding to the given identifier
;; in the signature environment
(define (lookup-signature id)
(free-id-table-ref (signature-env) id #f))
(cond
[(free-id-table-ref (signature-env) id #f) => force]
[else #f]))
;; lookup-signature/check : identifier? -> Signature?
;; lookup the identifier in the signature environment
@ -78,4 +67,7 @@
#:stx id)))
(define (signature-env-map f)
(sorted-dict-map (signature-env) f id<))
(sorted-dict-map (signature-env) (λ (id sig) (f id (force sig))) id<))
(define (signature-env-for-each f)
(sorted-dict-for-each (signature-env) (λ (id sig) (f id (force sig))) id<))

57
typed-racket-lib/typed-racket/env/signature-helper.rkt vendored
View File

@ -46,27 +46,35 @@
#:parent-signature super
(binding ...)
#:check? check) #:local)
(#%plain-app values)))
(define raw-map (syntax->list #'(binding ...)))
(define check? (syntax->datum #'check))
(define extends (get-extended-signature #'name #'super check? form))
(define super-bindings (get-signature-mapping extends))
(define new-bindings (map parse-signature-binding raw-map))
(define pre-mapping (append super-bindings new-bindings))
(#%plain-app values)))
;; helper for signature bindings
(define (parse-signature-binding binding-stx)
(syntax-parse binding-stx
[[name:id type]
(cons #'name (parse-type #'type))]))
;; use a delay for mutually recursive signatures -- lookup-signature
;; forces these
(register-signature!
#'name
(delay (let* ([raw-map (syntax->list #'(binding ...))]
[check? (syntax->datum #'check)]
[extends (get-extended-signature #'name #'super check? form)]
[super-bindings (get-signature-mapping extends)]
[new-bindings (map parse-signature-binding raw-map)]
[pre-mapping (append super-bindings new-bindings)])
;; Make sure a require/typed signature has bindings listed
;; that are consistent with its statically determined bindings
(when check?
(check-signature-bindings #'name (map car pre-mapping) form))
;; Make sure a require/typed signature has bindings listed
;; that are consistent with its statically determined bindings
(when check?
(check-signature-bindings #'name (map car pre-mapping) form))
;; require/typed signature bindings may not be in the correct order
;; this fixes the ordering based on the static order determined
;; by signature-members
(define mapping (if check?
(fix-order #'name pre-mapping)
pre-mapping))
;; require/typed signature bindings may not be in the correct order
;; this fixes the ordering based on the static order determined
;; by signature-members
(define mapping (if check?
(fix-order #'name pre-mapping)
pre-mapping))
(define signature (make-Signature #'name extends mapping))
(register-signature! #'name signature)]))
(make-Signature #'name extends mapping))))]))
;; check-signature-bindings : Identifier (Listof Identifier) -> Void
;; checks that the bindings of a signature identifier are consistent with
@ -110,17 +118,6 @@
"which extends signature" (syntax-e super)
#:stx stx))]))
;; parse-signature-binding : Syntax -> (list/c identifier? syntax?)
;; parses the binding forms inside of a define signature into the
;; form used by the Signature type representation
;; The call to `parse-type` is delayed to allow signatures and type aliases
;; to be mutually recursive, after aliases are registered in the environment
;; the promise will be forced to perform the actual type parsing
(define (parse-signature-binding binding-stx)
(syntax-parse binding-stx
[[name:id type]
(cons #'name (delay (parse-type #'type)))]))
;; signature->bindings : identifier? -> (listof (cons/c identifier? type?))
;; GIVEN: a signature name
;; RETURNS: the list of variables bound by that signature

8
typed-racket-lib/typed-racket/env/type-alias-env.rkt vendored
View File

@ -11,7 +11,8 @@
lookup-type-alias
resolve-type-aliases
register-resolved-type-alias
type-alias-env-map)
type-alias-env-map
type-alias-env-for-each)
(define-struct alias-def () #:inspector #f)
(define-struct (unresolved alias-def) (stx [in-process #:mutable]) #:inspector #f)
@ -65,3 +66,8 @@
(for/list ([(id t) (in-sorted-dict the-mapping id<)]
#:when (resolved? t))
(f id (resolved-ty t))))
(define (type-alias-env-for-each f)
(for ([(id t) (in-sorted-dict the-mapping id<)]
#:when (resolved? t))
(f id (resolved-ty t))))

10
typed-racket-lib/typed-racket/env/type-env-structs.rkt vendored
View File

@ -4,7 +4,7 @@
syntax/id-table
(except-in "../utils/utils.rkt" env)
(contract-req)
(rep object-rep))
(rep core-rep object-rep))
(require-for-cond-contract (rep type-rep prop-rep))
@ -20,14 +20,14 @@
(provide/cond-contract
[env? predicate/c]
[extend (env? identifier? Type/c . -> . env?)]
[extend/values (env? (listof identifier?) (listof Type/c) . -> . env?)]
[extend (env? identifier? Type? . -> . env?)]
[extend/values (env? (listof identifier?) (listof Type?) . -> . env?)]
[lookup (env? identifier? (identifier? . -> . any) . -> . any)]
[env-props (env? . -> . (listof Prop?))]
[replace-props (env? (listof Prop?) . -> . env?)]
[empty-prop-env env?]
[extend+alias/values (env? (listof identifier?) (listof Type/c) (listof Object?) . -> . env?)]
[lookup-alias (env? identifier? (identifier? . -> . (or/c #f Object?)) . -> . (or/c #f Object?))])
[extend+alias/values (env? (listof identifier?) (listof Type?) (listof OptObject?) . -> . env?)]
[lookup-alias (env? identifier? (identifier? . -> . (or/c OptObject? #f)) . -> . (or/c OptObject? #f))])
(define empty-prop-env
(env

20
typed-racket-lib/typed-racket/env/type-name-env.rkt vendored
View File

@ -13,16 +13,20 @@
(types utils))
(provide/cond-contract [register-type-name
(->* (identifier?) (Type/c) any)]
(->* (identifier?) (Type?) any)]
[register-type-names
(-> (listof identifier?) (listof Type/c) any)]
(-> (listof identifier?) (listof Type?) any)]
[add-alias (-> identifier? identifier? any)]
[type-name-env-map
(-> (-> identifier? (or/c #t Type/c) any) any)]
(-> (-> identifier? (or/c #t Type?) any) any)]
[type-variance-env-map
(-> (-> identifier? (listof variance?) any) any)]
[type-name-env-for-each
(-> (-> identifier? (or/c #t Type?) any) void?)]
[type-variance-env-for-each
(-> (-> identifier? (listof variance?) any) void?)]
[lookup-type-name
(->* (identifier?) (procedure?) (or/c #t Type/c))]
(->* (identifier?) (procedure?) (or/c #t Type?))]
[register-type-variance!
(-> identifier? (listof variance?) any)]
[lookup-type-variance
@ -31,7 +35,7 @@
(-> identifier? (or/c #f (listof identifier?)) any)]
[refine-variance!
(-> (listof identifier?)
(listof Type/c)
(listof Type?)
(listof (or/c #f (listof symbol?)))
any)])
@ -61,6 +65,9 @@
(define (type-name-env-map f)
(sorted-dict-map the-mapping f id<))
(define (type-name-env-for-each f)
(sorted-dict-for-each the-mapping f id<))
(define (add-alias from to)
(when (lookup-type-name to (lambda () #f))
(register-resolved-type-alias
@ -86,6 +93,9 @@
(define (type-variance-env-map f)
(sorted-dict-map variance-mapping f id<))
(define (type-variance-env-for-each f)
(sorted-dict-for-each variance-mapping f id<))
;; Refines the variance of a type in the name environment
(define (refine-variance! names types tvarss)
(let loop ()

2
typed-racket-lib/typed-racket/infer/constraint-structs.rkt
View File

@ -6,7 +6,7 @@
;; S, T types
;; represents S <: X <: T (see "Local Type Inference" pg. 12)
(define-struct/cond-contract c ([S Type/c] [T Type/c]) #:transparent)
(define-struct/cond-contract c ([S Type?] [T Type?]) #:transparent)
;; fixed : Listof[c]
;; rest : option[c]

638
typed-racket-lib/typed-racket/infer/infer-unit.rkt
View File

@ -11,7 +11,8 @@
(except-in
(combine-in
(utils tc-utils)
(rep free-variance type-rep prop-rep object-rep rep-utils)
(rep free-variance type-rep prop-rep object-rep
values-rep rep-utils type-mask)
(types utils abbrev numeric-tower union subtype resolve
substitute generalize prefab)
(env index-env tvar-env))
@ -41,7 +42,7 @@
;; Type Type -> Pair<Seq, Seq>
;; construct a pair for the set of seen type pairs
(define (seen-before s t)
(cons (Type-seq s) (Type-seq t)))
(cons (Rep-seq s) (Rep-seq t)))
;; Context, contains which type variables and indices to infer and which cannot be mentioned in
;; constraints.
@ -198,7 +199,8 @@
(define (List->seq v)
(match v
[(List: ts #:tail (app List->end end)) (and end (seq ts end))]))
[(List: ts #:tail (app List->end end)) (and end (seq ts end))]
[_ #f]))
(define-match-expander ValuesSeq:
@ -212,7 +214,7 @@
[(_ seq) #'(app List->seq (? values seq))])))
;; generate-dbound-prefix: Symbol Type/c Natural (U Symbol #f) -> (Values (Listof Symbol) (Listof Type/c))
;; generate-dbound-prefix: Symbol Type? Natural (U Symbol #f) -> (Values (Listof Symbol) (Listof Type?))
;; Substitutes n fresh new variables, replaces dotted occurences of v in t with the variables (and
;; maybe new-end), and then for each variable substitutes it in for regular occurences of v.
(define (generate-dbound-prefix v ty n new-end)
@ -229,6 +231,7 @@
(match* (s t)
[(e e) (empty-cset/context context)]
[(e (TrueProp:)) (empty-cset/context context)]
[((FalseProp:) e) (empty-cset/context context)]
;; FIXME - is there something to be said about the logical ones?
[((TypeProp: o s) (TypeProp: o t)) (cgen/inv context s t)]
[((NotTypeProp: o s) (NotTypeProp: o t)) (cgen/inv context s t)]
@ -244,7 +247,7 @@
[(_ _) #f]))
(define/cond-contract (cgen/object context s t)
(context? Object? Object? . -> . (or/c #f cset?))
(context? OptObject? OptObject? . -> . (or/c #f cset?))
(match* (s t)
[(e e) (empty-cset/context context)]
[(e (Empty:)) (empty-cset/context context)]
@ -371,7 +374,6 @@
(define/cond-contract (cgen/arr context s-arr t-arr)
(context? arr? arr? . -> . (or/c #f cset?))
(match* (s-arr t-arr)
[((arr: ss s s-rest s-drest s-kws) (arr: ts t t-rest t-drest t-kws))
(define (rest->end rest drest)
@ -413,10 +415,10 @@
. -> . (or/c #F cset?))
;; useful quick loop
(define/cond-contract (cg S T)
(Type/c Type/c . -> . (or/c #f cset?))
(Type? Type? . -> . (or/c #f cset?))
(cgen context S T))
(define/cond-contract (cg/inv S T)
(Type/c Type/c . -> . (or/c #f cset?))
(Type? Type? . -> . (or/c #f cset?))
(cgen/inv context S T))
;; this places no constraints on any variables
(define empty (empty-cset/context context))
@ -427,332 +429,336 @@
;; subtyping doesn't need to use it quite as much
(define cs (current-seen))
;; if we've been around this loop before, we're done (for rec types)
(if (seen? S T cs)
empty
(parameterize (;; remember S and T, and obtain everything we've seen from the context
;; we can't make this an argument since we may call back and forth with
;; subtyping, for example
[current-seen (remember S T cs)])
(match*/early (S T)
;; if they're equal, no constraints are necessary (CG-Refl)
[(a b) #:when (type-equal? a b) empty]
;; CG-Top
[(_ (Univ:)) empty]
;; AnyValues
[((AnyValues: p) (AnyValues: q))
(cgen/prop context p q)]
(cond
[(type-equal? S T) empty] ;; (CG-Refl)
[(Univ? T) empty] ;; CG-Top
[(seen? S T cs) empty]
[else
(parameterize (;; remember S and T, and obtain everything we've seen from the context
;; we can't make this an argument since we may call back and forth with
;; subtyping, for example
[current-seen (remember S T cs)])
(match*/early
(S T)
;; AnyValues
[((AnyValues: p) (AnyValues: q))
(cgen/prop context p q)]
[((or (Values: (list (Result: _ psets _) ...))
(ValuesDots: (list (Result: _ psets _) ...) _ _))
(AnyValues: q))
(cset-join
(filter identity
(for/list ([pset (in-list psets)])
(match pset
[(PropSet: p+ p-)
(% cset-meet (cgen/prop context p+ q) (cgen/prop context p- q))]))))]
[((or (Values: (list (Result: _ psets _) ...))
(ValuesDots: (list (Result: _ psets _) ...) _ _))
(AnyValues: q))
(cset-join
(filter identity
(for/list ([pset (in-list psets)])
(match pset
[(PropSet: p+ p-)
(% cset-meet (cgen/prop context p+ q) (cgen/prop context p- q))]))))]
;; check all non Type/c first so that calling subtype is safe
;; check all non Type? first so that calling subtype is safe
;; check each element
[((Result: s pset-s o-s)
(Result: t pset-t o-t))
(% cset-meet (cg s t)
(cgen/prop-set context pset-s pset-t)
(cgen/object context o-s o-t))]
;; check each element
[((Result: s pset-s o-s)
(Result: t pset-t o-t))
(% cset-meet (cg s t)
(cgen/prop-set context pset-s pset-t)
(cgen/object context o-s o-t))]
;; Values just delegate to cgen/seq, except special handling for -Bottom.
;; A single -Bottom in a Values means that there is no value returned and so any other
;; Values or ValuesDots should be above it.
[((ValuesSeq: s-seq) (ValuesSeq: t-seq))
;; Check for a substition that S is below (ret -Bottom).
(define bottom-case
(match S
[(Values: (list (Result: s f-s o-s)))
(cgen context s -Bottom)]
[else #f]))
(define regular-case
(cgen/seq context s-seq t-seq))
;; If we want the OR of the csets that the two cases return.
(cset-join
(filter values
(list bottom-case regular-case)))]
;; they're subtypes. easy.
[(a b)
#:when (subtype a b)
empty]
;; Lists delegate to sequences
[((ListSeq: s-seq) (ListSeq: t-seq))
(cgen/seq context s-seq t-seq)]
;; refinements are erased to their bound
[((Refinement: S _) T)
(cg S T)]
;; variables that are in X and should be constrained
;; all other variables are compatible only with themselves
[((F: (? (inferable-var? context) v)) T)
#:return-when
(match T
;; fail when v* is an index variable
[(F: v*) (and (bound-index? v*) (not (bound-tvar? v*)))]
[_ #f])
#f
;; constrain v to be below T (but don't mention bounds)
(singleton (Un) v (var-demote T (context-bounds context)))]
[(S (F: (? (inferable-var? context) v)))
#:return-when
;; Values just delegate to cgen/seq, except special handling for -Bottom.
;; A single -Bottom in a Values means that there is no value returned and so any other
;; Values or ValuesDots should be above it.
[((ValuesSeq: s-seq) (ValuesSeq: t-seq))
;; Check for a substition that S is below (ret -Bottom).
(define bottom-case
(match S
[(F: v*) (and (bound-index? v*) (not (bound-tvar? v*)))]
[_ #f])
#f
;; constrain v to be above S (but don't mention bounds)
(singleton (var-promote S (context-bounds context)) v Univ)]
[(Values: (list (Result: s f-s o-s)))
(cgen context s -Bottom)]
[else #f]))
(define regular-case
(cgen/seq context s-seq t-seq))
;; If we want the OR of the csets that the two cases return.
(cset-join
(filter values
(list bottom-case regular-case)))]
;; recursive names should get resolved as they're seen
[(s (? Name? t))
(cg s (resolve-once t))]
[((? Name? s) t)
(cg (resolve-once s) t)]
;; they're subtypes. easy.
[(a b) #:when (cond
[(Type? a) (subtype a b)]
[(Result? a) (subresult a b)]
[else (subval a b)])
empty]
;; constrain b1 to be below T, but don't mention the new vars
[((Poly: v1 b1) T) (cgen (context-add context #:bounds v1) b1 T)]
;; Lists delegate to sequences
[((ListSeq: s-seq) (ListSeq: t-seq))
(cgen/seq context s-seq t-seq)]
;; Mu's just get unfolded
[((? Mu? s) t) (cg (unfold s) t)]
[(s (? Mu? t)) (cg s (unfold t))]
;; refinements are erased to their bound
[((Refinement: S _) T)
(cg S T)]
;; find *an* element of elems which can be made a subtype of T
[((Intersection: ts) T)
(cset-join
(for*/list ([t (in-immutable-set ts)]
[v (in-value (cg t T))]
#:when v)
v))]
;; constrain S to be below *each* element of elems, and then combine the constraints
[(S (Intersection: ts))
(define cs (for/list/fail ([ts (in-immutable-set ts)]) (cg S ts)))
(and cs (cset-meet* (cons empty cs)))]
;; constrain *each* element of es to be below T, and then combine the constraints
[((Union: es) T)
(define cs (for/list/fail ([e (in-list es)]) (cg e T)))
(and cs (cset-meet* (cons empty cs)))]
;; variables that are in X and should be constrained
;; all other variables are compatible only with themselves
[((F: (? (inferable-var? context) v)) T)
#:return-when
(match T
;; fail when v* is an index variable
[(F: v*) (and (bound-index? v*) (not (bound-tvar? v*)))]
[_ #f])
#f
;; constrain v to be below T (but don't mention bounds)
(singleton -Bottom v (var-demote T (context-bounds context)))]
;; find *an* element of es which can be made to be a supertype of S
;; FIXME: we're using multiple csets here, but I don't think it makes a difference
;; not using multiple csets will break for: ???
[(S (Union: es))
(cset-join
(for*/list ([e (in-list es)]
[v (in-value (cg S e))]
#:when v)
v))]
[(S (F: (? (inferable-var? context) v)))
#:return-when
(match S
[(F: v*) (and (bound-index? v*) (not (bound-tvar? v*)))]
[_ #f])
#f
;; constrain v to be above S (but don't mention bounds)
(singleton (var-promote S (context-bounds context)) v Univ)]
;; from define-new-subtype
[((Distinction: nm1 id1 S) (app resolve (Distinction: nm2 id2 T)))
#:when (and (equal? nm1 nm2) (equal? id1 id2))
(cg S T)]
[((Distinction: _ _ S) T)
(cg S T)]
;; recursive names should get resolved as they're seen
[(s (? Name? t))
(cg s (resolve-once t))]
[((? Name? s) t)
(cg (resolve-once s) t)]
;; two structs with the same name
;; just check pairwise on the fields
[((Struct: nm _ flds proc _ _) (Struct: nm* _ flds* proc* _ _))
#:when (free-identifier=? nm nm*)
(let ([proc-c
(cond [(and proc proc*)
(cg proc proc*)]
[proc* #f]
[else empty])])
(% cset-meet proc-c (cgen/flds context flds flds*)))]
;; constrain b1 to be below T, but don't mention the new vars
[((Poly: v1 b1) T) (cgen (context-add context #:bounds v1) b1 T)]
;; two prefab structs with the same key
[((Prefab: k ss) (Prefab: k* ts))
#:when (and (prefab-key-subtype? k k*)
(>= (length ss) (length ts)))
(% cset-meet*
(for/list/fail ([s (in-list ss)]
[t (in-list ts)]
[mut? (in-list (prefab-key->field-mutability k*))])
(if mut?
(cgen/inv context s t)
(cgen context s t))))]
;; Mu's just get unfolded
[((? Mu? s) t) (cg (unfold s) t)]
[(s (? Mu? t)) (cg s (unfold t))]
;; two struct names, need to resolve b/c one could be a parent
[((Name: n _ #t) (Name: n* _ #t))
(if (free-identifier=? n n*)
empty ;; just succeed now
(% cg (resolve-once S) (resolve-once T)))]
;; pairs are pointwise
[((Pair: a b) (Pair: a* b*))
(% cset-meet (cg a a*) (cg b b*))]
;; sequences are covariant
[((Sequence: ts) (Sequence: ts*))
(cgen/list context ts ts*)]
[((Listof: t) (Sequence: (list t*)))
(cg t t*)]
[((Pair: t1 t2) (Sequence: (list t*)))
(% cset-meet (cg t1 t*) (cg t2 (-lst t*)))]
[((MListof: t) (Sequence: (list t*)))
(cg t t*)]
;; To check that mutable pair is a sequence we check that the cdr is
;; both an mutable list and a sequence
[((MPair: t1 t2) (Sequence: (list t*)))
(% cset-meet (cg t1 t*) (cg t2 T) (cg t2 (Un -Null (make-MPairTop))))]
[((List: ts) (Sequence: (list t*)))
(% cset-meet* (for/list/fail ([t (in-list ts)])
(cg t t*)))]
[((HeterogeneousVector: ts) (HeterogeneousVector: ts*))
(% cset-meet (cgen/list context ts ts*) (cgen/list context ts* ts))]
[((HeterogeneousVector: ts) (Vector: s))
(define ts* (map (λ _ s) ts)) ;; invariant, everything has to match
(% cset-meet (cgen/list context ts ts*) (cgen/list context ts* ts))]
[((HeterogeneousVector: ts) (Sequence: (list t*)))
(% cset-meet* (for/list/fail ([t (in-list ts)])
(cg t t*)))]
[((Vector: t) (Sequence: (list t*)))
(cg t t*)]
[((Base: 'String _ _ _) (Sequence: (list t*)))
(cg -Char t*)]
[((Base: 'Bytes _ _ _) (Sequence: (list t*)))
(cg -Nat t*)]
[((Base: 'Input-Port _ _ _) (Sequence: (list t*)))
(cg -Nat t*)]
[((Value: (? exact-nonnegative-integer? n)) (Sequence: (list t*)))
(define possibilities
(list
(list byte? -Byte)
(list portable-index? -Index)
(list portable-fixnum? -NonNegFixnum)
(list values -Nat)))
(define type
(for/or ([pred-type (in-list possibilities)])
(match pred-type
((list pred? type)
(and (pred? n) type)))))
(cg type t*)]
[((Base: _ _ _ #t) (Sequence: (list t*)))
(define type
(for/or ([t (in-list (list -Byte -Index -NonNegFixnum -Nat))])
(and (subtype S t) t)))
(% cg type t*)]
[((Hashtable: k v) (Sequence: (list k* v*)))
(cgen/list context (list k v) (list k* v*))]
[((Set: t) (Sequence: (list t*)))
(cg t t*)]
;; find *an* element of elems which can be made a subtype of T
[((Intersection: ts) T)
(cset-join
(for*/list ([t (in-list ts)]
[v (in-value (cg t T))]
#:when v)
v))]
;; constrain S to be below *each* element of elems, and then combine the constraints
[(S (Intersection: ts))
(define cs (for/list/fail ([ts (in-list ts)]) (cg S ts)))
(and cs (cset-meet* (cons empty cs)))]
;; constrain *each* element of es to be below T, and then combine the constraints
[((Union: es) T)
(define cs (for/list/fail ([e (in-list es)]) (cg e T)))
(and cs (cset-meet* (cons empty cs)))]
;; find *an* element of es which can be made to be a supertype of S
;; FIXME: we're using multiple csets here, but I don't think it makes a difference
;; not using multiple csets will break for: ???
[(S (or (Union: es)
(and (Bottom:) (bind es '()))))
(cset-join
(for*/list ([e (in-list es)]
[v (in-value (cg S e))]
#:when v)
v))]
;; from define-new-subtype
[((Distinction: nm1 id1 S) (app resolve (Distinction: nm2 id2 T)))
#:when (and (equal? nm1 nm2) (equal? id1 id2))
(cg S T)]
[((Distinction: _ _ S) T)
(cg S T)]
;; two structs with the same name
;; just check pairwise on the fields
[((Struct: nm _ flds proc _ _) (Struct: nm* _ flds* proc* _ _))
#:when (free-identifier=? nm nm*)
(let ([proc-c
(cond [(and proc proc*)
(cg proc proc*)]
[proc* #f]
[else empty])])
(% cset-meet proc-c (cgen/flds context flds flds*)))]
;; two prefab structs with the same key
[((Prefab: k ss) (Prefab: k* ts))
#:when (and (prefab-key-subtype? k k*)
(>= (length ss) (length ts)))
(% cset-meet*
(for/list/fail ([s (in-list ss)]
[t (in-list ts)]
[mut? (in-list (prefab-key->field-mutability k*))])
(if mut?
(cgen/inv context s t)
(cgen context s t))))]
;; two struct names, need to resolve b/c one could be a parent
[((Name: n _ #t) (Name: n* _ #t))
(if (free-identifier=? n n*)
empty ;; just succeed now
(% cg (resolve-once S) (resolve-once T)))]
;; pairs are pointwise
[((Pair: a b) (Pair: a* b*))
(% cset-meet (cg a a*) (cg b b*))]
;; sequences are covariant
[((Sequence: ts) (Sequence: ts*))
(cgen/list context ts ts*)]
[((Listof: t) (Sequence: (list t*)))
(cg t t*)]
[((Pair: t1 t2) (Sequence: (list t*)))
(% cset-meet (cg t1 t*) (cg t2 (-lst t*)))]
[((MListof: t) (Sequence: (list t*)))
(cg t t*)]
;; To check that mutable pair is a sequence we check that the cdr is
;; both an mutable list and a sequence
[((MPair: t1 t2) (Sequence: (list t*)))
(% cset-meet (cg t1 t*) (cg t2 T) (cg t2 (Un -Null (make-MPairTop))))]
[((List: ts) (Sequence: (list t*)))
(% cset-meet* (for/list/fail ([t (in-list ts)])
(cg t t*)))]
[((HeterogeneousVector: ts) (HeterogeneousVector: ts*))
(% cset-meet (cgen/list context ts ts*) (cgen/list context ts* ts))]
[((HeterogeneousVector: ts) (Vector: s))
(define ts* (map (λ _ s) ts)) ;; invariant, everything has to match
(% cset-meet (cgen/list context ts ts*) (cgen/list context ts* ts))]
[((HeterogeneousVector: ts) (Sequence: (list t*)))
(% cset-meet* (for/list/fail ([t (in-list ts)])
(cg t t*)))]
[((Vector: t) (Sequence: (list t*)))
(cg t t*)]
[((Base: 'String _ _ _) (Sequence: (list t*)))
(cg -Char t*)]
[((Base: 'Bytes _ _ _) (Sequence: (list t*)))
(cg -Nat t*)]
[((Base: 'Input-Port _ _ _) (Sequence: (list t*)))
(cg -Nat t*)]
[((Value: (? exact-nonnegative-integer? n)) (Sequence: (list t*)))
(define possibilities
(list
(list byte? -Byte)
(list portable-index? -Index)
(list portable-fixnum? -NonNegFixnum)
(list values -Nat)))
(define type
(for/or ([pred-type (in-list possibilities)])
(match pred-type
[(list pred? type)
(and (pred? n) type)])))
(cg type t*)]
[((Base: _ _ _ #t) (Sequence: (list t*)))
(define type
(for/or ([t (in-list (list -Byte -Index -NonNegFixnum -Nat))])
(and (subtype S t) t)))
(% cg type t*)]
[((Hashtable: k v) (Sequence: (list k* v*)))
(cgen/list context (list k v) (list k* v*))]
[((Set: t) (Sequence: (list t*)))
(cg t t*)]
;; resolve applications
[((App: _ _ _) _)
(% cg (resolve-once S) T)]
[(_ (App: _ _ _))
(% cg S (resolve-once T))]
;; resolve applications
[((App: _ _ _) _)
(% cg (resolve-once S) T)]
[(_ (App: _ _ _))
(% cg S (resolve-once T))]
;; If the struct names don't match, try the parent of S
;; Needs to be done after App and Mu in case T is actually the current struct
;; but not currently visible
[((Struct: nm (? Type? parent) _ _ _ _) other)
(cg parent other)]
;; If the struct names don't match, try the parent of S
;; Needs to be done after App and Mu in case T is actually the current struct
;; but not currently visible
[((Struct: nm (? Type? parent) _ _ _ _) other)
(cg parent other)]
;; Invariant here because struct types aren't subtypes just because the
;; structs are (since you can make a constructor from the type).
[((StructType: s) (StructType: t))
(cg/inv s t)]
;; Invariant here because struct types aren't subtypes just because the
;; structs are (since you can make a constructor from the type).
[((StructType: s) (StructType: t))
(cg/inv s t)]
;; vectors are invariant - generate constraints *both* ways
[((Vector: e) (Vector: e*))
(cg/inv e e*)]
;; boxes are invariant - generate constraints *both* ways
[((Box: e) (Box: e*))
(cg/inv e e*)]
[((Weak-Box: e) (Weak-Box: e*))
(cg/inv e e*)]
[((MPair: s t) (MPair: s* t*))
(% cset-meet (cg/inv s s*) (cg/inv t t*))]
[((Channel: e) (Channel: e*))
(cg/inv e e*)]
[((Async-Channel: e) (Async-Channel: e*))
(cg/inv e e*)]
[((ThreadCell: e) (ThreadCell: e*))
(cg/inv e e*)]
[((Continuation-Mark-Keyof: e) (Continuation-Mark-Keyof: e*))
(cg/inv e e*)]
[((Prompt-Tagof: s t) (Prompt-Tagof: s* t*))
(% cset-meet (cg/inv s s*) (cg/inv t t*))]
[((Promise: e) (Promise: e*))
(cg e e*)]
[((Ephemeron: e) (Ephemeron: e*))
(cg e e*)]
[((CustodianBox: e) (CustodianBox: e*))
(cg e e*)]
[((Set: a) (Set: a*))
(cg a a*)]
[((Evt: a) (Evt: a*))
(cg a a*)]
[((Base: 'Semaphore _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Output-Port _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Input-Port _ _ _) (Evt: t))
(cg S t)]
[((Base: 'TCP-Listener _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Thread _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Subprocess _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Will-Executor _ _ _) (Evt: t))
(cg S t)]
[((Base: 'LogReceiver _ _ _) (Evt: t ))
(cg (make-HeterogeneousVector
(list -Symbol -String Univ
(Un (-val #f) -Symbol)))
t)]
[((Base: 'Place _ _ _) (Evt: t))
(cg Univ t)]
[((Base: 'Base-Place-Channel _ _ _) (Evt: t))
(cg Univ t)]
[((CustodianBox: t) (Evt: t*)) (cg S t*)]
[((Channel: t) (Evt: t*)) (cg t t*)]
[((Async-Channel: t) (Evt: t*)) (cg t t*)]
;; we assume all HTs are mutable at the moment
[((Hashtable: s1 s2) (Hashtable: t1 t2))
;; for mutable hash tables, both are invariant
(% cset-meet (cg/inv s1 t1) (cg/inv s2 t2))]
;; syntax is covariant
[((Syntax: s1) (Syntax: s2))
(cg s1 s2)]
;; futures are covariant
[((Future: s1) (Future: s2))
(cg s1 s2)]
;; parameters are just like one-arg functions
[((Param: in1 out1) (Param: in2 out2))
(% cset-meet (cg in2 in1) (cg out1 out2))]
[((Function: (list s-arr ...))
(Function: (list t-arr ...)))
(% cset-meet*
(for/list/fail ([t-arr (in-list t-arr)])
;; for each element of t-arr, we need to get at least one element of s-arr that works
(let ([results (for*/list ([s-arr (in-list s-arr)]
[v (in-value (cgen/arr context s-arr t-arr))]
#:when v)
v)])
;; ensure that something produces a constraint set
(and (not (null? results))
(cset-join results)))))]
[(_ _)
;; nothing worked, and we fail
#f]))))
;; vectors are invariant - generate constraints *both* ways
[((Vector: e) (Vector: e*))
(cg/inv e e*)]
;; boxes are invariant - generate constraints *both* ways
[((Box: e) (Box: e*))
(cg/inv e e*)]
[((Weak-Box: e) (Weak-Box: e*))
(cg/inv e e*)]
[((MPair: s t) (MPair: s* t*))
(% cset-meet (cg/inv s s*) (cg/inv t t*))]
[((Channel: e) (Channel: e*))
(cg/inv e e*)]
[((Async-Channel: e) (Async-Channel: e*))
(cg/inv e e*)]
[((ThreadCell: e) (ThreadCell: e*))
(cg/inv e e*)]
[((Continuation-Mark-Keyof: e) (Continuation-Mark-Keyof: e*))
(cg/inv e e*)]
[((Prompt-Tagof: s t) (Prompt-Tagof: s* t*))
(% cset-meet (cg/inv s s*) (cg/inv t t*))]
[((Promise: e) (Promise: e*))
(cg e e*)]
[((Ephemeron: e) (Ephemeron: e*))
(cg e e*)]
[((CustodianBox: e) (CustodianBox: e*))
(cg e e*)]
[((Set: a) (Set: a*))
(cg a a*)]
[((Evt: a) (Evt: a*))
(cg a a*)]
[((Base: 'Semaphore _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Output-Port _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Input-Port _ _ _) (Evt: t))
(cg S t)]
[((Base: 'TCP-Listener _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Thread _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Subprocess _ _ _) (Evt: t))
(cg S t)]
[((Base: 'Will-Executor _ _ _) (Evt: t))
(cg S t)]
[((Base: 'LogReceiver _ _ _) (Evt: t ))
(cg (make-HeterogeneousVector
(list -Symbol -String Univ
(Un (-val #f) -Symbol)))
t)]
[((Base: 'Place _ _ _) (Evt: t))
(cg Univ t)]
[((Base: 'Base-Place-Channel _ _ _) (Evt: t))
(cg Univ t)]
[((CustodianBox: t) (Evt: t*)) (cg S t*)]
[((Channel: t) (Evt: t*)) (cg t t*)]
[((Async-Channel: t) (Evt: t*)) (cg t t*)]
;; we assume all HTs are mutable at the moment
[((Hashtable: s1 s2) (Hashtable: t1 t2))
;; for mutable hash tables, both are invariant
(% cset-meet (cg/inv s1 t1) (cg/inv s2 t2))]
;; syntax is covariant
[((Syntax: s1) (Syntax: s2))
(cg s1 s2)]
;; futures are covariant
[((Future: s1) (Future: s2))
(cg s1 s2)]
;; parameters are just like one-arg functions
[((Param: in1 out1) (Param: in2 out2))
(% cset-meet (cg in2 in1) (cg out1 out2))]
[((Function: (list s-arr ...))
(Function: (list t-arr ...)))
(% cset-meet*
(for/list/fail
([t-arr (in-list t-arr)])
;; for each element of t-arr, we need to get at least one element of s-arr that works
(let ([results (for*/list ([s-arr (in-list s-arr)]
[v (in-value (cgen/arr context s-arr t-arr))]
#:when v)
v)])
;; ensure that something produces a constraint set
(and (not (null? results))
(cset-join results)))))]
[(_ _)
;; nothing worked, and we fail
#f]))]))
;; C : cset? - set of constraints found by the inference engine
;; X : (listof symbol?) - type variables that must have entries
;; Y : (listof symbol?) - index variables that must have entries
;; R : Type/c - result type into which we will be substituting
;; R : Type? - result type into which we will be substituting
(define/cond-contract (subst-gen C X Y R)
(cset? (listof symbol?) (listof symbol?) (or/c Values/c AnyValues? ValuesDots?)
. -> . (or/c #f substitution/c))
@ -853,7 +859,7 @@
(define infer
(let ()
(define/cond-contract (infer X Y S T R [expected #f])
(((listof symbol?) (listof symbol?) (listof Type/c) (listof Type/c)
(((listof symbol?) (listof symbol?) (listof Type?) (listof Type?)
(or/c #f Values/c ValuesDots?))
((or/c #f Values/c AnyValues? ValuesDots?))
. ->* . (or/c boolean? substitution/c))
@ -866,7 +872,6 @@
(let* ([cs (cgen/list ctx S T #:expected-cset expected-cset)]
[cs* (% cset-meet cs expected-cset)])
(and cs* (if R (subst-gen cs* X Y R) #t)))))
;(trace infer)
infer)) ;to export a variable binding and not syntax
;; like infer, but T-var is the vararg type:
@ -901,10 +906,3 @@
(define m (cset-meet cs expected-cset))
#:return-unless m #f
(subst-gen m X (list dotted-var) R)))
;(trace subst-gen)
;(trace cgen)
;(trace cgen/list)
;(trace cgen/arr)
;(trace cgen/seq)

132
typed-racket-lib/typed-racket/infer/intersect.rkt
View File

@ -1,8 +1,8 @@
#lang racket/unit
(require "../utils/utils.rkt")
(require (rep type-rep)
(types abbrev base-abbrev union subtype resolve)
(require (rep type-rep type-mask)
(types abbrev base-abbrev union subtype resolve overlap)
"signatures.rkt"
racket/match
racket/set)
@ -22,55 +22,135 @@
;; subtyping performs a similar check for the same
;; reason
(let intersect
([t1 t1] [t2 t2] [resolved '()])
([t1 t1] [t2 t2] [resolved '()])
(match*/no-order
(t1 t2)
;; no overlap
[(_ _) #:when (disjoint-masks? (Type-mask t1) (Type-mask t2))
-Bottom]
;; already a subtype
[(t1 t2) #:no-order #:when (subtype t1 t2) t1]
;; polymorphic intersect
[(t1 (Poly: vars t))
#:no-order
#:when (infer vars null (list t1) (list t) #f)
t1]
;; structural recursion on types
[((Pair: a1 d1) (Pair: a2 d2))
(build-type -pair
(intersect a1 a2 resolved)
(intersect d1 d2 resolved))]
;; FIXME: support structural updating for structs when structs are updated to
;; contain not only *if* they are polymorphic, but *which* fields are too
;;[((Struct: _ _ _ _ _ _)
;; (Struct: _ _ _ _ _ _))]
[((Syntax: t1*) (Syntax: t2*))
(build-type -Syntax (intersect t1* t2* resolved))]
[((Promise: t1*) (Promise: t2*))
(build-type -Promise (intersect t1* t2* resolved))]
;; unions
[((Union: t1s) t2)
#:no-order
(apply Un (map (λ (t1) (intersect t1 t2 resolved)) t1s))]
;; intersections
[((Intersection: t1s) t2)
#:no-order
(apply -unsafe-intersect (for/list ([t1 (in-list t1s)])
(intersect t1 t2 resolved)))]
;; resolve resolvable types if we haven't already done so
[((? resolvable? t1) t2)
#:no-order
#:when (not (member (cons t1 t2) resolved))
(intersect (resolve t1) t2 (cons (cons t1 t2) resolved))]
;; if we're intersecting two recursive types, intersect their body
;; and have their recursive references point back to the result
[((? Mu?) (? Mu?))
(define name (gensym))
(make-Mu name (intersect (Mu-body name t1) (Mu-body name t2) resolved))]
;; t2 and t1 have a complex relationship, so we build an intersection
;; (note: intersection checks for overlap)
[(t1 t2) (-unsafe-intersect t1 t2)])))
;; restrict
;; Type Type -> Type
;;
;; attempt to compute (t1 - (¬ t2))
;; this is useful when you want to know what part of t1 intersects
;; with t2 without adding t2 to the result (i.e. note that intersect
;; will create an intersection type if the intersection is not obvious,
;; and sometimes we want to make sure and _not_ add t2 to the result
;; we just want to keep the parts of t1 consistent with t2)
(define (restrict t1 t2)
;; build-type: build a type while propogating bottom
(define (build-type constructor . args)
(if (memf Bottom? args) -Bottom (apply constructor args)))
;; resolved is a set tracking previously seen restrict cases
;; (i.e. pairs of t1 t2) to prevent infinite unfolding.
;; subtyping performs a similar check for the same
;; reason
(let restrict
([t1 t1] [t2 t2] [resolved '()])
(match* (t1 t2)
;; no overlap
[(_ _) #:when (not (overlap? t1 t2)) -Bottom]
;; already a subtype
[(t1 t2) #:no-order #:when (subtype t1 t2) t1]
[(t1 t2) #:when (subtype t1 t2) t1]
;; polymorphic intersect
[(t1 (Poly: vars t))
#:no-order
#:when (infer vars null (list t1) (list t) #f)
t1]
;; polymorphic restrict
[(t1 (Poly: vars t)) #:when (infer vars null (list t1) (list t) #f) t1]
;; structural recursion on types
[((Pair: a1 d1) (Pair: a2 d2))
(build-type -pair
(intersect a1 a2 resolved)
(intersect d1 d2 resolved))]
(restrict a1 a2 resolved)
(restrict d1 d2 resolved))]
;; FIXME: support structural updating for structs when structs are updated to
;; contain not only *if* they are polymorphic, but *which* fields are too
;;[((Struct: _ _ _ _ _ _)
;; (Struct: _ _ _ _ _ _))]
[((Syntax: t1*) (Syntax: t2*))
(build-type -Syntax (intersect t1* t2* resolved))]
(build-type -Syntax (restrict t1* t2* resolved))]
[((Promise: t1*) (Promise: t2*))
(build-type -Promise (intersect t1* t2* resolved))]
(build-type -Promise (restrict t1* t2* resolved))]
;; unions
[((Union: t1s) t2)
#:no-order
(apply Un (map (λ (t1) (intersect t1 t2 resolved)) t1s))]
(apply Un (map (λ (t1) (restrict t1 t2 resolved)) t1s))]
;; intersections
[(t1 (Union: t2s))
(apply Un (map (λ (t2) (restrict t1 t2 resolved)) t2s))]
;; restrictions
[((Intersection: t1s) t2)
#:no-order
(apply -unsafe-intersect (for/list ([t1 (in-immutable-set t1s)])
(intersect t1 t2 resolved)))]
(apply -unsafe-intersect (for/list ([t1 (in-list t1s)])
(restrict t1 t2 resolved)))]
[(t1 (Intersection: t2s))
(apply -unsafe-intersect (for/list ([t2 (in-list t2s)])
(restrict t1 t2 resolved)))]
;; resolve resolvable types if we haven't already done so
[((? needs-resolving? t1) t2)
#:no-order
[((? resolvable? t1) t2)
#:when (not (member (cons t1 t2) resolved))
(intersect (resolve t1) t2 (cons (cons t1 t2) resolved))]
(restrict (resolve t1) t2 (cons (cons t1 t2) resolved))]
[(t1 (? resolvable? t2))
#:when (not (member (cons t1 t2) resolved))
(restrict t1 (resolve t2) (cons (cons t1 t2) resolved))]
;; if we're intersecting two recursive types, intersect their body
;; and have their recursive references point back to the result
[((? Mu?) (? Mu?))
(define name (gensym))
(make-Mu name (intersect (Mu-body name t1) (Mu-body name t2) resolved))]
(make-Mu name (restrict (Mu-body name t1) (Mu-body name t2) resolved))]
;; t2 and t1 have a complex relationship, so we build an intersection
;; (note: intersection checks for overlap)
[(t1 t2) (-unsafe-intersect t1 t2)])))
;; else it's complicated and t1 remains unchanged
[(_ _) t1])))

111
typed-racket-lib/typed-racket/infer/promote-demote.rkt
View File

@ -1,15 +1,13 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep rep-utils)
(types abbrev utils structural)
(rep type-rep values-rep rep-utils free-variance)
(types abbrev utils)
(prefix-in c: (contract-req))
racket/performance-hint
racket/list racket/match)
(provide/cond-contract
[var-promote (c:-> Type/c (c:listof symbol?) Type/c)]
[var-demote (c:-> Type/c (c:listof symbol?) Type/c)])
[var-promote (c:-> Type? (c:listof symbol?) Type?)]
[var-demote (c:-> Type? (c:listof symbol?) Type?)])
(define (V-in? V . ts)
(for/or ([e (in-list (append* (map fv ts)))])
@ -24,49 +22,62 @@
[(ValuesDots: (list (Result: _ propsets _) ...) _ _) propsets]))
(begin-encourage-inline
(define (var-change V T change)
(define (structural-recur t sym)
(case sym
[(co) (var-change V t change)]
[(contra) (var-change V t (not change))]
[(inv)
(if (V-in? V t)
(if change Univ -Bottom)
t)]))
(define (co t) (structural-recur t 'co))
(define (contra t) (structural-recur t 'contra))
(define (var-promote T V)
(var-change V T #t))
(define (var-demote T V)
(var-change V T #f))
;; arr? -> (or/c #f arr?)
;; Returns the changed arr or #f if there is no arr above it
(define (arr-change arr)
(match arr
[(arr: dom rng rest drest kws)
(cond
[(apply V-in? V (get-propsets rng))
#f]
[(and drest (memq (cdr drest) V))
(make-arr (map contra dom)
(co rng)
(contra (car drest))
#f
(map contra kws))]
[else
(make-arr (map contra dom)
(co rng)
(and rest (contra rest))
(and drest (cons (contra (car drest)) (cdr drest)))
(map contra kws))])]))
(match T
[(F: name) (if (memq name V) (if change Univ -Bottom) T)]
[(Function: arrs)
(make-Function (filter-map arr-change arrs))]
[(? structural?) (structural-map T structural-recur)]
[(? Prop?) ((sub-f co) T)]
[(? Object?) ((sub-o co) T)]
[(? Type?) ((sub-t co) T)]))
(define (var-promote T V)
(var-change V T #t))
(define (var-demote T V)
(var-change V T #f)))
(define (var-change V cur change)
(define (co t) (var-change V t change))
(define (contra t) (var-change V t (not change)))
;; arr? -> (or/c #f arr?)
;; Returns the changed arr or #f if there is no arr above it
(define (arr-change arr)
(match arr
[(arr: dom rng rest drest kws)
(cond
[(apply V-in? V (get-propsets rng))
#f]
[(and drest (memq (cdr drest) V))
(make-arr (map contra dom)
(co rng)
(contra (car drest))
#f
(map contra kws))]
[else
(make-arr (map contra dom)
(co rng)
(and rest (contra rest))
(and drest (cons (contra (car drest)) (cdr drest)))
(map contra kws))])]))
(match cur
[(? structural? t)
(define mk (Rep-constructor t))
(apply mk (for/list ([t (in-list (Rep-values t))]
[v (in-list (Type-variances t))])
(cond
[(eq? v Covariant) (co t)]
[(eq? v Invariant)
(if (V-in? V t)
(if change Univ -Bottom)
t)]
[(eq? v Contravariant)
(contra t)])))]
[(Unit: imports exports init-depends t)
(make-Unit (map co imports)
(map contra imports)
(map co init-depends)
(co t))]
[(F: name) (if (memq name V)
(if change Univ -Bottom)
cur)]
[(Function: arrs)
(make-Function (filter-map arr-change arrs))]
[(HeterogeneousVector: elems)
(make-HeterogeneousVector (map (λ (t) (if (V-in? V t)
(if change Univ -Bottom)
t))
elems))]
[_ (Rep-fold co cur)]))

17
typed-racket-lib/typed-racket/infer/signatures.rkt
View File

@ -2,7 +2,7 @@
(require "../utils/utils.rkt"
racket/unit (contract-req)
(utils unit-utils)
(rep type-rep))
(rep type-rep values-rep))
(require-for-cond-contract (infer constraint-structs))
@ -16,12 +16,13 @@
[cond-contracted cset-meet* ((listof cset?) . -> . (or/c #f cset?))]
[cond-contracted no-constraint c?]
[cond-contracted empty-cset ((listof symbol?) (listof symbol?) . -> . cset?)]
[cond-contracted insert (cset? symbol? Type/c Type/c . -> . cset?)]
[cond-contracted insert (cset? symbol? Type? Type? . -> . cset?)]
[cond-contracted cset-join ((listof cset?) . -> . cset?)]
[cond-contracted c-meet ((c? c?) (symbol?) . ->* . (or/c #f c?))]))
(define-signature intersect^
([cond-contracted intersect (Type/c Type/c . -> . Type/c)]))
([cond-contracted intersect (Type? Type? . -> . Type?)]
[cond-contracted restrict (Type? Type? . -> . Type?)]))
(define-signature infer^
([cond-contracted infer ((;; variables from the forall
@ -29,9 +30,9 @@
;; indexes from the forall
(listof symbol?)
;; actual argument types from call site
(listof Type/c)
(listof Type?)
;; domain
(listof Type/c)
(listof Type?)
;; range
(or/c #f Values/c ValuesDots?))
;; optional expected type
@ -42,11 +43,11 @@
;; indexes from the forall
(listof symbol?)
;; actual argument types from call site
(listof Type/c)
(listof Type?)
;; domain
(listof Type/c)
(listof Type?)
;; rest
(or/c #f Type/c)
(or/c #f Type?)
;; range
(or/c #f Values/c ValuesDots?))
;; [optional] expected type

70
typed-racket-lib/typed-racket/private/parse-type.rkt
View File

@ -3,7 +3,7 @@
;; This module provides functions for parsing types written by the user
(require (rename-in "../utils/utils.rkt" [infer infer-in])
(except-in (rep type-rep object-rep) make-arr)
(except-in (rep core-rep type-rep object-rep) make-arr)
(rename-in (types abbrev union utils prop-ops resolve
classes prefab signatures)
[make-arr* make-arr])
@ -31,14 +31,14 @@
(only-in "../base-env/case-lambda.rkt" case-lambda)))
(provide/cond-contract ;; Parse the given syntax as a type
[parse-type (syntax? . c:-> . Type/c)]
[parse-type (syntax? . c:-> . Type?)]
;; Parse the given identifier using the lexical
;; context of the given syntax object
[parse-type/id (syntax? c:any/c . c:-> . Type/c)]
[parse-type/id (syntax? c:any/c . c:-> . Type?)]
[parse-tc-results (syntax? . c:-> . tc-results/c)]
[parse-literal-alls (syntax? . c:-> . (c:listof (c:or/c (c:listof identifier?) (c:list/c (c:listof identifier?) identifier?))))]
;; Parse a row, which is only allowed in row-inst
[parse-row (syntax? . c:-> . Type/c)])
[parse-row (syntax? . c:-> . Row?)])
(provide star ddd/bound
current-referenced-aliases
@ -340,7 +340,7 @@
(syntax-parse
stx
[t
#:declare t (3d Type/c?)
#:declare t (3d Type?)
(attribute t.datum)]
[(fst . rst)
#:fail-unless (not (syntax->list #'rst)) #f
@ -408,9 +408,9 @@
"Unit types must import and export distinct signatures"))
(define (init-depend-error)
(parse-error
#:stx stx
#:delayed? #f
"Unit type initialization dependencies must be a subset of imports"))
#:stx stx
#:delayed? #f
"Unit type initialization dependencies must be a subset of imports"))
(define imports
(check-imports/exports (stx-map id->sig #'(import ...)) import/export-error))
(define exports
@ -448,27 +448,27 @@
(let* ([var (syntax-e #'x)]
[tvar (make-F var)])
(extend-tvars (list var)
(let ([t* (parse-type #'t)])
;; is t in a productive position?
(define productive
(let loop ((ty t*))
(match ty
[(Union: elems) (andmap loop elems)]
[(F: _) (not (equal? ty tvar))]
[(App: rator rands stx)
(loop (resolve-app rator rands stx))]
[(Mu: _ body) (loop body)]
[(Poly: names body) (loop body)]
[(PolyDots: names body) (loop body)]
[(PolyRow: _ _ body) (loop body)]
[else #t])))
(unless productive
(parse-error
#:stx stx
"recursive types are not allowed directly inside their definition"))
(if (memq var (fv t*))
(make-Mu var t*)
t*))))]
(let ([t* (parse-type #'t)])
;; is t in a productive position?
(define productive
(let loop ((ty t*))
(match ty
[(Union: elems) (andmap loop elems)]
[(F: _) (not (equal? ty tvar))]
[(App: rator rands stx)
(loop (resolve-app rator rands stx))]
[(Mu: _ body) (loop body)]
[(Poly: names body) (loop body)]
[(PolyDots: names body) (loop body)]
[(PolyRow: _ _ body) (loop body)]
[else #t])))
(unless productive
(parse-error
#:stx stx
"recursive types are not allowed directly inside their definition"))
(if (memq var (fv t*))
(make-Mu var t*)
t*))))]
[(:U^ ts ...)
(apply Un (parse-types #'(ts ...)))]
[(:∩^ ts ...)
@ -549,9 +549,9 @@
(extend-tvars (list var) (parse-type #'rest))
var)))))]
#| ;; has to be below the previous one
[(dom:expr ... :->^ rng)
[(dom:expr ... :->^ rng)
(->* (parse-types #'(dom ...))
(parse-values-type #'rng))] |#
(parse-values-type #'rng))] |#
;; use expr to rule out keywords
[(~or (:->^ dom:non-keyword-ty ... kws:keyword-tys ... rng)
(dom:non-keyword-ty ... kws:keyword-tys ... :->^ rng))
@ -566,9 +566,9 @@
#:kws (map force (attribute kws.Keyword)))))))]
;; This case needs to be at the end because it uses cut points to give good error messages.
[(~or (:->^ ~! dom:non-keyword-ty ... rng:expr
:colon^ (~var latent (full-latent (syntax->list #'(dom ...)))))
:colon^ (~var latent (full-latent (syntax->list #'(dom ...)))))
(dom:non-keyword-ty ... :->^ rng:expr
~! :colon^ (~var latent (full-latent (syntax->list #'(dom ...))))))
~! :colon^ (~var latent (full-latent (syntax->list #'(dom ...))))))
;; use parse-type instead of parse-values-type because we need to add the props from the pred-ty
(with-arity (length (syntax->list #'(dom ...)))
(->* (parse-types #'(dom ...))
@ -625,8 +625,8 @@
(parse-error "bad syntax in ->")]
[(id arg args ...)
(let loop
([rator (parse-type #'id)]
[args (parse-types #'(arg args ...))])
([rator (parse-type #'id)]
[args (parse-types #'(arg args ...))])
(resolve-app-check-error rator args stx)
(match rator
[(? Name?) (make-App rator args stx)]

25
typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -8,7 +8,7 @@
(rep type-rep prop-rep object-rep)
(utils tc-utils)
(env type-name-env row-constraint-env)
(rep rep-utils)
(rep core-rep rep-utils type-mask values-rep)
(types resolve union utils printer)
(prefix-in t: (types abbrev numeric-tower subtype))
(private parse-type syntax-properties)
@ -28,7 +28,7 @@
(provide
(c:contract-out
[type->static-contract
(c:parametric->/c (a) ((Type/c (c:-> #:reason (c:or/c #f string?) a))
(c:parametric->/c (a) ((Type? (c:-> #:reason (c:or/c #f string?) a))
(#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
(provide change-contract-fixups
@ -137,7 +137,7 @@
"could not convert type to a contract"
#:more #,failure-reason
"identifier" #,(symbol->string (syntax-e orig-id))
"type" #,(pretty-format-type type #:indent 8)))]
"type" #,(pretty-format-rep type #:indent 8)))]
[else
(match-define (list defs ctc) result)
(define maybe-inline-val
@ -319,7 +319,7 @@
[(_ sc-cache type-expr typed-side-expr match-clause ...)
#'(let ([type type-expr]
[typed-side typed-side-expr])
(define key (cons (Type-seq type) typed-side))
(define key (cons (Rep-seq type) typed-side))
(cond [(hash-ref sc-cache key #f)]
[else
(define sc (match type match-clause ...))
@ -389,6 +389,7 @@
;; Ordinary type applications or struct type names, just resolve
[(or (App: _ _ _) (Name/struct:)) (t->sc (resolve-once type))]
[(Univ:) (if (from-typed? typed-side) any-wrap/sc any/sc)]
[(Bottom:) (or/sc)]
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
(listof/sc (t->sc elem-ty))]
[(Base: sym cnt _ _)
@ -398,7 +399,7 @@
[(Refinement: par p?)
(and/sc (t->sc par) (flat/sc p?))]
[(Union: elems)
(define-values (numeric non-numeric) (partition (λ (t) (equal? 'number (Type-key t))) elems ))
(define-values (numeric non-numeric) (partition (λ (t) (eq? mask:number (Type-mask t))) elems))
(define numeric-sc (numeric-type->static-contract (apply Un numeric)))
(if numeric-sc
(apply or/sc numeric-sc (map t->sc non-numeric))
@ -406,7 +407,7 @@
[(Intersection: ts)
(define-values (chaperones/impersonators others)
(for/fold ([cs/is null] [others null])
([elem (in-immutable-set ts)])
([elem (in-list ts)])
(define c (t->sc elem))
(if (equal? flat-sym (get-max-contract-kind c))
(values cs/is (cons c others))
@ -839,14 +840,10 @@
;; Name type in application position
(define (has-name-app? type)
(let/ec escape
(let loop ([type type])
(type-case
(#:Type loop #:Prop (sub-f loop) #:Object (sub-o loop))
type
[#:App arg _ _
(match arg
[(Name: _ _ #f) (escape #t)]
[_ type])]))
(let loop ([rep type])
(match rep
[(App: (Name: _ _ #f) _ _) (escape #t)]
[_ (Rep-walk loop rep)]))
#f))
;; True if the arities `arrs` are what we'd expect from a struct predicate

234
typed-racket-lib/typed-racket/rep/core-rep.rkt Normal file
View File

@ -0,0 +1,234 @@
#lang racket/base
;;************************************************************
;; core-rep.rkt
;;
;; In this file we define the parent structs that describe most of
;; Typed Racket's internal forms and define a few variants which are
;; referenced in many definitions.
;; ************************************************************
(require "../utils/utils.rkt"
"rep-utils.rkt"
"free-variance.rkt"
"type-mask.rkt"
(contract-req)
racket/match
racket/list
racket/lazy-require
(for-syntax racket/base racket/syntax
syntax/parse))
(provide Type Type-mask Type-subtype-cache Type?
Prop Prop?
Object Object? OptObject?
PathElem PathElem?
SomeValues SomeValues?
def-type
def-values
def-prop
def-object
def-pathelem
type-equal?
prop-equal?
object-equal?)
(define-syntax type-equal? (make-rename-transformer #'eq?))
(define-syntax prop-equal? (make-rename-transformer #'eq?))
(define-syntax object-equal? (make-rename-transformer #'eq?))
(provide-for-cond-contract name-ref/c)
;; A Name-Ref is any value that represents an object.
;; As an identifier, it represents a free variable in the environment
;; As a pair, it represents a De Bruijn indexed bound variable (cons lvl arg-num)
(define-for-cond-contract name-ref/c
(or/c identifier? (cons/c natural-number/c natural-number/c)))
;;************************************************************
;; Custom Printing Tools
;;************************************************************
(lazy-require
["../types/printer.rkt" (print-type
print-prop print-object print-pathelem
print-values print-propset print-result)])
;; Note: We eta expand the printer so it is not evaluated until needed.
(define-syntax (struct/printer stx)
(syntax-parse stx
[(_ name:id
(flds:id ...)
printer:id)
(with-syntax ([mk (generate-temporary 'dont-use-me)])
(syntax/loc
stx
(struct name Rep (flds ...)
#:constructor-name mk
#:transparent
#:property prop:custom-print-quotable 'never
#:methods gen:custom-write
[(define (write-proc v port write?) (printer v port write?))])))]))
(define-syntax (build-rep-definer syntax)
(syntax-parse syntax
[(_ class:id def-id:id)
(syntax/loc syntax
(define-syntax (def-id stx)
(syntax-parse stx
[(_ variant:id flds:expr . rst)
(syntax/loc stx
(def-rep variant flds [#:parent class] . rst))])))]))
;;
;; These structs are the 'meta-variables' of TR's internal grammar,
;; if you will. For reference, see the following two papers which
;; discuss Typed Racket's metatheory:
;;
;; 1. Logical Types for Untyped Languages, Tobin-Hochstadt &
;; Felleisen, ICFP 2010
;;
;; 2. Occurrence Typing Modulo Theories, Kent et al., PLDI 2016
;;************************************************************
;; Types
;;************************************************************
;;
;;
;; The 'mask' field that is used for quick-checking of certain
;; properties. See type-mask.rkt for details.
;; subtype-cache - for a given type τ, the subtype-cache
;; is a mapping from Type -> boolean, s.t. if
;; τ.subtype-cache[σ] = #t then τ <: σ holds, otherwise
;; if τ.subtype-cache[σ] = #f, then τ <: σ does not hold
;; mask - the type mask for this type
(struct/printer Type (subtype-cache mask) print-type)
(build-rep-definer Type def-type)
;;-----------------
;; Universal Type
;;-----------------
;; the type of all well-typed terms
;; (called Any in user programs)
(def-type Univ () #:base
[#:type-mask mask:unknown])
;;-----------------
;; Bottom Type
;;-----------------
(def-type Bottom () #:base
[#:type-mask mask:bottom])
;;************************************************************
;; Prop
;;************************************************************
;;
;; These convey learned information about program terms while
;; typechecking.
(struct/printer Prop () print-prop)
(build-rep-definer Prop def-prop)
(def-prop TrueProp () #:base)
(def-prop FalseProp () #:base)
;;************************************************************
;; Fields and Symbolic Objects
;;************************************************************
;;
;; These are used to represent the class of canonical program terms
;; that can be lifted to the type level while typechecking.
;;--------------
;; PathElements
;;--------------
;; e.g. car, cdr, etc
(struct/printer PathElem () print-pathelem)
(build-rep-definer PathElem def-pathelem)
;;----------
;; Objects
;;----------
(struct/printer Object () print-object)
(build-rep-definer Object def-object)
;; empty object
(def-rep Empty () #:base
[#:extras
#:property prop:custom-print-quotable 'never
#:methods gen:custom-write
[(define (write-proc v port write?)
(when write?
(write-string "-" port)))]])
(define/provide (OptObject? x)
(or (Object? x) (Empty? x)))
;;************************************************************
;; SomeValues
;;************************************************************
;;
;; Racket expressions can produce 0 or more values, 'SomeValues'
;; represents the general class of all these possibilities
(struct/printer SomeValues () print-values)
(build-rep-definer SomeValues def-values)
;;************************************************************
;; PropSets
;;************************************************************
;; These are a convenient way to pair 'then' and 'else' propositions
;; together, which appear in typechecking results and in function
;; types.
;;
;; Since there is only one form, we do not define an empty parent
;; struct that other structs inherit from.
(def-rep PropSet ([thn Prop?] [els Prop?])
[#:intern-key (cons (Rep-seq thn) (Rep-seq els))]
[#:frees (f) (combine-frees (list (f thn) (f els)))]
[#:fold (f) (make-PropSet (f thn) (f els))]
[#:walk (f) (begin (f thn) (f els))]
[#:extras
#:property prop:custom-print-quotable 'never
#:methods gen:custom-write
[(define (write-proc v port write?) (print-propset v port write?))]])
;;************************************************************
;; Results
;;************************************************************
;;
;; These represent all the relevant info derived from typechecking a
;; term which produces one value, namely it's type (t), what is learned
;; if it is used as an 'if' test expression (ps), and what, if any, symbolic
;; object the value would correspond to (o).
;;
;; Since there is only one form, we do not define an empty parent
;; struct that other structs inherit from.
(def-rep Result ([t Type?] [ps PropSet?] [o OptObject?])
[#:intern-key (list* (Rep-seq t) (Rep-seq ps) (Rep-seq o))]
[#:frees (f) (combine-frees (list (f t) (f ps) (f o)))]
[#:fold (f) (make-Result (f t) (f ps) (f o))]
[#:walk (f) (begin (f t) (f ps) (f o))]
[#:extras
#:property prop:custom-print-quotable 'never
#:methods gen:custom-write
[(define (write-proc v port write?) (print-result v port write?))]])

63
typed-racket-lib/typed-racket/rep/free-variance.rkt
View File

@ -75,57 +75,58 @@
;; frees -> frees
(define (flip-variances frees)
(match frees
((combined-frees hash computed)
(combined-frees
[(combined-frees hash computed)
(combined-frees
(for/hasheq (((k v) hash))
(values k (flip-variance v)))
(map flip-variances computed)))
((app-frees name args)
(app-frees name (map flip-variances args)))
((remove-frees inner name)
(remove-frees (flip-variances inner) name))))
(map flip-variances computed))]
[(app-frees name args)
(app-frees name (map flip-variances args))]
[(remove-frees inner name)
(remove-frees (flip-variances inner) name)]))
(define (make-invariant frees)
(combined-frees
(for/hasheq ((name (free-vars-names frees)))
(for/hasheq ([name (free-vars-names frees)])
(values name Invariant))
null))
(define (make-constant frees)
(combined-frees
(for/hasheq ((name (free-vars-names frees)))
(for/hasheq ([name (free-vars-names frees)])
(values name Constant))
null))
;; Listof[frees] -> frees
(define (combine-frees freess)
(define-values (hash computed)
(for/fold ((hash (hasheq)) (computed null))
((frees freess))
(for/fold ([hash (hasheq)]
[computed null])
([frees (in-list freess)])
(match frees
((combined-frees new-hash new-computed)
(values (combine-hashes (list hash new-hash))
(append new-computed computed))))))
[(combined-frees new-hash new-computed)
(values (combine-hashes (list hash new-hash))
(append new-computed computed))])))
(combined-frees hash computed))
(define (free-vars-remove frees name)
(match frees
((combined-frees hash computed)
(combined-frees (hash-remove hash name)
(map (λ (v) (remove-frees v name)) computed)))))
[(combined-frees hash computed)
(combined-frees (hash-remove hash name)
(map (λ (v) (remove-frees v name)) computed))]))
;;
(define (free-vars-names vars)
(match vars
((combined-frees hash computed)
[(combined-frees hash computed)
(apply set-union
(list->seteq (hash-keys hash))
(map free-vars-names computed)))
((remove-frees inner name) (set-remove (free-vars-names inner) name))
((app-frees name args)
(apply set-union (map free-vars-names args)))))
(map free-vars-names computed))]
[(remove-frees inner name) (set-remove (free-vars-names inner) name)]
[(app-frees name args)
(apply set-union (map free-vars-names args))]))
(define (free-vars-has-key? vars key)
(set-member? (free-vars-names vars) key))
@ -133,18 +134,18 @@
;; Only valid after full type resolution
(define (free-vars-hash vars)
(match vars
((combined-frees hash computed)
(combine-hashes (cons hash (map free-vars-hash computed))))
((remove-frees inner name) (hash-remove (free-vars-hash inner) name))
((app-frees name args)
[(combined-frees hash computed)
(combine-hashes (cons hash (map free-vars-hash computed)))]
[(remove-frees inner name) (hash-remove (free-vars-hash inner) name)]
[(app-frees name args)
(combine-hashes
(for/list ((var (lookup-type-variance name)) (arg args))
(for/list ((var (lookup-type-variance name)) (arg args))
(free-vars-hash
(cond
((eq? var Covariant) arg)
((eq? var Contravariant) (flip-variances arg))
((eq? var Invariant) (make-invariant arg))
((eq? var Constant) (make-constant arg)))))))))
[(eq? var Covariant) arg]
[(eq? var Contravariant) (flip-variances arg)]
[(eq? var Invariant) (make-invariant arg)]
[(eq? var Constant) (make-constant arg)]))))]))
;; frees = HT[Idx,Variance] where Idx is either Symbol or Number

45
typed-racket-lib/typed-racket/rep/interning.rkt
View File

@ -1,45 +0,0 @@
#lang racket/base
(require syntax/id-table racket/dict (for-syntax racket/base syntax/parse))
(provide defintern hash-id)
(define-syntax (defintern stx)
(define-splicing-syntax-class extra-kw-spec
(pattern (~seq kw:keyword [name:id default:expr])
#:with formal #'(kw [name default])))
(define-splicing-syntax-class extra-spec
(pattern ek:extra-kw-spec
#:with e #'ek.name)
(pattern e:expr))
(syntax-parse stx
[(_ name+args make-name key #:extra-args e ...)
#'(defintern name+args (lambda () (make-hash)) make-name key #:extra-args e ...)]
[(_ (*name:id arg:id ...) make-ht make-name key-expr #:extra-args . (~and ((~seq es:extra-spec) ...) ((~or (~seq ek:extra-kw-spec) e:expr) ...)))
(with-syntax ([((extra-formals ...) ...) #'(ek.formal ...)])
#'(define *name
(let ([table (make-ht)])
(lambda (arg ... extra-formals ... ...)
(let ([key key-expr])
(hash-ref table key
(lambda ()
(let ([new (make-name (count!) es.e ... arg ...)])
(hash-set! table key new)
new))))))))]))
(define (make-count!)
(let ([state 0])
(lambda () (begin0 state (set! state (add1 state))))))
(define count! (make-count!))
(define id-count! (make-count!))
(define identifier-table (make-free-id-table))
(define (hash-id id)
(dict-ref
identifier-table
id
(lambda () (let ([c (id-count!)])
(dict-set! identifier-table id c)
c))))

46
typed-racket-lib/typed-racket/rep/object-rep.rkt
View File

@ -5,24 +5,38 @@
;;
;; See "Logical Types for Untyped Languages" pg.3
(require "rep-utils.rkt" "free-variance.rkt" "prop-rep.rkt" "../utils/utils.rkt" (contract-req))
(provide object-equal?)
(require "../utils/utils.rkt"
"rep-utils.rkt"
"core-rep.rkt"
"free-variance.rkt"
(env mvar-env)
(contract-req))
(def-pathelem CarPE () [#:fold-rhs #:base])
(def-pathelem CdrPE () [#:fold-rhs #:base])
(def-pathelem SyntaxPE () [#:fold-rhs #:base])
(def-pathelem ForcePE () [#:fold-rhs #:base])
(provide -id-path)
(def-pathelem CarPE () #:base)
(def-pathelem CdrPE () #:base)
(def-pathelem SyntaxPE () #:base)
(def-pathelem ForcePE () #:base)
;; t is always a Name (can't put that into the contract b/c of circularity)
(def-pathelem StructPE ([t Type?] [idx natural-number/c])
[#:frees (λ (f) (f t))]
[#:fold-rhs (*StructPE (type-rec-id t) idx)])
(def-pathelem FieldPE () [#:fold-rhs #:base])
[#:intern-key (cons (Rep-seq t) idx)]
[#:frees (f) (f t)]
[#:fold (f) (make-StructPE (f t) idx)]
[#:walk (f) (f t)])
(def-pathelem FieldPE () #:base)
(def-object Empty () [#:fold-rhs #:base])
(def-object Path ([elems (listof PathElem?)] [name name-ref/c])
[#:intern-key (cons (hash-name name) (map Rep-seq elems))]
[#:frees (f) (combine-frees (map f elems))]
[#:fold (f) (make-Path (map f elems) name)]
[#:walk (f) (for-each f elems)])
(def-object Path ([p (listof PathElem?)] [v name-ref/c])
[#:intern (list (map Rep-seq p) (hash-name v))]
[#:frees (λ (f) (combine-frees (map f p)))]
[#:fold-rhs (*Path (map pathelem-rec-id p) v)])
(define (object-equal? o1 o2) (= (Rep-seq o1) (Rep-seq o2)))
(define (-id-path id)
(cond
[(identifier? id)
(if (is-var-mutated? id)
(make-Empty)
(make-Path null id))]
[else
(make-Path null id)]))

129
typed-racket-lib/typed-racket/rep/prop-rep.rkt
View File

@ -1,56 +1,101 @@
#lang racket/base
(require "../utils/utils.rkt" "rep-utils.rkt" "free-variance.rkt")
(require "../utils/utils.rkt"
(contract-req)
"rep-utils.rkt"
"free-variance.rkt"
"core-rep.rkt"
"object-rep.rkt"
racket/match
racket/lazy-require)
(provide hash-name prop-equal?)
(lazy-require
["../types/prop-ops.rkt" (-and -or)])
(begin-for-cond-contract
(require racket/contract/base racket/lazy-require)
(lazy-require ["type-rep.rkt" (Type/c Univ? Bottom?)]
["object-rep.rkt" (Path?)]))
(provide-for-cond-contract name-ref/c)
(provide hash-name
-is-type
-not-type
AndProp?
AndProp:
AndProp-ps
OrProp?
OrProp:
OrProp-ps
(rename-out [make-OrProp* make-OrProp]
[make-AndProp* make-AndProp]))
;; A Name-Ref is any value that represents an object.
;; As an identifier, it represents a free variable in the environment
;; As a list, it represents a De Bruijn indexed bound variable
(define-for-cond-contract name-ref/c
(or/c identifier? (list/c integer? integer?)))
(define (hash-name v) (if (identifier? v) (hash-id v) (list v)))
(def-prop TypeProp ([obj Object?] [type (and/c Type? (not/c Univ?) (not/c Bottom?))])
[#:intern-key (cons (Rep-seq obj) (Rep-seq type))]
[#:frees (f) (combine-frees (list (f obj) (f type)))]
[#:fold (f) (-is-type (f obj) (f type))]
[#:walk (f) (begin (f obj) (f type))])
(define-for-cond-contract ((length>=/c len) l)
(and (list? l)
(>= (length l) len)))
;; Abbreviation for props
;; `i` can be an integer or name-ref/c for backwards compatibility
;; FIXME: Make all callers pass in an object and remove backwards compatibility
(define/cond-contract (-is-type i t)
(-> (or/c integer? name-ref/c OptObject?) Type? Prop?)
(define o
(cond
[(OptObject? i) i]
[(exact-integer? i) (make-Path null (cons 0 i))]
[(pair? i) (make-Path null i)]
[else (-id-path i)]))
(cond
[(Empty? o) (make-TrueProp)]
[(Univ? t) (make-TrueProp)]
[(Bottom? t) (make-FalseProp)]
[else (make-TypeProp o t)]))
;; the trivially "true" proposition
(def-prop TrueProp () [#:fold-rhs #:base])
;; the absurd, "false" proposition
(def-prop FalseProp () [#:fold-rhs #:base])
(def-prop NotTypeProp ([obj Object?] [type (and/c Type? (not/c Univ?) (not/c Bottom?))])
[#:intern-key (cons (Rep-seq obj) (Rep-seq type))]
[#:frees (f) (combine-frees (list (f obj) (f type)))]
[#:fold (f) (-not-type (f obj) (f type))]
[#:walk (f) (begin (f obj) (f type))])
(def-prop TypeProp ([p Path?] [t (and/c Type/c (not/c Univ?) (not/c Bottom?))])
[#:intern (list (Rep-seq t) (Rep-seq p))]
[#:frees (λ (f) (combine-frees (map f (list t p))))]
[#:fold-rhs (*TypeProp (object-rec-id p) (type-rec-id t))])
(def-prop NotTypeProp ([p Path?] [t (and/c Type/c (not/c Univ?) (not/c Bottom?))])
[#:intern (list (Rep-seq t) (Rep-seq p))]
[#:frees (λ (f) (combine-frees (map f (list t p))))]
[#:fold-rhs (*NotTypeProp (object-rec-id p) (type-rec-id t))])
;; Abbreviation for not props
;; `i` can be an integer or name-ref/c for backwards compatibility
;; FIXME: Make all callers pass in an object and remove backwards compatibility
(define/cond-contract (-not-type i t)
(-> (or/c integer? name-ref/c OptObject?) Type? Prop?)
(define o
(cond
[(OptObject? i) i]
[(exact-integer? i) (make-Path null (cons 0 i))]
[(pair? i) (make-Path null i)]
[else (-id-path i)]))
(cond
[(Empty? o) (make-TrueProp)]
[(Bottom? t) (make-TrueProp)]
[(Univ? t) (make-FalseProp)]
[else (make-NotTypeProp o t)]))
(def-prop OrProp ([fs (and/c (length>=/c 2)
(listof (or/c TypeProp? NotTypeProp?)))])
[#:intern (map Rep-seq fs)]
[#:fold-rhs (*OrProp (map prop-rec-id fs))]
[#:frees (λ (f) (combine-frees (map f fs)))])
(def-prop OrProp ([ps (and/c (length>=/c 2)
(listof (or/c TypeProp? NotTypeProp?)))])
#:no-provide
[#:intern-key (for/hash ([p (in-list ps)]) (values p #t))]
[#:frees (f) (combine-frees (map f ps))]
[#:fold (f) (apply -or (map f ps))]
[#:walk (f) (for-each f ps)])
(def-prop AndProp ([fs (and/c (length>=/c 2)
(listof (or/c OrProp? TypeProp? NotTypeProp?)))])
[#:intern (map Rep-seq fs)]
[#:fold-rhs (*AndProp (map prop-rec-id fs))]
[#:frees (λ (f) (combine-frees (map f fs)))])
(define (make-OrProp* ps)
(match ps
[(list) (make-FalseProp)]
[(list p) p]
[ps (make-OrProp ps)]))
(def-prop PropSet ([thn Prop?] [els Prop?])
[#:fold-rhs (*PropSet (prop-rec-id thn) (prop-rec-id els))])
(def-prop AndProp ([ps (and/c (length>=/c 2)
(listof (or/c OrProp? TypeProp? NotTypeProp?)))])
#:no-provide
[#:intern-key (for/hash ([p (in-list ps)]) (values p #t))]
[#:frees (f) (combine-frees (map f ps))]
[#:fold (f) (apply -and (map f ps))]
[#:walk (f) (for-each f ps)])
(define (prop-equal? a b) (= (Rep-seq a) (Rep-seq b)))
(define (make-AndProp* ps)
(match ps
[(list) (make-TrueProp)]
[(list p) p]
[ps (make-AndProp ps)]))

792
typed-racket-lib/typed-racket/rep/rep-utils.rkt
View File

@ -1,393 +1,473 @@
#lang racket/base
(require "../utils/utils.rkt"
"../utils/print-struct.rkt"
racket/match
racket/generic
(contract-req)
"free-variance.rkt"
"interning.rkt"
racket/lazy-require
"type-mask.rkt"
racket/stxparam
syntax/parse/define
syntax/id-table
racket/unsafe/ops
(for-syntax
racket/match
racket/list
racket/sequence
(except-in syntax/parse id identifier keyword)
racket/base
syntax/struct
syntax/id-table
(contract-req)
racket/syntax
(rename-in (except-in (utils stxclass-util) bytes byte-regexp regexp byte-pregexp pregexp)
[id* id]
[keyword* keyword])))
racket/syntax))
(lazy-require
["../types/printer.rkt" (print-type print-prop print-object print-pathelem)])
(provide (all-defined-out)
(for-syntax var-name))
(provide-for-cond-contract length>=/c)
(provide == defintern hash-id (for-syntax fold-target))
(define-for-cond-contract ((length>=/c len) l)
(and (list? l)
(>= (length l) len)))
;; seq: interning-generated count that is used to compare types (type<).
;; seq: interning-generated serial number used to compare Reps (type<).
;; free-vars: cached free type variables
;; free-idxs: cached free dot sequence variables
;; stx: originating syntax for error-reporting
(define-struct Rep (seq free-vars free-idxs stx) #:transparent
#:methods gen:equal+hash
[(define (equal-proc x y recur)
(eq? (Rep-seq x) (Rep-seq y)))
(define (hash-proc x recur) (Rep-seq x))
(define (hash2-proc x recur) (Rep-seq x))])
(struct Rep (seq free-vars free-idxs) #:transparent
#:methods gen:equal+hash
[(define (equal-proc x y recur)
(unsafe-fx= (Rep-seq x) (Rep-seq y)))
(define (hash-proc x recur) (Rep-seq x))
(define (hash2-proc x recur) (Rep-seq x))])
;; evil tricks for hygienic yet unhygienic-looking reference
;; in say def-type for type-ref-id
(define-for-syntax fold-target #'fold-target)
(define-for-syntax default-fields (list #'seq #'free-vars #'free-idxs #'stx))
(define (Rep<? x y)
(unsafe-fx< (Rep-seq x) (Rep-seq y)))
;; parent is for struct inheritance.
;; ht-stx is the identifier of the intern-table
;; key? is #f iff the kind generated should not be interned.
(define-for-syntax (mk parent ht-stx key? the-rec-id)
(define-syntax-class opt-contract-id
#:attributes (i contract)
(pattern i:id
#:with contract #'any/c)
(pattern [i:id contract]))
;; unhygienic struct function generation
(define-syntax-class (idlist name)
#:attributes ((i 1) (contract 1) fields maker pred (accessor 1))
(pattern (oci:opt-contract-id ...)
#:with (i ...) #'(oci.i ...)
#:with (contract ...) #'(oci.contract ...)
#:with fields #'(i ...)
#:with (_ maker pred accessor ...) (build-struct-names name (syntax->list #'fields) #f #t name)))
;; prop:get-values
(define-values (prop:Rep-name Rep-name)
(let-values ([(prop _ accessor) (make-struct-type-property 'named)])
(values prop accessor)))
;; applies f to all fields and combines the results.
;; (construction prevents duplicates)
(define (combiner f flds)
(syntax-parse flds
[() #'empty-free-vars]
[(e) #`(#,f e)]
[(e ...) #`(combine-frees (list (#,f e) ...))]))
(define-splicing-syntax-class frees-pat
#:transparent
#:attributes (f1 f2)
(pattern (~seq f1:expr f2:expr))
;; [#:frees #f] pattern in e.g. def-type means no free vars or idxs.
(pattern #f
#:with f1 #'empty-free-vars
#:with f2 #'empty-free-vars)
;; [#:frees (λ (f) ...)] should combine free variables or idxs accordingly
;; (given the respective accessor functions)
(pattern e:expr
#:with f1 #'(e Rep-free-vars)
#:with f2 #'(e Rep-free-idxs)))
;; prop:get-values
(define-values (prop:values-fun values-fun)
(let-values ([(prop _ accessor) (make-struct-type-property 'values)])
(values prop accessor)))
;; fold-pat takes fold-name (e.g. App-fold) and produces the
;; pattern for the match as
(define-syntax-class (fold-pat fold-name)
#:transparent
#:attributes (proc)
(pattern #:base
#:with proc #`(procedure-rename
(lambda () #,fold-target)
'#,fold-name))
(pattern match-expander:expr
#:with proc #`(procedure-rename
;; double quote expander. First unquote below
;; Second unquote at expansion.
(lambda () #'match-expander)
'#,fold-name)))
;; Rep-values
(define (Rep-values x)
((values-fun x) x))
(define-syntax-class form-name
;; prop:get-constructor
(define-values (prop:constructor-fun Rep-constructor)
(let-values ([(prop _ accessor) (make-struct-type-property 'constructor)])
(values prop accessor)))
;; structural type info for simple/straightforward types
;; (i.e. we store the list of field variances)
(define-values (prop:structural structural? Type-variances)
(make-struct-type-property 'structural))
;; top type predicates
(define-values (prop:top-type has-top-type? top-type-pred)
(make-struct-type-property 'top-type))
;; prop:walk-fun
(define-values (prop:walk-fun walkable? walk-fun)
(make-struct-type-property 'walk))
;; Rep-walk
(define (Rep-walk f x)
(define fun (walk-fun x))
(when (procedure? fun)
(fun f x)))
;; prop:fold-fun
(define-values (prop:fold-fun foldable? fold-fun)
(make-struct-type-property 'fold))
;; Rep-fold
(define (Rep-fold f x)
(define fun (fold-fun x))
(if (procedure? fun)
(fun f x)
x))
;; Is this a type that can be a 'back-edge' into the type graph?
;; (i.e. could blindly following this type lead to infinite recursion?)
(define-values (prop:resolvable resolvable?)
(let-values ([(prop predicate _) (make-struct-type-property 'resolvable)])
(values prop predicate)))
;;************************************************************
;; Rep Declaration Syntax Classes
;;************************************************************
(define (make-counter!)
(let ([state 0])
(λ () (begin0 state (set! state (unsafe-fx+ 1 state))))))
(define count! (make-counter!))
(define id-count! (make-counter!))
(define identifier-table (make-free-id-table))
(define (hash-id id)
(free-id-table-ref!
identifier-table
id
(λ () (let ([c (id-count!)])
(free-id-table-set! identifier-table id c)
c))))
(define (hash-name name)
(if (identifier? name)
(hash-id name)
name))
(begin-for-syntax
;; #:frees definition parsing
(define-syntax-class freesspec
#:attributes (free-vars free-idxs)
(pattern ([#:vars (f1) . vars-body]
[#:idxs (f2) . idxs-body])
#:with free-vars #'(let ([f1 Rep-free-vars]) . vars-body)
#:with free-idxs #'(let ([f2 Rep-free-idxs]) . idxs-body))
(pattern ((f:id) . body)
#:with free-vars #'(let ([f Rep-free-vars]) . body)
#:with free-idxs #'(let ([f Rep-free-idxs]) . body)))
;; #:fold definition parsing
(define-syntax-class (walkspec name match-expdr struct-fields)
#:attributes (def)
(pattern ((f:id) . body)
#:with def
(with-syntax ([name name]
[(flds ...) struct-fields]
[mexpdr match-expdr])
#'(λ (f self)
(match self
[(mexpdr flds ...) . body]
[_ (error 'Rep-walk "bad match in ~a's walk" (quote name))])))))
;; #:map definition parsing
(define-syntax-class (foldspec name match-expdr struct-fields)
#:attributes (def)
(pattern ((f:id (~optional (~seq #:self self:id)
#:defaults ([self (generate-temporary 'self)])))
. body)
#:with def
(with-syntax ([name name]
[(flds ...) struct-fields]
[mexpdr match-expdr])
#'(λ (f self)
(match self
[(mexpdr flds ...) . body]
[_ (error 'Rep-fold "bad match in ~a's fold" (quote name))])))))
;; variant name parsing
(define-syntax-class var-name
#:attributes (name raw-constructor constructor mexpdr pred)
(pattern name:id
;; Type -> Type:
#:with match-expander (format-id #'name "~a:" #'name)
;; Type -> Type-fold
#:with fold (format-id #f "~a-fold" #'name)
;; symbol made keyword of given type's name (e.g. Type -> #:Type)
#:with kw (string->keyword (symbol->string (syntax-e #'name)))
;; Type -> *Type
#:with *maker (format-id #'name "*~a" #'name)))
#:with raw-constructor
;; raw constructor should only be used by macros (hence the gensym)
(format-id #'name "raw-make-~a" (gensym (syntax-e #'name)))
#:with constructor
(format-id #'name "make-~a" (syntax-e #'name))
#:with mexpdr
(format-id #'name "~a:" (syntax-e #'name))
#:with pred
(format-id #'name "~a?" (syntax-e #'name))))
;; structure accessor parsing
(define-syntax-class (fld-id struct-name)
#:attributes (name accessors)
(pattern name:id
#:with accessors
(format-id #'name "~a-~a" (syntax-e struct-name) (syntax-e #'name))))
;; struct field name parsing
(define-syntax-class (var-fields name)
#:attributes ((ids 1)
(contracts 1)
(accessors 1))
(pattern ([(~var ids (fld-id name))
contracts:expr] ...)
#:with (accessors ...) #'(ids.accessors ...))))
(define (key->list key? v) (if key? (list v) (list)))
(lambda (stx)
(syntax-parse stx
[(dform name:form-name ;; e.g. Function
;; field/contract pairs e.g. ([rator Type/c] [rand Type/c])
(~var flds (idlist #'name))
(~or
(~optional (~and (~fail #:unless key? "#:key not allowed")
;; expression evaluates to intern key.
;; e.g. (list rator rand)
[#:key key-expr:expr])
#:defaults ([key-expr #'#f]))
;; intern? is explicitly given when other fields of the type
;; shouldn't matter. (e.g. Opaque)
;; or need further processing (e.g. fld)
(~optional [#:intern intern?:expr]
#:defaults
([intern? (syntax-parse #'flds.fields
[() #'#f]
[(f) #'(if (Rep? f) (Rep-seq f) f)]
[(fields ...) #'(list (if (Rep? fields) (Rep-seq fields) fields) ...)])]))
;; expression that when given a "get free-variables"
;; function, combines the results in the expected fashion.
(~optional [#:frees frees:frees-pat]
#:defaults
([frees.f1 (combiner #'Rep-free-vars #'flds.fields)]
[frees.f2 (combiner #'Rep-free-idxs #'flds.fields)]))
;; This tricky beast is for defining the type/prop/etc.'s
;; part of the fold. The make-prim-type's given
;; rec-ids are bound in this expression's context.
(~optional [#:fold-rhs (~var fold-rhs (fold-pat #'name.fold))]
#:defaults ;; defaults to folding down all fields.
([fold-rhs.proc
;; This quote makes the inner quasiquote be
;; evaluated later (3rd element of the hashtable)
;; in mk-fold.
;; Thus only def-type'd entities will be properly
;; folded down.
#`(procedure-rename
(lambda ()
#'(name.*maker (#,the-rec-id flds.i) ...))
;; rename to fold name for better error messages
'name.fold)]))
;; how do we contract a value of this type?
(~optional [#:contract contract:expr]
;; defaults to folding down all fields.
#:defaults ([contract
#'(->* (flds.contract ...)
(#:syntax (or/c syntax? #f))
flds.pred)]))
(~optional (~and #:no-provide no-provide?))) ...)
(with-syntax
;; makes as many underscores as default fields (+1 for key? if provided)
([(ign-pats ...) (let loop ([fs default-fields])
(if (null? fs)
(key->list key? #'_)
(cons #'_ (loop (cdr fs)))))]
;; has to be down here to refer to #'contract
[provides (if (attribute no-provide?)
#'(begin)
#'(begin
(provide name.match-expander flds.pred flds.accessor ...)
(provide/cond-contract (rename name.*maker flds.maker contract))))])
#`(begin
;; struct "name" defined here.
(define-struct (name #,parent) flds.fields #:inspector #f)
(define-match-expander name.match-expander
(lambda (s)
(syntax-parse s
[(_ . fields)
;; skips past ignores and binds fields for struct "name"
#:with pat (syntax/loc s (ign-pats ... . fields))
;; This is the match (struct struct-id (pat ...)) form.
(syntax/loc s (struct name pat))])))
;; set the type's keyword in the hashtable to its
;; match expander, fields and fold-rhs's for further construction.
(begin-for-syntax
(hash-set! #,ht-stx
'name.kw
(list #'name.match-expander
#'flds.fields
;; first unquote for match-expander
fold-rhs.proc
#f)))
#,(quasisyntax/loc stx
(with-cond-contract name ([name.*maker contract])
#,(quasisyntax/loc #'name
(defintern (name.*maker . flds.fields)
flds.maker intern?
#:extra-args
frees.f1 frees.f2
#:syntax [orig-stx #f]
#,@(key->list key? #'key-expr)))))
provides))])))
;; rec-ids are identifiers that are of the folded type, so we recur on them.
;; kws is e.g. '(#:Type #:Prop #:Object #:PathElem)
(define-for-syntax (mk-fold hashtable rec-ids kws)
(lambda (stx)
(define new-hashtable (make-hasheq))
(define-syntax-class clause
(pattern
;; Given name, matcher.
(k:keyword #:matcher matcher pats ... e:expr)
#:attr kw (attribute k.datum)
#:attr val (list #'matcher
(syntax/loc this-syntax (pats ...))
(lambda () #'e)
this-syntax))
;; Match on a type (or prop etc) case with keyword k
;; pats are the unignored patterns (say for rator rand)
;; and e is the expression that will run as fold-rhs.
(pattern
(k:keyword pats ... e:expr)
#:attr kw (syntax-e #'k)
;; no given name. Use "keyword:"
#:attr val (list (format-id stx "~a:" (attribute kw))
(syntax/loc this-syntax (pats ...))
(lambda () #'e)
this-syntax)))
#|
e.g. #:App (list #'App: (list #'rator #'rand)
(lambda () #'(*App (type-rec-id rator)
(map type-rec-id rands)
stx))
<stx>)
|#
(define (gen-clause k v)
(match v
[(list match-expander pats body-f src)
;; makes [(Match-name all-patterns ...) body]
(define pat (quasisyntax/loc (or src stx)
(#,match-expander . #,pats)))
(quasisyntax/loc (or src stx) (#,pat
;; evaluate thunk containing rhs syntax
#,(body-f)))]))
(define (no-duplicates? lst)
(cond [(null? lst) #t]
[(member (car lst) (cdr lst)) #f]
[else (no-duplicates? (cdr lst))]))
;; Accept only keywords in the given list.
(define-syntax-class (keyword-in kws)
#:attributes (datum)
(pattern k:keyword
#:fail-unless (memq (attribute k.datum) kws) (format "expected keyword in ~a" kws)
#:attr datum (attribute k.datum)))
;; makes a keyword to expr hash table out of given keyword expr pairs.
(define-syntax-class (sized-list kws)
#:description (format "keyword expr pairs matching with keywords in the list ~a" kws)
(pattern ((~seq (~var k (keyword-in kws)) e:expr) ...)
#:when (no-duplicates? (attribute k.datum))
#:attr mapping (for/hash ([k* (attribute k.datum)]
[e* (attribute e)])
(values k* e*))))
(syntax-parse stx
[(tc (~var recs (sized-list kws)) ty clauses:clause ...)
;; map defined types' keywords to their given fold-rhs's.
;; we will then combine this with the default hash table to generate
;; the full match expression
(for ([k (attribute clauses.kw)]
[v (attribute clauses.val)])
(hash-set! new-hashtable k v))
;; bind given expressions for #:Type etc to local ids
(define rec-ids* (generate-temporaries rec-ids))
(with-syntax ([(let-clauses ...)
(for/list ([rec-id* rec-ids*]
[k kws])
;; Each rec-id binds to their corresponding given exprs
;; rec-ids and kws correspond pointwise.
#`[#,rec-id* #,(hash-ref (attribute recs.mapping) k
#'values)])]
[(parameterize-clauses ...)
(for/list ([rec-id rec-ids]
[rec-id* rec-ids*])
#`[#,rec-id (make-rename-transformer #'#,rec-id*)])]
[(match-clauses ...)
;; create all clauses we fold on, with keyword/body
(append
(hash-map new-hashtable gen-clause)
(hash-map hashtable gen-clause))]
[error-msg (quasisyntax/loc stx (error 'tc "no pattern for ~a" #,fold-target))])
#`(let (let-clauses ...
;; binds #'fold-target to the given element to fold down.
;; e.g. In a type-case, this is commonly "ty." Others perhaps "e".
[#,fold-target ty])
(syntax-parameterize (parameterize-clauses ...)
;; then generate the fold
#,(quasisyntax/loc stx
(match #,fold-target
match-clauses ...
[_ error-msg])))))])))
(define-syntax (make-prim-type stx)
(define-syntax-class type-name
#:attributes (name define-id key? (field-names 1) case printer hashtable rec-id kw pred? (accessors 1))
#:transparent
(pattern [name:id ;; e.g. Type
define-id:id ;; e.g. def-type
kw:keyword ;; e.g. #:Type
case:id ;; e.g. type-case
printer:id ;; e.g. print-type
hashtable:id ;; e.g. type-name-ht
rec-id:id ;; e.g. type-rec-id
(~optional (~and #:key ;; only given for Type.
(~bind [key? #'#t]
[(field-names 1) (list #'key)]))
#:defaults ([key? #'#f]
[(field-names 1) null]))]
#:with (_ _ pred? accessors ...)
(build-struct-names #'name (syntax->list #'(field-names ...)) #f #t #'name)))
;;************************************************************
;; def-rep
;;************************************************************
;;
;; Declaration macro for Rep structures
(define-syntax (def-rep stx)
(syntax-parse stx
[(_ i:type-name ...)
#'(begin
(provide i.define-id ...
i.name ...
i.pred? ...
i.rec-id ...
i.accessors ... ... ;; several accessors per type.
(for-syntax i.hashtable ... ))
;; make type name and populate hashtable with
;; keyword to (list match-expander-stx fields fold-rhs.proc #f)
;; e.g. def-type type-name-ht #t
(define-syntax i.define-id
(mk #'i.name #'i.hashtable i.key? #'i.rec-id)) ...
(define-for-syntax i.hashtable (make-hasheq)) ...
(define-struct/printer (i.name Rep) (i.field-names ...) i.printer) ...
(define-syntax-parameter i.rec-id
(λ (stx)
(raise-syntax-error #f
(format "used outside ~a" 'i.define-id)
stx))) ...
(provide i.case ...)
(define-syntaxes (i.case ...) ;; each fold case gets its own macro.
(let ([rec-ids (list #'i.rec-id ...)])
(apply values
(map (lambda (ht) ;; each type has a hashtable. For each type...
;; make its fold function using populated hashtable.
;; [unsyntax (*1)]
(mk-fold ht
rec-ids
;; '(#:Type #:Prop #:Object #:PathElem)
'(i.kw ...)))
(list i.hashtable ...))))))]))
[(_
;; variant name
var:var-name
;; fields and field contracts
(~var flds (var-fields #'var.name))
;; options
(~or
;; parent struct (if any)
(~optional (~optional [#:parent parent:id])
#:defaults ([parent #'Rep]))
;; base declaration (i.e. no fold/map)
(~optional (~and #:base base?))
;; All Reps are interned
(~optional [#:intern-key provided-intern-key])
;; #:frees spec (how to compute this Rep's free type variables)
(~optional [#:frees . frees-spec:freesspec])
;; #:walk spec (how to traverse this structure for effect)
(~optional [#:walk . (~var walk-spec (walkspec #'var.name
#'var.mexpdr
#'(flds.ids ...)))])
;; #:fold spec (how to transform & fold this structure)
(~optional [#:fold . (~var fold-spec (foldspec #'var.name
#'var.mexpdr
#'(flds.ids ...)))])
(~optional [#:type-mask . type-mask-body])
;; is this a Type w/ a Top type? (e.g. Vector --> VectorTop)
(~optional [#:top top-pred:id])
;; #:no-provide option (i.e. don't provide anything automatically)
(~optional (~and #:needs-resolving needs-resolving?))
;; #:no-provide option (i.e. don't provide anything automatically)
(~optional (~and #:no-provide no-provide?))
;; field variances (e.g. covariant/contravariant/etc) declarations
(~optional (~and [#:variances variances ...] structural))
;; #:extras to specify other struct properties in a per-definition manner
(~optional [#:extras . extras]))
...)
(make-prim-type [Type def-type #:Type type-case print-type type-name-ht type-rec-id #:key]
[Prop def-prop #:Prop prop-case print-prop prop-name-ht prop-rec-id]
[Object def-object #:Object object-case print-object object-name-ht object-rec-id]
[PathElem def-pathelem #:PathElem pathelem-case print-pathelem pathelem-name-ht pathelem-rec-id])
;; - - - - - - - - - - - - - - -
;; Error checking
;; - - - - - - - - - - - - - - -
;; build convenient boolean flags
(define is-a-type? (eq? 'Type (syntax-e #'parent)))
(define intern-key (if (attribute provided-intern-key)
#'provided-intern-key
#'#t))
;; intern-key is required (when the number of fields is > 0)
(when (and (not (attribute provided-intern-key))
(> (length (syntax->list #'flds)) 0))
(raise-syntax-error 'def-rep "intern key specification required when the number of fields > 0"
#'var))
;; no frees, walk, or fold for #:base Reps
(when (and (attribute base?) (or (attribute frees-spec)
(attribute walk-spec)
(attribute fold-spec)))
(raise-syntax-error 'def-rep "base reps cannot have #:frees, #:walk, or #:fold"
#'var))
;; if non-base, frees, walk, and fold are required
(when (and (not (attribute base?))
(or (not (attribute frees-spec))
(not (attribute walk-spec))
(not (attribute fold-spec))))
(raise-syntax-error 'def-rep "non-base reps require #:frees, #:walk, and #:fold"
#'var))
;; can't be structural and not a type
(when (and (not is-a-type?) (attribute structural))
(raise-syntax-error 'def-rep "only types can be structural" #'structural))
(define (Rep-values rep)
(match rep
[(? (lambda (e) (or (Prop? e)
(Object? e)
(PathElem? e)))
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq fv fi stx vals)))
vals]
[(? Type?
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq fv fi stx key vals)))
vals]))
;; - - - - - - - - - - - - - - -
;; Let's build the definitions!
;; - - - - - - - - - - - - - - -
(with-syntax*
([intern-key intern-key]
;; contract for constructor
[constructor-contract #'(-> flds.contracts ... var.pred)]
;; match expander (skips 'meta' fields)
[mexpdr-def
#`(define-match-expander var.mexpdr
(λ (s)
(syntax-parse s
[(_ . pats)
#,(if is-a-type? ;; skip Type-mask and subtype cache
#'(syntax/loc s (var.name _ _ _ _ _ . pats))
#'(syntax/loc s (var.name _ _ _ . pats)))])))]
;; free var/idx defs
[free-vars-def (cond
[(attribute base?) #'empty-free-vars]
[else #'frees-spec.free-vars])]
[free-idxs-def (cond
[(attribute base?) #'empty-free-vars]
[else #'frees-spec.free-idxs])]
;; top type info
[(maybe-top-type-spec ...)
(if (attribute top-pred)
#'(#:property prop:top-type top-pred)
#'())]
;; if it's a structural type, save its field variances
[(maybe-structural ...)
(if (attribute structural)
#'(#:property prop:structural (list variances ...))
#'())]
;; an argument if we accept a type mask
[mask-arg (generate-temporary 'mask)]
;; constructor w/ interning and Type-mask handeling if necessary
[constructor-def
(cond
;; non-Types don't need masks
[(not is-a-type?)
#'(define var.constructor
(let ([intern-table (make-hash)])
(λ (flds.ids ...)
(let ([key intern-key]
[fail (λ () (let ([fvs free-vars-def]
[fis free-idxs-def])
(var.raw-constructor (count!) fvs fis flds.ids ...)))])
(hash-ref! intern-table key fail)))))]
[else
;; Types have to provide Type-masks and subtype caches
#`(define var.constructor
(let ([intern-table (make-hash)])
(λ (flds.ids ...)
(let ([key intern-key]
[fail (λ () (let ([fvs free-vars-def]
[fis free-idxs-def]
[mask-val #,(if (attribute type-mask-body)
#'(let () . type-mask-body)
#'mask:unknown)])
(var.raw-constructor (count!) fvs fis (make-hash) mask-val flds.ids ...)))])
(hash-ref! intern-table key fail)))))])]
;; walk def
[walk-def (cond
[(attribute base?) #'#f]
[else #'walk-spec.def])]
;; fold def
[fold-def (cond
[(attribute base?) #'#f]
[else #'fold-spec.def])]
;; is this a type that needs resolving (e.g. Mu)
[(maybe-needs-resolving ...)
(if (attribute needs-resolving?)
#'(#:property prop:resolvable #t)
#'())]
;; how do we pull out the values required to fold this Rep?
[values-def #'(match-lambda
[(var.mexpdr flds.ids ...) (list flds.ids ...)])]
;; module provided defintions, if any
[(provides ...)
(cond
[(attribute no-provide?) #'()]
[else
#'((provide var.mexpdr var.pred flds.accessors ...)
(provide/cond-contract (var.constructor constructor-contract)))])]
[(extra-defs ...) (if (attribute extras) #'extras #'())])
;; - - - - - - - - - - - - - - -
;; macro output
;; - - - - - - - - - - - - - - -
#'(begin
(struct var.name parent (flds.ids ...) #:transparent
#:constructor-name
var.raw-constructor
#:property prop:Rep-name (quote var.name)
#:property prop:constructor-fun
(λ (flds.ids ...) (var.constructor flds.ids ...))
#:property prop:values-fun
values-def
#:property prop:walk-fun
walk-def
#:property prop:fold-fun
fold-def
maybe-top-type-spec ...
maybe-structural ...
maybe-needs-resolving ...
extra-defs ...)
constructor-def
mexpdr-def
provides ...))]))
;; macro for easily defining sets of types represented by fixnum bitfields
(define-syntax (define-type-bitfield stx)
(define-syntax-class atoms-spec
(pattern [abbrev:id
name:id
contract:expr
predicate:expr]
#:with bits (format-id #'name "bits:~a" (syntax-e #'name))
#:with provide #'(provide bits)))
(define-syntax-class union-spec
(pattern [abbrev:id
name:id
contract:expr
predicate:expr
(elements:id ...)
(~optional (~and #:no-provide no-provide?))]
#:with bits (format-id #'name "bits:~a" (syntax-e #'name))
#:with provide #'(provide bits)))
(syntax-parse stx
[(_ #:atom-count atomic-type-count:id
#:atomic-type-vector atomic-type-vector:id
#:atomic-name-vector atomic-name-vector:id
#:name-hash name-hash:id
#:atomic-contract-vector atomic-contract-vector:id
#:contract-hash contract-hash:id
#:atomic-predicate-vector atomic-predicate-vector:id
#:predicate-hash predicate-hash:id
#:constructor-template (mk-bits:id) mk-expr:expr
#:atoms
atoms:atoms-spec ...
#:unions
unions:union-spec ...)
(define max-base-atomic-count 31) ;; this way we can do unsafe fx ops on any machine
(define atom-list (syntax->datum #'(atoms.name ...)))
(define atom-count (length atom-list))
(unless (<= atom-count max-base-atomic-count)
(raise-syntax-error
'define-type-bitfield
(format "too many atomic base types (~a is the max)"
max-base-atomic-count)
stx))
(with-syntax ([(n ... ) (range atom-count)]
[(2^n ...)
(build-list atom-count (λ (n) (arithmetic-shift 1 n)))])
#`(begin
;; how many atomic types?
(define atomic-type-count #,atom-count)
;; define the atomic types' bit identifiers (e.g. bits:Null)
(begin (define atoms.bits 2^n) ...)
;; define the union types' bit identifiers
(begin (define unions.bits
(bitwise-ior unions.elements ...))
...)
;; define the actual type references (e.g. -Null)
(begin (define/decl atoms.abbrev
(let ([mk-bits atoms.bits]) mk-expr)) ...)
(begin (define/decl unions.abbrev
(let ([mk-bits unions.bits]) mk-expr)) ...)
;; define the various vectors and hashes
(define atomic-type-vector
(vector-immutable atoms.abbrev ...))
(define atomic-name-vector
(vector-immutable (quote atoms.name) ...))
(define name-hash
(make-immutable-hasheqv
(list (cons atoms.bits (quote atoms.name)) ...
(cons unions.bits (quote unions.name)) ...)))
(define atomic-contract-vector
(vector-immutable atoms.contract ...))
(define contract-hash
(make-immutable-hasheqv
(list
(cons atoms.bits atoms.contract)
...
(cons unions.bits unions.contract)
...)))
(define atomic-predicate-vector
(vector-immutable atoms.predicate ...))
(define predicate-hash
(make-immutable-hasheqv
(list
(cons atoms.bits atoms.predicate) ...
(cons unions.bits unions.predicate) ...)))
;; provide the bit variables (e.g. bits:Null)
atoms.provide ...
unions.provide ...))]))
;; Rep equality and inequality
(define (rep-equal? s t)
(eq? (Rep-seq s) (Rep-seq t)))
(define (rep<? s t)
(< (Rep-seq s) (Rep-seq t)))
(provide
Rep-values
(rename-out [Rep-seq Type-seq]
[Rep-free-vars free-vars*]
(rename-out [Rep-free-vars free-vars*]
[Rep-free-idxs free-idxs*]))
(provide/cond-contract
[rename rep-equal? type-equal? (Type? Type? . -> . boolean?)]
[rename rep<? type<? (Type? Type? . -> . boolean?)]
[rename rep<? prop<? (Prop? Prop? . -> . boolean?)]
[struct Rep ([seq exact-nonnegative-integer?]
[free-vars (hash/c symbol? variance?)]
[free-idxs (hash/c symbol? variance?)]
[stx (or/c #f syntax?)])])

156
typed-racket-lib/typed-racket/rep/type-mask.rkt Normal file
View File

@ -0,0 +1,156 @@
#lang racket/base
;;************************************************************
;; Type Masks
;;
;; - - Purpose - -
;;
;; Type masks allow us to identify disjoint base types and unions of
;; base types. This allows us to short-circuit certain subtype and
;; overlap checks.
;;
;; - - Details - -
;;
;; Type masks are represented with a simple 31-bit fixnum.
;;
;; If a bit flag in a Type's bitmask is set to 1, it means the Type
;; _may_ overlap with the values described by that bit flag.
;;
;; If a bit flag in a Type's bitmask is set to 0, it means the Type
;; _cannot_ overlap with values described by that bit flag.
;;************************************************************
(require (for-syntax racket/base syntax/parse)
racket/unsafe/ops
racket/fixnum)
(provide type-mask?
mask-union
mask-intersect
disjoint-masks?
sub-mask?
mask:bottom
mask:unknown)
(define-syntax OR (make-rename-transformer #'unsafe-fxior))
(define-syntax AND (make-rename-transformer #'unsafe-fxand))
(define-syntax NOT (make-rename-transformer #'unsafe-fxnot))
(define-syntax EQUALS? (make-rename-transformer #'unsafe-fx=))
(define-syntax mask-union (make-rename-transformer #'unsafe-fxior))
(define-syntax mask-intersect (make-rename-transformer #'unsafe-fxand))
;; debugging safe versions
;; (define-syntax OR (make-rename-transformer #'fxior))
;; (define-syntax AND (make-rename-transformer #'fxand))
;; (define-syntax NOT (make-rename-transformer #'fxnot))
;; (define-syntax EQUALS? (make-rename-transformer #'fx=))
;; (define-syntax mask-union (make-rename-transformer #'fxior))
;; (define-syntax mask-intersect (make-rename-transformer #'fxand))
;; type mask predicate
(define-syntax type-mask? (make-rename-transformer #'fixnum?))
;; define the max size of type masks
(module const racket/base
(provide max-mask-size)
(define max-mask-size 31))
(require 'const (for-syntax 'const))
;;************************************************************
;; Mask Operations
;;************************************************************
(define-syntax-rule (ZERO? n)
(EQUALS? 0 n))
;; disjoint-masks?
;; returns #t if the two masks could not
;; possibly have overlapping values
(define (disjoint-masks? m1 m2)
(ZERO? (mask-intersect m1 m2)))
;; sub-mask?
;; returns #t if it is possible that m1 ⊆ m2
;; (i.e. values represented by m1 are also
;; described by m2)
(define (sub-mask? m1 m2)
(ZERO? (AND m1 (NOT m2))))
;;************************************************************
;; Masks
;;************************************************************
;;---------------------
;; declare-type-flags
;;---------------------
;; macro for easily defining the type mask flags
(define-syntax (declare-type-flags stx)
(syntax-parse stx
[(_ name:id ...)
(define name-list (syntax->datum #'(name ...)))
(define count (length name-list))
(unless (<= count max-mask-size)
(raise-syntax-error 'declare-type-flags
(format "too many type flags (~a is the max)"
max-mask-size)
stx))
(with-syntax ([(n ...) (build-list count (λ (n) (arithmetic-shift 1 n)))])
#`(begin (begin (define name n)
(provide name))
...))]))
;;-------------------
;; Top/Bottom Masks
;;-------------------
;; bottom mask - no value inhabits this mask
(define mask:bottom 0)
;; unknown/top mask - this mask says the value may inhabit any type
(define mask:unknown
(sub1 (expt 2 max-mask-size)))
;;----------------------
;; Specific Type Flags
;;----------------------
;; Note: mask:other is for values which are
;; disjoint from all other specified values,
;; but which we are not specifically tracking
(declare-type-flags
;; a few common base types have their own masks
mask:null
mask:true
mask:false
mask:char
mask:symbol
mask:void
mask:string
;; the other base types use this catch-all
mask:base-other
mask:number
mask:pair
mask:mpair
mask:vector
mask:hash
mask:box
mask:channel
mask:thread-cell
mask:promise ;; huh? (structs can be promises)
mask:ephemeron
mask:future
mask:other-box
mask:set
mask:procedure
mask:prompt-tag
mask:continuation-mark-key
mask:struct
mask:prefab
mask:struct-type
mask:syntax
mask:class
mask:instance
mask:unit)

1332
typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

File diff suppressed because it is too large Load Diff

62
typed-racket-lib/typed-racket/rep/values-rep.rkt Normal file
View File

@ -0,0 +1,62 @@
#lang racket/base
(require "../utils/utils.rkt"
"rep-utils.rkt"
"free-variance.rkt"
"core-rep.rkt"
(contract-req)
racket/match
syntax/parse/define
racket/lazy-require)
(provide SomeValues?)
(provide-for-cond-contract Values/c)
;;**************************************************************
;; SomeValues (i.e. the things that can returned from functions)
;;**************************************************************
;;---------
;; Values
;;---------
(def-values Values ([results (listof Result?)])
[#:intern-key (map Rep-seq results)]
[#:frees (f) (combine-frees (map f results))]
[#:fold (f) (make-Values (map f results))]
[#:walk (f) (for-each f results)])
;; Anything that can be treated as a _simple_
;; Values by sufficient expansion
(define/provide (Values/c? x)
(or (Type? x) (Values? x) (Result? x)))
(define-for-cond-contract Values/c (flat-named-contract 'Values Values/c?))
;;------------
;; AnyValues
;;------------
;; A Type that corresponds to the any contract for the
;; return type of functions
(def-values AnyValues ([p Prop?])
[#:intern-key (Rep-seq p)]
[#:frees (f) (f p)]
[#:fold (f) (make-AnyValues (f p))]
[#:walk (f) (f p)])
;;-------------
;; ValuesDots
;;-------------
(def-values ValuesDots ([results (listof Result?)]
[dty Type?]
[dbound (or/c symbol? natural-number/c)])
[#:intern-key (list* (Rep-seq dty) dbound (map Rep-seq results))]
[#:frees (f) (combine-frees (map f results))]
[#:fold (f) (make-ValuesDots (map f results) (f dty) dbound)]
[#:walk (f) (begin (f dty)
(for-each f results))])

4
typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt
View File

@ -30,8 +30,8 @@
static-contract?
static-contract?
static-contract?)))]
[lookup-name-sc (-> Type/c symbol? (or/c #f static-contract?))]
[register-name-sc (-> Type/c
[lookup-name-sc (-> Type? symbol? (or/c #f static-contract?))]
[register-name-sc (-> Type?
(-> static-contract?)
(-> static-contract?)
(-> static-contract?)

14
typed-racket-lib/typed-racket/typecheck/check-below.rkt
View File

@ -9,12 +9,12 @@
(typecheck error-message))
(provide/cond-contract
[check-below (-->i ([s (-or/c Type/c full-tc-results/c)]
[t (s) (if (Type/c? s) Type/c tc-results/c)])
[_ (s) (if (Type/c? s) Type/c full-tc-results/c)])]
[cond-check-below (-->i ([s (-or/c Type/c full-tc-results/c)]
[t (s) (-or/c #f (if (Type/c? s) Type/c tc-results/c))])
[_ (s) (-or/c #f (if (Type/c? s) Type/c full-tc-results/c))])]
[check-below (-->i ([s (-or/c Type? full-tc-results/c)]
[t (s) (if (Type? s) Type? tc-results/c)])
[_ (s) (if (Type? s) Type? full-tc-results/c)])]
[cond-check-below (-->i ([s (-or/c Type? full-tc-results/c)]
[t (s) (-or/c #f (if (Type? s) Type? tc-results/c))])
[_ (s) (-or/c #f (if (Type? s) Type? full-tc-results/c))])]
[fix-results (--> tc-results/c full-tc-results/c)])
(provide type-mismatch)
@ -198,7 +198,7 @@
(value-mismatch expected tr1)
(fix-results expected)]
[((? Type/c? t1) (? Type/c? t2))
[((? Type? t1) (? Type? t2))
(unless (subtype t1 t2)
(expected-but-got t2 t1))
expected]

2
typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -16,7 +16,7 @@
(types utils abbrev union subtype resolve generalize)
(typecheck check-below internal-forms)
(utils tc-utils mutated-vars)
(rep object-rep type-rep)
(rep object-rep type-rep values-rep)
(for-syntax racket/base)
(for-template racket/base
(submod "internal-forms.rkt" forms)

9
typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
View File

@ -41,7 +41,8 @@
(define body-results #f)
;; syntax tc-result1 type -> tc-results
;; The result of applying the function to a single argument of the type of its first argument
;; The result of applying the function to a single argument of the type of its first argument.
;; Is used when checking forms like with-handlers, for example.
(define (get-range-result stx t prop-type)
(let loop ((t t))
(match t
@ -51,7 +52,7 @@
[(Function: (list _ ... (arr: '() _ (? values rest) #f (list (Keyword: _ _ #f) ...)) _ ...))
#:when (subtype prop-type rest)
(tc/funapp #'here #'(here) t (list (ret rest)) #f)]
[(? needs-resolving? t)
[(? resolvable? t)
(loop (resolve t))]
[(or (Poly: ns _) (PolyDots: (list ns ... _) _))
(loop (instantiate-poly t (map (λ (n) Univ) ns)))]
@ -72,7 +73,7 @@
(cond [;; make sure the predicate has an appropriate type
(subtype pred-type (-> Univ Univ))
(define fun-type
(if (needs-resolving? pred-type)
(if (resolvable? pred-type)
(resolve pred-type)
pred-type))
(match fun-type
@ -80,7 +81,7 @@
;; be worth being more precise here for some rare code.
[(PredicateProp: ps)
(match ps
[(PropSet: (TypeProp: (Path: '() '(0 0)) ft) _) ft]
[(PropSet: (TypeProp: (Path: '() (cons 0 0)) ft) _) ft]
[(FalseProp:) (Un)]
[_ Univ])]
[_ Univ])]

2
typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
View File

@ -74,7 +74,7 @@
(types utils abbrev union subtype resolve generalize signatures)
(typecheck check-below internal-forms)
(utils tc-utils)
(rep type-rep)
(rep type-rep values-rep)
(for-syntax racket/base racket/unit-exptime syntax/parse)
(for-template racket/base
racket/unsafe/undefined

14
typed-racket-lib/typed-racket/typecheck/error-message.rkt
View File

@ -11,15 +11,15 @@
(types utils subtype resolve)
(utils tc-utils)
(rep type-rep)
(only-in (types printer) pretty-format-type))
(only-in (types printer) pretty-format-rep))
(provide/cond-contract [expected-but-got
(--> (-or/c Type/c string?)
(-or/c Type/c string?)
(--> (-or/c Type? string?)
(-or/c Type? string?)
-any)]
[type-mismatch
(-->* ((-or/c Type/c Prop? string?)
(-or/c Type/c Prop? string?))
(-->* ((-or/c Type? Prop? PropSet? string?)
(-or/c Type? Prop? PropSet? string?))
((-or/c string? #f))
-any)])
@ -27,8 +27,8 @@
;; Type errors with "type mismatch", arguments may be types or other things
;; like the length of a list of types
(define (type-mismatch t1 t2 [more #f])
(define t1* (if (Type/c? t1) (pretty-format-type t1 #:indent 12) t1))
(define t2* (if (Type/c? t2) (pretty-format-type t2 #:indent 9) t2))
(define t1* (if (Type? t1) (pretty-format-rep t1 #:indent 12) t1))
(define t2* (if (Type? t2) (pretty-format-rep t2 #:indent 9) t2))
(tc-error/fields "type mismatch" #:more more "expected" t1* "given" t2* #:delayed? #t))
;; expected-but-got : (U Type String) (U Type String) -> Void

2
typed-racket-lib/typed-racket/typecheck/find-annotation.rkt
View File

@ -8,7 +8,7 @@
(require-for-cond-contract (rep type-rep))
(provide/cond-contract [find-annotation (syntax? identifier? . -> . (or/c #f Type/c))])
(provide/cond-contract [find-annotation (syntax? identifier? . -> . (or/c #f Type?))])
(define-syntax-class lv-clause
#:transparent

4
typed-racket-lib/typed-racket/typecheck/possible-domains.rkt
View File

@ -4,14 +4,14 @@
(contract-req)
racket/list
racket/match
(rep type-rep prop-rep)
(rep core-rep type-rep prop-rep values-rep)
(except-in (types abbrev subtype tc-result)
-> ->* one-of/c))
(provide possible-domains)
(provide/cond-contract
[cleanup-type ((Type/c) ((or/c #f Type/c) any/c) . ->* . Type/c)])
[cleanup-type ((Type?) ((or/c #f Type?) any/c) . ->* . Type?)])
;; to avoid long and confusing error messages, in the case of functions with
;; multiple similar domains (<, >, +, -, etc.), we show only the domains that

2
typed-racket-lib/typed-racket/typecheck/provide-handling.rkt
View File

@ -89,7 +89,7 @@
;; otherwise, not defined in this module, not our problem
[else (mk-ignored-quad internal-id)]))
;; mk-struct-syntax-quad : identifier? identifier? struct-info? Type/c -> quad/c
;; mk-struct-syntax-quad : identifier? identifier? struct-info? Type? -> quad/c
;; This handles `(provide s)` where `s` was defined with `(struct s ...)`.
(define (mk-struct-syntax-quad internal-id new-id si constr-type)
(define type-is-constructor? #t) ;Conservative estimate (provide/contract does the same)

12
typed-racket-lib/typed-racket/typecheck/signatures.rkt
View File

@ -9,10 +9,10 @@
([cond-contracted tc-expr (syntax? . -> . full-tc-results/c)]
[cond-contracted tc-expr/check (syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)]
[cond-contracted tc-expr/check? (syntax? (or/c tc-results/c #f) . -> . (or/c full-tc-results/c #f))]
[cond-contracted tc-expr/check/t (syntax? tc-results/c . -> . Type/c)]
[cond-contracted tc-expr/check/t? (syntax? (or/c tc-results/c #f) . -> . (or/c Type/c #f))]
[cond-contracted tc-expr/check/t (syntax? tc-results/c . -> . Type?)]
[cond-contracted tc-expr/check/t? (syntax? (or/c tc-results/c #f) . -> . (or/c Type? #f))]
[cond-contracted tc-body/check (syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)]
[cond-contracted tc-expr/t (syntax? . -> . Type/c)]
[cond-contracted tc-expr/t (syntax? . -> . Type?)]
[cond-contracted single-value ((syntax?) ((or/c tc-results/c #f)) . ->* . full-tc-results/c)]))
(define-signature check-subforms^
@ -32,7 +32,7 @@
([cond-contracted tc/if-twoarm ((syntax? syntax? syntax?) ((or/c tc-results/c #f)) . ->* . full-tc-results/c)]))
(define-signature tc-literal^
([cond-contracted tc-literal (->* (syntax?) ((or/c Type/c #f)) Type/c)]))
([cond-contracted tc-literal (->* (syntax?) ((or/c Type? #f)) Type?)]))
(define-signature tc-send^
([cond-contracted tc/send ((syntax? syntax?
@ -47,7 +47,7 @@
(define-signature tc-lambda^
([cond-contracted tc/lambda (syntax? syntax? syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)]
[cond-contracted tc/rec-lambda/check (syntax? syntax? syntax? (listof Type/c) tc-results/c . -> .
[cond-contracted tc/rec-lambda/check (syntax? syntax? syntax? (listof Type?) tc-results/c . -> .
(values full-tc-results/c full-tc-results/c))]))
(define-signature tc-app^
@ -62,5 +62,5 @@
[cond-contracted tc/letrec-values ((syntax? syntax? syntax?) ((or/c #f tc-results/c) (-> any)) . ->* . full-tc-results/c)]))
(define-signature tc-dots^
([cond-contracted tc/dots (syntax? . -> . (values Type/c symbol?))]))
([cond-contracted tc/dots (syntax? . -> . (values Type? symbol?))]))

15
typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -6,7 +6,7 @@
(contract-req)
(typecheck check-below tc-subst tc-metafunctions possible-domains)
(utils tc-utils)
(rep type-rep prop-rep)
(rep type-rep prop-rep values-rep)
(except-in (types utils abbrev subtype type-table)
-> ->* one-of/c))
(require-for-cond-contract
@ -24,7 +24,7 @@
;; we check that all kw args are optional
[((arr: dom rng rest #f (and kws (list (Keyword: _ _ #f) ...)))
(list (tc-result1: t-a phi-a o-a) ...))
(when check?
(cond [(and (not rest) (not (= (length dom) (length t-a))))
(tc-error/fields "could not apply function"
@ -93,9 +93,9 @@
;; Generates error messages when operand types don't match operator domains.
(provide/cond-contract
[domain-mismatches
((syntax? syntax? Type/c (listof (listof Type/c)) (listof (or/c #f Type/c))
(listof (or/c #f (cons/c Type/c (or/c natural-number/c symbol?))))
(listof SomeValues/c) (listof tc-results?) (or/c #f Type/c) any/c)
((syntax? syntax? Type? (listof (listof Type?)) (listof (or/c #f Type?))
(listof (or/c #f (cons/c Type? (or/c natural-number/c symbol?))))
(listof SomeValues?) (listof tc-results?) (or/c #f Type?) any/c)
(#:expected (or/c #f tc-results/c)
#:return tc-results?
#:msg-thunk (-> string? string?))
@ -170,7 +170,7 @@
;; mode, do the check here. Note that using restrictive mode
;; above results in poor error messages (see PR 14731).
(or (not expected)
(subtype (car rngs) (tc-results->values expected))))
(subval (car rngs) (tc-results->values expected))))
;; if we narrowed down the possible cases to a single one, have
;; tc/funapp1 generate a better error message
(tc/funapp1 f-stx args-stx
@ -199,7 +199,7 @@
(provide/cond-contract
[poly-fail ((syntax? syntax? Type/c (listof tc-results?))
[poly-fail ((syntax? syntax? Type? (listof tc-results?))
(#:name (or/c #f syntax?)
#:expected (or/c #f tc-results/c))
. ->* . tc-results/c)])
@ -260,3 +260,4 @@
(if name
(format "function `~a'" (syntax->datum name))
"function"))

4
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -6,7 +6,7 @@
"utils.rkt"
(types utils abbrev numeric-tower union resolve type-table generalize)
(typecheck signatures check-below)
(rep type-rep rep-utils)
(rep type-rep type-mask rep-utils)
(for-label racket/unsafe/ops racket/base))
(import tc-expr^ tc-app^ tc-literal^)
@ -128,7 +128,7 @@
;; it like any other expected type.
[(tc-result1: (app resolve (Union: ts))) (=> continue)
(define u-ts (for/list ([t (in-list ts)]
#:when (eq? 'vector (Type-key t)))
#:when (eq? mask:vector (Type-mask t)))
t))
(match u-ts
[(list t0) (tc/app #'(#%plain-app . form) (ret t0))]

2
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt
View File

@ -118,7 +118,7 @@
(if (null? new-arities)
(domain-mismatches
(car (syntax-e form)) (cdr (syntax-e form))
arities doms rests drests rngs
(make-Function arities) doms rests drests rngs
(stx-map tc-expr pos-args)
#f #f #:expected expected
#:msg-thunk

2
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt
View File

@ -7,7 +7,7 @@
syntax/parse/experimental/reflect
"../signatures.rkt" "../tc-funapp.rkt"
(types utils)
(rep type-rep prop-rep object-rep))
(rep type-rep prop-rep object-rep values-rep))
(import tc-expr^ tc-app-keywords^
tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^

6
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -66,7 +66,7 @@
[arg (in-syntax named-args)])
(list (syntax-e name) arg)))
(match (resolve (tc-expr/t cl))
[(Union: '()) (ret (Un))]
[(Bottom:) (ret -Bottom)]
[(and c (Class: _ inits fields _ _ init-rest))
(cond [;; too many positional arguments, fail
(and (> (length pos-args) (length inits)) (not init-rest))
@ -140,7 +140,7 @@
#:more "the object is missing an expected field"
"field" field-sym
"object type" ty)])]
[(Instance: (? needs-resolving? type))
[(Instance: (? resolvable? type))
(check (make-Instance (resolve type)))]
[type
(tc-error/expr/fields "type mismatch"
@ -176,7 +176,7 @@
#:more (~a "expected an object with field "
maybe-field-sym)
"given" ty)])]
[(Instance: (? needs-resolving? type))
[(Instance: (? resolvable? type))
(check (make-Instance (resolve type)))]
[type
(tc-error/expr/fields "type mismatch"

2
typed-racket-lib/typed-racket/typecheck/tc-apply.rkt
View File

@ -5,7 +5,7 @@
(typecheck signatures tc-app-helper)
(types utils abbrev substitute)
(utils tc-utils)
(rep type-rep)
(rep type-rep core-rep values-rep)
(r:infer infer))
(import tc-expr^ tc-lambda^ tc-let^ tc-app^)

71
typed-racket-lib/typed-racket/typecheck/tc-envops.rkt
View File

@ -6,8 +6,8 @@
(contract-req)
(rep type-rep prop-rep object-rep rep-utils)
(utils tc-utils)
(types tc-result resolve subtype remove update union prop-ops)
(env type-env-structs lexical-env)
(types tc-result resolve subtype update union prop-ops)
(env type-env-structs lexical-env mvar-env)
(rename-in (types abbrev)
[-> -->]
[->* -->*]
@ -18,22 +18,41 @@
;; Returns #f if anything becomes (U)
(define (env+ env ps)
(let/ec exit*
(define (exit) (exit* #f empty))
(define-values (props atoms) (combine-props ps (env-props env) exit))
(values
(for/fold ([Γ (replace-props env props)]) ([p (in-list atoms)])
(match p
[(or (TypeProp: (Path: lo x) pt) (NotTypeProp: (Path: lo x) pt))
(update-type/lexical
(lambda (x t)
(define new-t (update t pt (TypeProp? p) lo))
(when (type-equal? new-t -Bottom)
(exit))
new-t)
x Γ)]
[_ Γ]))
atoms)))
(define-values (props atoms) (combine-props ps (env-props env)))
(cond
[props
(let loop ([ps atoms]
[negs '()]
[Γ (replace-props env props)])
(match ps
[(cons p ps)
(match p
[(TypeProp: (Path: lo x) pt)
#:when (and (not (is-var-mutated? x))
(identifier-binding x))
(let* ([t (lookup-type/lexical x Γ #:fail (lambda _ Univ))]
[new-t (update t pt #t lo)])
(if (type-equal? new-t -Bottom)
(values #f '())
(loop ps negs (extend Γ x new-t))))]
;; process negative info _after_ positive info so we don't miss anything
[(NotTypeProp: (Path: _ x) _)
#:when (and (not (is-var-mutated? x))
(identifier-binding x))
(loop ps (cons p negs) Γ)]
[_ (loop ps negs Γ)])]
[_ (let ([Γ (let loop ([negs negs]
[Γ Γ])
(match negs
[(cons (NotTypeProp: (Path: lo x) pt) rst)
(let* ([t (lookup-type/lexical x Γ #:fail (lambda _ Univ))]
[new-t (update t pt #f lo)])
(if (type-equal? new-t -Bottom)
#f
(loop rst (extend Γ x new-t))))]
[_ Γ]))])
(values Γ atoms))]))]
[else (values #f '())]))
;; run code in an extended env and with replaced props. Requires the body to return a tc-results.
;; TODO make this only add the new prop instead of the entire environment once tc-id is fixed to
@ -46,10 +65,12 @@
(syntax-parse stx
[(_ ps:expr u:unreachable? . b)
#'(let-values ([(new-env atoms) (env+ (lexical-env) ps)])
(if new-env
(with-lexical-env new-env
(add-unconditional-prop (let () . b) (apply -and (append atoms (env-props new-env)))))
;; unreachable, bail out
(let ()
u.form
(ret -Bottom))))]))
(cond
[new-env
(with-lexical-env
new-env
(add-unconditional-prop (let () . b) (apply -and (append atoms (env-props new-env)))))]
[else
;; unreachable, bail out
u.form
(ret -Bottom)]))]))

30
typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -6,12 +6,12 @@
"signatures.rkt"
"check-below.rkt" "../types/kw-types.rkt"
(types utils abbrev union subtype type-table path-type
prop-ops overlap resolve generalize)
(private-in syntax-properties)
prop-ops overlap resolve generalize tc-result)
(private-in syntax-properties parse-type)
(rep type-rep prop-rep object-rep)
(only-in (infer infer) intersect)
(utils tc-utils)
(env lexical-env)
(env lexical-env scoped-tvar-env)
racket/list
racket/private/class-internal
syntax/parse
@ -51,8 +51,9 @@
[(Path: p x) (values p x)]
[(Empty:) (values (list) id*)]))
;; calculate the type, resolving aliasing and paths if necessary
(define ty (path-type alias-path (lookup-type/lexical alias-id)))
(define ty (or (path-type alias-path (lookup-type/lexical alias-id))
Univ))
(ret ty
(if (overlap? ty (-val #f))
(-PS (-not-type obj (-val #f)) (-is-type obj (-val #f)))
@ -72,7 +73,7 @@
;; typecheck an expression by passing tr-expr/check a tc-results
(define/cond-contract (tc-expr/check/type form expected)
(--> syntax? Type/c tc-results/c)
(--> syntax? Type? tc-results/c)
(tc-expr/check form (ret expected)))
(define (tc-expr/check form expected)
@ -80,10 +81,16 @@
;; the argument must be syntax
(unless (syntax? form)
(int-err "bad form input to tc-expr: ~a" form))
;; typecheck form
(define t (tc-expr/check/internal form expected))
(add-typeof-expr form t)
(cond-check-below t expected)))
(define result
;; if there is an annotation, use that expected type for internal checking
(syntax-parse form
[exp:type-ascription^
(add-scoped-tvars #'exp (parse-literal-alls (attribute exp.value)))
(tc-expr/check/internal #'exp (parse-tc-results (attribute exp.value)))]
[_ (reduce-tc-results/subsumption
(tc-expr/check/internal form expected))]))
(add-typeof-expr form result)
(cond-check-below result expected)))
;; typecheck and return a truth value indicating a typecheck failure (#f)
;; or success (any non-#f value)
@ -115,7 +122,6 @@
(define/cond-contract (tc-expr/check/internal form expected)
(--> syntax? (-or/c tc-results/c #f) full-tc-results/c)
(parameterize ([current-orig-stx form])
;(printf "form: ~a\n" (syntax-object->datum form))
;; the argument must be syntax
(unless (syntax? form)
(int-err "bad form input to tc-expr: ~a" form))
@ -361,7 +367,7 @@
;; true if execution reaches this point.
(loop (rest es)))]))]))
;; find-stx-type : Any [(or/c Type/c #f)] -> Type/c
;; find-stx-type : Any [(or/c Type? #f)] -> Type?
;; recursively find the type of either a syntax object or the result of syntax-e
(define (find-stx-type datum-stx [expected #f])
(match datum-stx

3
typed-racket-lib/typed-racket/typecheck/tc-expression.rkt
View File

@ -24,9 +24,6 @@
(do-inst (tc-expr #'e) (attribute exp.value))]
[(exp:row-inst^ e)
(do-inst (tc-expr #'e) (attribute exp.value) #t)]
[(exp:type-ascription^ e)
(add-scoped-tvars #'e (parse-literal-alls (attribute exp.value)))
(tc-expr/check #'e (parse-tc-results (attribute exp.value)))]
[(exp:ignore-some-expr^ e)
(register-ignored! #'e)
(check-subforms/ignore #'e)

287
typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
View File

@ -6,7 +6,7 @@
(env tvar-env)
(for-syntax syntax/parse racket/base)
(types utils subtype resolve abbrev
substitute classes)
substitute classes prop-ops)
(typecheck tc-metafunctions tc-app-helper)
(rep type-rep)
(r:infer infer))
@ -15,7 +15,7 @@
(provide/cond-contract
[tc/funapp
(syntax? stx-list? Type/c (c:listof tc-results1/c)
(syntax? stx-list? Type? (c:listof tc-results1/c)
(c:or/c #f tc-results/c)
. c:-> . full-tc-results/c)])
@ -35,143 +35,146 @@
#:expected expected))))]))
(define (tc/funapp f-stx args-stx f-type args-res expected)
(match-define (list (tc-result1: argtys) ...) args-res)
(match f-type
;; we special-case this (no case-lambda) for improved error messages
;; tc/funapp1 currently cannot handle drest arities
[(Function: (list (and a (arr: _ _ _ #f _))))
(tc/funapp1 f-stx args-stx a args-res expected)]
[(Function/arrs: doms rngs rests (and drests #f) kws #:arrs arrs)
(or
;; find the first function where the argument types match
(for/first ([dom (in-list doms)] [rng (in-list rngs)] [rest (in-list rests)] [a (in-list arrs)]
#:when (subtypes/varargs argtys dom rest))
;; then typecheck here
;; we call the separate function so that we get the appropriate
;; props/objects
(tc/funapp1 f-stx args-stx a args-res expected #:check #f))
;; if nothing matched, error
(domain-mismatches
f-stx args-stx f-type doms rests drests rngs args-res #f #f
#:expected expected
#:msg-thunk (lambda (dom)
(string-append
"No function domains matched in function application:\n"
dom))))]
;; any kind of dotted polymorphic function without mandatory keyword args
[(PolyDots: (list fixed-vars ... dotted-var)
(Function/arrs: doms rngs rests drests (list (Keyword: _ _ #f) ...) #:arrs arrs))
(handle-clauses
(doms rngs rests drests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
(lambda (dom _ rest drest a)
(cond [rest (<= (length dom) (length argtys))]
[drest (and (<= (length dom) (length argtys))
(eq? dotted-var (cdr drest)))]
[else (= (length dom) (length argtys))]))
;; Only try to infer the free vars of the rng (which includes the vars
;; in props/objects).
(λ (dom rng rest drest a)
(extend-tvars fixed-vars
(cond
[drest
(infer/dots
fixed-vars dotted-var argtys dom (car drest) rng (fv rng)
#:expected (and expected (tc-results->values expected)))]
[rest
(infer/vararg fixed-vars (list dotted-var) argtys dom rest rng
(and expected (tc-results->values expected)))]
;; no rest or drest
[else (infer fixed-vars (list dotted-var) argtys dom rng
(and expected (tc-results->values expected)))])))
f-type args-res expected)]
;; regular polymorphic functions without dotted rest,
;; we do not choose any instantiations with mandatory keyword arguments
[(Poly: vars (Function/arrs: doms rngs rests #f (list (Keyword: _ _ kw?) ...) #:arrs arrs))
(handle-clauses
(doms rngs rests kw? arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
;; and there's no mandatory kw
(λ (dom _ rest kw? a)
(and (andmap not kw?) ((if rest <= =) (length dom) (length argtys))))
;; Only try to infer the free vars of the rng (which includes the vars
;; in props/objects).
(λ (dom rng rest kw? a)
(extend-tvars vars
(infer/vararg vars null argtys dom rest rng
(and expected (tc-results->values expected)))))
f-type args-res expected)]
;; Row polymorphism. For now we do really dumb inference that only works
;; in very restricted cases, but is probably enough for most cases in
;; the Racket codebase. Eventually this should be extended.
[(PolyRow: vars constraints (and f-ty (Function/arrs: doms _ _ #f _)))
(define (fail)
(poly-fail f-stx args-stx f-type args-res
#:name (and (identifier? f-stx) f-stx)
#:expected expected))
;; there's only one row variable in a PolyRow (for now)
(define row-var (car vars))
;; only infer if there is only one argument type that has the relevant
;; row type variable in its free variables in all cases
(define row-var-idxs
(for/list ([dom doms])
(define num-occurs
(for/list ([dom-type dom] [idx (in-naturals)]
#:when (member row-var (fv dom-type)))
idx))
(unless (<= (length num-occurs) 1)
(fail))
(if (null? num-occurs) 0 (car num-occurs))))
(unless (or (< (length row-var-idxs) 2)
(apply = row-var-idxs))
;; row var wasn't in the same position in some cases
(fail))
(define idx (car row-var-idxs))
(define resolved-argty (resolve (list-ref argtys idx)))
(cond [(Class? resolved-argty)
(define substitution
(hash row-var
(t-subst (infer-row constraints resolved-argty))))
(tc/funapp f-stx args-stx (subst-all substitution f-ty)
args-res expected)]
[else (fail)])]
;; procedural structs
[(Struct: _ _ _ (? Function? proc-ty) _ _)
(tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) proc-ty
(cons (ret f-type) args-res) expected)]
;; parameters are functions too
[(Param: in out)
(match argtys
[(list) (ret out)]
[(list t)
(if (subtype t in)
(ret -Void -true-propset)
(tc-error/expr
#:return (ret -Void -true-propset)
"Wrong argument to parameter - expected ~a and got ~a"
in t))]
[_ (tc-error/expr
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtys))])]
[(Distinction: _ _ t)
(tc/funapp f-stx args-stx t args-res expected)]
;; resolve names, polymorphic apps, mu, etc
[(? needs-resolving?)
(tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)]
;; a union of functions can be applied if we can apply all of the elements
[(Union: (and ts (list (? Function?) ...)))
(merge-tc-results
(for/list ([fty ts])
(tc/funapp f-stx args-stx fty args-res expected)))]
;; error type is a perfectly good fcn type
[(Error:) (ret f-type)]
;; otherwise fail
[(Poly: ns (Function: arrs))
(tc-error/expr
(string-append "Cannot infer type instantiation for type ~a. Please add "
"more type annotations")
f-type)]
[_
(tc-error/expr
"Cannot apply expression of type ~a, since it is not a function type"
f-type)]))
(match-define (list (tc-result1: argtys (PropSet: argps+ argps-) _) ...) args-res)
(define result
(match f-type
;; we special-case this (no case-lambda) for improved error messages
;; tc/funapp1 currently cannot handle drest arities
[(Function: (list (and a (arr: _ _ _ #f _))))
(tc/funapp1 f-stx args-stx a args-res expected)]
[(Function/arrs: doms rngs rests (and drests #f) kws #:arrs arrs)
(or
;; find the first function where the argument types match
(for/first ([dom (in-list doms)] [rng (in-list rngs)] [rest (in-list rests)] [a (in-list arrs)]
#:when (subtypes/varargs argtys dom rest))
;; then typecheck here
;; we call the separate function so that we get the appropriate
;; props/objects
(tc/funapp1 f-stx args-stx a args-res expected #:check #f))
;; if nothing matched, error
(domain-mismatches
f-stx args-stx f-type doms rests drests rngs args-res #f #f
#:expected expected
#:msg-thunk (lambda (dom)
(string-append
"No function domains matched in function application:\n"
dom))))]
;; any kind of dotted polymorphic function without mandatory keyword args
[(PolyDots: (list fixed-vars ... dotted-var)
(Function/arrs: doms rngs rests drests (list (Keyword: _ _ #f) ...) #:arrs arrs))
(handle-clauses
(doms rngs rests drests arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
(lambda (dom _ rest drest a)
(cond [rest (<= (length dom) (length argtys))]
[drest (and (<= (length dom) (length argtys))
(eq? dotted-var (cdr drest)))]
[else (= (length dom) (length argtys))]))
;; Only try to infer the free vars of the rng (which includes the vars
;; in props/objects).
(λ (dom rng rest drest a)
(extend-tvars fixed-vars
(cond
[drest
(infer/dots
fixed-vars dotted-var argtys dom (car drest) rng (fv rng)
#:expected (and expected (tc-results->values expected)))]
[rest
(infer/vararg fixed-vars (list dotted-var) argtys dom rest rng
(and expected (tc-results->values expected)))]
;; no rest or drest
[else (infer fixed-vars (list dotted-var) argtys dom rng
(and expected (tc-results->values expected)))])))
f-type args-res expected)]
;; regular polymorphic functions without dotted rest,
;; we do not choose any instantiations with mandatory keyword arguments
[(Poly: vars (Function/arrs: doms rngs rests #f (list (Keyword: _ _ kw?) ...) #:arrs arrs))
(handle-clauses
(doms rngs rests kw? arrs) f-stx args-stx
;; only try inference if the argument lengths are appropriate
;; and there's no mandatory kw
(λ (dom _ rest kw? a)
(and (andmap not kw?) ((if rest <= =) (length dom) (length argtys))))
;; Only try to infer the free vars of the rng (which includes the vars
;; in props/objects).
(λ (dom rng rest kw? a)
(extend-tvars vars
(infer/vararg vars null argtys dom rest rng
(and expected (tc-results->values expected)))))
f-type args-res expected)]
;; Row polymorphism. For now we do really dumb inference that only works
;; in very restricted cases, but is probably enough for most cases in
;; the Racket codebase. Eventually this should be extended.
[(PolyRow: vars constraints (and f-ty (Function/arrs: doms _ _ #f _)))
(define (fail)
(poly-fail f-stx args-stx f-type args-res
#:name (and (identifier? f-stx) f-stx)
#:expected expected))
;; there's only one row variable in a PolyRow (for now)
(define row-var (car vars))
;; only infer if there is only one argument type that has the relevant
;; row type variable in its free variables in all cases
(define row-var-idxs
(for/list ([dom doms])
(define num-occurs
(for/list ([dom-type dom] [idx (in-naturals)]
#:when (member row-var (fv dom-type)))
idx))
(unless (<= (length num-occurs) 1)
(fail))
(if (null? num-occurs) 0 (car num-occurs))))
(unless (or (< (length row-var-idxs) 2)
(apply = row-var-idxs))
;; row var wasn't in the same position in some cases
(fail))
(define idx (car row-var-idxs))
(define resolved-argty (resolve (list-ref argtys idx)))
(cond [(Class? resolved-argty)
(define substitution
(hash row-var
(t-subst (infer-row constraints resolved-argty))))
(tc/funapp f-stx args-stx (subst-all substitution f-ty)
args-res expected)]
[else (fail)])]
;; procedural structs
[(Struct: _ _ _ (? Function? proc-ty) _ _)
(tc/funapp f-stx #`(#,(syntax/loc f-stx dummy) . #,args-stx) proc-ty
(cons (ret f-type) args-res) expected)]
;; parameters are functions too
[(Param: in out)
(match argtys
[(list) (ret out)]
[(list t)
(if (subtype t in)
(ret -Void -true-propset)
(tc-error/expr
#:return (ret -Void -true-propset)
"Wrong argument to parameter - expected ~a and got ~a"
in t))]
[_ (tc-error/expr
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
(length argtys))])]
[(Distinction: _ _ t)
(tc/funapp f-stx args-stx t args-res expected)]
;; resolve names, polymorphic apps, mu, etc
[(? resolvable?)
(tc/funapp f-stx args-stx (resolve-once f-type) args-res expected)]
;; a union of functions can be applied if we can apply all of the elements
[(Union: (and ts (list (? Function?) ...)))
(merge-tc-results
(for/list ([fty ts])
(tc/funapp f-stx args-stx fty args-res expected)))]
;; bottom or error type is a perfectly good fcn type
[(or (Bottom:) (Error:)) (ret f-type)]
;; otherwise fail
[(Poly: ns (Function: arrs))
(tc-error/expr
(string-append "Cannot infer type instantiation for type ~a. Please add "
"more type annotations")
f-type)]
[_
(tc-error/expr
"Cannot apply expression of type ~a, since it is not a function type"
f-type)]))
;; keep any info learned from the arguments
(add-unconditional-prop result (apply -and (map -or argps+ argps-))))

8
typed-racket-lib/typed-racket/typecheck/tc-if.rkt
View File

@ -1,6 +1,6 @@
#lang racket/unit
(require "../utils/utils.rkt"
(rep prop-rep)
(rep core-rep prop-rep)
(types abbrev utils prop-ops)
(utils tc-utils)
(typecheck signatures tc-envops tc-metafunctions)
@ -15,17 +15,17 @@
(define (tc/if-twoarm tst thn els [expected #f])
(match (single-value tst)
[(tc-result1: _ (PropSet: fs+ fs-) _)
[(tc-result1: _ (PropSet: ps+ ps-) _)
(define expected* (and expected (erase-props expected)))
(define results-t
(with-lexical-env/extend-props (list fs+)
(with-lexical-env/extend-props (list ps+)
#:unreachable (begin
(handle-unreachable-casted-exprs thn)
(warn-unreachable thn))
(test-position-add-true tst)
(tc-expr/check thn expected*)))
(define results-u
(with-lexical-env/extend-props (list fs-)
(with-lexical-env/extend-props (list ps-)
#:unreachable (begin
(handle-unreachable-casted-exprs els)
(warn-unreachable els))

32
typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
View File

@ -62,8 +62,8 @@
;; body: The body of the lambda to typecheck.
(define/cond-contract
(tc-lambda-body arg-names arg-types #:rest [raw-rest #f] #:expected [expected #f] body)
(->* ((listof identifier?) (listof Type/c) syntax?)
(#:rest (or/c #f (list/c identifier? (or/c Type/c (cons/c Type/c symbol?))))
(->* ((listof identifier?) (listof Type?) syntax?)
(#:rest (or/c #f (list/c identifier? (or/c Type? (cons/c Type? symbol?))))
#:expected (or/c #f tc-results/c))
arr?)
(define-values (rest-id rest)
@ -100,8 +100,8 @@
;; ret-ty: The expected type of the body of the lambda.
(define/cond-contract (check-clause arg-list rest-id body arg-tys rest-ty drest ret-ty)
((listof identifier?)
(or/c #f identifier?) syntax? (listof Type/c) (or/c #f Type/c)
(or/c #f (cons/c Type/c symbol?)) tc-results/c
(or/c #f identifier?) syntax? (listof Type?) (or/c #f Type?)
(or/c #f (cons/c Type? symbol?)) tc-results/c
. -> .
arr?)
(let* ([arg-len (length arg-list)]
@ -149,15 +149,15 @@
;; typecheck a single lambda, with argument list and body
;; drest-ty and drest-bound are both false or not false
;; tc/lambda-clause/check: formals syntax listof[Type/c] tc-result
;; option[Type/c] option[(cons Type/c symbol)] -> arr?
;; tc/lambda-clause/check: formals syntax listof[Type?] tc-result
;; option[Type?] option[(cons Type? symbol)] -> arr?
(define (tc/lambda-clause/check formals body arg-tys ret-ty rest-ty drest)
(check-clause (formals-positional formals) (formals-rest formals) body arg-tys rest-ty drest ret-ty))
;; typecheck a single opt-lambda clause with argument list and body
;; tc/opt-lambda-clause: listof[identifier] syntax -> listof[arr?]
(define (tc/opt-lambda-clause arg-list body aux-table flag-table)
;; arg-types: Listof[Type/c]
;; arg-types: Listof[Type?]
(define arg-types
(for/list ([a (in-list arg-list)])
(get-type a #:default (lambda ()
@ -166,7 +166,7 @@
(get-type id #:default Univ)
Univ)))))
;; new-arg-types: Listof[Listof[Type/c]]
;; new-arg-types: Listof[Listof[Type?]]
(define new-arg-types
(if (= 0 (dict-count flag-table))
(list arg-types)
@ -435,9 +435,9 @@
;; tc/plambda syntax tvarss-list syntax-list syntax-list type -> Poly
;; formals and bodies must by syntax-lists
(define/cond-contract (tc/plambda form tvarss-list formals bodies expected)
(syntax? (listof list?) syntax? syntax? (or/c tc-results/c #f) . -> . Type/c)
(syntax? (listof list?) syntax? syntax? (or/c tc-results/c #f) . -> . Type?)
(define/cond-contract (maybe-loop form formals bodies expected)
(syntax? syntax? syntax? (or/c tc-results/c #f) . -> . Type/c)
(syntax? syntax? syntax? (or/c tc-results/c #f) . -> . Type?)
(match expected
[(tc-result1: (app resolve (or (? Poly?) (? PolyDots?) (? PolyRow?))))
(tc/plambda form (remove-poly-layer tvarss-list) formals bodies expected)]
@ -544,9 +544,11 @@
(define (tc/rec-lambda/check formals* body name args return)
(define formals (syntax->list formals*))
(define ft (t:->* args (tc-results->values return)))
(define names (cons name formals))
(define objs (map (λ (_) -empty-obj) names))
(with-lexical-env/extend-types
(cons name formals)
(cons ft args)
(values
(replace-names (map (λ (f) (list f -empty-obj)) (cons name formals)) (ret ft))
(replace-names (map (λ (f) (list f -empty-obj)) (cons name formals)) (tc-body/check body return)))))
(cons name formals)
(cons ft args)
(values
(replace-names names objs (ret ft))
(replace-names names objs (tc-body/check body return)))))

84
typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -47,62 +47,59 @@
((-> any/c))
. ->* .
tc-results/c)
(with-cond-contract t/p ([expected-types (listof (listof Type/c))]
[objs (listof (listof Object?))]
(with-cond-contract t/p ([expected-types (listof (listof Type?))]
[objs (listof (listof OptObject?))]
[props (listof (listof Prop?))])
(define-values (expected-types objs props)
(for/lists (e o p)
([e-r (in-list expected-results)]
[names (in-list namess)])
(match e-r
[(list (tc-result: e-ts (PropSet: fs+ fs-) os) ...)
[(list (tc-result: e-ts (PropSet: ps+ ps-) os) ...)
(values e-ts
(map (λ (o n t) (if (or (is-var-mutated? n) (F? t)) -empty-obj o)) os names e-ts)
(map (λ (o n) (if (is-var-mutated? n) -empty-obj o)) os names)
(apply append
(for/list ([n (in-list names)]
[t (in-list e-ts)]
[f+ (in-list fs+)]
[f- (in-list fs-)]
[p+ (in-list ps+)]
[p- (in-list ps-)]
[o (in-list os)])
(cond
[(not (overlap? t (-val #f)))
(list f+)]
[(is-var-mutated? n)
(list)]
;; n is being bound to an expression w/ object o, no new info
;; is required due to aliasing (note: we currently do not
;; alias objects typed as type variables)
[(and (Path? o) (not (F? t))) (list)]
;; n is being bound to an expression w/o an object (or whose
;; type is a type variable) so create props about n
[else (list (-or (-and (-not-type n (-val #f)) f+)
(-and (-is-type n (-val #f)) f-)))]))))]
[(not (overlap? t (-val #f))) (list p+)]
[(is-var-mutated? n) (list)]
[else
(define obj (if (Object? o) o n))
(list (-or (-and (-not-type obj (-val #f)) p+)
(-and (-is-type obj (-val #f)) p-)))]))))]
;; amk: does this case ever occur?
[(list (tc-result: e-ts #f _) ...)
(values e-ts (make-list (length e-ts) -empty-obj) null)]))))
;; extend the lexical environment for checking the body
;; with types and potential aliases
(with-lexical-env/extend-types+aliases
(append* namess)
(append* expected-types)
(append* objs)
(replace-names
(get-names+objects namess expected-results)
(with-lexical-env/extend-props
(apply append props)
;; if a let rhs does not return, the body isn't checked
#:unreachable (for ([form (in-list (syntax->list body))])
(register-ignored! form))
;; type-check the rhs exprs
(for ([expr (in-list exprs)] [results (in-list expected-results)])
(match results
[(list (tc-result: ts fs os) ...)
(expr->type expr (ret ts fs os))]))
;; Perform additional context-dependent checking that needs to be done
;; in the context of the letrec body
(check-thunk)
;; typecheck the body
(tc-body/check body (and expected (erase-props expected)))))))
(let ([names (append* namess)]
[objs (append* objs)])
(with-lexical-env/extend-types+aliases
names
(append* expected-types)
objs
(replace-names
names
objs
(with-lexical-env/extend-props
(apply append props)
;; if a let rhs does not return, the body isn't checked
#:unreachable (for ([form (in-list (syntax->list body))])
(register-ignored! form))
;; type-check the rhs exprs
(for ([expr (in-list exprs)] [results (in-list expected-results)])
(match results
[(list (tc-result: ts fs os) ...)
(expr->type expr (ret ts fs os))]))
;; Perform additional context-dependent checking that needs to be done
;; in the context of the letrec body
(check-thunk)
;; typecheck the body
(tc-body/check body (and expected (erase-props expected))))))))
(define (tc-expr/maybe-expected/t e names)
(syntax-parse names
@ -111,7 +108,7 @@
[_ (tc-expr e)]))
(define (regsiter-aliases-and-declarations names exprs)
(define (register-aliases-and-declarations names exprs)
;; Collect the declarations, which are represented as expressions.
;; We put them back into definitions to reuse the existing machinery
(define-values (type-aliases declarations signature-forms)
@ -159,7 +156,7 @@
(let* ([names (stx-map syntax->list namess)]
[orig-flat-names (apply append names)]
[exprs (syntax->list exprs)])
(regsiter-aliases-and-declarations names exprs)
(register-aliases-and-declarations names exprs)
;; First look at the clauses that do not bind the letrec names
(define all-clauses
@ -270,7 +267,8 @@
(with-lexical-env/extend-types
names
ts
(replace-names (map list names os)
(replace-names names
os
(loop (cdr clauses))))])))
;; this is so match can provide us with a syntax property to
@ -292,7 +290,7 @@
;; all the trailing expressions - the ones actually bound to the names
[exprs (syntax->list exprs)])
(regsiter-aliases-and-declarations names exprs)
(register-aliases-and-declarations names exprs)
(let* (;; the types of the exprs
#;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)]

93
typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt
View File

@ -4,7 +4,7 @@
racket/match racket/list
(except-in (types abbrev union utils prop-ops tc-result)
-> ->* one-of/c)
(rep type-rep prop-rep object-rep rep-utils)
(rep type-rep prop-rep object-rep values-rep rep-utils)
(typecheck tc-subst check-below)
(contract-req))
@ -16,15 +16,16 @@
;; Objects representing the rest argument are currently not supported
(define/cond-contract (abstract-results results arg-names #:rest-id [rest-id #f])
((tc-results/c (listof identifier?)) (#:rest-id (or/c #f identifier?))
. ->* . SomeValues/c)
. ->* . SomeValues?)
(define positional-arg-objects
(for/list ([(nm k) (in-indexed (in-list arg-names))])
(list nm (make-Path null (list 0 k)))))
(define arg-objects
(for/list ([n (in-range (length arg-names))])
(make-Path null (cons 0 n))))
(define-values (names objects)
(if rest-id
(cons (list rest-id -empty-obj) positional-arg-objects)
positional-arg-objects))
(tc-results->values (replace-names arg-objects results)))
(values (cons rest-id arg-names)
(cons -empty-obj positional-arg-objects))
(values arg-names positional-arg-objects)))
(tc-results->values (replace-names names objects results)))
(define (tc-results->values tc)
(match (fix-results tc)
@ -41,16 +42,16 @@
. -> .
Prop?)
(for/fold ([prop prop])
([a (in-list atoms)])
([a (in-list atoms)])
(match prop
[(AndProp: ps)
(let loop ([ps ps] [result null])
(if (null? ps)
(apply -and result)
(let ([p (car ps)])
(cond [(contradictory? a p) -ff]
[(implies-atomic? a p) (loop (cdr ps) result)]
[else (loop (cdr ps) (cons p result))]))))]
(match ps
[(cons p ps)
(cond [(contradictory? a p) -ff]
[(implies-atomic? a p) (loop ps result)]
[else (loop ps (cons p result))])]
[_ (apply -and result)]))]
[_ prop])))
(define (flatten-props ps)
@ -60,40 +61,44 @@
[(cons (AndProp: ps*) ps) (loop (append ps* ps))]
[(cons p ps) (cons p (loop ps))])))
(define/cond-contract (combine-props new-props old-props exit)
((listof Prop?) (listof Prop?) (-> none/c)
. -> .
(values (listof OrProp?) (listof (or/c TypeProp? NotTypeProp?))))
(define/cond-contract (combine-props new-props old-props)
((listof Prop?) (listof Prop?)
. -> .
(values (or/c #f (listof OrProp?))
(or/c #f (listof (or/c TypeProp? NotTypeProp?)))))
(define (atomic-prop? p) (or (TypeProp? p) (NotTypeProp? p)))
(define-values (new-atoms new-formulas) (partition atomic-prop? (flatten-props new-props)))
(let loop ([derived-formulas null]
(let loop ([derived-ors null]
[derived-atoms new-atoms]
[worklist (append old-props new-formulas)])
(if (null? worklist)
(values derived-formulas derived-atoms)
(let* ([p (car worklist)]
[p (resolve derived-atoms p)])
(match p
[(OrProp: ps)
(let ([new-or
(let or-loop ([ps ps] [result null])
(cond
[(null? ps) (apply -or result)]
[(for/or ([other-p (in-list (append derived-formulas derived-atoms))])
(contradictory? (car ps) other-p))
(or-loop (cdr ps) result)]
[(for/or ([other-p (in-list derived-atoms)])
(implies-atomic? other-p (car ps)))
-tt]
[else (or-loop (cdr ps) (cons (car ps) result))]))])
(if (OrProp? new-or)
(loop (cons new-or derived-formulas) derived-atoms (cdr worklist))
(loop derived-formulas derived-atoms (cons new-or (cdr worklist)))))]
[(or (? TypeProp?) (? NotTypeProp?)) (loop derived-formulas (cons p derived-atoms) (cdr worklist))]
(match worklist
[(cons (app (λ (p) (resolve derived-atoms p)) p)
worklist)
(match p
[(OrProp: qs)
(let or-loop ([qs qs] [result null])
(match qs
[(cons q qs)
(let check-loop ([atoms derived-atoms])
(match atoms
[(cons a atoms)
(cond
[(contradictory? q a) (or-loop qs result)]
[(implies-atomic? a q) (loop derived-ors derived-atoms worklist)]
[else (check-loop atoms)])]
[_ (or-loop qs (cons q result))]))]
[_ (define new-or (apply -or result))
(if (OrProp? new-or)
(loop (cons new-or derived-ors) derived-atoms worklist)
(loop derived-ors derived-atoms (cons new-or worklist)))]))]
[(or (? TypeProp?)
(? NotTypeProp?))
(loop derived-ors (cons p derived-atoms) worklist)]
[(AndProp: ps) (loop derived-formulas derived-atoms (append ps (cdr worklist)))]
[(TrueProp:) (loop derived-formulas derived-atoms (cdr worklist))]
[(FalseProp:) (exit)])))))
[(AndProp: qs) (loop derived-ors derived-atoms (append qs worklist))]
[(== -tt prop-equal?) (loop derived-ors derived-atoms worklist)]
[(== -ff prop-equal?) (values #f #f)])]
[_ (values derived-ors derived-atoms)])))
(define (unconditional-prop res)

8
typed-racket-lib/typed-racket/typecheck/tc-send.rkt
View File

@ -20,10 +20,10 @@
method-var method
arg-vars args
[expected #f])
;; do-check : Type/c -> tc-results/c
;; do-check : Type? -> tc-results/c
(define (do-check rcvr-type)
(match rcvr-type
[(Instance: (? needs-resolving? type))
[(Instance: (? resolvable? type))
(do-check (make-Instance (resolve type)))]
[(and obj (Instance: (Class: _ _ _ methods _ _)))
(match (tc-expr/t method)
@ -42,9 +42,7 @@
rcvr-type)])]
;; union of objects, check pointwise and union the results
[(Union: (list (and objs (Instance: _)) ...))
(merge-tc-results
(for/list ([obj (in-list objs)])
(do-check obj)))]
(merge-tc-results (map do-check objs))]
[_ (tc-error/expr/fields
"send: type mismatch"
"expected" "an object"

4
typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View File

@ -159,7 +159,7 @@
;; the base-type, with free type variables
(define name-type
(make-Name (struct-names-type-name names) 0 #t))
(make-Name (struct-names-type-name names) (length tvars) #t))
(define poly-base
(if (null? tvars)
name-type
@ -350,7 +350,7 @@
;; FIXME - figure out how to make this lots lazier
(define/cond-contract (tc/builtin-struct nm parent fld-names tys kernel-maker)
(c:-> identifier? (c:or/c #f identifier?) (c:listof identifier?)
(c:listof Type/c) (c:or/c #f identifier?)
(c:listof Type?) (c:or/c #f identifier?)
c:any/c)
(define parent-type
(and parent (resolve-name (make-Name parent 0 #t))))

323
typed-racket-lib/typed-racket/typecheck/tc-subst.rkt
View File

@ -4,179 +4,192 @@
;; figure 8, pg 8 of "Logical Types for Untyped Languages"
(require "../utils/utils.rkt"
(utils tc-utils)
racket/match racket/list
(contract-req)
(except-in (types abbrev utils prop-ops path-type)
(except-in (types abbrev utils prop-ops path-type subtract overlap)
-> ->* one-of/c)
(only-in (infer infer) intersect)
(rep type-rep object-rep prop-rep rep-utils))
(provide add-scope)
(only-in (infer infer) intersect restrict)
(types subtype)
(rep core-rep type-rep object-rep
prop-rep rep-utils values-rep))
(provide/cond-contract
[restrict-values (-> SomeValues/c (listof Type/c) SomeValues/c)]
[values->tc-results (->* (SomeValues/c (listof Object?)) ((listof Type/c)) full-tc-results/c)]
[replace-names (-> (listof (list/c identifier? Object?)) tc-results/c tc-results/c)])
[restrict-values (-> SomeValues? (listof Type?) SomeValues?)]
[values->tc-results (->* (SomeValues? (listof OptObject?))
((listof Type?))
full-tc-results/c)]
[replace-names (-> (listof identifier?)
(listof OptObject?)
tc-results/c
tc-results/c)])
;; Substitutes the given objects into the values and turns it into a tc-result.
;; This matches up to the substitutions in the T-App rule from the ICFP paper.
(define (values->tc-results v os [ts (map (λ (o) Univ) os)])
;; Substitutes the given objects into the values and turns it into a
;; tc-result. This matches up to the substitutions in the T-App rule
;; from the ICFP paper.
(define (values->tc-results v os [ts (map (λ (_) Univ) os)])
(define targets
(for/list ([o (in-list os)]
[arg (in-naturals)]
[t (in-list ts)])
(list (cons 0 arg) o t)))
(define res
(match v
[(AnyValues: f)
(tc-any-results f)]
[(Results: t f o)
(ret t f o)]
[(Results: t f o dty dbound)
(ret t f o dty dbound)]))
(for/fold ([res res]) ([(o arg) (in-indexed (in-list os))]
[t (in-list ts)])
(subst-tc-results res (list 0 arg) o #t t)))
[(AnyValues: p)
(tc-any-results p)]
[(Results: t ps o)
(ret t ps o)]
[(Results: t ps o dty dbound)
(ret t ps o dty dbound)]
[_ (int-err "invalid res in values->tc-results: ~a" res)]))
(subst-tc-results res targets))
;; Restrict the objects in v refering to the current functions arguments to be of the types ts.
;; Restrict the objects in v refering to the current functions
;; arguments to be of the types ts. Uses an identity substitution (yuck)
;; since substitution does this same restriction.
(define (restrict-values v ts)
(for/fold ([v v]) ([t (in-list ts)] [arg (in-naturals)])
(subst-type v (list 0 arg) (-arg-path arg) #t t)))
(define targets
(for/list ([t (in-list ts)]
[arg (in-naturals)])
(define nm (cons 0 arg))
(list nm (-id-path nm) t)))
(subst-rep v targets))
;; replace-names: (listof (list/c identifier? Object?) tc-results? -> tc-results?
;; For each name replaces all uses of it in res with the corresponding object.
;; This is used so that names do not escape the scope of their definitions
(define (replace-names names+objects res)
(for/fold ([res res]) ([name/object (in-list names+objects)])
(subst-tc-results res (first name/object) (second name/object) #t Univ)))
;; Substitution of objects into a tc-results
;; This is a combination of all of thes substitions from the paper over the different parts of the
;; results.
;; t is the type of the object that we are substituting in. This allows for restriction/simplification
;; of some props if they conflict with the argument type.
(define/cond-contract (subst-tc-results res k o polarity t)
(-> full-tc-results/c name-ref/c Object? boolean? Type? full-tc-results/c)
(define (st ty) (subst-type ty k o polarity t))
(define (sr ty fs ob) (subst-tc-result ty fs ob k o polarity t))
(define (sf f) (subst-prop f k o polarity t))
;; For each name replaces all uses of it in res with the
;; corresponding object. This is used so that names do not escape the
;; scope of their definitions
(define (replace-names names objects res)
(define targets
(for/list ([nm (in-list names)]
[o (in-list objects)])
(list nm o Univ)))
(subst-tc-results res targets))
(define (subst-tc-results res targets)
(define (sr t ps o)
(subst-tc-result t ps o targets))
(define (sub x) (subst-rep x targets))
(match res
[(tc-any-results: f) (tc-any-results (sf f))]
[(tc-results: ts fs os)
(tc-results (map sr ts fs os) #f)]
[(tc-results: ts fs os dt db)
(tc-results (map sr ts fs os) (cons (st dt) db))]))
[(tc-any-results: p) (tc-any-results (sub p))]
[(tc-results: ts ps os)
(tc-results (map sr ts ps os) #f)]
[(tc-results: ts ps os dt db)
(tc-results (map sr ts ps os) (cons (sub dt) db))]
[_ (int-err "invalid res in subst-tc-results: ~a" res)]))
;; Substitution of objects into a tc-result
;; This is a combination of the other substitutions, plus a restriction of the returned type
;; to the arguments type if the returned object corresponds to an argument.
(define (subst-tc-result r-t r-fs r-o k o polarity t)
(define argument-side
;; Substitution of objects into a tc-result This is a combination of
;; the other substitutions, plus a restriction of the returned type to
;; the arguments type if the returned object corresponds to an
;; argument.
(define (subst-tc-result r-t r-ps r-o targets)
(define type*
(match r-o
[(Path: p (? (lambda (nm) (name-ref=? nm k))))
(path-type p t)]
[_ Err]))
[(Path: flds nm)
(cond
[(assoc nm targets name-ref=?) =>
(match-lambda
[(list _ _ t)
(or (path-type flds t) Univ)])]
[else Univ])]
[_ Univ]))
(tc-result
(if (equal? argument-side Err)
(subst-type r-t k o polarity t)
(intersect argument-side
(subst-type r-t k o polarity t)))
(subst-prop-set r-fs k o polarity t)
(subst-object r-o k o polarity)))
(intersect (subst-rep r-t targets)
type*)
(subst-rep r-ps targets)
(subst-rep r-o targets)))
;; Substitution of objects into a prop set
;; This is essentially ψ+|ψ- [o/x] from the paper
(define/cond-contract (subst-prop-set pset k o polarity t)
(-> (or/c #f PropSet?) name-ref/c Object? boolean? Type/c PropSet?)
(define extra-prop (-is-type k t))
(define (add-extra-prop p)
(define p* (-and p extra-prop))
(cond
[(prop-equal? p* extra-prop) -tt]
[(FalseProp? p*) -ff]
[else p]))
(match pset
[(PropSet: p+ p-)
(-PS (subst-prop (add-extra-prop p+) k o polarity t)
(subst-prop (add-extra-prop p-) k o polarity t))]
[_ -tt-propset]))
;; Substitution of objects into a type
;; This is essentially t [o/x] from the paper
(define/cond-contract (subst-type t k o polarity ty)
(-> Type? name-ref/c Object? boolean? Type/c Type?)
(define (st t) (subst-type t k o polarity ty))
(define/cond-contract (sf fs) (PropSet? . -> . PropSet?) (subst-prop-set fs k o polarity ty))
(type-case (#:Type st
#:Prop sf
#:Object (lambda (f) (subst-object f k o polarity)))
t
[#:arr dom rng rest drest kws
(let* ([st* (λ (t) (subst-type t (add-scope k) (add-scope/object o) polarity ty))])
(make-arr (map st dom)
(st* rng)
(and rest (st rest))
(and drest (cons (st (car drest)) (cdr drest)))
(map st kws)))]))
;; inc-lvl
;; (cons nat nat) -> (cons nat nat)
;; DeBruijn indexes are represented as a pair of naturals.
;; This function increments the 'lvl' field of such an index.
(define (inc-lvl x)
(match x
[(cons lvl arg) (cons (add1 lvl) arg)]
[_ x]))
;; add-scope : name-ref/c -> name-ref/c
;; Add a scope to an index name-ref
(define (add-scope key)
(match key
[(list fun arg) (list (add1 fun) arg)]
[(? identifier?) key]))
;; inc-lvls
;; This function increments the 'lvl' field in all of the targets
;; and objects of substitution (see 'inc-lvl' above)
(define (inc-lvls targets)
(for/list ([tgt (in-list targets)])
(match tgt
[(list nm1 (Path: flds nm2) ty)
(list (inc-lvl nm1) (make-Path flds (inc-lvl nm2)) ty)]
[(cons nm1 rst)
(cons (inc-lvl nm1) rst)])))
;; add-scope/object : Object? -> Object?
;; Add a scope to an index object
(define (add-scope/object obj)
(match obj
[(Empty:) -empty-obj]
[(Path: p nm) (make-Path p (add-scope nm))]))
;; Substitution of objects into objects
;; This is o [o'/x] from the paper
(define/cond-contract (subst-object t k o polarity)
(-> Object? name-ref/c Object? boolean? Object?)
(match t
[#f t]
[(Empty:) t]
[(Path: p i)
(if (name-ref=? i k)
(match o
[(Empty:) -empty-obj]
;; the result is not from an annotation, so it isn't a NoObject
[#f -empty-obj]
[(Path: p* i*) (make-Path (append p p*) i*)])
t)]))
;; Substitution of objects into a prop in a prop set
;; This is ψ+ [o/x] and ψ- [o/x] with the addition that props are restricted to
;; only those values which are a subtype of the actual argument type (ty).
(define/cond-contract (subst-prop p k o polarity ty)
(-> Prop? name-ref/c Object? boolean? Type/c Prop?)
(define (ap q) (subst-prop q k o polarity ty))
(define (tprop-matcher pes i t maker)
(cond
[(name-ref=? i k)
(match o
[(Empty:)
(if polarity -tt -ff)]
[_
;; `ty` alone doesn't account for the path, so
;; first traverse it with the path to match `t`
(define ty/path (path-type pes ty))
(maker
(-acc-path pes o)
;; don't intersect if the path doesn't match the type
(if (equal? ty/path Err)
(subst-type t k o polarity ty)
(intersect ty/path
(subst-type t k o polarity ty))))])]
[else p]))
(match p
[(AndProp: ps) (apply -and (map ap ps))]
[(OrProp: ps) (apply -or (map ap ps))]
[(FalseProp:) -ff]
[(TrueProp:) -tt]
[(TypeProp: (Path: pes i) t)
(tprop-matcher pes i t -is-type)]
[(NotTypeProp: (Path: pes i) t)
(tprop-matcher pes i t -not-type)]))
;; Simple substitution of objects into a Rep
;; This is basically 'rep[x ↦ o]'.
;; If that was the only substitution we were doing,
;; and the type of 'x' was 'τ', then 'targets'
;; would equal (list (list x o τ)) (i.e. it's the list of
;; identifiers being substituted out, the optional object replacing
;; them, and their type).
(define/cond-contract (subst-rep rep targets)
(-> any/c (listof (list/c name-ref/c OptObject? Type?))
any/c)
(define (sub/inc rep)
(subst-rep rep (inc-lvls targets)))
;; substitution loop
(let subst ([rep rep])
(match rep
;; Functions
;; increment the level of the substituted object
[(arr: dom rng rest drest kws)
(make-arr (map subst dom)
(sub/inc rng)
(and rest (subst rest))
(and drest (cons (subst (car drest)) (cdr drest)))
(map subst kws))]
[(Path: flds nm)
(let ([flds (map subst flds)])
(cond
[(assoc nm targets name-ref=?) =>
(λ (l) (match (second l)
[(Empty:) -empty-obj]
[(Path: flds* nm*)
(make-Path (append flds flds*) nm*)]))]
[else (make-Path flds nm)]))]
;; restrict with the type for results and props
[(TypeProp: (Path: flds nm) ty-at-flds)
(let ([flds (map subst flds)])
(cond
[(assoc nm targets name-ref=?) =>
(match-lambda
[(list _ new-obj new-obj-ty)
(define arg-ty-at-flds (or (path-type flds new-obj-ty) Univ))
(define new-ty-at-flds (intersect ty-at-flds arg-ty-at-flds))
(match new-obj
[_ #:when (Bottom? new-ty-at-flds) -ff]
[_ #:when (subtype arg-ty-at-flds ty-at-flds) -tt]
[(Empty:) -tt]
[(Path: flds* nm*)
(define resulting-obj (make-Path (append flds flds*) nm*))
(-is-type resulting-obj new-ty-at-flds)])])]
[else (-is-type (make-Path flds nm) (subst ty-at-flds))]))]
[(NotTypeProp: (Path: flds nm) not-ty-at-flds)
(let ([flds (map subst flds)])
(cond
[(assoc nm targets name-ref=?) =>
(match-lambda
[(list _ new-obj new-obj-ty)
(define arg-ty-at-flds (or (path-type flds new-obj-ty) Univ))
(define new-ty-at-flds (subtract arg-ty-at-flds not-ty-at-flds))
(define new-not-ty-at-flds (restrict not-ty-at-flds arg-ty-at-flds))
(match new-obj
[_ #:when (Bottom? new-ty-at-flds) -ff]
[_ #:when (Bottom? new-not-ty-at-flds) -tt]
[(Empty:) -tt]
[(Path: flds* nm*)
(define resulting-obj (make-Path (append flds flds*) nm*))
(-not-type resulting-obj new-not-ty-at-flds)])])]
[else
(-not-type (make-Path flds nm) (subst not-ty-at-flds))]))]
;; else default fold over subfields
[_ (Rep-fold subst rep)])))

7
typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -4,7 +4,7 @@
racket/syntax syntax/parse syntax/stx syntax/id-table
racket/list racket/dict racket/match racket/sequence
(prefix-in c: (contract-req))
(rep type-rep)
(rep core-rep type-rep values-rep)
(types utils abbrev type-table struct-table)
(private parse-type type-annotation syntax-properties type-contract)
(env global-env init-envs type-name-env type-alias-env
@ -349,9 +349,10 @@
;; Add the struct names to the type table, but not with a type
(let ((names (map name-of-struct struct-defs))
(type-vars (map type-vars-of-struct struct-defs)))
(for ([name names])
(for ([name (in-list names)]
[tvars (in-list type-vars)])
(register-resolved-type-alias
name (make-Name name 0 #t)))
name (make-Name name (length tvars) #t)))
(for-each register-type-name names)
(for-each add-constant-variance! names type-vars))
(do-time "after adding type names")

8
typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt
View File

@ -38,7 +38,7 @@
syntax/kerncase
syntax/parse
syntax/stx
(rep type-rep)
(rep type-rep values-rep)
(optimizer optimizer)
(types utils abbrev printer generalize)
(typecheck tc-toplevel possible-domains)
@ -146,7 +146,7 @@
(define tc (cleanup-type t))
(define tg (generalize tc))
(format "- : ~a~a~a\n"
(pretty-format-type tg #:indent 4)
(pretty-format-rep tg #:indent 4)
(cond [(equal? tc tg) ""]
[else (format " [more precisely: ~a]" tc)])
(cond [(equal? tc t) ""]
@ -157,14 +157,14 @@
(define tcs (map cleanup-type t))
(define tgs (map generalize tcs))
(define tgs-val (make-Values (map -result tgs)))
(define formatted (pretty-format-type tgs-val #:indent 4))
(define formatted (pretty-format-rep tgs-val #:indent 4))
(define indented? (regexp-match? #rx"\n" formatted))
(format "- : ~a~a~a\n"
formatted
(cond [(andmap equal? tgs tcs) ""]
[indented?
(format "\n[more precisely: ~a]"
(pretty-format-type (make-Values (map -result tcs))
(pretty-format-rep (make-Values (map -result tcs))
#:indent 17))]
[else (format " [more precisely: ~a]" (cons 'Values tcs))])
;; did any get pruned?

18
typed-racket-lib/typed-racket/types/abbrev.rkt
View File

@ -12,7 +12,7 @@
racket/function
(prefix-in c: (contract-req))
(rename-in (rep type-rep prop-rep object-rep)
(rename-in (rep type-rep prop-rep object-rep values-rep)
[make-Base make-Base*])
(types union numeric-tower prefab)
;; Using this form so all-from-out works
@ -87,22 +87,20 @@
;; Convenient constructor for Values
;; (wraps arg types with Result)
(define/cond-contract (-values args)
(c:-> (c:listof Type/c) (c:or/c Type/c Values?))
(c:-> (c:listof Type?) (c:or/c Type? Values?))
(match args
;[(list t) t]
[_ (make-Values (for/list ([i (in-list args)]) (-result i)))]))
;; Convenient constructor for ValuesDots
;; (wraps arg types with Result)
(define/cond-contract (-values-dots args dty dbound)
(c:-> (c:listof Type/c) Type/c (c:or/c symbol? c:natural-number/c)
(c:-> (c:listof Type?) Type? (c:or/c symbol? c:natural-number/c)
ValuesDots?)
(make-ValuesDots (for/list ([i (in-list args)]) (-result i))
dty dbound))
;; Basic types
(define -Listof (-poly (list-elem) (make-Listof list-elem)))
(define/decl -Boolean (Un -False -True))
(define/decl -Undefined
(make-Base 'Undefined
#'(lambda (x) (eq? x undefined))
@ -276,16 +274,16 @@
(make-Function (list (make-arr* (list dom) rng #:props prop))))
(define/cond-contract make-pred-ty
(c:case-> (c:-> Type/c Type/c)
(c:-> (c:listof Type/c) Type/c Type/c Type/c)
(c:-> (c:listof Type/c) Type/c Type/c Object? Type/c))
(c:case-> (c:-> Type? Type?)
(c:-> (c:listof Type?) Type? Type? Type?)
(c:-> (c:listof Type?) Type? Type? Object? Type?))
(case-lambda
[(in out t o)
(->* in out : (-PS (-is-type o t) (-not-type o t)))]
[(in out t)
(make-pred-ty in out t (make-Path null (list 0 0)))]
(make-pred-ty in out t (make-Path null (cons 0 0)))]
[(t)
(make-pred-ty (list Univ) -Boolean t (make-Path null (list 0 0)))]))
(make-pred-ty (list Univ) -Boolean t (make-Path null (cons 0 0)))]))
(define/decl -true-propset (-PS -tt -ff))
(define/decl -false-propset (-PS -ff -tt))

208
typed-racket-lib/typed-racket/types/base-abbrev.rkt
View File

@ -6,7 +6,7 @@
;; extends it with more types and type abbreviations.
(require "../utils/utils.rkt"
(rep type-rep prop-rep object-rep rep-utils)
(rep type-rep prop-rep object-rep values-rep rep-utils)
(env mvar-env)
racket/match racket/list (prefix-in c: (contract-req))
(for-syntax racket/base syntax/parse racket/list)
@ -14,6 +14,9 @@
(for-template racket/base))
(provide (all-defined-out)
-is-type
-not-type
-id-path
(rename-out [make-Listof -lst]
[make-MListof -mlst]))
@ -34,11 +37,12 @@
;; Top and error types
(define/decl Univ (make-Univ))
(define/decl -Bottom (make-Union null))
(define/decl -Bottom (make-Bottom))
(define/decl Err (make-Error))
(define/decl -False (make-Value #f))
(define/decl -True (make-Value #t))
(define/decl -Boolean (make-Union (list -False -True)))
(define -val make-Value)
@ -70,25 +74,14 @@
;; The input types can be union types, but should not have a complicated
;; overlap relationship.
(define simple-Un
(let ()
;; List[Type] -> Type
;; Argument types should not overlap or be union types
(define (make-union* types)
(match types
[(list t) t]
[_ (make-Union types)]))
;; Type -> List[Type]
(define (flat t)
(match t
[(Union: es) es]
[_ (list t)]))
(let ([flat (match-lambda
[(Union: es) es]
[t (list t)])])
(case-lambda
[() -Bottom]
[(t) t]
[args
(make-union* (remove-dups (sort (append-map flat args) type<?)))])))
(make-Union (remove-duplicates (append-map flat args) type-equal?))])))
;; Recursive types
(define-syntax -v
@ -103,7 +96,7 @@
;; Results
(define/cond-contract (-result t [pset -tt-propset] [o -empty-obj])
(c:->* (Type/c) (PropSet? Object?) Result?)
(c:->* (Type?) (PropSet? OptObject?) Result?)
(cond
[(or (equal? t -Bottom) (equal? pset -ff-propset))
(make-Result -Bottom -ff-propset o)]
@ -116,16 +109,9 @@
(define/decl -tt-propset (make-PropSet -tt -tt))
(define/decl -ff-propset (make-PropSet -ff -ff))
(define/decl -empty-obj (make-Empty))
(define (-id-path id)
(cond
[(identifier? id)
(if (is-var-mutated? id)
-empty-obj
(make-Path null id))]
[else
(make-Path null id)]))
(define (-arg-path arg [depth 0])
(make-Path null (list depth arg)))
(make-Path null (cons depth arg)))
(define (-acc-path path-elems o)
(match o
[(Empty:) -empty-obj]
@ -135,41 +121,6 @@
(c:-> Prop? Prop? PropSet?)
(make-PropSet + -))
;; Abbreviation for props
;; `i` can be an integer or name-ref/c for backwards compatibility
;; FIXME: Make all callers pass in an object and remove backwards compatibility
(define/cond-contract (-is-type i t)
(c:-> (c:or/c integer? name-ref/c Object?) Type/c Prop?)
(define o
(cond
[(Object? i) i]
[(integer? i) (make-Path null (list 0 i))]
[(list? i) (make-Path null i)]
[else (-id-path i)]))
(cond
[(Empty? o) -tt]
[(equal? Univ t) -tt]
[(equal? -Bottom t) -ff]
[else (make-TypeProp o t)]))
;; Abbreviation for not props
;; `i` can be an integer or name-ref/c for backwards compatibility
;; FIXME: Make all callers pass in an object and remove backwards compatibility
(define/cond-contract (-not-type i t)
(c:-> (c:or/c integer? name-ref/c Object?) Type/c Prop?)
(define o
(cond
[(Object? i) i]
[(integer? i) (make-Path null (list 0 i))]
[(list? i) (make-Path null i)]
[else (-id-path i)]))
(cond
[(Empty? o) -tt]
[(equal? -Bottom t) -tt]
[(equal? Univ t) -ff]
[else (make-NotTypeProp o t)]))
;; A Type that corresponds to the any contract for the
;; return type of functions
@ -180,14 +131,14 @@
(define/cond-contract (make-arr* dom rng
#:rest [rest #f] #:drest [drest #f] #:kws [kws null]
#:props [props -tt-propset] #:object [obj -empty-obj])
(c:->* ((c:listof Type/c) (c:or/c SomeValues/c Type/c))
(#:rest (c:or/c #f Type/c)
#:drest (c:or/c #f (c:cons/c Type/c symbol?))
(c:->* ((c:listof Type?) (c:or/c SomeValues? Type?))
(#:rest (c:or/c #f Type?)
#:drest (c:or/c #f (c:cons/c Type? symbol?))
#:kws (c:listof Keyword?)
#:props PropSet?
#:object Object?)
#:object OptObject?)
arr?)
(make-arr dom (if (Type/c? rng)
(make-arr dom (if (Type? rng)
(make-Values (list (-result rng props obj)))
rng)
rest drest (sort #:key Keyword-kw kws keyword<?)))
@ -197,44 +148,55 @@
(pattern x:id #:fail-unless (eq? ': (syntax-e #'x)) #f))
(syntax-parse stx
[(_ dom rng)
#'(make-Function (list (make-arr* dom rng)))]
(syntax/loc stx
(make-Function (list (make-arr* dom rng))))]
[(_ dom rst rng)
#'(make-Function (list (make-arr* dom rng #:rest rst)))]
(syntax/loc stx
(make-Function (list (make-arr* dom rng #:rest rst))))]
[(_ dom rng :c props)
#'(make-Function (list (make-arr* dom rng #:props props)))]
(syntax/loc stx
(make-Function (list (make-arr* dom rng #:props props))))]
[(_ dom rng _:c props _:c object)
#'(make-Function (list (make-arr* dom rng #:props props #:object object)))]
(syntax/loc stx
(make-Function (list (make-arr* dom rng #:props props #:object object))))]
[(_ dom rst rng _:c props)
#'(make-Function (list (make-arr* dom rng #:rest rst #:props props)))]
(syntax/loc stx
(make-Function (list (make-arr* dom rng #:rest rst #:props props))))]
[(_ dom rst rng _:c props : object)
#'(make-Function (list (make-arr* dom rng #:rest rst #:props props #:object object)))]))
(syntax/loc stx
(make-Function (list (make-arr* dom rng #:rest rst #:props props #:object object))))]))
(define-syntax (-> stx)
(define-syntax-class c
(pattern x:id #:fail-unless (eq? ': (syntax-e #'x)) #f))
(syntax-parse stx
[(_ dom ... rng _:c props _:c objects)
#'(->* (list dom ...) rng : props : objects)]
(syntax/loc stx
(->* (list dom ...) rng : props : objects))]
[(_ dom ... rng :c props)
#'(->* (list dom ...) rng : props)]
(syntax/loc stx
(->* (list dom ...) rng : props))]
[(_ dom ... rng)
#'(->* (list dom ...) rng)]))
(syntax/loc stx
(->* (list dom ...) rng))]))
(define-syntax ->...
(syntax-rules (:)
[(_ dom rng)
(->* dom rng)]
(define-syntax (->... stx)
(syntax-parse stx
[(_ dom rng) (syntax/loc stx (->* dom rng))]
[(_ dom (dty dbound) rng)
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound))))]
[(_ dom rng : props)
(->* dom rng : props)]
[(_ dom (dty dbound) rng : props)
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:props props)))]))
(syntax/loc stx
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound)))))]
[(_ dom rng (~datum :) props)
(syntax/loc stx
(->* dom rng (~datum :) props))]
[(_ dom (dty dbound) rng (~datum :) props)
(syntax/loc stx
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:props props))))]))
(define (simple-> doms rng)
(->* doms rng))
(define (->acc dom rng path #:var [var (list 0 0)])
(define (->acc dom rng path #:var [var (cons 0 0)])
(define obj (-acc-path path (-id-path var)))
(make-Function
(list (make-arr* dom rng
@ -248,53 +210,57 @@
[(Function: as) as]))
(make-Function (apply append (map funty-arities args))))
(define-syntax cl->
(syntax-parser
[(_ [(dom ...) rng] ...)
#'(cl->* (dom ... . -> . rng) ...)]))
(define-syntax (cl-> stx)
(syntax-parse stx
[(_ [(dom ...) rng] ...)
(syntax/loc stx
(cl->* (dom ... . -> . rng) ...))]))
(define-syntax (->key stx)
(syntax-parse stx
[(_ ty:expr ... (~seq k:keyword kty:expr opt:boolean) ... rng)
#'(make-Function
(list
(make-arr* (list ty ...)
rng
#:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
(list (make-Keyword 'k kty opt) ...)
keyword<?))))]))
[(_ ty:expr ... (~seq k:keyword kty:expr opt:boolean) ... rng)
(syntax/loc stx
(make-Function
(list
(make-arr* (list ty ...)
rng
#:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
(list (make-Keyword 'k kty opt) ...)
keyword<?)))))]))
(define-syntax (->optkey stx)
(syntax-parse stx
[(_ ty:expr ... [oty:expr ...] #:rest rst:expr (~seq k:keyword kty:expr opt:boolean) ... rng)
(let ([l (syntax->list #'(oty ...))])
(with-syntax ([((extra ...) ...)
(for/list ([i (in-range (add1 (length l)))])
(take l i))]
[(rsts ...) (for/list ([i (in-range (add1 (length l)))]) #'rst)])
#'(make-Function
(list
(make-arr* (list ty ... extra ...)
rng
#:rest rsts
#:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
(list (make-Keyword 'k kty opt) ...)
keyword<?))
...))))]
(for/list ([i (in-range (add1 (length l)))])
(take l i))]
[(rsts ...) (for/list ([i (in-range (add1 (length l)))]) #'rst)])
(syntax/loc stx
(make-Function
(list
(make-arr* (list ty ... extra ...)
rng
#:rest rsts
#:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
(list (make-Keyword 'k kty opt) ...)
keyword<?))
...)))))]
[(_ ty:expr ... [oty:expr ...] (~seq k:keyword kty:expr opt:boolean) ... rng)
(let ([l (syntax->list #'(oty ...))])
(with-syntax ([((extra ...) ...)
(for/list ([i (in-range (add1 (length l)))])
(take l i))])
#'(make-Function
(list
(make-arr* (list ty ... extra ...)
rng
#:rest #f
#:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
(list (make-Keyword 'k kty opt) ...)
keyword<?))
...))))]))
(for/list ([i (in-range (add1 (length l)))])
(take l i))])
(syntax/loc stx
(make-Function
(list
(make-arr* (list ty ... extra ...)
rng
#:rest #f
#:kws (sort #:key (match-lambda [(Keyword: kw _ _) kw])
(list (make-Keyword 'k kty opt) ...)
keyword<?))
...)))))]))
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #:drest (cons dty dbound)))

41
typed-racket-lib/typed-racket/types/classes.rkt
View File

@ -130,36 +130,17 @@
;; Infer constraints on a row for a row polymorphic function
(define (infer-row-constraints type)
(define constraints (list null null null null))
;; Crawl the type tree and mutate constraints when a
;; class type with row variable is found.
(define (inf type)
(type-case
(#:Type inf #:Prop (sub-f inf) #:Object (sub-o inf))
type
[#:Class row inits fields methods augments init-rest
(cond
[(and row (F? row))
(match-define (list init-cs field-cs method-cs augment-cs)
constraints)
(set! constraints
(list (append (dict-keys inits) init-cs)
(append (dict-keys fields) field-cs)
(append (dict-keys methods) method-cs)
(append (dict-keys augments) augment-cs)))
(make-Class row inits fields methods augments init-rest)]
[else
(match-define (list (list init-names init-tys init-reqds) ...) inits)
(match-define (list (list field-names field-tys) ...) fields)
(match-define (list (list method-names method-tys) ...) methods)
(match-define (list (list augment-names augment-tys) ...) augments)
(make-Class
(and row (inf row))
(map list init-names (map inf init-tys) init-reqds)
(map list field-names (map inf field-tys))
(map list method-names (map inf method-tys))
(map list augment-names (map inf augment-tys))
init-rest)])]))
(inf type)
(let infer! ([cur type])
(match cur
[(Class: (? F? row) inits fields methods augments init-rest)
(match-define (list init-cs field-cs method-cs augment-cs)
constraints)
(set! constraints
(list (append (dict-keys inits) init-cs)
(append (dict-keys fields) field-cs)
(append (dict-keys methods) method-cs)
(append (dict-keys augments) augment-cs)))]
[_ (Rep-walk infer! cur)]))
(map remove-duplicates constraints))
;; infer-row : RowConstraints Type -> Row

52
typed-racket-lib/typed-racket/types/current-seen.rkt
View File

@ -1,28 +1,38 @@
#lang racket/base
(require "../utils/utils.rkt")
(require (rep type-rep) (contract-req))
(provide (except-out (all-defined-out) current-seen-mark))
(require "../utils/utils.rkt"
(rep rep-utils))
(define current-seen-mark (make-continuation-mark-key 'current-seen))
(define (current-seen)
(continuation-mark-set-first #f current-seen-mark null))
(provide (except-out (all-defined-out) seen-mark))
;;************************************************************
;; Current Seen Continuation Mark
;;************************************************************
;;
;; Prevents infinite loops when subtyping calls outside
;; functions that may then call subtyping
;; Type references/indirections that have been seen so far while
;; subtyping, including the following: Mus, Names, Structs, and Apps
(define seen-mark (make-continuation-mark-key 'seen))
(define (seen)
(continuation-mark-set-first #f seen-mark null))
(define (currently-subtyping?)
(continuation-mark-set-first #f current-seen-mark))
(define-syntax-rule (update-current-seen new-value body)
(with-continuation-mark current-seen-mark new-value body))
(continuation-mark-set-first #f seen-mark))
(define (seen-before s t) (cons (Type-seq s) (Type-seq t)))
(define-syntax-rule (with-updated-seen A . body)
(with-continuation-mark seen-mark A (let () . body)))
(define (remember s t A)
(if (or (Mu? s) (Mu? t)
(Name? s) (Name? t)
(Instance? s) (Instance? t)
(Struct? s) (Struct? t)
(App? s) (App? t))
(cons (seen-before s t) A)
A))
(define (seen? ss st cs)
(for/or ([i (in-list cs)])
(and (eq? ss (car i)) (eq? st (cdr i)))))
(define-syntax-rule (remember t1 t2 A)
(cons (cons t1 t2) A))
(define-syntax-rule (remember* t1s/t2s A)
(append t1s/t2s A))
(define-syntax-rule (seen? t1 t2 seen-ts)
(let ([seq1 (Rep-seq t1)]
[seq2 (Rep-seq t2)])
(for/or ([p (in-list seen-ts)])
(and (= (Rep-seq (car p)) seq1)
(= (Rep-seq (cdr p)) seq2)))))

5
typed-racket-lib/typed-racket/types/kw-types.rkt
View File

@ -1,6 +1,9 @@
#lang racket/base
(require "abbrev.rkt" "../rep/type-rep.rkt"
(require "abbrev.rkt"
"../rep/core-rep.rkt"
"../rep/type-rep.rkt"
"../rep/values-rep.rkt"
"../utils/tc-utils.rkt"
"../base-env/annotate-classes.rkt"
"tc-result.rkt"

17
typed-racket-lib/typed-racket/types/match-expanders.rkt
View File

@ -3,7 +3,7 @@
(require "../utils/utils.rkt")
(require (rep type-rep rep-utils)
(require (rep type-rep values-rep rep-utils)
racket/match
(types resolve)
(contract-req)
@ -18,12 +18,9 @@
(lambda (stx)
(syntax-parse stx
[(_ elem-pat (~optional var-pat #:defaults ([var-pat #'var])))
;; Note: in practice it's unlikely that the second pattern will ever come up
;; because the sequence number for '() will be low and the union will
;; be sorted by sequence number. As a paranoid precaution, however,
;; we will match against both patterns here.
(syntax/loc stx (or (Mu: var-pat (Union: (list (Value: '()) (Pair: elem-pat (F: var-pat)))))
(Mu: var-pat (Union: (list (Pair: elem-pat (F: var-pat)) (Value: '()))))))])))
(syntax/loc stx
(or (Mu: var-pat (Union: (list (Value: '()) (Pair: elem-pat (F: var-pat)))))
(Mu: var-pat (Union: (list (Pair: elem-pat (F: var-pat)) (Value: '()))))))])))
(define-match-expander List:
(lambda (stx)
@ -33,15 +30,15 @@
[(_ elem-pats #:tail tail-pat)
#'(? Type? (app untuple (? values elem-pats) tail-pat))])))
;; Type/c -> (or/c (values/c #f #f) (values/c (listof Type/c) Type/c)))
;; Type? -> (or/c (values/c #f #f) (values/c (listof Type?) Type?)))
;; Returns the prefix of types that are consed on to the last type (a non finite-pair type).
;; The last type may contain pairs if it is a list type.
(define (untuple t)
(let loop ((t t) (seen (set)))
(if (not (set-member? seen (Type-seq t)))
(if (not (set-member? seen (Rep-seq t)))
(match (resolve t)
[(Pair: a b)
(define-values (elems tail) (loop b (set-add seen (Type-seq t))))
(define-values (elems tail) (loop b (set-add seen (Rep-seq t))))
(values (cons a elems) tail)]
[_ (values null t)])
(values null t))))

181
typed-racket-lib/typed-racket/types/overlap.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep rep-utils)
(rep type-rep rep-utils type-mask)
(prefix-in c: (contract-req))
(types abbrev subtype resolve utils)
racket/match racket/set)
racket/match)
(provide overlap?)
@ -38,100 +38,99 @@
;; a conservative check to see if two types
;; have a non-empty intersection
(define/cond-contract (overlap? t1 t2)
(c:-> Type/c Type/c boolean?)
(define k1 (Type-key t1))
(define k2 (Type-key t2))
(c:-> Type? Type? boolean?)
(cond
[(type-equal? t1 t2) #t]
[(and (symbol? k1) (symbol? k2) (not (eq? k1 k2))) #f]
[(and (symbol? k1) (pair? k2) (not (memq k1 k2))) #f]
[(and (symbol? k2) (pair? k1) (not (memq k2 k1))) #f]
[(and (pair? k1) (pair? k2)
(for/and ([i (in-list k1)]) (not (memq i k2))))
#f]
[(disjoint-masks? (Type-mask t1) (Type-mask t2)) #f]
[(seen? t1 t2) #t]
[else
(with-updated-seen
t1 t2
(match*/no-order
(t1 t2)
[((Univ:) _) #:no-order #t]
[((or (B: _) (F: _)) _) #:no-order #t]
[((Opaque: _) _) #:no-order #t]
[((Name/simple: n) (Name/simple: n*))
(or (free-identifier=? n n*)
(overlap? (resolve-once t1) (resolve-once t2)))]
[(t (? Name? s))
#:no-order
(overlap? t (resolve-once s))]
[((? Mu? t) s) #:no-order (overlap? (unfold t) s)]
[((Refinement: t _) s) #:no-order (overlap? t s)]
[((Union: ts) s)
#:no-order
(ormap (λ (t) (overlap? t s)) ts)]
[((Intersection: ts) s)
#:no-order
(for/and ([t (in-immutable-set ts)])
(overlap? t s))]
[((? Poly?) _) #:no-order #t] ;; conservative
[((Base: s1 _ _ _) (Base: s2 _ _ _)) (or (subtype t1 t2) (subtype t2 t1))]
[((? Base? t) (? Value? s)) #:no-order (subtype s t)] ;; conservative
[((Syntax: t) (Syntax: t*)) (overlap? t t*)]
[((Syntax: _) _) #:no-order #f]
[((Base: _ _ _ _) _) #:no-order #f]
[((Value: (? pair?)) (Pair: _ _)) #:no-order #t]
[((Pair: a b) (Pair: a* b*)) (and (overlap? a a*)
(overlap? b b*))]
;; lots of things are sequences, but not values where sequence? produces #f
[((Sequence: _) (Value: v)) #:no-order (sequence? v)]
;; hash tables are two-valued sequences
[((Sequence: (or (list _) (list _ _ _ ...)))
(or (? Hashtable?) (? HashtableTop?)))
#:no-order
#f]
;; these are single-valued sequences
[((Sequence: (list _ _ _ ...))
(or (? Pair?) (? Vector?) (? VectorTop?)))
#:no-order
#f]
;; be conservative about other kinds of sequences
[((Sequence: _) _) #:no-order #t]
;; Values where evt? produces #f cannot be Evt
[((Evt: _) (Value: v)) #:no-order (evt? v)]
[((Pair: _ _) _) #:no-order #f]
[((Value: (? simple-datum? v1))
(Value: (? simple-datum? v2)))
(equal? v1 v2)]
[((Value: (? simple-datum?))
(or (? Struct?) (? StructTop?) (? Function?)))
#:no-order
#f]
[((Value: (not (? hash?)))
(or (? Hashtable?) (? HashtableTop?)))
#:no-order
#f]
[((Struct: n _ flds _ _ _)
(Struct: n* _ flds* _ _ _))
#:when (free-identifier=? n n*)
(for/and ([f (in-list flds)] [f* (in-list flds*)])
(match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap? t t*)]))]
[((Struct: n #f _ _ _ _)
(StructTop: (Struct: n* #f _ _ _ _)))
#:when (free-identifier=? n n*)
#t]
;; n and n* must be different, so there's no overlap
[((Struct: n #f flds _ _ _)
(Struct: n* #f flds* _ _ _))
#f]
[((Struct: n #f flds _ _ _)
(StructTop: (Struct: n* #f flds* _ _ _)))
#f]
[((and t1 (Struct: _ _ _ _ _ _))
(and t2 (Struct: _ _ _ _ _ _)))
(or (subtype t1 t2) (subtype t2 t1)
(parent-of? t1 t2) (parent-of? t2 t1))]
[(_ _) #t]))]))
t1 t2
(match*/no-order
(t1 t2)
[((Univ:) _) #:no-order #t]
[((or (B: _) (F: _)) _) #:no-order #t]
[((Opaque: _) _) #:no-order #t]
[((Name/simple: n) (Name/simple: n*))
(or (free-identifier=? n n*)
(overlap? (resolve-once t1) (resolve-once t2)))]
[(t (or (? Name? s)
(? App? s)))
#:no-order
(overlap? t (resolve-once s))]
[((? Mu? t) s) #:no-order (overlap? (unfold t) s)]
[((Refinement: t _) s) #:no-order (overlap? t s)]
[((Union: ts) s)
#:no-order
(ormap (λ (t) (overlap? t s)) ts)]
[((Intersection: ts) s)
#:no-order
(for/and ([t (in-list ts)])
(overlap? t s))]
[((or (Poly-unsafe: _ t1)
(PolyDots-unsafe: _ t1))
t2)
#:no-order
(overlap? t1 t2)] ;; conservative
[((Base: s1 _ _ _) (Base: s2 _ _ _)) (or (subtype t1 t2) (subtype t2 t1))]
[((? Base? t) (? Value? s)) #:no-order (subtype s t)] ;; conservative
[((Syntax: t) (Syntax: t*)) (overlap? t t*)]
[((Syntax: _) _) #:no-order #f]
[((Base: _ _ _ _) _) #:no-order #f]
[((Value: (? pair?)) (Pair: _ _)) #:no-order #t]
[((Pair: a b) (Pair: a* b*)) (and (overlap? a a*)
(overlap? b b*))]
;; lots of things are sequences, but not values where sequence? produces #f
[((Sequence: _) (Value: v)) #:no-order (sequence? v)]
;; hash tables are two-valued sequences
[((Sequence: (or (list _) (list _ _ _ ...)))
(or (? Hashtable?) (? HashtableTop?)))
#:no-order
#f]
;; these are single-valued sequences
[((Sequence: (list _ _ _ ...))
(or (? Pair?) (? Vector?) (? VectorTop?)))
#:no-order
#f]
;; be conservative about other kinds of sequences
[((Sequence: _) _) #:no-order #t]
;; Values where evt? produces #f cannot be Evt
[((Evt: _) (Value: v)) #:no-order (evt? v)]
[((Pair: _ _) _) #:no-order #f]
[((Value: (? simple-datum? v1))
(Value: (? simple-datum? v2)))
(equal? v1 v2)]
[((Value: (? simple-datum?))
(or (? Struct?) (? StructTop?) (? Function?)))
#:no-order
#f]
[((Value: (not (? hash?)))
(or (? Hashtable?) (? HashtableTop?)))
#:no-order
#f]
[((Struct: n _ flds _ _ _)
(Struct: n* _ flds* _ _ _))
#:when (free-identifier=? n n*)
(for/and ([f (in-list flds)] [f* (in-list flds*)])
(match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap? t t*)]))]
[((Struct: n #f _ _ _ _)
(StructTop: (Struct: n* #f _ _ _ _)))
#:when (free-identifier=? n n*)
#t]
;; n and n* must be different, so there's no overlap
[((Struct: n #f flds _ _ _)
(Struct: n* #f flds* _ _ _))
#f]
[((Struct: n #f flds _ _ _)
(StructTop: (Struct: n* #f flds* _ _ _)))
#f]
[((and t1 (Struct: _ _ _ _ _ _))
(and t2 (Struct: _ _ _ _ _ _)))
(or (subtype t1 t2) (subtype t2 t1)
(parent-of? t1 t2) (parent-of? t2 t1))]
[(_ _) #t]))]))
;; Type Type -> Boolean
;; Given two struct types, check if the second is a parent struct

90
typed-racket-lib/typed-racket/types/path-type.rkt
View File

@ -3,7 +3,7 @@
(require "../utils/utils.rkt"
racket/match racket/set
(contract-req)
(rep object-rep type-rep)
(rep object-rep type-rep values-rep)
(utils tc-utils)
(typecheck renamer)
(types subtype resolve union)
@ -12,7 +12,7 @@
(require-for-cond-contract (rep rep-utils))
(provide/cond-contract
[path-type ((listof PathElem?) Type/c . -> . Type/c)])
[path-type ((listof PathElem?) Type? . -> . (or/c Type? #f))])
;; returns the result of following a path into a type
@ -24,48 +24,62 @@
;; It is intentionally reset each time we decrease the
;; paths size on a recursive call, and maintained/extended
;; when the path does not decrease on a recursive call.
(define (path-type path t [resolved (set)])
(match* (t path)
;; empty path
[(t (list)) t]
(define (path-type path t)
(let path-type ([path (reverse path)]
[t t]
[resolved (hash)])
(match* (t path)
;; empty path
[(t (list)) t]
;; pair ops
[((Pair: t s) (list rst ... (CarPE:)))
(path-type rst t)]
[((Pair: t s) (list rst ... (CdrPE:)))
(path-type rst s)]
;; pair ops
[((Pair: t s) (cons (CarPE:) rst))
(path-type rst t (hash))]
[((Pair: t s) (cons (CdrPE:) rst))
(path-type rst s (hash))]
;; syntax ops
[((Syntax: t) (list rst ... (SyntaxPE:)))
(path-type rst t)]
;; syntax ops
[((Syntax: t) (cons (SyntaxPE:) rst))
(path-type rst t (hash))]
;; promise op
[((Promise: t) (list rst ... (ForcePE:)))
(path-type rst t)]
;; promise op
[((Promise: t) (cons (ForcePE:) rst))
(path-type rst t (hash))]
;; struct ops
[((Struct: nm par flds proc poly pred)
(list rst ... (StructPE: (? (λ (s) (subtype t s)) s) idx)))
(match-let ([(fld: ft _ _) (list-ref flds idx)])
(path-type rst ft))]
;; struct ops
[((Struct: nm par flds proc poly pred) (cons (StructPE: struct-ty idx) rst))
#:when (subtype t struct-ty)
(match-let ([(fld: ft _ _) (list-ref flds idx)])
(path-type rst ft (hash)))]
[((Intersection: ts) _)
(apply -unsafe-intersect (for*/list ([t (in-list ts)]
[t (in-value (path-type path t resolved))]
#:when t)
t))]
[((Union: ts) _)
(apply Un (for*/list ([t (in-list ts)]
[t (in-value (path-type path t resolved))]
#:when t)
t))]
[((Union: ts) _)
(apply Un (map (λ (t) (path-type path t resolved)) ts))]
;; paths into polymorphic types
;; TODO can this expose unbound type indices... probably. It should be
;; shielded with a check for type indexes/variables/whatever.
[((Poly: _ body-t) _) (path-type path body-t resolved)]
[((PolyDots: _ body-t) _) (path-type path body-t resolved)]
[((PolyRow: _ _ body-t) _) (path-type path body-t resolved)]
[((Distinction: _ _ t) _) (path-type path t resolved)]
;; paths into polymorphic types
[((Poly: _ body-t) _) (path-type path body-t resolved)]
[((PolyDots: _ body-t) _) (path-type path body-t resolved)]
[((PolyRow: _ _ body-t) _) (path-type path body-t resolved)]
;; for private fields in classes
[((Function: (list (arr: doms (Values: (list (Result: rng _ _))) _ _ _)))
(list rst ... (FieldPE:)))
(path-type rst rng)]
;; for private fields in classes
[((Function: (list (arr: doms (Values: (list (Result: rng _ _))) _ _ _)))
(cons (FieldPE:) rst))
(path-type rst rng (hash))]
;; types which need resolving
[((? needs-resolving?) _) #:when (not (set-member? resolved t))
(path-type path (resolve-once t) (set-add resolved t))]
;; types which need resolving
[((? resolvable?) _) #:when (not (hash-ref resolved t #f))
(path-type path (resolve-once t) (hash-set resolved t #t))]
;; type/path mismatch =(
[(_ _) Err]))
;; type/path mismatch =(
[(_ _) #f])))

202
typed-racket-lib/typed-racket/types/printer.rkt
View File

@ -8,13 +8,15 @@
racket/list
racket/set
(path-up "rep/type-rep.rkt" "rep/prop-rep.rkt" "rep/object-rep.rkt"
"rep/rep-utils.rkt" "types/subtype.rkt"
"rep/core-rep.rkt" "rep/values-rep.rkt"
"rep/rep-utils.rkt" "types/subtype.rkt" "types/overlap.rkt"
"types/match-expanders.rkt"
"types/kw-types.rkt"
"types/utils.rkt"
"types/utils.rkt" "types/abbrev.rkt"
"types/resolve.rkt"
"types/prefab.rkt"
"utils/utils.rkt"
"utils/primitive-comparison.rkt"
"utils/tc-utils.rkt")
(for-syntax racket/base syntax/parse))
@ -25,11 +27,14 @@
(if (eq? printer-type 'debug)
#'(provide (rename-out [debug-printer print-type]
[debug-printer print-prop]
[debug-printer print-propset]
[debug-printer print-values]
[debug-printer print-result]
[debug-printer print-object]
[debug-printer print-pathelem]
[debug-pretty-format-type pretty-format-type]))
#'(provide print-type print-prop print-object print-pathelem
pretty-format-type)))
[debug-pretty-format-type pretty-format-rep]))
#'(provide print-type print-prop print-propset print-object print-pathelem
pretty-format-rep print-values print-result)))
(provide-printer)
(provide print-complex-props? type-output-sexpr-tweaker
@ -76,12 +81,23 @@
(define (print-pathelem pe port write?)
(display (pathelem->sexp pe) port))
(define (print-prop prop port write?)
(display (prop->sexp prop) port))
(define (print-propset prop port write?)
(display (propset->sexp prop) port))
(define (print-object obj port write?)
(display (object->sexp obj) port))
(define (print-result res port write?)
(display (result->sexp res) port))
(define (print-values vals port write?)
(display (values->sexp vals) port))
;; Table for formatting pretty-printed types
(define type-style-table
(pretty-print-extend-style-table
@ -89,28 +105,31 @@
;; pretty-format-type : Type -> String
;; Formats the type using pretty printing
(define (pretty-format-type type #:indent [indent 0])
(define (pretty-format-rep rep #:indent [indent 0])
(define out (open-output-string))
(port-count-lines! out)
(write-string (make-string indent #\space) out)
(parameterize ([pretty-print-current-style-table type-style-table])
(pretty-display ((type-output-sexpr-tweaker) (type->sexp type '()))
(pretty-display ((type-output-sexpr-tweaker) (match rep
[(? Type?) (type->sexp rep '())]
[(? SomeValues?) (values->sexp rep)]
[(? Result?) (result->sexp rep)]))
out))
(string-trim #:left? #f (substring (get-output-string out) indent)))
(define name-ref->sexp
(match-lambda
[(? syntax? name-ref) (syntax-e name-ref)]
[(cons lvl arg) `(,lvl ,arg)]))
;; prop->sexp : Prop -> S-expression
;; Print a Prop (see prop-rep.rkt) to the given port
(define (prop->sexp filt)
(define (name-ref->sexp name-ref)
(if (syntax? name-ref)
(syntax-e name-ref)
name-ref))
(define (prop->sexp prop)
(define (path->sexps path)
(if (null? path)
'()
(list (map pathelem->sexp path))))
(match filt
[(PropSet: thn els) `(,(prop->sexp thn) \| ,(prop->sexp els))]
(match prop
[(NotTypeProp: (Path: path nm) type)
`(! ,(type->sexp type) @ ,@(path->sexps path) ,(name-ref->sexp nm))]
[(TypeProp: (Path: path nm) type)
@ -119,7 +138,7 @@
[(FalseProp:) 'Bot]
[(AndProp: a) `(AndProp ,@(map prop->sexp a))]
[(OrProp: a) `(OrProp ,@(map prop->sexp a))]
[else `(Unknown Prop: ,(struct->vector filt))]))
[else `(Unknown Prop: ,(struct->vector prop))]))
;; pathelem->sexp : PathElem -> S-expression
;; Print a PathElem (see object-rep.rkt) to the given port
@ -137,7 +156,7 @@
(define (object->sexp object)
(match object
[(Empty:) '-]
[(Path: pes i) (append (map pathelem->sexp pes) (list i))]
[(Path: pes n) (append (map pathelem->sexp pes) (list (name-ref->sexp n)))]
[else `(Unknown Object: ,(struct->vector object))]))
;; cover-union : Type LSet<Type> -> Listof<Symbol> Listof<Type>
@ -218,39 +237,48 @@
(if rest `(,(type->sexp rest) *) null)
(if drest `(,(type->sexp (car drest)) ... ,(cdr drest)) null)
(match rng
[(AnyValues: (TrueProp:)) '(AnyValues)]
[(AnyValues: f) `(AnyValues : ,(prop->sexp f))]
[(Values: (list (Result: t (PropSet: (TrueProp:) (TrueProp:)) (Empty:))))
[(AnyValues: (? TrueProp?)) '(AnyValues)]
[(AnyValues: p) `(AnyValues : ,(prop->sexp p))]
[(Values: (or (list (Result: t (PropSet: (? TrueProp?) (? TrueProp?)) (? Empty?)))
(list (Result: (and (== -False) t) (PropSet: (? FalseProp?) (? TrueProp?)) (? Empty?)))
(list (Result: (and t (app (λ (t) (overlap? t -False)) #f))
(PropSet: (? TrueProp?) (? FalseProp?))
(? Empty?)))))
(list (type->sexp t))]
[(Values: (list (Result: t
(PropSet: (TypeProp: (Path: pth (list 0 0)) ft)
(NotTypeProp: (Path: pth (list 0 0)) ft))
(Empty:))))
(PropSet:
(TypeProp: (Path: pth1 (cons 0 0)) ft1)
(NotTypeProp: (Path: pth2 (cons 0 0)) ft2))
(? Empty?))))
;; Only print a simple prop for single argument functions,
;; since parse-type only accepts simple latent props on single
;; argument functions.
#:when (= 1 (length dom))
(if (null? pth)
`(,(type->sexp t) : ,(type->sexp ft))
`(,(type->sexp t) : ,(type->sexp ft) @
,@(map pathelem->sexp pth)))]
#:when (and (equal? pth1 pth2)
(equal? ft1 ft2)
(= 1 (length dom)))
(if (null? pth1)
`(,(type->sexp t) : ,(type->sexp ft1))
`(,(type->sexp t) : ,(type->sexp ft1) @
,@(map pathelem->sexp pth1)))]
;; Print asymmetric props with only a positive prop as a
;; special case (even when complex printing is off) because it's
;; useful to users who use functions like `prop`.
[(Values: (list (Result: t
(PropSet: (TypeProp: (Path: '() (list 0 0)) ft) (TrueProp:))
(Empty:))))
(PropSet:
(TypeProp: (Path: '() (cons 0 0)) ft)
(? TrueProp?))
(? Empty?))))
#:when (= 1 (length dom))
`(,(type->sexp t) : #:+ ,(type->sexp ft))]
[(Values: (list (Result: t fs (Empty:))))
[(Values: (list (Result: t ps (? Empty?))))
(if (print-complex-props?)
`(,(type->sexp t) : ,(prop->sexp fs))
`(,(type->sexp t) : ,(propset->sexp ps))
(list (type->sexp t)))]
[(Values: (list (Result: t lf lo)))
[(Values: (list (Result: t ps o)))
(if (print-complex-props?)
`(,(type->sexp t) : ,(prop->sexp lf) ,(object->sexp lo))
`(,(type->sexp t) : ,(propset->sexp ps) ,(object->sexp o))
(list (type->sexp t)))]
[_ (list (type->sexp rng))]))]
[_ (list (values->sexp rng))]))]
[else `(Unknown Function Type: ,(struct->vector arr))]))
;; format->* : (Listof arr) -> S-Expression
@ -275,7 +303,7 @@
(match-define (Keyword: k t _) opt-kw)
(list k (type->sexp t))))
,@(if rst (list '#:rest (type->sexp rst)) null)
,(type->sexp rng))]))
,(values->sexp rng))]))
;; cover-case-lambda : (Listof arr) -> (Listof s-expression)
;; Try to cover a case-> type with ->* types
@ -356,6 +384,49 @@
`(,(if object? 'Object 'Class)
,@row-var* ,@inits* ,@init-rest* ,@fields* ,@methods* ,@augments*))
;; result->sexp : Result -> S-expression
;; convert a result to an s-expression that can be printed
(define (result->sexp res)
(match res
[(Result: t
(or 'none (PropSet: (? TrueProp?) (? TrueProp?)))
(or 'none (? Empty?)))
(type->sexp t)]
[(Result: t ps (? Empty?)) `(,(type->sexp t) : ,(propset->sexp ps))]
[(Result: t ps lo) `(,(type->sexp t) :
,(propset->sexp ps) :
,(object->sexp lo))]
[else `(Unknown Result: ,(struct->vector res))]))
;; propset->sexp : Result -> S-expression
;; convert a prop set to an s-expression that can be printed
(define (propset->sexp ps)
(match ps
[(PropSet: thn els) `(,(prop->sexp thn) \| ,(prop->sexp els))]
[else `(Unknown PropSet: ,(struct->vector ps))]))
;; values->sexp : SomeValues -> S-expression
;; convert a values to an s-expression that can be printed
(define (values->sexp v)
(match v
[(AnyValues: (? TrueProp?)) 'AnyValues]
[(AnyValues: p) `(AnyValues : ,(prop->sexp p))]
[(Values: (list v)) v]
[(Values: vals) (cons 'values (map result->sexp vals))]
[(ValuesDots: v dty dbound)
(cons 'values (append (map result->sexp v)
(list (type->sexp dty) '... dbound)))]
[else `(Unknown SomeValues: ,(struct->vector v))]))
;; signature->sexp : Signature -> S-expression
;; convert a values to an s-expression that can be printed
(define (signature->sexp s)
(match s
[(Signature: name extends mapping)
(syntax->datum name)]
[else `(Unknown Signature: ,(struct->vector s))]))
;; type->sexp : Type -> S-expression
;; convert a type to an s-expression that can be printed
(define (type->sexp type [ignored-names '()])
@ -373,12 +444,8 @@
[(Pair: a e) (cons a (tuple-elems e))]
[(Value: '()) null]))
(match type
;; if we know how it was written, print that
[(? Rep-stx a)
(if (Error? a)
`(Error ,(syntax->datum (Rep-stx a)))
(syntax->datum (Rep-stx a)))]
[(Univ:) 'Any]
[(Bottom:) 'Nothing]
;; struct names are just printed as the original syntax
[(Name/struct: id) (syntax-e id)]
;; If a type has a name, then print it with that name.
@ -401,12 +468,15 @@
(set-box! (current-print-unexpanded)
(cons (car names) (unbox (current-print-unexpanded)))))
(car names)])]
[(? Base?) (Base-name type)]
[(StructType: (Struct: nm _ _ _ _ _)) `(StructType ,(syntax-e nm))]
;; this case occurs if the contained type is a type variable
[(StructType: ty) `(Struct-Type ,(t->s ty))]
[(StructTypeTop:) 'Struct-TypeTop]
[(StructTop: (Struct: nm _ _ _ _ _)) `(Struct ,(syntax-e nm))]
[(Prefab: key fields) `(Prefab ,(abbreviate-prefab-key key) ,@fields)]
[(Prefab: key field-types)
`(Prefab ,(abbreviate-prefab-key key)
,@(map t->s field-types))]
[(BoxTop:) 'BoxTop]
[(Weak-BoxTop:) 'Weak-BoxTop]
[(ChannelTop:) 'ChannelTop]
@ -433,7 +503,6 @@
[(Value: v) (format "~v" v)]
[(? tuple? t)
`(List ,@(map type->sexp (tuple-elems t)))]
[(Base: n cnt _ _) n]
[(Opaque: pred) `(Opaque ,(syntax->datum pred))]
[(Struct: nm par (list (fld: t _ _) ...) proc _ _)
`#(,(string->symbol (format "struct:~a" (syntax-e nm)))
@ -459,19 +528,12 @@
[(Evt: r) `(Evtof ,(t->s r))]
[(Union: elems)
(define-values (covered remaining) (cover-union type ignored-names))
(cons 'U (append covered (map t->s remaining)))]
(cons 'U (sort (append covered (map t->s remaining)) primitive<=?))]
[(Intersection: elems)
(cons '∩ (for/list ([elem (in-immutable-set elems)]) (t->s elem)))]
(cons '∩ (sort (map t->s elems) primitive<=?))]
[(Pair: l r) `(Pairof ,(t->s l) ,(t->s r))]
[(ListDots: dty dbound) `(List ,(t->s dty) ... ,dbound)]
[(F: nm) nm]
;; FIXME (Values are not types and shouldn't need to be considered here
[(AnyValues: (TrueProp:)) 'AnyValues]
[(AnyValues: f) `(AnyValues : ,(prop->sexp f))]
[(Values: (list v)) v]
[(Values: (list v ...)) (cons 'values (map t->s v))]
[(ValuesDots: v dty dbound)
(cons 'values (append (map t->s v) (list (t->s dty) '... dbound)))]
[(Param: in out)
(if (equal? in out)
`(Parameterof ,(t->s in))
@ -488,6 +550,7 @@
;; FIXME: should this print constraints too
[(PolyRow-names: names _ body)
`(All (,(car names) #:row) ,(t->s body))]
;; x1 --> ()
[(Mu: x (Syntax: (Union: (list
(Base: 'Number _ _ _)
(Base: 'Boolean _ _ _)
@ -510,28 +573,20 @@
[(? Class?) (class->sexp type)]
[(Unit: (list imports ...) (list exports ...) (list init-depends ...) body)
`(Unit
(import ,@(map t->s imports))
(export ,@(map t->s exports))
(init-depend ,@(map t->s init-depends))
,(t->s body))]
[(Signature: name extends mapping)
(syntax->datum name)]
[(Result: t
(or #f (PropSet: (TrueProp:) (TrueProp:)))
(or #f (Empty:))) (type->sexp t)]
[(Result: t fs (Empty:)) `(,(type->sexp t) : ,(prop->sexp fs))]
[(Result: t fs lo) `(,(type->sexp t) : ,(prop->sexp fs) : ,(object->sexp lo))]
(import ,@(map signature->sexp imports))
(export ,@(map signature->sexp exports))
(init-depend ,@(map signature->sexp init-depends))
,(values->sexp body))]
[(MPair: s t) `(MPairof ,(t->s s) ,(t->s t))]
[(Refinement: parent p?)
`(Refinement ,(t->s parent) ,(syntax-e p?))]
[(Sequence: ts)
`(Sequenceof ,@(map t->s ts))]
[(Error:) 'Error]
[(fld: t a m) `(fld ,(type->sexp t))]
;[(fld: t a m) `(fld ,(type->sexp t))]
[(Distinction: name sym ty) ; from define-new-subtype
name]
[else `(Unknown Type: ,(struct->vector type))]
))
[else `(Unknown Type: ,(struct->vector type))]))
@ -540,12 +595,22 @@
[(_ debug-printer:id)
#:when (eq? printer-type 'debug)
#'(begin
(require racket/pretty
typed-racket/env/init-envs)
(require racket/pretty)
(require mzlib/pconvert)
(define (converter v basic sub)
(define (gen-constructor sym)
(string->symbol (string-append "make-" (substring (symbol->string sym) 7))))
(match v
[(? Rep? rep)
`(,(gen-constructor (car (vector->list (struct->vector rep))))
,@(map sub (Rep-values rep)))]
[_ (basic v)]))
(define (debug-printer v port write?)
((if write? pretty-write pretty-print)
(syntax->datum (datum->syntax #f (type->sexp v)))
(parameterize ((current-print-convert-hook converter))
(print-convert v))
port)))]
[_ #'(begin)]))
@ -566,4 +631,3 @@
#'(void))]))
(define-debug-pretty-format-type debug-pretty-format-type)

351
typed-racket-lib/typed-racket/types/prop-ops.rkt
View File

@ -3,9 +3,10 @@
(require "../utils/utils.rkt"
racket/list racket/match
(prefix-in c: (contract-req))
(rep type-rep prop-rep object-rep rep-utils)
(rep type-rep prop-rep object-rep values-rep rep-utils)
(only-in (infer infer) intersect)
(types union subtype overlap abbrev tc-result))
compatibility/mlist
(types union subtype overlap subtract abbrev tc-result))
(provide/cond-contract
[-and (c:->* () #:rest (c:listof Prop?) Prop?)]
@ -14,37 +15,85 @@
[negate-prop (c:-> Prop? Prop?)]
[complementary? (c:-> Prop? Prop? boolean?)]
[contradictory? (c:-> Prop? Prop? boolean?)]
[add-unconditional-prop-all-args (c:-> Function? Type/c Function?)]
[add-unconditional-prop-all-args (c:-> Function? Type? Function?)]
[add-unconditional-prop (c:-> tc-results/c Prop? tc-results/c)]
[erase-props (c:-> tc-results/c tc-results/c)]
[name-ref=? (c:-> name-ref/c name-ref/c boolean?)])
[name-ref=? (c:-> name-ref/c name-ref/c boolean?)]
[reduce-propset/type (c:-> PropSet? Type? PropSet?)]
[reduce-tc-results/subsumption (c:-> tc-results/c tc-results/c)])
;; reduces a PropSet 'ps' with info from the type 't'
;; so the two are consistent (e.g. if the type is False,
;; its true proposition is -ff, etc)
(define (reduce-propset/type ps t)
(cond
[(type-equal? -Bottom t) -ff-propset]
[(type-equal? -False t) (-PS -ff (PropSet-els ps))]
[(not (overlap? t -False)) (-PS (PropSet-thn ps) -ff)]
[else ps]))
;; reduce-tc-result/subsumption
;;
;; tc-result -> tc-result
;;
;; Update the tc-result to incorporate the
;; return type in the proposition (i.e. if it
;; can't be False, then the else prop should be -ff)
(define (reduce-tc-results/subsumption res)
(define (update-ps t ps obj)
(cond
[(Bottom? t) (tc-result t -ff-propset -empty-obj)]
[else
(define p+ (if ps (PropSet-thn ps) -tt))
(define p- (if ps (PropSet-els ps) -tt))
(define o (if obj obj -empty-obj))
(cond
[(or (type-equal? -False t)
(FalseProp? p+))
(tc-result (intersect t -False) (-PS -ff p-) o)]
[(not (overlap? t -False))
(tc-result t (-PS p+ -ff) o)]
[(prop-equal? -ff p-) (tc-result (subtract t -False) (-PS p+ -ff) o)]
[else (tc-result t (-PS p+ p-) o)])]))
(match res
[(tc-any-results: _) res]
[(tc-results: ts pss os)
(tc-results (map update-ps ts pss os) #f)]
[(tc-results: ts pss os dt db)
(tc-results (map update-ps ts pss os) (cons dt db))]
[_ (error 'reduce-tc-results/subsumption
"invalid res in subst-tc-results: ~a"
res)]))
(define (atomic-prop? p)
(or (TypeProp? p) (NotTypeProp? p)
(TrueProp? p) (FalseProp? p)))
;; contradictory: Prop? Prop? -> boolean?
;; Returns true if the AND of the two props is equivalent to FalseProp
(define (contradictory? f1 f2)
(match* (f1 f2)
[((TypeProp: o t1) (NotTypeProp: o t2))
(define (contradictory? p1 p2)
(match* (p1 p2)
[((TypeProp: o1 t1) (TypeProp: o2 t2))
#:when (object-equal? o1 o2)
(not (overlap? t1 t2))]
[((TypeProp: o1 t1) (NotTypeProp: o2 t2))
#:when (object-equal? o1 o2)
(subtype t1 t2)]
[((NotTypeProp: o t2) (TypeProp: o t1))
[((NotTypeProp: o2 t2) (TypeProp: o1 t1))
#:when (object-equal? o1 o2)
(subtype t1 t2)]
[((FalseProp:) _) #t]
[(_ (FalseProp:)) #t]
[(_ _) #f]))
[(_ _) (or (prop-equal? p1 -ff)
(prop-equal? p2 -ff))]))
;; complementary: Prop? Prop? -> boolean?
;; Returns true if the OR of the two props is equivalent to Top
(define (complementary? f1 f2)
(match* (f1 f2)
[((TypeProp: o t1) (NotTypeProp: o t2))
(define (complementary? p1 p2)
(match* (p1 p2)
[((TypeProp: o1 t1) (NotTypeProp: o2 t2))
#:when (object-equal? o1 o2)
(subtype t2 t1)]
[((NotTypeProp: o t2) (TypeProp: o t1))
[((NotTypeProp: o2 t2) (TypeProp: o1 t1))
#:when (object-equal? o1 o2)
(subtype t2 t1)]
[((TrueProp:) (TrueProp:)) #t]
[(_ _) #f]))
[(_ _) (or (prop-equal? p1 -tt)
(prop-equal? p2 -tt))]))
(define (name-ref=? a b)
(or (equal? a b)
@ -56,73 +105,94 @@
(define (implies-atomic? p q)
(match* (p q)
;; reflexivity
[(p p) #t]
;; trivial prop is always satisfied
[(_ (TrueProp:)) #t]
;; ex falso quodlibet
[((FalseProp:) _) #t]
[(_ _) #:when (or (prop-equal? p q)
(prop-equal? q -tt)
(prop-equal? p -ff)) #t]
;; ps ⊆ qs ?
[((OrProp: ps) (OrProp: qs))
(and (for/and ([p (in-list ps)])
(member p qs prop-equal?))
#t)]
;; p ∈ qs ?
[(p (OrProp: qs))
(and (member p qs prop-equal?) #t)]
[(p (OrProp: qs)) (and (member p qs prop-equal?) #t)]
;; q ∈ ps ?
[((AndProp: ps) q)
(and (member q ps prop-equal?) #t)]
[((AndProp: ps) q) (and (member q ps prop-equal?) #t)]
;; t1 <: t2 ?
[((TypeProp: o t1) (TypeProp: o t2))
[((TypeProp: o1 t1)
(TypeProp: o2 t2))
#:when (object-equal? o1 o2)
(subtype t1 t2)]
;; t2 <: t1 ?
[((NotTypeProp: o t1) (NotTypeProp: o t2))
[((NotTypeProp: o1 t1) (NotTypeProp: o2 t2))
#:when (object-equal? o1 o2)
(subtype t2 t1)]
;; t1 ∩ t2 = ∅ ?
[((TypeProp: o t1) (NotTypeProp: o t2))
[((TypeProp: o1 t1) (NotTypeProp: o2 t2))
#:when (object-equal? o1 o2)
(not (overlap? t1 t2))]
;; otherwise we give up
[(_ _) #f]))
(define (hash-name-ref i)
(if (identifier? i) (hash-id i) i))
;; compact : (Listof prop) bool -> (Listof prop)
;; props : propositions to compress
;; or? : is this an Or (alternative is And)
;; intersect-update
;; (mlist (mcons Object Type)) Object Type -> (mlist (mcons Object Type))
;;
;; This combines all the TypeProps at the same path into one TypeProp. If it is an Or the
;; combination is done using Un, otherwise, intersect. The reverse is done for NotTypeProps. If it is
;; an Or this simplifies to -tt if any of the atomic props simplified to -tt, and removes
;; any -ff values. The reverse is done if this is an And.
;;
(define/cond-contract (compact props or?)
((c:listof Prop?) boolean? . c:-> . (c:listof Prop?))
(define tf-map (make-hash))
(define ntf-map (make-hash))
(define (intersect-update dict t1 p)
(hash-update! dict p (λ (t2) (intersect t1 t2)) Univ))
(define (union-update dict t1 p)
(hash-update! dict p (λ (t2) (Un t1 t2)) -Bottom))
;; updates mutable association list 'dict' entry for 'o' w/ type t
;; if no entry for 'o' is found, else if some previous type s is present
;; update the type to t ∩ s
(define (intersect-update dict o t)
(cond
[(massq o dict) => (λ (p)
(set-mcdr! p (intersect t (mcdr p)))
dict)]
[else (mcons (mcons o t) dict)]))
(define-values (atomics others) (partition atomic-prop? props))
(for ([prop (in-list atomics)])
(match prop
[(TypeProp: o t1)
((if or? union-update intersect-update) tf-map t1 o) ]
[(NotTypeProp: o t1)
((if or? intersect-update union-update) ntf-map t1 o) ]))
(define raw-results
(append others
(for/list ([(k v) (in-hash tf-map)]) (-is-type k v))
(for/list ([(k v) (in-hash ntf-map)]) (-not-type k v))))
(if or?
(if (member -tt raw-results)
(list -tt)
(filter-not FalseProp? raw-results))
(if (member -ff raw-results)
(list -ff)
(filter-not TrueProp? raw-results))))
;; union-update
;; (mlist (mcons Object Type)) Object Type -> (mlist (mcons Object Type))
;;
;; updates mutable association list 'dict' entry for 'o' w/ type t
;; if no entry for 'o' is found, else if some previous type s is present
;; update the type to t ∪ s
(define (union-update dict o t)
(cond
[(massq o dict) => (λ (p)
(set-mcdr! p (Un t (mcdr p)))
dict)]
[else (mcons (mcons o t) dict)]))
;; compact-or-props : (Listof prop) -> (Listof prop)
;;
;; This combines all the TypeProps at the same path into one TypeProp with Un, and
;; all of the NotTypeProps at the same path into one NotTypeProp with intersect.
;; The Or then simplifies to -tt if any of the atomic props simplified to -tt, and
;; any values of -ff are removed.
(define/cond-contract (compact-or-props props)
((c:listof Prop?) . c:-> . (c:listof Prop?))
(define-values (pos neg others)
(for/fold ([pos '()] [neg '()] [others '()])
([prop (in-list props)])
(match prop
[(TypeProp: o t)
(values (union-update pos o t) neg others)]
[(NotTypeProp: o t)
(values pos (intersect-update neg o t) others)]
[_ (values pos neg (cons prop others))])))
(let ([pos (for*/list ([p (in-mlist pos)]
[p (in-value (-is-type (mcar p) (mcdr p)))]
#:when (not (FalseProp? p)))
p)]
[neg (for*/list ([p (in-mlist neg)]
[p (in-value (-not-type (mcar p) (mcdr p)))]
#:when (not (FalseProp? p)))
p)])
(if (or (member -tt pos prop-equal?)
(member -tt neg prop-equal?))
(list -tt)
(append pos neg others))))
@ -130,76 +200,94 @@
;; Logically inverts a prop.
(define (negate-prop p)
(match p
[(FalseProp:) -tt]
[(TrueProp:) -ff]
[(? FalseProp?) -tt]
[(? TrueProp?) -ff]
[(TypeProp: o t) (-not-type o t)]
[(NotTypeProp: o t) (-is-type o t)]
[(AndProp: ps) (apply -or (map negate-prop ps))]
[(OrProp: ps) (apply -and (map negate-prop ps))]))
;; -or
;; (listof Prop?) -> Prop?
;;
;; Smart 'normalizing' constructor for disjunctions. The result
;; will be a disjunction of only atomic propositions (i.e. a clause
;; in a CNF formula)
(define (-or . args)
(define mk
(case-lambda [() -ff]
[(f) f]
[ps (make-OrProp (sort ps prop<?))]))
(define (distribute args)
(define-values (ands others) (partition AndProp? args))
(if (null? ands)
(apply mk others)
(match-let ([(AndProp: elems) (car ands)])
(apply -and (for/list ([a (in-list elems)])
(apply -or a (append (cdr ands) others)))))))
(match ands
[(cons (AndProp: elems) ands)
(apply -and (for/list ([elem (in-list elems)])
(apply -or elem (append ands others))))]
[_ (make-OrProp others)]))
(let loop ([ps args] [result null])
(if (null? ps)
(distribute (compact result #t))
(match (car ps)
[(and t (TrueProp:)) t]
[(OrProp: ps*) (loop (append ps* (cdr ps)) result)]
[(FalseProp:) (loop (cdr ps) result)]
[t
(cond [(for/or ([f (in-list (append (cdr ps) result))])
(complementary? f t))
-tt]
[(let ([t-seq (Rep-seq t)])
(for/or ([f (in-list result)])
(or (= (Rep-seq f) t-seq) (implies-atomic? t f))))
(loop (cdr ps) result)]
[else
(loop (cdr ps) (cons t result))])]))))
(match ps
[(cons p ps)
(match p
[(OrProp: ps*) (loop (append ps* ps) result)]
[(? FalseProp?) (loop ps result)]
[_
(let check-loop ([qs ps])
(match qs
[(cons q qs) (cond
[(complementary? p q) -tt]
[(implies-atomic? p q) (loop ps result)]
[else (check-loop qs)])]
[_ #:when (for/or ([q (in-list result)])
(implies-atomic? p q))
(loop ps result)]
[_ (loop ps (cons p result))]))])]
[_ (distribute (compact-or-props result))])))
;; -and
;; (listof Prop?) -> Prop?
;;
;; Smart 'normalizing' constructor for conjunctions. The result
;; will be a conjunction of only atomic propositions and disjunctions
;; (i.e. a CNF proposition)
(define (-and . args)
(define mk
(case-lambda [() -tt]
[(f) f]
[ps (make-AndProp (sort ps prop<?))]))
(define (flatten-ands ps)
(let loop ([ps ps] [results null])
(match ps
[(list) results]
[(cons (AndProp: ps*) ps) (loop ps (append ps* results))]
[(cons f ps) (loop ps (cons f results))])))
(define-values (pos neg others)
(let loop ([args args]
[pos '()]
[neg '()]
[others '()])
(match args
[(cons arg args)
(match arg
[(TypeProp: o t) (loop args (intersect-update pos o t) neg others)]
[(NotTypeProp: o t) (loop args pos (union-update neg o t) others)]
[(AndProp: ps)
(let-values ([(pos neg others) (loop ps pos neg others)])
(loop args pos neg others))]
[_ (loop args pos neg (cons arg others))])]
[_ (values pos neg others)])))
;; Move all the type props up front as they are the stronger props
(define-values (props other-args)
(partition (λ (p) (or (TypeProp? p) (NotTypeProp? p)))
(flatten-ands (remove-duplicates args eq? #:key Rep-seq))))
(define-values (type-props not-type-props)
(partition TypeProp? props))
(let loop ([ps (append type-props not-type-props other-args)] [result null])
(if (null? ps)
(apply mk (compact result #f))
(match (car ps)
[(and t (FalseProp:)) t]
[(TrueProp:) (loop (cdr ps) result)]
[t (cond [(for/or ([f (in-list (append (cdr ps) result))])
(contradictory? f t))
-ff]
[(let ([t-seq (Rep-seq t)])
(for/or ([f (in-list result)])
(or (= (Rep-seq f) t-seq)
(implies-atomic? f t))))
(loop (cdr ps) result)]
[else
(loop (cdr ps) (cons t result))])]))))
(let loop ([ps (append (for*/list ([p (in-mlist pos)]
[p (in-value (-is-type (mcar p) (mcdr p)))]
#:when (not (prop-equal? -tt p)))
p)
(for*/list ([p (in-mlist neg)]
[p (in-value (-not-type (mcar p) (mcdr p)))]
#:when (not (prop-equal? -tt p)))
p)
others)]
[result null])
(match ps
[(cons p ps)
(cond
[(let check-loop ([qs ps])
(match qs
[(cons q qs) (cond
[(contradictory? p q) -ff]
[(implies-atomic? q p) (loop ps result)]
[else (check-loop qs)])]
[_ #f]))]
[(for/or ([q (in-list result)])
(implies-atomic? q p))
(loop ps result)]
[else (loop ps (cons p result))])]
[_ (make-AndProp result)])))
;; add-unconditional-prop: tc-results? Prop? -> tc-results?
;; Ands the given proposition to the props in the tc-results.
@ -209,14 +297,17 @@
[(tc-any-results: f) (tc-any-results (-and prop f))]
[(tc-results: ts (list (PropSet: ps+ ps-) ...) os)
(ret ts
(for/list ([f+ ps+] [f- ps-])
(for/list ([f+ (in-list ps+)]
[f- (in-list ps-)])
(-PS (-and prop f+) (-and prop f-)))
os)]
[(tc-results: ts (list (PropSet: ps+ ps-) ...) os dty dbound)
(ret ts
(for/list ([f+ ps+] [f- ps-])
(-PS (-and prop f+) (-and prop f-)))
os)]))
os
dty
dbound)]))
;; ands the given type prop to both sides of the given arr for each argument
@ -254,4 +345,4 @@
(ret ts
empties
empties
dty dbound)]))
dty dbound)]))

170
typed-racket-lib/typed-racket/types/resolve.rkt
View File

@ -9,11 +9,11 @@
(contract-req)
racket/format)
(provide resolve-name resolve-app needs-resolving?
(provide resolve-name resolve-app resolvable?
resolve resolve-app-check-error
resolver-cache-remove!
current-check-polymorphic-recursion)
(provide/cond-contract [resolve-once (Type/c . -> . (or/c Type/c #f))])
(provide/cond-contract [resolve-once (Type? . -> . (or/c Type? #f))])
(define-struct poly (name vars) #:prefab)
@ -31,8 +31,7 @@
(define (resolve-name t)
(match t
[(Name/simple: n) (let ([t (lookup-type-name n)])
(if (Type/c? t) t #f))]
[(Name/simple: (app lookup-type-name t)) (if (Type? t) t #f)]
[_ (int-err "resolve-name: not a name ~a" t)]))
(define already-resolving? (make-parameter #f))
@ -48,77 +47,69 @@
"\n expected: " n
"\n given: " (length rands)
"\n arguments...: " rands)))]
[(Name/struct: n)
(when (and (current-poly-struct)
(free-identifier=? n (poly-name (current-poly-struct))))
(define num-rands (length rands))
(define num-poly (length (poly-vars (current-poly-struct))))
;; check arity of constructor first
(if (= num-rands num-poly)
(when (not (or (ormap Error? rands)
(andmap type-equal? rands
(poly-vars (current-poly-struct)))))
(tc-error (~a "structure type constructor applied to non-regular arguments"
"\n type: " rator
"\n arguments...: " rands)))
(tc-error (~a "wrong number of arguments to structure type constructor"
"\n type: " rator
"\n expected: " num-poly
"\n given: " num-rands
"\n arguments...: " rands))))]
[(Name: name-id num-args #f)
(cond [(> num-args 0)
(define num-rands (length rands))
(unless (= num-rands num-args)
(tc-error (~a "wrong number of arguments to polymorphic type"
"\n type: " rator
"\n expected: " num-args
"\n given: " num-rands
"\n arguments...: " rands)))
;; Does not allow polymorphic recursion since both type
;; inference and equirecursive subtyping for polymorphic
;; recursion are difficult.
;;
;; Type inference is known to be undecidable in general, but
;; practical algorithms do exist[1] that do not diverge in
;; practice.
;;
;; It is possible that equirecursive subtyping with polymorphic
;; recursion is as difficult as equivalence of DPDAs[2], which is
;; known to be decidable[3], but good algorithms may not exist.
;;
;; [1] Fritz Henglein. "Type inference with polymorphic recursion"
;; TOPLAS 1993
;; [2] Marvin Solomon. "Type definitions with parameters"
;; POPL 1978
;; [3] Geraud Senizergues.
;; "L(A)=L(B)? decidability results from complete formal systems"
;; TCS 2001.
;;
;; check-argument : Type Id -> Void
;; Check argument to make sure there's no polymorphic recursion
(define (check-argument given-type arg-name)
(define ok?
(or (F? given-type)
(not (member (syntax-e arg-name) (fv given-type)))))
(unless ok?
(tc-error (~a "recursive type cannot be applied at a"
" different type in its recursive invocation"
"\n type: " rator
"\n new argument name: " arg-name
"\n new argument: " given-type
"\n new arguments...: " rands))))
(match (current-check-polymorphic-recursion)
[`#s(poly-rec-info ,same-component? ,current-vars)
#:when (same-component? name-id)
(for* ([rand (in-list rands)]
[var (in-list current-vars)])
(check-argument rand var))]
[_ (void)])]
[else
(tc-error (~a "type cannot be applied"
"\n type: " rator
"\n arguments...: " rands))])]
[(Name/struct: n) #:when (and (current-poly-struct)
(free-identifier=? n (poly-name (current-poly-struct))))
(define poly-num (length (poly-vars (current-poly-struct))))
(if (= poly-num (length rands))
(when (not (or (ormap Error? rands)
(andmap type-equal? rands
(poly-vars (current-poly-struct)))))
(tc-error (~a "structure type constructor applied to non-regular arguments"
"\n type: " rator
"\n arguments...: " rands)))
(tc-error (~a "wrong number of arguments to structure type constructor"
"\n type: " rator
"\n expected: " poly-num
"\n given: " (length rands)
"\n arguments...: " rands)))]
[(Name: name-id num-args _) #:when (> num-args 0)
(define num-rands (length rands))
(unless (= num-rands num-args)
(tc-error (~a "wrong number of arguments to polymorphic type"
"\n type: " rator
"\n expected: " num-args
"\n given: " num-rands
"\n arguments...: " rands)))
;; Does not allow polymorphic recursion since both type
;; inference and equirecursive subtyping for polymorphic
;; recursion are difficult.
;;
;; Type inference is known to be undecidable in general, but
;; practical algorithms do exist[1] that do not diverge in
;; practice.
;;
;; It is possible that equirecursive subtyping with polymorphic
;; recursion is as difficult as equivalence of DPDAs[2], which is
;; known to be decidable[3], but good algorithms may not exist.
;;
;; [1] Fritz Henglein. "Type inference with polymorphic recursion"
;; TOPLAS 1993
;; [2] Marvin Solomon. "Type definitions with parameters"
;; POPL 1978
;; [3] Geraud Senizergues.
;; "L(A)=L(B)? decidability results from complete formal systems"
;; TCS 2001.
;;
;; check-argument : Type Id -> Void
;; Check argument to make sure there's no polymorphic recursion
(define (check-argument given-type arg-name)
(define ok?
(or (F? given-type)
(not (member (syntax-e arg-name) (fv given-type)))))
(unless ok?
(tc-error (~a "recursive type cannot be applied at a"
" different type in its recursive invocation"
"\n type: " rator
"\n new argument name: " arg-name
"\n new argument: " given-type
"\n new arguments...: " rands))))
(match (current-check-polymorphic-recursion)
[`#s(poly-rec-info ,same-component? ,current-vars)
#:when (same-component? name-id)
(for* ([rand (in-list rands)]
[var (in-list current-vars)])
(check-argument rand var))]
[_ (void)])]
[(Mu: _ _) (void)]
[(App: _ _ _) (void)]
[(Error:) (void)]
@ -143,23 +134,17 @@
"\n arguments: " rands))])))
(define (needs-resolving? t)
(or (Mu? t) (App? t) (Name? t)))
(define resolver-cache (make-hasheq))
(define resolver-cache (make-hash))
(define (resolve-once t)
(define seq (Rep-seq t))
(define r (hash-ref resolver-cache seq #f))
(define r (hash-ref resolver-cache t #f))
(or r
(let ([r* (match t
[(Mu: _ _) (unfold t)]
[(App: r r* s)
(resolve-app r r* s)]
[(App: r r* s) (resolve-app r r* s)]
[(? Name?) (resolve-name t)])])
(when (and r*
(not (currently-subtyping?)))
(hash-set! resolver-cache seq r*))
(when (and r* (not (currently-subtyping?)))
(hash-set! resolver-cache t r*))
r*)))
;; resolver-cache-remove! : (Listof Type) -> Void
@ -168,15 +153,12 @@
;; undo certain resolutions.
(define (resolver-cache-remove! keys)
(for ([key (in-list keys)])
(hash-remove! resolver-cache (Rep-seq key))))
(hash-remove! resolver-cache key)))
;; Repeatedly unfolds Mu, App, and Name constructors until the top type
;; constructor is not one of them.
;; Type/c? -> Type/c?
;; Type? -> Type?
(define (resolve t)
(let loop ((t t))
(if (needs-resolving? t)
(loop (resolve-once t))
t)))
;(trace resolve-app)
(if (resolvable? t)
(resolve (resolve-once t))
t))

137
typed-racket-lib/typed-racket/types/structural.rkt
View File

@ -1,137 +0,0 @@
#lang racket/base
;; Module for providing recursive operations over types when the operation doesn't care about the
;; type constructor.
;; This file is meant to implement more general versions of type-case.
;; Currently supported
;; * Trivial type constructors (only have Rep? or (listof Rep?) fields)
;; * A variance aware traversal of a Rep? with the return value having the same type constructor as
;; the input.
;; To be added
;; * Support for type constructors with non Rep? fields
;; * Support for objects and filters
;; * Support for smart constructors for the return value
;; * Support for return values that are not Rep?
;; * Parallel traversal of two types
(require
"../utils/utils.rkt"
racket/match
(rep type-rep)
(for-syntax
racket/base
syntax/parse
racket/syntax))
(provide
structural?
structural-map)
(define-for-syntax structural-reps
#'([BoxTop ()]
[ChannelTop ()]
[Async-ChannelTop ()]
[ClassTop ()]
[UnitTop ()]
[Continuation-Mark-KeyTop ()]
[Error ()]
[HashtableTop ()]
[MPairTop ()]
[Prompt-TagTop ()]
[StructTypeTop ()]
[ThreadCellTop ()]
[Univ ()]
[VectorTop ()]
[CustodianBox (#:co)]
[Ephemeron (#:co)]
[Evt (#:co)]
[Future (#:co)]
[Instance (#:co)]
[Promise (#:co)]
[Set (#:co)]
[StructTop (#:co)]
[StructType (#:co)]
[Syntax (#:co)]
[Pair (#:co #:co)]
[Sequence ((#:listof #:co))]
[Function ((#:listof #:co))]
[Param (#:contra #:co)]
[Continuation-Mark-Keyof (#:inv)]
[Box (#:inv)]
[Channel (#:inv)]
[Async-Channel (#:inv)]
[ThreadCell (#:inv)]
[Vector (#:inv)]
[Hashtable (#:inv #:inv)]
[MPair (#:inv #:inv)]
[Prompt-Tagof (#:inv #:inv)]
[HeterogeneousVector ((#:listof #:inv))]
;; Non Types
[Result (#:co #:co #:co)]
[Values ((#:listof #:co))]
[AnyValues (#:co)]))
(begin-for-syntax
(define-syntax-class type-name
#:attributes (pred? matcher: maker)
(pattern t:id
#:with pred? (format-id #'t "~a?" #'t)
#:with matcher: (format-id #'t "~a:" #'t)
#:with maker (format-id #'t "make-~a" #'t))))
(begin-for-syntax
(define-syntax-class type-variance
#:attributes (sym)
(pattern #:co #:with sym 'co)
(pattern #:inv #:with sym 'inv)
(pattern #:contra #:with sym 'contra))
(define-syntax-class type-field
(pattern var:type-variance)
(pattern (#:listof var:type-variance))))
(define-syntax (gen-structural? stx)
(syntax-parse structural-reps
[([type:type-name (field:type-field ...)] ...)
#'(lambda (t)
(or (type.pred? t) ...))]))
;; Returns true if the type/prop/object supports structural operations.
(define structural? (gen-structural?))
(define-syntax (gen-structural-map stx)
(syntax-parse stx
[(_ input-type:id recur-f:id)
(define-syntax-class type-field*
#:attributes (recur)
(pattern var:type-variance
#:with recur #'(λ (t) (recur-f t 'var.sym)))
(pattern (#:listof var:type-variance)
#:with recur #'(λ (ts) (for/list ([t (in-list ts)]) (recur-f t 'var.sym)))))
(define-syntax-class type-clause
#:attributes (match-clause)
(pattern [type:type-name (field:type-field* ...)]
#:with (field-pat ...) (generate-temporaries #'(field ...))
#:with match-clause
#'[(type.matcher: field-pat ...)
(type.maker (field.recur field-pat) ...)]))
(syntax-parse structural-reps
[(:type-clause ...)
#'(match input-type match-clause ...)])]))
;; Rep? (-> Rep? (or/c 'co 'contra 'inv) Rep?) -> Rep?
;; Calls `f` on each sub-type with the corresponding variance of the sub-type and combines the results
;; using the type constructor of the input type
(define (structural-map t f)
(gen-structural-map t f))

254
typed-racket-lib/typed-racket/types/substitute.rkt
View File

@ -5,9 +5,9 @@
racket/lazy-require
(contract-req)
(only-in (types base-abbrev) -Tuple* -lst -Null -result ManyUniv)
(rep type-rep rep-utils)
(rep type-rep values-rep rep-utils)
(utils tc-utils)
(rep free-variance)
(rep rep-utils free-variance)
(env tvar-env))
(lazy-require ("union.rkt" (Un)))
@ -18,18 +18,18 @@
(provide-for-cond-contract substitution/c)
(define-struct/cond-contract subst-rhs () #:transparent)
(define-struct/cond-contract (t-subst subst-rhs) ([type Type/c]) #:transparent)
(define-struct/cond-contract (i-subst subst-rhs) ([types (listof Type/c)]) #:transparent)
(define-struct/cond-contract (i-subst/starred subst-rhs) ([types (listof Type/c)] [starred Type/c]) #:transparent)
(define-struct/cond-contract (i-subst/dotted subst-rhs) ([types (listof Type/c)] [dty Type/c] [dbound symbol?]) #:transparent)
(define-struct/cond-contract (t-subst subst-rhs) ([type Rep?]) #:transparent)
(define-struct/cond-contract (i-subst subst-rhs) ([types (listof Rep?)]) #:transparent)
(define-struct/cond-contract (i-subst/starred subst-rhs) ([types (listof Rep?)] [starred Rep?]) #:transparent)
(define-struct/cond-contract (i-subst/dotted subst-rhs) ([types (listof Rep?)] [dty Rep?] [dbound symbol?]) #:transparent)
(define-for-cond-contract substitution/c (hash/c symbol? subst-rhs? #:immutable #t))
(define-for-cond-contract simple-substitution/c (hash/c symbol? Type/c #:immutable #t))
(define-for-cond-contract simple-substitution/c (hash/c symbol? Rep? #:immutable #t))
(define (subst v t e) (substitute t v e))
(define/cond-contract (make-simple-substitution vs ts)
(([vs (listof symbol?)] [ts (listof Type/c)]) ()
(([vs (listof symbol?)] [ts (listof Rep?)]) ()
#:pre (vs ts) (= (length vs) (length ts))
. ->i . [_ substitution/c])
(for/hash ([v (in-list vs)] [t (in-list ts)])
@ -39,138 +39,150 @@
;; substitute-many : Hash[Name,Type] Type -> Type
(define/cond-contract (substitute-many subst target)
(simple-substitution/c Type? . -> . Type?)
(define (sb t) (substitute-many subst t))
(simple-substitution/c Rep? . -> . Rep?)
(define names (hash-keys subst))
(define fvs (free-vars* target))
(if (ormap (lambda (name) (free-vars-has-key? fvs name)) names)
(type-case (#:Type sb #:Prop (sub-f sb) #:Object (sub-o sb))
target
[#:Union tys (apply Un (map sb tys))]
[#:F name (hash-ref subst name target)]
[#:arr dom rng rest drest kws
(cond
[(and (pair? drest)
(ormap (λ (name)
(and (equal? name (cdr drest))
(not (bound-tvar? name))
name))
names))
=>
(lambda (name)
(int-err "substitute used on ... variable ~a in type ~a" name target))]
[else
(make-arr (map sb dom)
(sb rng)
(and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest)))
(map sb kws))])]
[#:ValuesDots types dty dbound
(cond
[(ormap (lambda (x) (and (equal? dbound x) (not (bound-tvar? x)))) names) =>
(lambda (name)
(int-err "substitute used on ... variable ~a in type ~a" name target))]
[else (make-ValuesDots (map sb types) (sb dty) dbound)])]
[#:ListDots dty dbound
(cond
[(ormap (lambda (x) (and (equal? dbound x) (not (bound-tvar? x)))) names) =>
(lambda (name)
(int-err "substitute used on ... variable ~a in type ~a" name target))]
[else (make-ListDots (sb dty) dbound)])])
target))
(let sub ([target target])
(match target
[(F: name) (hash-ref subst name target)]
[(arr: dom rng rest drest kws)
(cond
[(and (pair? drest)
(ormap (λ (name) (and (equal? name (cdr drest))
(not (bound-tvar? name))
name))
names))
=>
(λ (name)
(int-err "substitute used on ... variable ~a in type ~a" name target))]
[else
(make-arr (map sub dom)
(sub rng)
(and rest (sub rest))
(and drest (cons (sub (car drest)) (cdr drest)))
(map sub kws))])]
[(ValuesDots: types dty dbound)
(cond
[(for/or ([name (in-list names)])
(and (equal? dbound name)
(not (bound-tvar? name))))
=>
(λ (name)
(int-err "substitute used on ... variable ~a in type ~a" name target))]
[else (make-ValuesDots (map sub types) (sub dty) dbound)])]
[(ListDots: dty dbound)
(cond
[(for/or ([name (in-list names)])
(and (equal? dbound name)
(not (bound-tvar? name))))
=>
(λ (name)
(int-err "substitute used on ... variable ~a in type ~a" name target))]
[else (make-ListDots (sub dty) dbound)])]
[_ (Rep-fold sub target)])))
;; substitute : Type Name Type -> Type
(define/cond-contract (substitute image name target)
(Type/c symbol? Type? . -> . Type?)
(Rep? symbol? Rep? . -> . Rep?)
(substitute-many (hash name image) target))
;; implements angle bracket substitution from the formalism
;; substitute-dots : Listof[Type] Option[type] Name Type -> Type
;; implements angle bracket substitution from the formalism (TODO what formalism?)
;; substitute-dots : Listof[Type] Option[type] Name Type -> Type
(define/cond-contract (substitute-dots images rimage name target)
((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?)
(define (sb t) (substitute-dots images rimage name t))
(if (or (set-member? (free-vars-names (free-idxs* target)) name)
(set-member? (free-vars-names (free-vars* target)) name))
(type-case (#:Type sb #:Prop (sub-f sb)) target
[#:ListDots dty dbound
(if (eq? name dbound)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sb dty)])
(for/fold ([t (if rimage (-lst rimage) -Null)])
([img (in-list (reverse images))])
(make-Pair (substitute img name expanded) t)))
(make-ListDots (sb dty) dbound))]
[#:ValuesDots types dty dbound
(if (eq? name dbound)
(if rimage
ManyUniv
(make-Values
(append
(map sb types)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sb dty)])
(for/list ([img (in-list images)])
(-result (substitute img name expanded)))))))
(make-ValuesDots (map sb types) (sb dty) dbound))]
[#:arr dom rng rest drest kws
(if (and (pair? drest)
(eq? name (cdr drest)))
(make-arr (append
(map sb dom)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sb (car drest))])
(map (lambda (img) (substitute img name expanded)) images)))
(sb rng)
rimage
#f
(map sb kws))
(make-arr (map sb dom)
(sb rng)
(and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest)))
(map sb kws)))])
target))
((listof Rep?) (or/c #f Rep?) symbol? Rep? . -> . Rep?)
(let sub ([target target])
(match target
[(ListDots: dty dbound)
(if (eq? name dbound)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sub dty)])
(for/fold ([t (if rimage (-lst rimage) -Null)])
([img (in-list (reverse images))])
(make-Pair (substitute img name expanded) t)))
(make-ListDots (sub dty) dbound))]
[(ValuesDots: types dty dbound)
(cond
[(eq? name dbound)
(cond
[rimage ManyUniv]
[else
(make-Values
(append
(map sub types)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sub dty)])
(for/list ([img (in-list images)])
(-result (substitute img name expanded))))))])]
[else (make-ValuesDots (map sub types) (sub dty) dbound)])]
[(arr: dom rng rest drest kws)
(cond
[(and (pair? drest)
(eq? name (cdr drest)))
(make-arr (append
(map sub dom)
;; We need to recur first, just to expand out any dotted usages of this.
(let ([expanded (sub (car drest))])
(map (λ (img) (substitute img name expanded))
images)))
(sub rng)
rimage
#f
(map sub kws))]
[else
(make-arr (map sub dom)
(sub rng)
(and rest (sub rest))
(and drest (cons (sub (car drest)) (cdr drest)))
(map sub kws))])]
[_ (Rep-fold sub target)])))
;; implements curly brace substitution from the formalism, with the addition
;; that a substitution can include fixed args in addition to a different dotted arg
;; substitute-dotted : Listof[Type] Type Name Name Type -> Type
(define (substitute-dotted pre-image image image-bound name target)
(define (sb t) (substitute-dotted pre-image image image-bound name t))
;; We do a quick check on the free variables to see if we can short circuit the substitution
(if (or (set-member? (free-vars-names (free-idxs* target)) name)
(set-member? (free-vars-names (free-vars* target)) name))
(type-case (#:Type sb #:Prop (sub-f sb))
target
[#:ValuesDots types dty dbound
(let ([extra-types (if (eq? name dbound) pre-image null)])
(make-ValuesDots (append (map sb types) (map -result extra-types))
(sb dty)
(if (eq? name dbound) image-bound dbound)))]
[#:ListDots dty dbound
(-Tuple*
(if (eq? name dbound) pre-image null)
(make-ListDots (sb dty)
(if (eq? name dbound) image-bound dbound)))]
[#:F name*
(if (eq? name* name)
image
target)]
[#:arr dom rng rest drest kws
(let ([extra-types (if (and drest (eq? name (cdr drest))) pre-image null)])
(make-arr (append (map sb dom) extra-types)
(sb rng)
(and rest (sb rest))
(and drest
(cons (substitute image (cdr drest) (sb (car drest)))
(if (eq? name (cdr drest)) image-bound (cdr drest))))
(map sb kws)))])
target))
(let sub ([target target])
(match target
[(ValuesDots: types dty dbound)
(let ([extra-types (cond
[(eq? name dbound) pre-image]
[else null])])
(make-ValuesDots (append (map sub types) (map -result extra-types))
(sub dty)
(cond
[(eq? name dbound) image-bound]
[else dbound])))]
[(ListDots: dty dbound)
(-Tuple*
(if (eq? name dbound) pre-image null)
(make-ListDots (sub dty)
(if (eq? name dbound) image-bound dbound)))]
[(F: name*)
(cond [(eq? name* name) image]
[else target])]
[(arr: dom rng rest drest kws)
(let ([extra-types (cond
[(and drest (eq? name (cdr drest)))
pre-image]
[else null])])
(make-arr (append (map sub dom) extra-types)
(sub rng)
(and rest (sub rest))
(and drest
(cons (substitute image (cdr drest) (sub (car drest)))
(cond
[(eq? name (cdr drest))
image-bound]
[else (cdr drest)])))
(map sub kws)))]
[_ (Rep-fold sub target)])))
;; substitute many variables
;; subst-all : substitution/c Type -> Type
(define/cond-contract (subst-all s ty)
(substitution/c Type? . -> . Type?)
(substitution/c Rep? . -> . Rep?)
(define t-substs
(for/fold ([acc (hash)]) ([(v r) (in-hash s)])

19
typed-racket-lib/typed-racket/types/remove.rkt → typed-racket-lib/typed-racket/types/subtract.rkt
View File

@ -1,31 +1,32 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep rep-utils)
(rep type-rep rep-utils type-mask)
(types abbrev union subtype resolve utils)
racket/match racket/set)
(provide remove)
(provide subtract)
;; remove
;; subtract
;; Type Type -> Type
;; conservatively calculates set subtraction
;; between the types (i.e. t - s)
(define (remove t s)
(define (subtract t s)
(define result
(let rem ([t t])
(let sub ([t t])
(match t
[_ #:when (disjoint-masks? (Type-mask t) (Type-mask s)) t]
[_ #:when (subtype t s) -Bottom]
[(or (App: _ _ _) (? Name?))
;; must be different, since they're not subtypes
;; and n must refer to a distinct struct type
t]
[(Union: elems) (apply Un (map rem elems))]
[(Union: elems) (apply Un (map sub elems))]
[(Intersection: ts)
(apply -unsafe-intersect (set-map ts rem))]
[(? Mu?) (rem (unfold t))]
[(Poly: vs b) (make-Poly vs (rem b))]
(apply -unsafe-intersect (set-map ts sub))]
[(? Mu?) (sub (unfold t))]
[(Poly: vs b) (make-Poly vs (sub b))]
[_ t])))
(cond
[(subtype t result) t]

1286
typed-racket-lib/typed-racket/types/subtype.rkt
View File

File diff suppressed because it is too large Load Diff

6
typed-racket-lib/typed-racket/types/tc-error.rkt
View File

@ -14,11 +14,11 @@
[tc-error/expr/fields ((string?) (#:more (c:or/c string? #f) #:return c:any/c #:stx syntax?)
#:rest (c:listof c:any/c) . c:->* . c:any/c)]
[lookup-fail (identifier? . c:-> . Type/c)]
[lookup-type-fail (identifier? . c:-> . Type/c)]
[lookup-fail (identifier? . c:-> . Type?)]
[lookup-type-fail (identifier? . c:-> . Type?)]
[lookup-variance-fail (identifier? . c:-> . void?)])
;; produce a type-checking error, and also return a result (e.g., a tc-result)
;; produce a type-checking error, and also return a result (e.g., a tc-results)
(define (tc-error/expr msg
#:return [return (ret -Bottom)]
#:stx [stx (current-orig-stx)]

38
typed-racket-lib/typed-racket/types/tc-result.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep prop-rep)
(rep core-rep type-rep prop-rep values-rep)
(utils tc-utils)
(types base-abbrev)
racket/match
@ -10,10 +10,10 @@
;; this structure represents the result of typechecking an expression
;; fields are #f only when the direct result of parsing or annotations
(define-struct/cond-contract tc-result
([t Type/c] [pset (c:or/c PropSet? #f)] [o (c:or/c Object? #f)])
([t Type?] [pset (c:or/c PropSet? #f)] [o (c:or/c OptObject? #f)])
#:transparent)
(define-struct/cond-contract tc-results
([ts (c:listof tc-result?)] [drest (c:or/c (c:cons/c Type/c symbol?) #f)])
([ts (c:listof tc-result?)] [drest (c:or/c (c:cons/c Type? symbol?) #f)])
#:transparent)
(define-struct/cond-contract tc-any-results ([f (c:or/c Prop? #f)]) #:transparent)
@ -32,10 +32,12 @@
[(tc-any-results: p) (and p #t)]
[(tc-results: _ ps os)
(and (andmap (λ (x) x) ps)
(andmap (λ (x) x) os))]
(andmap (λ (x) x) os)
#t)]
[(tc-results: _ ps os _ _)
(and (andmap (λ (x) x) ps)
(andmap (λ (x) x) os))]
(andmap (λ (x) x) os)
#t)]
[else #f]))
@ -79,7 +81,7 @@
;; expand-Results: (Listof Rresult) -> (Values (Listof Type) (Listof PropSet) (Listof Object))
(define (expand-Results results)
(values (map Result-t results) (map Result-f results) (map Result-o results)))
(values (map Result-t results) (map Result-ps results) (map Result-o results)))
(define-match-expander Results:
@ -88,7 +90,7 @@
[(_ tp fp op) (Values: (app expand-Results tp fp op))]
[(_ tp fp op dty dbound) (ValuesDots: (app expand-Results tp fp op) dty dbound)]))
;; make-tc-result*: Type/c PropSet/c Object? -> tc-result?
;; make-tc-result*: Type? PropSet/c Object? -> tc-result?
;; Smart constructor for a tc-result.
(define (-tc-result type [prop -tt-propset] [object -empty-obj])
(cond
@ -102,7 +104,7 @@
(define ret
(case-lambda [(t)
(make-tc-results
(cond [(Type/c? t)
(cond [(Type? t)
(list (-tc-result t -tt-propset -empty-obj))]
[else
(for/list ([i (in-list t)])
@ -110,7 +112,7 @@
#f)]
[(t pset)
(make-tc-results
(if (Type/c? t)
(if (Type? t)
(list (-tc-result t pset -empty-obj))
(for/list ([i (in-list t)] [pset (in-list pset)])
(-tc-result i pset -empty-obj)))
@ -130,18 +132,16 @@
(list (-tc-result t pset o)))
(cons dty dbound))]))
;(trace ret)
(provide/cond-contract
[ret
(c:->i ([t (c:or/c Type/c (c:listof Type/c))])
(c:->i ([t (c:or/c Type? (c:listof Type?))])
([f (t) (if (list? t)
(c:listof (c:or/c #f PropSet?))
(c:or/c #f PropSet?))]
[o (t) (if (list? t)
(c:listof (c:or/c #f Object?))
(c:or/c #f Object?))]
[dty Type/c]
(c:listof (c:or/c #f OptObject?))
(c:or/c #f OptObject?))]
[dty Type?]
[dbound symbol?])
[res tc-results/c])])
@ -152,11 +152,11 @@
(provide/cond-contract
[rename -tc-result tc-result
(c:case->
(Type/c . c:-> . tc-result?)
(Type/c PropSet? Object? . c:-> . tc-result?))]
(Type? . c:-> . tc-result?)
(Type? PropSet? OptObject? . c:-> . tc-result?))]
[tc-any-results ((c:or/c Prop? #f) . c:-> . tc-any-results?)]
[tc-result-t (tc-result? . c:-> . Type/c)]
[rename tc-results-ts* tc-results-ts (tc-results? . c:-> . (c:listof Type/c))]
[tc-result-t (tc-result? . c:-> . Type?)]
[rename tc-results-ts* tc-results-ts (tc-results? . c:-> . (c:listof Type?))]
[tc-result-equal? (tc-result? tc-result? . c:-> . boolean?)]
[tc-result? (c:any/c . c:-> . boolean?)]
[tc-results? (c:any/c . c:-> . boolean?)]

6
typed-racket-lib/typed-racket/types/type-table.rkt
View File

@ -104,7 +104,7 @@
;; down compilation excessively (e.g., serializing the 4k type
;; of the + function)
(printer-thunk type-names
(pretty-format-type (cleanup-type type))))]
(pretty-format-rep (cleanup-type type))))]
[(or (tc-results: types)
(tc-results: types _ _ _ _)) ; FIXME, account for dty/dbound
(printer-thunk type-names
@ -112,8 +112,8 @@
(for/list ([(type index) (in-indexed (in-list types))])
(format "Value ~a:~n ~a~n"
(add1 index)
(pretty-format-type (cleanup-type type)
#:indent 2)))))]
(pretty-format-rep (cleanup-type type)
#:indent 2)))))]
[(tc-any-results: _) "AnyValues"]))
(cond [(not printed-type-thunks) tooltips]
[else

15
typed-racket-lib/typed-racket/types/union.rkt
View File

@ -9,14 +9,7 @@
(provide/cond-contract
[Un (() #:rest (c:listof Type/c) . c:->* . Type/c)])
;; List[Type] -> Type
;; Argument types should not overlap or be union types
(define (make-union* types)
(match types
[(list t) t]
[_ (make-Union types)]))
[Un (() #:rest (c:listof Type?) . c:->* . Type?)])
;; a is a Type (not a union type)
;; b is a List[Type] (non overlapping, non Union-types)
@ -24,7 +17,7 @@
;; The overlapping constraint is lifted if we are in the midst of subtyping. This is because during
;; subtyping calls to subtype are expensive.
(define (merge a b)
(define b* (make-union* b))
(define b* (make-Union b))
(match* (a b)
;; If a union element is a Name application, then it should not
;; be checked for subtyping since that can cause infinite
@ -58,7 +51,7 @@
(cond [(hash-ref Un-cache args #f)]
[else
(define ts (foldr merge '()
(remove-dups (sort (append-map flat args) type<?))))
(define type (make-union* ts))
(remove-duplicates (append-map flat args) type-equal?)))
(define type (make-Union ts))
(hash-set! Un-cache args type)
type])]))

29
typed-racket-lib/typed-racket/types/update.rkt
View File

@ -4,9 +4,9 @@
(require racket/match racket/list
(contract-req)
(infer-in infer)
(rep type-rep prop-rep object-rep rep-utils)
(rep core-rep type-rep prop-rep object-rep values-rep rep-utils)
(utils tc-utils)
(types resolve subtype remove union)
(types resolve subtype subtract union)
(rename-in (types abbrev)
[-> -->]
[->* -->*]
@ -22,7 +22,7 @@
;; path-elems : which fields we're traversing to update,
;; in *syntactic order* (e.g. (car (cdr x)) -> '(car cdr))
(define/cond-contract (update t new-t pos? path-elems)
(Type/c Type/c boolean? (listof PathElem?) . -> . Type/c)
(Type? Type? boolean? (listof PathElem?) . -> . Type?)
;; build-type: build a type while propogating bottom
(define (build constructor . args)
(if (memf Bottom? args) -Bottom (apply constructor args)))
@ -32,10 +32,6 @@
(let update
([t t] [path (reverse path-elems)])
(match path
;; path is empty (base case)
[(list) (cond
[pos? (intersect (resolve t) new-t)]
[else (remove (resolve t) new-t)])]
;; path is non-empty
;; (i.e. there is some field access we'll try and traverse)
[(cons path-elem rst)
@ -87,9 +83,20 @@
[((Union: ts) _)
(apply Un (map (λ (t) (update t path)) ts))]
[((Intersection: ts) _)
(for/fold ([t Univ])
([elem (in-list ts)])
(intersect t (update elem path)))]
[(_ _)
;; This likely comes up with (-lst t) and we need to improve the system to make sure this case
;; dosen't happen
;;(int-err "update along ill-typed path: ~a ~a ~a" t t* lo)
t])])))
(match path-elem
[(CarPE:) (intersect t (-pair (update Univ rst) Univ))]
[(CdrPE:) (intersect t (-pair Univ (update Univ rst)))]
[(SyntaxPE:) (intersect t (-syntax-e (update Univ rst)))]
[(ForcePE:) (intersect t (-force (update Univ rst)))]
[_ t])])]
;; path is empty (base case)
[_ (cond
[pos? (intersect (resolve t) new-t)]
[else (subtract (resolve t) new-t)])])))

20
typed-racket-lib/typed-racket/types/utils.rkt
View File

@ -14,17 +14,6 @@
(provide (all-from-out "tc-result.rkt" "tc-error.rkt"))
;; unfold : Type -> Type
;; must be applied to a Mu
(define (unfold t)
(match t
[(Mu: name b)
(define (sb target)
(type-case (#:Type sb #:Prop (sub-f sb) #:Object (sub-o sb))
target
[#:F name* (if (eq? name name*) t target)]))
(sb b)]))
(define (instantiate-poly t types)
(match t
[(Poly: ns body)
@ -114,14 +103,13 @@
ok?)))
(provide/cond-contract
[unfold (Mu? . -> . Type/c)]
[instantiate-poly ((or/c Poly? PolyDots? PolyRow?) (listof Type/c)
. -> . Type/c)]
[instantiate-poly ((or/c Poly? PolyDots? PolyRow?) (listof Rep?)
. -> . Rep?)]
[instantiate-poly-dotted
(PolyDots? (listof Type/c) Type/c symbol? . -> . Type/c)]
(PolyDots? (listof Rep?) Rep? symbol? . -> . Rep?)]
[fv (Rep? . -> . (listof symbol?))]
[fi (Rep? . -> . (listof symbol?))]
[fv/list ((listof Type/c) . -> . (set/c symbol?))]
[fv/list ((listof Rep?) . -> . (set/c symbol?))]
[current-poly-struct (parameter/c (or/c #f poly?))]
[has-optional-args? (-> (listof arr?) any)]
)

55
typed-racket-lib/typed-racket/utils/primitive-comparison.rkt Normal file
View File

@ -0,0 +1,55 @@
#lang racket/base
(require racket/unsafe/ops
racket/format)
(provide primitive<=?)
;; vector of predicates for primitives paired with
;; functions which compair primitives of the same type
(define prims
(vector (cons (λ (v) (eq? v #t)) (λ _ #t))
(cons (λ (v) (eq? v #f)) (λ _ #t))
(cons (λ (v) (eq? v '())) (λ _ #t))
(cons real? <=)
(cons complex? (λ (x y) (and (<= (real-part x)
(real-part y))
(<= (imag-part x)
(imag-part y)))))
(cons char? char<=?)
(cons string? string<=?)
(cons bytes? (λ (b1 b2) (or (bytes<? b1 b2)
(bytes=? b1 b2))))
(cons symbol? (λ (s1 s2) (or (symbol<? s1 s2)
(eq? s1 s2))))
(cons keyword? (λ (k1 k2) (or (keyword<? k1 k2)
(eq? k1 k2))))
(cons pair? (λ (p1 p2) (and (primitive<=? (car p1) (car p2))
(primitive<=? (cdr p1) (cdr p2)))))
(cons vector? (λ (v1 v2) (and (< (vector-length v1) (vector-length v2))
(and (= (vector-length v1) (vector-length v2))
(for/and ([val1 (in-vector v1)]
[val2 (in-vector v2)])
(primitive<=? val1 val2))))))
(cons box? (λ (b1 b2) (primitive<=? (unbox b1) (unbox b2))))))
;; finds which index into prims 's' belongs
(define (index-of s)
(let loop ([i 0])
(cond
[(unsafe-fx<= i (vector-length prims))
(if ((unsafe-car (unsafe-vector-ref prims i)) s)
i
(loop (unsafe-fx+ i 1)))]
[else (error 'index-of "impossible!")])))
;; compares two primitives (i.e. sexps) based on the ordering
;; implied by the 'prims' predicates and, if they are equal types of
;; primitives, on the functions contained in prims
(define (primitive<=? s1 s2)
(define idx1 (index-of s1))
(define idx2 (index-of s2))
(cond
[(unsafe-fx< idx1 idx2) #t]
[(unsafe-fx> idx1 idx2) #f]
[else ((unsafe-cdr (vector-ref prims idx1)) s1 s2)]))

33
typed-racket-lib/typed-racket/utils/utils.rkt
View File

@ -5,9 +5,10 @@ This file is for utilities that are of general interest,
at least theoretically.
|#
(require (for-syntax racket/base syntax/parse/pre racket/string)
(require (for-syntax racket/base racket/string)
racket/require-syntax racket/provide-syntax
racket/match
syntax/parse/define
racket/struct-info "timing.rkt")
(provide
@ -22,7 +23,8 @@ at least theoretically.
filter-multiple
syntax-length
in-sequence-forever
match*/no-order)
match*/no-order
bind)
(define optimize? (make-parameter #t))
(define-for-syntax enable-contracts? (and (getenv "PLT_TR_CONTRACTS") #t))
@ -99,12 +101,15 @@ at least theoretically.
define-struct/cond-contract
define/cond-contract
contract-req
define/provide
define/cond-contract/provide
define-for-cond-contract
provide-for-cond-contract
require-for-cond-contract
begin-for-cond-contract)
(define-require-syntax contract-req
(if enable-contracts?
(lambda (stx) (datum->syntax stx 'racket/contract))
@ -136,11 +141,19 @@ at least theoretically.
[(_ e:expr ...) #'(begin)])))
(define-syntax-rule (define/cond-contract/provide (name . args) c . body)
(begin (define/cond-contract name c
(begin
(define (name . args) body)
name))
(define-syntax (define/provide stx)
(syntax-parse stx
[(_ name:id . body)
(syntax/loc stx
(begin (define name . body)
(provide name)))]
[(_ (name:id . args) . body)
(syntax/loc stx
(begin (define (name . args) . body)
(provide name)))]))
(define-simple-macro (define/cond-contract/provide (name:id . args) c . body)
(begin (define (name . args) . body)
(provide/cond-contract [name c])))
;; these are versions of the contract forms conditionalized by `enable-contracts?'
@ -253,3 +266,9 @@ at least theoretically.
. clauses)
#`(match* (val1 val2)
. #,(parse-clauses #'clauses))]))
(define-match-expander bind
(syntax-parser
[(_ x:id val:expr)
#'(app (λ (_) val) x)]))

2
typed-racket-more/typed/racket/sandbox.rkt
View File

@ -4,7 +4,7 @@
;; racket/sandbox
(require racket/sandbox
(for-syntax (only-in typed-racket/rep/type-rep make-ValuesDots)))
(for-syntax (only-in typed-racket/rep/values-rep make-ValuesDots)))
(provide exn:fail:resource?
exn:fail:resource-resource)

2
typed-racket-test/fail/pr13209.rkt
View File

@ -1,5 +1,5 @@
#;
(exn-pred #rx"wrong number of arguments to structure type constructor")
(exn-pred #rx"wrong number of arguments")
#lang typed/racket
;; Test for PR 13209

21
typed-racket-test/succeed/type-printer-single-level.rkt
View File

@ -28,22 +28,21 @@
(string-append "(U Integer String)\n[can expand further: Integer]"
"(-> Foo Foo)\n[can expand further: Foo]"
"(-> Number Integer)\n[can expand further: Integer Number]"
"(-> (U String\n"
" 0\n"
"(-> (U 0\n"
" 1\n"
" Byte-Larger-Than-One\n"
" Positive-Index-Not-Byte\n"
" Positive-Fixnum-Not-Index\n"
" Negative-Fixnum\n"
" Negative-Integer-Not-Fixnum\n"
" Positive-Fixnum-Not-Index\n"
" Positive-Index-Not-Byte\n"
" Positive-Integer-Not-Fixnum\n"
" Negative-Integer-Not-Fixnum)\n"
" (U String\n"
" 0\n"
" String)\n"
" (U 0\n"
" 1\n"
" Byte-Larger-Than-One\n"
" Positive-Index-Not-Byte\n"
" Positive-Fixnum-Not-Index\n"
" Negative-Fixnum\n"
" Negative-Integer-Not-Fixnum\n"
" Positive-Fixnum-Not-Index\n"
" Positive-Index-Not-Byte\n"
" Positive-Integer-Not-Fixnum\n"
" Negative-Integer-Not-Fixnum))\n"))
" String))\n"))

2
typed-racket-test/unit-tests/check-below-tests.rkt
View File

@ -33,7 +33,7 @@
(for-each check-object os)]
[(tc-any-results: f)
(check-prop f)]
[(? Type/c?)
[(? Type?)
(void)]))

143
typed-racket-test/unit-tests/class-tests.rkt
View File

@ -5,6 +5,7 @@
(require (submod "typecheck-tests.rkt" test-helpers)
(except-in "test-utils.rkt" private)
(for-syntax racket/base
(submod "typecheck-tests.rkt" test-helpers)
typed-racket/tc-setup
typed-racket/utils/tc-utils))
@ -52,7 +53,7 @@
(init x)
(define/public (m x) 0)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"superclass expression should produce a class"]
;; Method using argument type
[tc-e (let ()
@ -83,7 +84,7 @@
(init [x 0])
(define/public (m x) (send this z))))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"method not understood.*method name: z"]
;; Send to other methods
[tc-e (let ()
@ -107,8 +108,8 @@
-Void]
;; Send to non object
[tc-err (send 4 m 3)
#:ret (ret (-val 5) -ff-propset)
#:expected (ret (-val 5) #f #f)]
#:ret (tc-ret -Bottom -ff-propset)
#:expected (tc-ret -Bottom -ff-propset)]
;; Fails, sending to multiple/unknown values
[tc-err (send (values 'a 'b) m 'c)
#:msg #rx"expected single value"]
@ -131,7 +132,7 @@
(define (f o) (send o m))
(f (new (class object% (super-new)
(define/public (m) (values "foo" 'bar))))))
#:ret (ret (list (t:Un -String -Symbol) (t:Un -String -Symbol)))]
#:ret (tc-ret (list (t:Un -String -Symbol) (t:Un -String -Symbol)))]
[tc-err
(let ()
(define obj
@ -165,13 +166,13 @@
(super-new)
(field [x : String "foo"])))
'not-string)
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"set-field! only allowed with"]
;; fails, field's default value has wrong type
[tc-err (class object% (super-new)
(: x Symbol)
(field [x "foo"]))
#:ret (ret (-class #:field ([x -Symbol])))
#:ret (tc-ret (-class #:field ([x -Symbol])))
#:msg #rx"expected: Symbol.*given: String"]
;; Fail, field access to missing field
[tc-err (let ()
@ -180,7 +181,7 @@
(super-new)
(define/public (m) (get-field n this))))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"missing an expected field.*field: n"]
;; Fail, conflict with parent field
[tc-err (let ()
@ -196,7 +197,7 @@
(field [n 17])
(super-new)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"has a conflicting public field.*field: n"]
;; Fail, conflict with parent method
[tc-err (let ()
@ -209,7 +210,7 @@
(super-new)
(define/public (m) 17)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"has a conflicting public method.*method: m"]
;; Inheritance
[tc-e (let ()
@ -226,7 +227,7 @@
-Void]
;; fail, superclass expression is not a class with no expected type
[tc-err (class "foo" (super-new))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg "expected: a class"]
;; should fail, too many methods
[tc-err (let ()
@ -235,7 +236,7 @@
(super-new)
(define/public (m) 0)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"method `m' that is not in expected type"]
;; same as previous
[tc-err (let ()
@ -244,7 +245,7 @@
(define/public (m x) (add1 x))
(define/public (n) 0)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"method `n' that is not in expected type"]
;; fails, too many inits
[tc-err (let ()
@ -252,7 +253,7 @@
(define c% (class object% (super-new)
(init x)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"init `x' that is not in expected type"]
;; fails, init should be optional but is mandatory
[tc-err (let ()
@ -260,7 +261,7 @@
(define c% (class object% (super-new)
(init str)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: optional init `str'.*given: mandatory init `str'"]
;; fails, too many fields
[tc-err (let ()
@ -268,7 +269,7 @@
(define c% (class object% (super-new)
(field [str "foo"] [x 0])))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"field `x' that is not in expected type"]
;; test that an init with no annotation still type-checks
;; (though it will have the Any type)
@ -313,7 +314,7 @@
(define/public (m) 0)))
(mixin arg-class%))
#:ret (ret (-class #:method ([m (t:-> -Integer)] [n (t:-> -String)])))
#:ret (tc-ret (-class #:method ([m (t:-> -Integer)] [n (t:-> -String)])))
#:msg #rx"lacks expected method `n'"]
;; Fail, bad mixin argument
[tc-err (let ()
@ -334,7 +335,7 @@
(mixin arg-class%)
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"lacks expected method `m'"]
;; classes that don't use define/public directly
[tc-e (let ()
@ -369,7 +370,7 @@
(: c% (Class (init [x Integer])))
(define c% (class object% (init x)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"must call `super-new'"]
;; fails, non-top-level super-new
;; FIXME: this case also spits out additional untyped identifier
@ -378,7 +379,7 @@
(: c% (Class (init [x Integer])))
(define c% (class object% (let () (super-new)) (init x)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"must call `super-new'"]
;; fails, bad super-new argument
[tc-err (let ()
@ -387,7 +388,7 @@
(: d% (Class))
(define d% (class c% (super-new [x "bad"])))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: Symbol.*given: String"]
;; test override
[tc-e (let ()
@ -418,7 +419,7 @@
(define/override (m y)
(string-append (assert y string?) "foo"))))
(void))
#:ret (ret -Void)]
#:ret (tc-ret -Void)]
;; local field access and set!
[tc-e (let ()
(: c% (Class (field [x Integer])
@ -460,7 +461,7 @@
(define/public (m y) 'a)
(string-append (string->symbol "a") "a")))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: String.*given: Symbol"]
;; fails, ill-typed method call
[tc-err (let ()
@ -469,7 +470,7 @@
(define/public (m y) 'a)
(m "foo")))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: Symbol.*given: String"]
;; fails, ill-typed field access
[tc-err (let ()
@ -478,7 +479,7 @@
(field [f "foo"])
(set! f 'a)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: String.*given: 'a"]
;; test private field
[tc-e (let ()
@ -504,14 +505,14 @@
(: x Symbol)
(define x 'a)
(set! x "foo"))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg #rx"expected: Symbol.*given: String"]
;; fails, bad private field default
[tc-err (class object%
(super-new)
(: x Symbol)
(define x "foo"))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg #rx"expected: Symbol.*given: String"]
;; ok, synthesis works on private fields
[tc-e (class object% (super-new)
@ -550,20 +551,20 @@
(define/private (x) 'a)
(: m (-> String))
(define/public (m) (x)))
#:ret (ret (-class #:method ([m (t:-> -String)])))
#:ret (tc-ret (-class #:method ([m (t:-> -String)])))
#:msg #rx"expected: String.*given: Symbol"]
;; fails, not enough annotation on private
[tc-err (class object% (super-new)
(define/private (x) 3)
(: m (-> Integer))
(define/public (m) (x)))
#:ret (ret (-class #:method ([m (t:-> -Integer)])))
#:ret (tc-ret (-class #:method ([m (t:-> -Integer)])))
#:msg #rx"Cannot apply expression of type Any"]
;; fails, ill-typed private method implementation
[tc-err (class object% (super-new)
(: x (-> Symbol))
(define/private (x) "bad result"))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg #rx"expected: Symbol.*given: String"]
;; test optional init arg
[tc-e (let ()
@ -591,7 +592,7 @@
(: x Integer)
(init [x 0])))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: mandatory init `x'.*given: optional init `x'"]
;; fails, mandatory init not provided
[tc-err (let ()
@ -599,7 +600,7 @@
(: x Integer)
(init x)))
(new d%))
#:ret (ret (-object #:init ([x -Integer #f])))
#:ret (tc-ret (-object #:init ([x -Integer #f])))
#:msg #rx"value not provided for named init arg x"]
;; test that provided super-class inits don't count
;; towards the type of current class
@ -618,10 +619,10 @@
(init x))
(super-new [x 3])))
(new c% [x 5]))
#:ret (ret (-object))]
#:ret (tc-ret (-object))]
;; fails, super-new can only be called once per class
[tc-err (class object% (super-new) (super-new))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg #rx"`super-new' a single time"]
;; test passing an init arg to super-new
[tc-e (let ()
@ -641,10 +642,10 @@
(: x String)
(init x)
(super-new [x x]))
#:ret (ret (-class #:init ([x -String #f])))]
#:ret (tc-ret (-class #:init ([x -String #f])))]
;; fails, superclass does not accept this init arg
[tc-err (class object% (super-new [x 3]))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg "not accepted by superclass"]
;; test inherit method
[tc-e (let ()
@ -716,11 +717,11 @@
[tc-err (class (class object% (super-new))
(super-new)
(inherit-field [y x]))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg #rx"superclass is missing a required field"]
;; fails, missing super method for inherit
[tc-err (class (class object% (super-new)) (super-new) (inherit z))
#:ret (ret (-class))]
#:ret (tc-ret (-class))]
;; fails, bad argument type to inherited method
[tc-err (class (class object% (super-new)
(: m (Integer -> Integer))
@ -728,7 +729,7 @@
(super-new)
(inherit m)
(m "foo"))
#:ret (ret (-class #:method ([m (t:-> -Integer -Integer)])))]
#:ret (tc-ret (-class #:method ([m (t:-> -Integer -Integer)])))]
;; test that keyword methods type-check
[tc-e (let ()
(: c% (Class [n (Integer #:foo Integer -> Integer)]))
@ -857,7 +858,7 @@
(public [m m])
(define m (lambda () "a"))))
(send (new c%) m))
#:ret (ret -String -true-propset)]
#:ret (tc-ret -String -true-propset)]
;; fails, internal name not accessible
[tc-err (let ()
(define c% (class object% (super-new)
@ -899,7 +900,7 @@
(: i Integer)
(init ([i j]))))
(new c% [i 5]))
#:ret (ret (-object #:init ([j -Integer #f])))]
#:ret (tc-ret (-object #:init ([j -Integer #f])))]
;; test that different internal names can map to the same external name
;; and that the internal-external name mapping is set correctly.
[tc-e (class object%
@ -919,7 +920,7 @@
[tc-err (class object% (super-new)
(: z Integer)
(init [z "foo"]))
#:ret (ret (-class #:init ([z -Integer #t])))
#:ret (tc-ret (-class #:init ([z -Integer #t])))
#:msg #rx"expected: Integer.*given: String"]
;; test init field default value
[tc-e (let ()
@ -932,7 +933,7 @@
[tc-err (class object% (super-new)
(: x Integer)
(init-field ([x y] "foo")))
#:ret (ret (-class #:init ([y -Integer #t]) #:field ([y -Integer])))]
#:ret (tc-ret (-class #:init ([y -Integer #t]) #:field ([y -Integer])))]
;; test type-checking method with internal/external
[tc-err (let ()
(: c% (Class [n (Integer -> Integer)]))
@ -951,7 +952,7 @@
[tc-err (class object% (super-new)
(define/public (m) (n))
(define/public (n x) 0))
#:ret (ret (-class #:method ([m (t:-> -Bottom)] [n (t:-> Univ -Zero : -true-propset)])))
#:ret (tc-ret (-class #:method ([m (t:-> -Bottom)] [n (t:-> Univ -Zero : -true-propset)])))
#:msg #rx"since it is not a function type"]
;; test type-checking for classes without any
;; internal type annotations on methods
@ -959,7 +960,7 @@
(define c% (class object% (super-new)
(define/public (m) "a")))
(send (new c%) m))
#:ret (ret -String -true-propset)]
#:ret (tc-ret -String -true-propset)]
;; test inheritance without expected
[tc-e (let ()
(define c% (class (class object% (super-new)
@ -1001,7 +1002,7 @@
(class cls (super-new)
(field [x 5])))
(row-inst f (Row (field [x Integer]))))
#:ret (ret (t:-> (-class
#:ret (tc-ret (t:-> (-class
#:row (make-Row null `([x ,-Integer]) null null #f))
(-class
#:row (make-Row null `([x ,-Integer]) null null #f)
@ -1020,7 +1021,7 @@
(row-inst f (Row (field [y Integer]))))
(instantiated
(class object% (super-new))))
#:ret (ret (-class
#:ret (tc-ret (-class
#:row (make-Row null (list (list 'y -Integer)) null null #f)
#:field ([x -Integer])))]
;; fails, the argument object lacks required fields (with inference)
@ -1030,7 +1031,7 @@
(Class (field [x Any]) #:row-var r))))
(define (mixin cls) cls)
(mixin object%))
#:ret (ret (-class #:row (make-Row null null null null #f)
#:ret (tc-ret (-class #:row (make-Row null null null null #f)
#:field ([x Univ])))
#:msg #rx"lacks expected field `x'"]
;; mixin application succeeds
@ -1095,7 +1096,7 @@
(class cls (super-new)
(field [x 5])))
(row-inst f (Row (field [x Integer]))))
#:ret (ret (t:-> (-class
#:ret (tc-ret (t:-> (-class
#:row (make-Row null `([x ,-Integer]) null null #f))
(-class
#:row (make-Row null `([x ,-Integer]) null null #f)
@ -1204,7 +1205,7 @@
(define/augment (m x)
(string-append x "bar"))))
(send (new c%) m 'b))
#:ret (ret -Symbol)
#:ret (tc-ret -Symbol)
#:msg #rx"expected: String.*given: Symbol"]
;; Fail, bad inner default
[tc-err (class object%
@ -1212,7 +1213,7 @@
(: m (Symbol -> Symbol))
(define/pubment (m x)
(inner "foo" m x)))
#:ret (ret (-class #:method ([m (t:-> -Symbol -Symbol)])
#:ret (tc-ret (-class #:method ([m (t:-> -Symbol -Symbol)])
#:augment ([m (t:-> -Symbol -Symbol)])))
#:msg #rx"expected: Symbol.*given: String"]
;; Fail, wrong number of arguments to inner
@ -1221,7 +1222,7 @@
(: m (Integer -> Integer))
(define/pubment (m x)
(inner 3 m)))
#:ret (ret (-class #:method ([m (t:-> -Integer -Integer)])
#:ret (tc-ret (-class #:method ([m (t:-> -Integer -Integer)])
#:augment ([m (t:-> -Integer -Integer)])))
#:msg #rx"wrong number of arguments provided.*expected: 2"]
;; Fail, bad augment type
@ -1237,7 +1238,7 @@
(super-new)
(define/augment (m x) "bad type")))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: Symbol.*given: String"]
;; Fail, cannot augment non-augmentable method
[tc-err (let ()
@ -1251,7 +1252,7 @@
(super-new)
(define/augment (m x) 1)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"superclass is missing a required augmentable method"]
;; Pubment with separate internal/external names
[tc-e (let ()
@ -1282,7 +1283,7 @@
(: x Symbol)
(init-field x)))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: String"]
;; test polymorphic class
[tc-e (let ()
@ -1303,7 +1304,7 @@
(init-field x)
(set! x "a")))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: A.*given: String"]
;; test polymorphism with keyword
[tc-e (let ()
@ -1343,21 +1344,21 @@
(super-new)
(: m (X -> X))
(define/public (m x) "a"))
#:ret (ret (-poly (X) (-class #:method ([m (t:-> X X)]))))
#:ret (tc-ret (-poly (X) (-class #:method ([m (t:-> X X)]))))
#:msg #rx"expected: X.*given: String"]
;; fails because default init value cannot be polymorphic
[tc-err (class object%
#:forall (Z)
(super-new)
(init-field [x : Z] [y : Z 0]))
#:ret (ret (-poly (Z) (-class #:init-field ([x Z #f] [y Z #t]))))
#:ret (tc-ret (-poly (Z) (-class #:init-field ([x Z #f] [y Z #t]))))
#:msg #rx"expected: Z.*given: Zero"]
;; fails because default field value cannot be polymorphic
[tc-err (class object%
#:forall (Z)
(super-new)
(field [x : Z "a"]))
#:ret (ret (-poly (Z) (-class #:field ([x Z]))))
#:ret (tc-ret (-poly (Z) (-class #:field ([x Z]))))
#:msg #rx"expected: Z.*given: String"]
;; test in-clause type annotations (next several tests)
[tc-e (let ()
@ -1402,7 +1403,7 @@
(super-new)
(: x String)
(field [x : Symbol 0]))
#:ret (ret (-class #:field ([x -String])))
#:ret (tc-ret (-class #:field ([x -String])))
#:msg #rx"duplicate type annotation.*new type: Symbol"]
;; fails, expected type and annotation don't match
[tc-err (let ()
@ -1410,13 +1411,13 @@
(define c% (class object% (super-new)
(field [x : Symbol 'a])))
(void))
#:ret (ret -Void)
#:ret (tc-ret -Void)
#:msg #rx"expected: String.*given: Symbol"]
;; fails, but make sure it's not an internal error
[tc-err (class object% (super-new)
(define/pubment (foo x) 0)
(define/public (g x) (foo 3)))
#:ret (ret (-class #:method ([g (t:-> Univ -Bottom)]
#:ret (tc-ret (-class #:method ([g (t:-> Univ -Bottom)]
[foo (t:-> Univ -Zero : -true-propset)])
#:augment ([foo top-func])))
#:msg #rx"Cannot apply expression of type Any"]
@ -1483,7 +1484,7 @@
(super-new)
(init-rest [rst : (List Symbol)])))
(make-object c% "wrong"))
#:ret (ret (make-Instance (make-Class #f null null null null (-Tuple (list -Symbol)))))
#:ret (tc-ret (make-Instance (make-Class #f null null null null (-Tuple (list -Symbol)))))
#:msg #rx"expected: \\(List Symbol.*given: \\(List String"]
;; PR 14408, test init-field order
[tc-e (let ()
@ -1506,7 +1507,7 @@
-Void]
;; fail, too many positional arguments to superclass
[tc-err (class object% (super-make-object "foo"))
#:ret (ret (-class))
#:ret (tc-ret (-class))
#:msg #rx"too many positional init arguments"]
;; check that case-lambda methods work
[tc-e (let ()
@ -1530,7 +1531,7 @@
(: m (case-> (Any -> Integer)))
(public m)
(define m (case-lambda [(x) "bad"])))
#:ret (ret (-class #:method [(m (t:-> Univ -Integer))]))
#:ret (tc-ret (-class #:method [(m (t:-> Univ -Integer))]))
#:msg #rx"expected: Integer.*given: String"]
;; test that rest args work
[tc-e (let ()
@ -1557,8 +1558,8 @@
(class object%
(super-new)
(init x)))
#:ret (ret (-poly (A) (-class #:init ([x A #f]))))
#:expected (ret (-poly (A) (-class #:init ([x A #f]))) #f #f)]
#:ret (tc-ret (-poly (A) (-class #:init ([x A #f]))))
#:expected (tc-ret (-poly (A) (-class #:init ([x A #f]))) #f #f)]
;; test uses of a macro in the body of the class
[tc-e
(let ()
@ -1741,7 +1742,7 @@
[tc-e (class object%
(super-new)
(define/public foo (case-lambda [(str) (void)] [(sym size) (void)])))
(-class #:method [(foo (cl->* (t:-> Univ Univ -Void) (t:-> Univ -Void)))])]
(-class #:method [(foo (cl->* (t:-> Univ Univ -Void : -true-propset) (t:-> Univ -Void : -true-propset)))])]
;; PR 14911
[tc-e (class object%
(super-new)
@ -2020,7 +2021,7 @@
(define/public (m)
(if (string? x) (string-append x "bar") "baz"))))
(error "foo"))
#:msg #rx"expected: String.*given: \\(U String 'obfuscate\\)"]
#:msg #rx"expected: String.*given: \\(U 'obfuscate String\\)"]
[tc-err (let ()
(define c%
(class object%
@ -2032,7 +2033,7 @@
(define/public (m)
(if (string? x) (string-append x "bar") "baz"))))
(error "foo"))
#:msg #rx"expected: String.*given: \\(U String 'obfuscate\\)"]
#:msg #rx"expected: String.*given: \\(U 'obfuscate String\\)"]
[tc-err (let ()
(define c%
(class object%
@ -2044,7 +2045,7 @@
(define/public (m)
(if (string? x) (string-append x "bar") "baz"))))
(error "foo"))
#:msg #rx"expected: String.*given: \\(U String 'obfuscate\\)"]
#:msg #rx"expected: String.*given: \\(U 'obfuscate String\\)"]
;; tests that we are not creating objects for mutable private fields
[tc-e (let ()
(class object%

8
typed-racket-test/unit-tests/contract-tests.rkt
View File

@ -5,7 +5,7 @@
syntax/parse)
(for-template racket/base)
(private type-contract)
(rep type-rep)
(rep type-rep values-rep)
(types abbrev numeric-tower union)
(static-contracts combinators optimize)
(submod typed-racket/private/type-contract numeric-contracts)
@ -137,7 +137,7 @@
(t (make-Function
(list (make-arr* (list Univ) -Boolean #:kws (list (make-Keyword '#:key Univ #t))
#:props (-PS (-is-type 0 -Symbol) (-not-type 0 -Symbol))))))
(t (-struct #'struct-name #f (list (make-fld -Symbol #'acc #f))))
(t (-struct #'struct-name1 #f (list (make-fld -Symbol #'acc #f))))
;; Adapted from PR 13815
(t (-poly (a) (-> a a)))
(t (-poly (a) (-mu X (-> a X))))
@ -203,7 +203,7 @@
(-> -Boolean -Boolean)
(-> -Symbol -Symbol))
"two cases of arity 1")
(t/fail (-struct #'struct-name #f (list (make-fld -Symbol #'acc #f)) (-> -Symbol))
(t/fail (-struct #'struct-name2 #f (list (make-fld -Symbol #'acc #f)) (-> -Symbol))
"procedural structs are not supported")
(t/fail (-Syntax (-> -Boolean -Boolean))
"required a flat contract but generated a chaperone contract")
@ -218,7 +218,7 @@
(make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t)))
(make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t)))))
"case function type with optional keyword arguments")
(t/fail (-vec (-struct #'struct-name #f (list (make-fld (-seq -Symbol) #'acc #f)) #f #t))
(t/fail (-vec (-struct #'struct-name3 #f (list (make-fld (-seq -Symbol) #'acc #f)) #f #t))
"required a chaperone contract but generated an impersonator contract")
(t-sc -Number number/sc)

2
typed-racket-test/unit-tests/generalize-tests.rkt
View File

@ -3,7 +3,7 @@
(require "test-utils.rkt"
racket/format
rackunit
(rep rep-utils)
(rep rep-utils core-rep type-rep)
(types generalize abbrev union)
(for-syntax racket/base syntax/parse))

47
typed-racket-test/unit-tests/metafunction-tests.rkt
View File

@ -3,7 +3,7 @@
(require "test-utils.rkt"
rackunit racket/format
(typecheck tc-metafunctions tc-subst)
(rep prop-rep type-rep object-rep)
(rep prop-rep type-rep object-rep values-rep)
(types abbrev union prop-ops tc-result numeric-tower)
(for-syntax racket/base syntax/parse))
@ -16,9 +16,10 @@
(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))
(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))))]))
@ -89,59 +90,59 @@
(ret -Symbol (-PS -tt -ff)))
(check-equal?
(values->tc-results (make-Values (list (-result -Symbol (-PS -tt -ff) (make-Path null '(0 0)))))
(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))))
(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))))
(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)))))
(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)))))
(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))))))
(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)))))
(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))))))
(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))
(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)
(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)))))
(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))))
@ -150,9 +151,9 @@
(values->tc-results
(make-Values
(list (-result -Boolean
(-PS (make-TypeProp (make-Path (list -car) '(0 0))
(-PS (make-TypeProp (make-Path (list -car) '(0 . 0))
-PosReal)
(make-TypeProp (make-Path (list -car) '(0 0))
(make-TypeProp (make-Path (list -car) '(0 . 0))
-NonPosReal)))))
(list (make-Path null #'x))
(list (-lst -Integer)))
@ -163,12 +164,12 @@
(test-suite "replace-names"
(check-equal?
(replace-names (list (list #'x (make-Path null (list 0 0))))
(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 (list 0 0))))
(ret Univ -tt-propset (make-Path null '(0 . 0))))
(check-equal?
(replace-names (list (list #'x (make-Path null (list 0 0))))
(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 (list 1 0)))))
(ret (-> Univ Univ : -tt-propset : (make-Path null '(1 . 0)))))
)
))

10
typed-racket-test/unit-tests/parse-type-tests.rkt
View File

@ -10,7 +10,7 @@
(env tvar-env type-alias-env mvar-env)
(utils tc-utils)
(private parse-type)
(rep type-rep)
(rep type-rep values-rep)
(submod typed-racket/base-env/base-types initialize)
(rename-in (types union abbrev numeric-tower resolve)
@ -168,13 +168,13 @@
(t:->* (list Univ) -Boolean : (-PS (-not-type 0 -Number) (-is-type 0 -Number)))]
[(-> Any (-> Any Boolean : #:+ (Number @ 1 0) #:- (! Number @ 1 0)))
(t:-> Univ
(t:->* (list Univ) -Boolean : (-PS (-is-type '(1 0) -Number) (-not-type '(1 0) -Number))))]
(t:->* (list Univ) -Boolean : (-PS (-is-type (cons 1 0) -Number) (-not-type (cons 1 0) -Number))))]
[(-> Any Any (-> Any Boolean : #:+ (Number @ 1 1) #:- (! Number @ 1 1)))
(t:-> Univ Univ
(t:->* (list Univ) -Boolean : (-PS (-is-type '(1 1) -Number) (-not-type '(1 1) -Number))))]
(t:->* (list Univ) -Boolean : (-PS (-is-type (cons 1 1) -Number) (-not-type (cons 1 1) -Number))))]
[(-> Any #:foo Any (-> Any Boolean : #:+ (Number @ 1 0) #:- (! Number @ 1 0)))
(->key Univ #:foo Univ #t
(t:->* (list Univ) -Boolean : (-PS (-is-type '(1 0) -Number) (-not-type '(1 0) -Number))))]
(t:->* (list Univ) -Boolean : (-PS (-is-type (cons 1 0) -Number) (-not-type (cons 1 0) -Number))))]
[(All (a b) (-> (-> a Any : #:+ b) (Listof a) (Listof b)))
(-poly (a b) (t:-> (asym-pred a Univ (-PS (-is-type 0 b) -tt)) (-lst a) (-lst b)))]
[(All (a b) (-> (-> a Any : #:+ (! b)) (Listof a) (Listof b)))
@ -239,7 +239,7 @@
[(->* (#:bar Integer Integer) (#:foo Integer String) Void)
(->optkey -Integer [-String] #:bar -Integer #t #:foo -Integer #f -Void)]
[(->* (Any (-> Any Boolean : #:+ (String @ 1 0))) Void)
(t:-> Univ (t:->* (list Univ) -Boolean : (-PS (-is-type '(1 0) -String) -tt))
(t:-> Univ (t:->* (list Univ) -Boolean : (-PS (-is-type (cons 1 0) -String) -tt))
-Void)]
[FAIL (->* (Any (-> Any Boolean : #:+ (String @ 2 0))) Void)
#:msg "Index 2 used in"]

2
typed-racket-test/unit-tests/prop-tests.rkt
View File

@ -59,7 +59,7 @@
-ff
-ff)
(test-opposite #:not-complementary #:contradictory
(test-opposite #:complementary #:contradictory
-ff
-tt)

12
typed-racket-test/unit-tests/remove-intersect-tests.rkt
View File

@ -3,7 +3,7 @@
(for-syntax racket/base)
(r:infer infer)
(rep type-rep)
(types abbrev numeric-tower subtype union remove overlap)
(types abbrev numeric-tower subtype union subtract overlap)
rackunit)
(provide tests)
(gen-test-main)
@ -64,10 +64,10 @@
(syntax-case stx ()
[(_ [t1 t2 res] ...)
(syntax/loc stx
(test-suite "Tests for remove"
(test-check (format "~a ~a" 't1 't2) type-compare? (remove t1 t2) res) ...))]))
(test-suite "Tests for subtract"
(test-check (format "~a ~a" 't1 't2) type-compare? (subtract t1 t2) res) ...))]))
(define remove-tests
(define subtract-tests
(remo-tests
[(Un -Number -Symbol) -Number -Symbol]
[-Number -Number (Un)]
@ -90,7 +90,7 @@
))
(define tests
(test-suite "Remove Intersect"
remove-tests
(test-suite "Subtract Intersect"
subtract-tests
intersect-tests
overlap-tests))

8
typed-racket-test/unit-tests/special-env-typecheck-tests.rkt
View File

@ -27,11 +27,11 @@
(begin-for-syntax (do-standard-inits))
(define-syntax-rule (tc-e/t e t) (tc-e e #:ret (ret t -true-propset)))
(define-syntax-rule (tc-e/t e t) (tc-e e #:ret (reduce-tc-results/subsumption (ret t -true-propset))))
(define-syntax (tc-e stx)
(syntax-parse stx
[(tc-e expr ty) (syntax/loc stx (tc-e expr #:ret (ret ty)))]
[(tc-e expr ty) (syntax/loc stx (tc-e expr #:ret (reduce-tc-results/subsumption (ret ty))))]
[(id a #:ret b)
(syntax/loc stx
(test-case (format "~a ~a" (quote-line-number id) 'a)
@ -44,7 +44,9 @@
[(res2) (phase1-phase0-eval #`'#,b)])
(with-check-info (['expanded expanded])
(unless (tc-result-equal/test? res1 res2)
(fail-check "Expression didn't have expected type."))))))]))
(fail-check (format "Expression didn't have expected type.\n Expected: ~a\n Actual: ~a\n"
(struct->vector res1)
(struct->vector res2))))))))]))
(define tests
(test-suite

12
typed-racket-test/unit-tests/subtype-tests.rkt
View File

@ -2,7 +2,7 @@
(require "test-utils.rkt"
(types subtype numeric-tower union utils abbrev)
(rep type-rep)
(rep type-rep values-rep)
(env init-envs type-env-structs)
rackunit
(for-syntax racket/base))
@ -60,6 +60,8 @@
[(-unsafe-intersect -Sexp
(Un -Null (-pair -Sexp (-unsafe-intersect (make-Listof Univ) -Sexp))))
(make-Listof Univ)]
[(-unsafe-intersect (-v A) (-v B))
(Un -String (-unsafe-intersect (-v A) (-v B)))]
;; sexps vs list*s of nums
[(-mu x (Un -Number -Symbol (make-Listof x))) (-mu x (Un -Number -Symbol -Boolean (make-Listof x)))]
[(-mu x (Un -Number (make-Listof x))) (-mu x (Un -Number -Symbol (make-Listof x)))]
@ -131,7 +133,7 @@
(cl-> [() (-pair -Number (-v b))]
[(-Number) (-pair -Number (-v b))])]
[(-values (list -Number)) (-values (list Univ))]
;[(-values (list -Number)) (-values (list Univ))]
[(-poly (b) ((Un (make-Base 'foo #'dummy values #f)
(-struct #'bar #f
@ -171,6 +173,8 @@
[(-pair -String (-lst -String)) (-seq -String)]
[FAIL (-pair -String (-lst -Symbol)) (-seq -String)]
[FAIL (-pair -String (-vec -String)) (-seq -String)]
[(-mpair -String -Null) (-seq -String)]
[(-mlst -String) (-seq -String)]
[(-mpair -String (-mlst -String)) (-seq -String)]
[FAIL (-mpair -String (-mlst -Symbol)) (-seq -String)]
[FAIL (-mpair -String (-vec -String)) (-seq -String)]
@ -280,8 +284,8 @@
[FAIL (make-ListDots (-box (make-F 'a)) 'a) (-lst (-box Univ))]
[(make-ListDots (-> -Symbol (make-F 'a)) 'a) (-lst (-> -Symbol Univ))]
[FAIL (make-ValuesDots (list) -Symbol 'a) (make-ValuesDots (list (-result -String)) -String 'a)]
[(-values (list -Bottom)) (-values (list -String -Symbol))]
;[FAIL (make-ValuesDots (list) -Symbol 'a) (make-ValuesDots (list (-result -String)) -String 'a)]
;[(-values (list -Bottom)) (-values (list -String -Symbol))]
[(-> Univ -Bottom) (-> Univ (-values (list -String -Symbol)))]
[(-> Univ -Bottom) (-> Univ (-values-dots null -String 'x))]

34
typed-racket-test/unit-tests/type-printer-tests.rkt
View File

@ -7,6 +7,7 @@
typed-racket/standard-inits
typed-racket/tc-setup
typed-racket/rep/type-rep
typed-racket/rep/values-rep
typed-racket/types/abbrev
typed-racket/types/numeric-tower
typed-racket/types/printer
@ -21,7 +22,7 @@
(string=? (format "~a" thing) str))
(define (pretty-prints-as? thing str)
(string=? (pretty-format-type thing) str))
(string=? (pretty-format-rep thing) str))
(define-binary-check (check-prints-as? prints-as? actual expected))
(define-binary-check (check-pretty-prints-as? pretty-prints-as? actual expected))
@ -49,9 +50,12 @@
(check-prints-as? (-lst* -String -Symbol) "(List String Symbol)")
;; next three cases for PR 14552
(check-prints-as? (-mu x (Un (-pair x x) -Null)) "(Rec x (U Null (Pairof x x)))")
(check-prints-as? (-mu x (Un (-pair (-box x) x) -Null)) "(Rec x (U Null (Pairof (Boxof x) x)))")
(check-prints-as? (-mu x (Un (-mpair x x) -Null)) "(Rec x (U Null (MPairof x x)))")
(check-prints-as? (-mu x (Un (-pair x x) -Null))
"(Rec x (U Null (Pairof x x)))")
(check-prints-as? (-mu x (Un (-pair (-box x) x) -Null))
"(Rec x (U Null (Pairof (Boxof x) x)))")
(check-prints-as? (-mu x (Un (-mpair x x) -Null))
"(Rec x (U Null (MPairof x x)))")
(check-prints-as? -Custodian "Custodian")
(check-prints-as? (make-Opaque #'integer?) "(Opaque integer?)")
@ -86,14 +90,14 @@
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type 1 -String) -tt))
"(-> Any Any Boolean)")
;; PR 14510 (next three tests)
(check-prints-as? (-> Univ (-> Univ -Boolean : (-PS (-is-type '(1 0) -String)
(-not-type '(1 0) -String))))
(check-prints-as? (-> Univ (-> Univ -Boolean : (-PS (-is-type '(1 . 0) -String)
(-not-type '(1 . 0) -String))))
"(-> Any (-> Any Boolean))")
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type '(0 1) -String)
(-not-type '(0 1) -String)))
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type '(0 . 1) -String)
(-not-type '(0 . 1) -String)))
"(-> Any Any Boolean)")
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type '(0 0) -String)
(-not-type '(0 0) -String)))
(check-prints-as? (-> Univ Univ -Boolean : (-PS (-is-type '(0 . 0) -String)
(-not-type '(0 . 0) -String)))
"(-> Any Any Boolean)")
(check-prints-as? (-> Univ (make-Values (list (-result -String -tt-propset -empty-obj)
(-result -String -tt-propset -empty-obj))))
@ -110,15 +114,15 @@
(one-of/c 'binary 'text)
#f
-Void)
(string-append "(-> Any Path-String [#:exists (U 'error"
" 'append 'update 'replace 'truncate"
" 'truncate/replace)] [#:mode (U"
(string-append "(-> Any Path-String [#:exists (U 'append"
" 'error 'replace 'truncate 'truncate/replace"
" 'update)] [#:mode (U"
" 'binary 'text)] Void)"))
(check-prints-as? (-> Univ (-AnyValues -tt)) "(-> Any AnyValues)")
(check-prints-as? (-> Univ (-AnyValues (-is-type '(0 0) -String)))
(check-prints-as? (-> Univ (-AnyValues (-is-type '(0 . 0) -String)))
"(-> Any AnyValues : (String @ (0 0)))")
(check-prints-as? (-AnyValues -tt) "AnyValues")
(check-prints-as? (-AnyValues (-is-type '(0 0) -String))
(check-prints-as? (-AnyValues (-is-type '(0 . 0) -String))
"(AnyValues : (String @ (0 0)))")
(check-prints-as? (->opt Univ [] -Void) "(-> Any Void)")

626
typed-racket-test/unit-tests/typecheck-tests.rkt
View File

File diff suppressed because it is too large Load Diff