From 24c64e9de06b25291ca685ae954e6bed58583326 Mon Sep 17 00:00:00 2001 From: Andrew Kent Date: Fri, 9 Sep 2016 08:42:28 -0400 Subject: [PATCH] new representation scheme for typed racket internals 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) --- .../typed-racket/base-env/ann-inst.rkt | 4 +- .../base-env/base-env-numeric.rkt | 2 +- .../typed-racket/base-env/base-env.rkt | 2 +- .../typed-racket/base-env/top-interaction.rkt | 8 +- typed-racket-lib/typed-racket/core.rkt | 1 - .../typed-racket/env/env-utils.rkt | 8 +- .../typed-racket/env/global-env.rkt | 12 +- .../typed-racket/env/init-envs.rkt | 48 +- .../typed-racket/env/lexical-env.rkt | 37 +- .../typed-racket/env/signature-env.rkt | 26 +- .../typed-racket/env/signature-helper.rkt | 57 +- .../typed-racket/env/type-alias-env.rkt | 8 +- .../typed-racket/env/type-env-structs.rkt | 10 +- .../typed-racket/env/type-name-env.rkt | 20 +- .../typed-racket/infer/constraint-structs.rkt | 2 +- .../typed-racket/infer/infer-unit.rkt | 638 ++++---- .../typed-racket/infer/intersect.rkt | 132 +- .../typed-racket/infer/promote-demote.rkt | 111 +- .../typed-racket/infer/signatures.rkt | 17 +- .../typed-racket/private/parse-type.rkt | 70 +- .../typed-racket/private/type-contract.rkt | 25 +- .../typed-racket/rep/core-rep.rkt | 234 +++ .../typed-racket/rep/free-variance.rkt | 63 +- .../typed-racket/rep/interning.rkt | 45 - .../typed-racket/rep/object-rep.rkt | 46 +- .../typed-racket/rep/prop-rep.rkt | 129 +- .../typed-racket/rep/rep-utils.rkt | 792 +++++----- .../typed-racket/rep/type-mask.rkt | 156 ++ .../typed-racket/rep/type-rep.rkt | 1332 +++++++++-------- .../typed-racket/rep/values-rep.rkt | 62 + .../static-contracts/combinators/name.rkt | 4 +- .../typed-racket/typecheck/check-below.rkt | 14 +- .../typecheck/check-class-unit.rkt | 2 +- .../typecheck/check-subforms-unit.rkt | 9 +- .../typecheck/check-unit-unit.rkt | 2 +- .../typed-racket/typecheck/error-message.rkt | 14 +- .../typecheck/find-annotation.rkt | 2 +- .../typecheck/possible-domains.rkt | 4 +- .../typecheck/provide-handling.rkt | 2 +- .../typed-racket/typecheck/signatures.rkt | 12 +- .../typed-racket/typecheck/tc-app-helper.rkt | 15 +- .../typecheck/tc-app/tc-app-hetero.rkt | 4 +- .../typecheck/tc-app/tc-app-keywords.rkt | 2 +- .../typecheck/tc-app/tc-app-main.rkt | 2 +- .../typecheck/tc-app/tc-app-objects.rkt | 6 +- .../typed-racket/typecheck/tc-apply.rkt | 2 +- .../typed-racket/typecheck/tc-envops.rkt | 71 +- .../typed-racket/typecheck/tc-expr-unit.rkt | 30 +- .../typed-racket/typecheck/tc-expression.rkt | 3 - .../typed-racket/typecheck/tc-funapp.rkt | 287 ++-- .../typed-racket/typecheck/tc-if.rkt | 8 +- .../typed-racket/typecheck/tc-lambda-unit.rkt | 32 +- .../typed-racket/typecheck/tc-let-unit.rkt | 84 +- .../typecheck/tc-metafunctions.rkt | 93 +- .../typed-racket/typecheck/tc-send.rkt | 8 +- .../typed-racket/typecheck/tc-structs.rkt | 4 +- .../typed-racket/typecheck/tc-subst.rkt | 323 ++-- .../typed-racket/typecheck/tc-toplevel.rkt | 7 +- .../typecheck/toplevel-trampoline.rkt | 8 +- .../typed-racket/types/abbrev.rkt | 18 +- .../typed-racket/types/base-abbrev.rkt | 208 ++- .../typed-racket/types/classes.rkt | 41 +- .../typed-racket/types/current-seen.rkt | 52 +- .../typed-racket/types/kw-types.rkt | 5 +- .../typed-racket/types/match-expanders.rkt | 17 +- .../typed-racket/types/overlap.rkt | 181 ++- .../typed-racket/types/path-type.rkt | 90 +- .../typed-racket/types/printer.rkt | 202 ++- .../typed-racket/types/prop-ops.rkt | 351 +++-- .../typed-racket/types/resolve.rkt | 170 +-- .../typed-racket/types/structural.rkt | 137 -- .../typed-racket/types/substitute.rkt | 254 ++-- .../types/{remove.rkt => subtract.rkt} | 19 +- .../typed-racket/types/subtype.rkt | 1286 ++++++++-------- .../typed-racket/types/tc-error.rkt | 6 +- .../typed-racket/types/tc-result.rkt | 38 +- .../typed-racket/types/type-table.rkt | 6 +- typed-racket-lib/typed-racket/types/union.rkt | 15 +- .../typed-racket/types/update.rkt | 29 +- typed-racket-lib/typed-racket/types/utils.rkt | 20 +- .../utils/primitive-comparison.rkt | 55 + typed-racket-lib/typed-racket/utils/utils.rkt | 33 +- typed-racket-more/typed/racket/sandbox.rkt | 2 +- typed-racket-test/fail/pr13209.rkt | 2 +- .../succeed/type-printer-single-level.rkt | 21 +- .../unit-tests/check-below-tests.rkt | 2 +- typed-racket-test/unit-tests/class-tests.rkt | 143 +- .../unit-tests/contract-tests.rkt | 8 +- .../unit-tests/generalize-tests.rkt | 2 +- .../unit-tests/metafunction-tests.rkt | 47 +- .../unit-tests/parse-type-tests.rkt | 10 +- typed-racket-test/unit-tests/prop-tests.rkt | 2 +- .../unit-tests/remove-intersect-tests.rkt | 12 +- .../special-env-typecheck-tests.rkt | 8 +- .../unit-tests/subtype-tests.rkt | 12 +- .../unit-tests/type-printer-tests.rkt | 34 +- .../unit-tests/typecheck-tests.rkt | 626 ++++---- 97 files changed, 5105 insertions(+), 4210 deletions(-) create mode 100644 typed-racket-lib/typed-racket/rep/core-rep.rkt delete mode 100644 typed-racket-lib/typed-racket/rep/interning.rkt create mode 100644 typed-racket-lib/typed-racket/rep/type-mask.rkt create mode 100644 typed-racket-lib/typed-racket/rep/values-rep.rkt delete mode 100644 typed-racket-lib/typed-racket/types/structural.rkt rename typed-racket-lib/typed-racket/types/{remove.rkt => subtract.rkt} (60%) create mode 100644 typed-racket-lib/typed-racket/utils/primitive-comparison.rkt diff --git a/typed-racket-lib/typed-racket/base-env/ann-inst.rkt b/typed-racket-lib/typed-racket/base-env/ann-inst.rkt index cfd26362..5dc9dcbf 100644 --- a/typed-racket-lib/typed-racket/base-env/ann-inst.rkt +++ b/typed-racket-lib/typed-racket/base-env/ann-inst.rkt @@ -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 (:) diff --git a/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt b/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt index fada7e16..c78a169e 100644 --- a/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt +++ b/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt @@ -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?)) diff --git a/typed-racket-lib/typed-racket/base-env/base-env.rkt b/typed-racket-lib/typed-racket/base-env/base-env.rkt index 3480cae1..7f350995 100644 --- a/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/base-env/top-interaction.rkt b/typed-racket-lib/typed-racket/base-env/top-interaction.rkt index 8afbae9c..a7580275 100644 --- a/typed-racket-lib/typed-racket/base-env/top-interaction.rkt +++ b/typed-racket-lib/typed-racket/base-env/top-interaction.rkt @@ -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")) diff --git a/typed-racket-lib/typed-racket/core.rkt b/typed-racket-lib/typed-racket/core.rkt index f9f46b78..6b1e6481 100644 --- a/typed-racket-lib/typed-racket/core.rkt +++ b/typed-racket-lib/typed-racket/core.rkt @@ -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") diff --git a/typed-racket-lib/typed-racket/env/env-utils.rkt b/typed-racket-lib/typed-racket/env/env-utils.rkt index dd981e27..5286f47b 100644 --- a/typed-racket-lib/typed-racket/env/env-utils.rkt +++ b/typed-racket-lib/typed-racket/env/env-utils.rkt @@ -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 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<)) diff --git a/typed-racket-lib/typed-racket/env/init-envs.rkt b/typed-racket-lib/typed-racket/env/init-envs.rkt index 7a21a863..f5dc3eb2 100644 --- a/typed-racket-lib/typed-racket/env/init-envs.rkt +++ b/typed-racket-lib/typed-racket/env/init-envs.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/env/lexical-env.rkt b/typed-racket-lib/typed-racket/env/lexical-env.rkt index 0b9fe1ce..211e4283 100644 --- a/typed-racket-lib/typed-racket/env/lexical-env.rkt +++ b/typed-racket-lib/typed-racket/env/lexical-env.rkt @@ -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)) \ No newline at end of file diff --git a/typed-racket-lib/typed-racket/env/signature-env.rkt b/typed-racket-lib/typed-racket/env/signature-env.rkt index c525df67..05b21ac0 100644 --- a/typed-racket-lib/typed-racket/env/signature-env.rkt +++ b/typed-racket-lib/typed-racket/env/signature-env.rkt @@ -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<)) diff --git a/typed-racket-lib/typed-racket/env/signature-helper.rkt b/typed-racket-lib/typed-racket/env/signature-helper.rkt index d7ac170f..ee00c52e 100644 --- a/typed-racket-lib/typed-racket/env/signature-helper.rkt +++ b/typed-racket-lib/typed-racket/env/signature-helper.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/env/type-alias-env.rkt b/typed-racket-lib/typed-racket/env/type-alias-env.rkt index 68915228..bb6c02ba 100644 --- a/typed-racket-lib/typed-racket/env/type-alias-env.rkt +++ b/typed-racket-lib/typed-racket/env/type-alias-env.rkt @@ -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)))) diff --git a/typed-racket-lib/typed-racket/env/type-env-structs.rkt b/typed-racket-lib/typed-racket/env/type-env-structs.rkt index cecca36d..39d76e9d 100644 --- a/typed-racket-lib/typed-racket/env/type-env-structs.rkt +++ b/typed-racket-lib/typed-racket/env/type-env-structs.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/env/type-name-env.rkt b/typed-racket-lib/typed-racket/env/type-name-env.rkt index ad087b4b..4ac7169d 100644 --- a/typed-racket-lib/typed-racket/env/type-name-env.rkt +++ b/typed-racket-lib/typed-racket/env/type-name-env.rkt @@ -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 () diff --git a/typed-racket-lib/typed-racket/infer/constraint-structs.rkt b/typed-racket-lib/typed-racket/infer/constraint-structs.rkt index 400968ed..0577ea3f 100644 --- a/typed-racket-lib/typed-racket/infer/constraint-structs.rkt +++ b/typed-racket-lib/typed-racket/infer/constraint-structs.rkt @@ -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] diff --git a/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/typed-racket-lib/typed-racket/infer/infer-unit.rkt index aa2cc101..2099372b 100644 --- a/typed-racket-lib/typed-racket/infer/infer-unit.rkt +++ b/typed-racket-lib/typed-racket/infer/infer-unit.rkt @@ -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 ;; 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) diff --git a/typed-racket-lib/typed-racket/infer/intersect.rkt b/typed-racket-lib/typed-racket/infer/intersect.rkt index 0484714f..cfca3505 100644 --- a/typed-racket-lib/typed-racket/infer/intersect.rkt +++ b/typed-racket-lib/typed-racket/infer/intersect.rkt @@ -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]))) diff --git a/typed-racket-lib/typed-racket/infer/promote-demote.rkt b/typed-racket-lib/typed-racket/infer/promote-demote.rkt index 23170d12..618a83ab 100644 --- a/typed-racket-lib/typed-racket/infer/promote-demote.rkt +++ b/typed-racket-lib/typed-racket/infer/promote-demote.rkt @@ -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)])) diff --git a/typed-racket-lib/typed-racket/infer/signatures.rkt b/typed-racket-lib/typed-racket/infer/signatures.rkt index 47899503..5c98a34d 100644 --- a/typed-racket-lib/typed-racket/infer/signatures.rkt +++ b/typed-racket-lib/typed-racket/infer/signatures.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/private/parse-type.rkt b/typed-racket-lib/typed-racket/private/parse-type.rkt index 7a12d9e8..2d187822 100644 --- a/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -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)] diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 91a10da1..9f8e8229 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/rep/core-rep.rkt b/typed-racket-lib/typed-racket/rep/core-rep.rkt new file mode 100644 index 00000000..d198279b --- /dev/null +++ b/typed-racket-lib/typed-racket/rep/core-rep.rkt @@ -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?))]]) + diff --git a/typed-racket-lib/typed-racket/rep/free-variance.rkt b/typed-racket-lib/typed-racket/rep/free-variance.rkt index 08ca3088..e2ae489b 100644 --- a/typed-racket-lib/typed-racket/rep/free-variance.rkt +++ b/typed-racket-lib/typed-racket/rep/free-variance.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/rep/interning.rkt b/typed-racket-lib/typed-racket/rep/interning.rkt deleted file mode 100644 index 79fafd25..00000000 --- a/typed-racket-lib/typed-racket/rep/interning.rkt +++ /dev/null @@ -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)))) diff --git a/typed-racket-lib/typed-racket/rep/object-rep.rkt b/typed-racket-lib/typed-racket/rep/object-rep.rkt index cc93659f..70974a88 100644 --- a/typed-racket-lib/typed-racket/rep/object-rep.rkt +++ b/typed-racket-lib/typed-racket/rep/object-rep.rkt @@ -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)])) diff --git a/typed-racket-lib/typed-racket/rep/prop-rep.rkt b/typed-racket-lib/typed-racket/rep/prop-rep.rkt index c904e215..5dd6a143 100644 --- a/typed-racket-lib/typed-racket/rep/prop-rep.rkt +++ b/typed-racket-lib/typed-racket/rep/prop-rep.rkt @@ -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)])) diff --git a/typed-racket-lib/typed-racket/rep/rep-utils.rkt b/typed-racket-lib/typed-racket/rep/rep-utils.rkt index 38733acd..62de23f0 100644 --- a/typed-racket-lib/typed-racket/rep/rep-utils.rkt +++ b/typed-racket-lib/typed-racket/rep/rep-utils.rkt @@ -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 (Replist #'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)) - ) - |# - (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 . boolean?)] - [rename rep . boolean?)] - [rename rep . boolean?)] - [struct Rep ([seq exact-nonnegative-integer?] - [free-vars (hash/c symbol? variance?)] - [free-idxs (hash/c symbol? variance?)] - [stx (or/c #f syntax?)])]) diff --git a/typed-racket-lib/typed-racket/rep/type-mask.rkt b/typed-racket-lib/typed-racket/rep/type-mask.rkt new file mode 100644 index 00000000..8112ef93 --- /dev/null +++ b/typed-racket-lib/typed-racket/rep/type-mask.rkt @@ -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) diff --git a/typed-racket-lib/typed-racket/rep/type-rep.rkt b/typed-racket-lib/typed-racket/rep/type-rep.rkt index 19c8cb92..6fbef055 100644 --- a/typed-racket-lib/typed-racket/rep/type-rep.rkt +++ b/typed-racket-lib/typed-racket/rep/type-rep.rkt @@ -7,35 +7,43 @@ ;; TODO use contract-req (require (utils tc-utils) - "rep-utils.rkt" "object-rep.rkt" "prop-rep.rkt" "free-variance.rkt" + "rep-utils.rkt" + "core-rep.rkt" + "values-rep.rkt" + "type-mask.rkt" + "object-rep.rkt" + "free-variance.rkt" racket/match racket/list racket/set racket/contract racket/lazy-require racket/promise - (for-syntax racket/base syntax/parse)) + syntax/parse/define + (for-syntax racket/base + racket/syntax + syntax/parse)) -(provide Mu-name: +(provide (all-from-out "core-rep.rkt") + Type? + Mu-name: Poly-names: Poly-fresh: PolyDots-names: PolyRow-names: PolyRow-fresh: - Type-seq -unsafe-intersect Mu-unsafe: Poly-unsafe: PolyDots-unsafe: Mu? Poly? PolyDots? PolyRow? - Prop? Object? - Type/c Type/c? - Values/c SomeValues/c - Bottom? Poly-n PolyDots-n Class? Row? Row: free-vars* type-equal? - remove-dups - sub-t sub-f sub-o sub-pe Name/simple: Name/struct: - (rename-out [Class:* Class:] + unfold + Union? + Union: + Union-elems + (rename-out [make-Union* make-Union] + [Class:* Class:] [Class* make-Class] [Row* make-Row] [Mu:* Mu:] @@ -52,7 +60,6 @@ [PolyRow-body* PolyRow-body])) -;; Ugly hack - should use units (lazy-require ("../types/union.rkt" (Un)) ("../types/overlap.rkt" (overlap?)) @@ -60,51 +67,28 @@ (define name-table (make-weak-hasheq)) -(define Type/c? - (λ (e) - (and (Type? e) - (not (arr? e)) - (not (fld? e)) - (not (Values? e)) - (not (ValuesDots? e)) - (not (AnyValues? e)) - (not (Result? e)) - (not (Signature? e))))) - -;; (or/c Type/c Values? Results?) -;; Anything that can be treated as a Values by sufficient expansion -(define Values/c? - (λ (e) - (and (Type? e) - (not (arr? e)) - (not (fld? e)) - (not (ValuesDots? e)) - (not (AnyValues? e)) - (not (Signature? e))))) - -(define Type/c (flat-named-contract 'Type Type/c?)) -(define Values/c (flat-named-contract 'Values Values/c?)) -(define Bottom? - (match-lambda - [(Union: (list)) #t] - [else #f])) - ;; Name = Symbol ;; Type is defined in rep-utils.rkt ;; this is ONLY used when a type error ocurrs -(def-type Error () [#:frees #f] [#:fold-rhs #:base]) +(def-type Error () #:base) ;; de Bruijn indexes - should never appear outside of this file ;; bound type variables ;; i is an nat -(def-type B ([i natural-number/c]) [#:frees #f] [#:fold-rhs #:base]) +(def-type B ([i natural-number/c]) #:base + [#:intern-key i]) ;; free type variables ;; n is a Name -(def-type F ([n symbol?]) [#:frees (single-free-var n) empty-free-vars] - [#:fold-rhs #:base]) +(def-type F ([n symbol?]) + [#:intern-key n] + [#:frees + [#:vars (_) (single-free-var n)] + [#:idxs (_) empty-free-vars]] + [#:fold (_ #:self self) self] + [#:walk (_) (void)]) ;; Name, an indirection of a type through the environment ;; @@ -117,97 +101,32 @@ (def-type Name ([id identifier?] [args exact-nonnegative-integer?] [struct? boolean?]) - [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base]) + [#:intern-key (hash-id id)] + [#:frees (f) empty-free-vars] + [#:fold (_ #:self self) self] + [#:walk (_) (void)] + #:needs-resolving) ;; rator is a type ;; rands is a list of types ;; stx is the syntax of the pair of parens -(def-type App ([rator Type/c] [rands (listof Type/c)] [stx (or/c #f syntax?)]) - [#:intern (cons (Rep-seq rator) (map Rep-seq rands))] - [#:frees (λ (f) - (match rator - ((Name: n _ _) - (instantiate-frees n (map f rands))) - (else (f (resolve-app rator rands stx)))))] +(def-type App ([rator Type?] + [rands (listof Type?)] + [stx (or/c #f syntax?)]) + [#:intern-key (cons (Rep-seq rator) (map Rep-seq rands))] + [#:frees (f) + (match rator + [(Name: n _ _) + (instantiate-frees n (map f rands))] + [_ (f (resolve-app rator rands stx))])] + [#:fold (f) (make-App (f rator) + (map f rands) + stx)] + [#:walk (f) + (f rator) + (for-each f rands)] + #:needs-resolving) - [#:fold-rhs (*App (type-rec-id rator) - (map type-rec-id rands) - stx)]) - -;; left and right are Types -(def-type Pair ([left Type/c] [right Type/c]) [#:key 'pair]) - -;; dotted list -- after expansion, becomes normal Pair-based list type -(def-type ListDots ([dty Type/c] [dbound (or/c symbol? natural-number/c)]) - [#:frees (if (symbol? dbound) - (free-vars-remove (free-vars* dty) dbound) - (free-vars* dty)) - (if (symbol? dbound) - (combine-frees (list (single-free-var dbound) (free-idxs* dty))) - (free-idxs* dty))] - [#:fold-rhs (*ListDots (type-rec-id dty) dbound)]) - -;; *mutable* pairs - distinct from regular pairs -;; left and right are Types -(def-type MPair ([left Type/c] [right Type/c]) - [#:frees (λ (f) (make-invariant (combine-frees (list (f left) (f right)))))] - [#:key 'mpair]) - -;; elem is a Type -(def-type Vector ([elem Type/c]) - [#:frees (λ (f) (make-invariant (f elem)))] - [#:key 'vector]) - -;; elems are all Types -(def-type HeterogeneousVector ([elems (listof Type/c)]) - [#:intern (map Rep-seq elems)] - [#:frees (λ (f) (make-invariant (combine-frees (map f elems))))] - [#:key 'vector] - [#:fold-rhs (*HeterogeneousVector (map type-rec-id elems))]) - -;; elem is a Type -(def-type Box ([elem Type/c]) - [#:frees (λ (f) (make-invariant (f elem)))] - [#:key 'box]) - -;; elem is a Type -(def-type Channel ([elem Type/c]) - [#:frees (λ (f) (make-invariant (f elem)))] - [#:key 'channel]) - -;; elem is a Type -(def-type Async-Channel ([elem Type/c]) - [#:frees (λ (f) (make-invariant (f elem)))] - [#:key 'async-channel]) - -;; elem is a Type -(def-type ThreadCell ([elem Type/c]) - [#:frees (λ (f) (make-invariant (f elem)))] - [#:key 'thread-cell]) - -;; elem is a Type -(def-type Promise ([elem Type/c]) - [#:key 'promise]) - -;; elem is a Type -(def-type Ephemeron ([elem Type/c]) - [#:key 'ephemeron]) - -;; elem is a Type -(def-type Weak-Box ([elem Type/c]) - [#:key 'weak-box]) - -;; elem is a Type -(def-type CustodianBox ([elem Type/c]) - [#:key 'custodian-box]) - -;; elem is a Type -(def-type Set ([elem Type/c]) - [#:key 'set]) - -;; result is a Type -(def-type Evt ([result Type/c]) - [#:key #f]) ;; name is a Symbol (not a Name) ;; contract is used when generating contracts from types @@ -215,145 +134,402 @@ ;; to that base type. This is used to check for subtyping between value ;; types and base types. ;; numeric determines if the type is a numeric type -(def-type Base ([name symbol?] [contract syntax?] [predicate procedure?] [numeric? boolean?]) - [#:frees #f] [#:fold-rhs #:base] [#:intern name] - [#:key (if numeric? - 'number - (case name - [(Boolean) 'boolean] - [(String) 'string] - [(Symbol) 'symbol] - [(Keyword) 'keyword] - [else #f]))]) +(def-type Base ([name symbol?] + [contract syntax?] + [predicate procedure?] + [numeric? boolean?]) + #:base + [#:intern-key name] + [#:type-mask + (if numeric? + mask:number + (case name + [(Char) mask:char] + [(String) mask:string] + [(Void) mask:void] + [(Symbol) mask:symbol] + [else mask:base-other]))]) -(def-type Mu ([body Type/c]) #:no-provide [#:frees (λ (f) (f body))] - [#:fold-rhs (*Mu (type-rec-id body))] - [#:key (Type-key body)]) + +;;************************************************************ +;; Structural Types +;;************************************************************ + +;; structural types +;; these have only Type? fields, for which they specify their variance +;; (either #:covariant, #:contravariant, or #:invariant for Covariant, Contravariant, or Invariant) +;; instead of specifying a contract for the fields +(define-syntax (def-structural stx) + (define-syntax-class (structural-flds frees) + #:attributes (name variance fld-frees) + (pattern [name:id #:covariant] + #:with variance #'Covariant + #:with fld-frees #'(frees name)) + (pattern [name:id #:contravariant] + #:with variance #'Contravariant + #:with fld-frees #'(flip-variances (frees name))) + (pattern [name:id #:invariant] + #:with variance #'Invariant + #:with fld-frees #'(make-invariant (frees name)))) + (syntax-parse stx + [(_ name:var-name ((~var flds (structural-flds #'frees)) ...) . rst) + #'(def-rep name ([flds.name Type?] ...) + [#:parent Type] + [#:intern-key (list* (Rep-seq flds.name) ...)] + [#:variances flds.variance ...] + [#:frees (frees) (combine-frees (list flds.fld-frees ...))] + [#:fold (f) (name.constructor (f flds.name) ...)] + [#:walk (f) (f flds.name) ...] + . rst)])) + + +;;-------- +;; Pairs +;;-------- + +;; left and right are Types +(def-structural Pair ([left #:covariant] + [right #:covariant]) + [#:type-mask mask:pair]) + +;;---------------- +;; Mutable Pairs +;;---------------- + +(def-type MPairTop () [#:type-mask mask:mpair] #:base) + +;; *mutable* pairs - distinct from regular pairs +;; left and right are Types +(def-structural MPair ([left #:invariant] [right #:invariant]) + [#:type-mask mask:mpair] + [#:top MPairTop?]) + +;;---------- +;; Vectors +;;---------- + +(def-type VectorTop () [#:type-mask mask:vector] #:base) + +;; elem is a Type +(def-structural Vector ([elem #:invariant]) + [#:type-mask mask:vector] + [#:top VectorTop?]) + +;;------ +;; Box +;;------ + +(def-type BoxTop () + [#:type-mask mask:box] #:base) + +(def-structural Box ([elem #:invariant]) + [#:type-mask mask:box] + [#:top BoxTop?]) + +;;---------- +;; Channel +;;---------- + +(def-type ChannelTop () + [#:type-mask mask:channel] #:base) + +(def-structural Channel ([elem #:invariant]) + [#:type-mask mask:channel] + [#:top ChannelTop?]) + +;;---------------- +;; Async-Channel +;;---------------- + +(def-type Async-ChannelTop () + [#:type-mask mask:channel] #:base) + +(def-structural Async-Channel ([elem #:invariant]) + [#:type-mask mask:channel] + [#:top Async-ChannelTop?]) + +;;------------- +;; ThreadCell +;;------------- + +(def-type ThreadCellTop () + [#:type-mask mask:thread-cell] #:base) + +(def-structural ThreadCell ([elem #:invariant]) + [#:type-mask mask:thread-cell] + [#:top ThreadCellTop?]) + +;;---------- +;; Promise +;;---------- + +(def-structural Promise ([elem #:covariant]) + [#:type-mask mask:promise]) + +;;------------ +;; Ephemeron +;;------------ + +(def-structural Ephemeron ([elem #:covariant]) + [#:type-mask mask:ephemeron]) + + +;;----------- +;; Weak-Box +;;----------- + +(def-type Weak-BoxTop () + [#:type-mask mask:other-box] #:base) + +(def-structural Weak-Box ([elem #:invariant]) + [#:type-mask mask:other-box] + [#:top Weak-BoxTop?]) + + +;;--------------- +;; CustodianBox +;;--------------- + +(def-structural CustodianBox ([elem #:covariant]) + [#:type-mask mask:other-box]) + +;;------ +;; Set +;;------ + +;; TODO separate mutable/immutable set types +(def-structural Set ([elem #:covariant]) + [#:type-mask mask:set]) + +;;------------ +;; Hashtable +;;------------ + +(def-type HashtableTop () + [#:type-mask mask:hash] #:base) + +;; TODO separate mutable/immutable Hashtables +(def-structural Hashtable ([key #:invariant] [value #:invariant]) + [#:type-mask mask:hash] + [#:top HashtableTop?]) + + +;;------ +;; Evt +;;------ + +(def-structural Evt ([result #:covariant])) + +;;-------- +;; Param +;;-------- + +(def-structural Param ([in #:contravariant] + [out #:covariant]) + [#:type-mask mask:procedure]) + + +;;--------- +;; Syntax +;;--------- + +;; t is the type of the result of syntax-e, not the result of syntax->datum +(def-structural Syntax ([t #:covariant]) + [#:type-mask mask:syntax]) + +;;--------- +;; Future +;;--------- + +(def-structural Future ([t #:covariant]) + [#:type-mask mask:future]) + + +;;--------------- +;; Prompt-Tagof +;;--------------- + +(def-type Prompt-TagTop () + [#:type-mask mask:prompt-tag] #:base) + +;; body: the type of the body +;; handler: the type of the prompt handler +;; prompts with this tag will return a union of `body` +;; and the codomains of `handler` +(def-structural Prompt-Tagof ([body #:invariant] + [handler #:invariant]) + [#:type-mask mask:prompt-tag] + [#:top Prompt-TagTop?]) + +;;-------------------------- +;; Continuation-Mark-Keyof +;;-------------------------- + +(def-type Continuation-Mark-KeyTop () + [#:type-mask mask:continuation-mark-key] #:base) + +;; value: the type of allowable values +(def-structural Continuation-Mark-Keyof ([value #:invariant]) + [#:type-mask mask:continuation-mark-key] + [#:top Continuation-Mark-KeyTop?]) + +;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +;; List/Vector Types (that are not simple structural types) +;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + +;; dotted list -- after expansion, becomes normal Pair-based list type +(def-type ListDots ([dty Type?] [dbound (or/c symbol? natural-number/c)]) + [#:intern-key (cons (Rep-seq dty) dbound)] + [#:frees + [#:vars (f) + (if (symbol? dbound) + (free-vars-remove (f dty) dbound) + (f dty))] + [#:idxs (f) + (if (symbol? dbound) + (combine-frees (list (single-free-var dbound) (f dty))) + (f dty))]] + [#:fold (f) (make-ListDots (f dty) dbound)] + [#:walk (f) (f dty)]) + + + +;; elems are all Types +(def-type HeterogeneousVector ([elems (listof Type?)]) + [#:intern-key (map Rep-seq elems)] + [#:frees (f) (make-invariant (combine-frees (map f elems)))] + [#:fold (f) (make-HeterogeneousVector (map f elems))] + [#:walk (f) (for-each f elems)] + [#:type-mask mask:vector] + [#:top VectorTop?]) + + +;; * * * * * * * +;; Type Binders +;; * * * * * * * + + +(def-type Mu ([body Type?]) + #:no-provide + [#:intern-key (Rep-seq body)] + [#:frees (f) (f body)] + [#:fold (f) (make-Mu (f body))] + [#:walk (f) (f body)] + [#:type-mask (Type-mask body)] + #:needs-resolving) ;; n is how many variables are bound here ;; body is a type -(def-type Poly (n body) #:no-provide - [#:contract (->i ([n natural-number/c] - [body Type/c]) - (#:syntax [stx (or/c #f syntax?)]) - [result Poly?])] - [#:frees (λ (f) (f body))] - [#:fold-rhs (*Poly n (type-rec-id body))] - [#:key (Type-key body)]) +(def-type Poly ([n exact-nonnegative-integer?] + [body Type?]) + #:no-provide + [#:intern-key (cons n (Rep-seq body))] + [#:frees (f) (f body)] + [#:fold (f) (make-Poly n (f body))] + [#:walk (f) (f body)] + [#:type-mask (Type-mask body)]) ;; n is how many variables are bound here ;; there are n-1 'normal' vars and 1 ... var -(def-type PolyDots (n body) #:no-provide - [#:contract (->i ([n natural-number/c] - [body Type/c]) - (#:syntax [stx (or/c #f syntax?)]) - [result PolyDots?])] - [#:key (Type-key body)] - [#:frees (λ (f) (f body))] - [#:fold-rhs (*PolyDots n (type-rec-id body))]) +(def-type PolyDots ([n exact-nonnegative-integer?] + [body Type?]) + #:no-provide + [#:intern-key (cons n (Rep-seq body))] + [#:frees (f) (f body)] + [#:fold (f) (make-PolyDots n (f body))] + [#:walk (f) (f body)] + [#:type-mask (Type-mask body)]) ;; interp. A row polymorphic function type ;; constraints are row absence constraints, represented ;; as a set for each of init, field, methods -(def-type PolyRow (constraints body) #:no-provide - [#:contract (->i ([constraints (list/c list? list? list? list?)] - [body Type/c]) - (#:syntax [stx (or/c #f syntax?)]) - [result PolyRow?])] - [#:frees (λ (f) (f body))] - [#:fold-rhs (*PolyRow constraints - (type-rec-id body))] - [#:key (Type-key body)]) +(def-type PolyRow ([constraints (list/c list? list? list? list?)] + [body Type?]) + #:no-provide + [#:intern-key (cons (Rep-seq body) constraints)] + [#:frees (f) (f body)] + [#:fold (f) (make-PolyRow constraints (f body))] + [#:walk (f) (f body)] + [#:type-mask (Type-mask body)]) ;; pred : identifier -(def-type Opaque ([pred identifier?]) - [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base] [#:key pred]) +(def-type Opaque ([pred identifier?]) #:base + [#:intern-key (hash-id pred)]) + + ;; kw : keyword? ;; ty : Type ;; required? : Boolean -(def-type Keyword ([kw keyword?] [ty Type/c] [required? boolean?]) - [#:frees (λ (f) (f ty))] - [#:fold-rhs (*Keyword kw (type-rec-id ty) required?)]) +(def-rep Keyword ([kw keyword?] [ty Type?] [required? boolean?]) + [#:intern-key (vector-immutable kw (Rep-seq ty) required?)] + [#:frees (f) (f ty)] + [#:fold (f) (make-Keyword kw (f ty) required?)] + [#:walk (f) (f ty)]) -(def-type Result ([t Type/c] [f PropSet?] [o Object?]) - [#:frees (λ (frees) (combine-frees (map frees (list t f o))))] - [#:fold-rhs (*Result (type-rec-id t) (prop-rec-id f) (object-rec-id o))]) - -(def-type Values ([rs (listof Result?)]) - [#:intern (map Rep-seq rs)] - [#:frees (λ (f) (combine-frees (map f rs)))] - [#:fold-rhs (*Values (map type-rec-id rs))]) - - -(def-type AnyValues ([f Prop?]) - [#:fold-rhs #:base]) - -(def-type ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)]) - [#:intern (list (map Rep-seq rs) (Rep-seq dty) dbound)] - [#:frees (if (symbol? dbound) - (free-vars-remove (combine-frees (map free-vars* (cons dty rs))) dbound) - (combine-frees (map free-vars* (cons dty rs)))) - (if (symbol? dbound) - (combine-frees (cons (single-free-var dbound) - (map free-idxs* (cons dty rs)))) - (combine-frees (map free-idxs* (cons dty rs))))] - [#:fold-rhs (*ValuesDots (map type-rec-id rs) (type-rec-id dty) dbound)]) - -(define SomeValues/c (or/c Values? AnyValues? ValuesDots?)) - -;; arr is NOT a Type -(def-type arr ([dom (listof Type/c)] - [rng SomeValues/c] - [rest (or/c #f Type/c)] - [drest (or/c #f (cons/c Type/c (or/c natural-number/c symbol?)))] - [kws (listof Keyword?)]) - [#:intern (list (map Rep-seq dom) (Rep-seq rng) (and rest (Rep-seq rest)) - (and drest (cons (Rep-seq (car drest)) (cdr drest))) - (map Rep-seq kws))] - [#:frees (combine-frees - (append (map (compose flip-variances free-vars*) - (append (if rest (list rest) null) - (map Keyword-ty kws) - dom)) - (match drest - [(cons t (? symbol? bnd)) - (list (free-vars-remove (flip-variances (free-vars* t)) bnd))] - [(cons t _) - (list (flip-variances (free-vars* t)))] - [_ null]) - (list (free-vars* rng)))) - (combine-frees - (append (map (compose flip-variances free-idxs*) - (append (if rest (list rest) null) - (map Keyword-ty kws) - dom)) - (match drest - [(cons t (? symbol? bnd)) - (list (single-free-var bnd Contravariant) - (flip-variances (free-idxs* t)))] - [(cons t _) - (list (flip-variances (free-idxs* t)))] - [_ null]) - (list (free-idxs* rng))))] - [#:fold-rhs (*arr (map type-rec-id dom) - (type-rec-id rng) - (and rest (type-rec-id rest)) - (and drest (cons (type-rec-id (car drest)) (cdr drest))) - (map type-rec-id kws))]) +(def-rep arr ([dom (listof Type?)] + [rng SomeValues?] + [rest (or/c #f Type?)] + [drest (or/c #f (cons/c Type? (or/c natural-number/c symbol?)))] + [kws (listof Keyword?)]) + [#:intern-key (vector-immutable + (map Rep-seq dom) (Rep-seq rng) (and rest (Rep-seq rest)) + (and drest (cons (Rep-seq (car drest)) (cdr drest))) + (map Rep-seq kws))] + [#:frees + [#:vars (f) + (combine-frees + (append (map (compose flip-variances f) + (append (if rest (list rest) null) + (map Keyword-ty kws) + dom)) + (match drest + [(cons t (? symbol? bnd)) + (list (free-vars-remove (flip-variances (f t)) bnd))] + [(cons t _) + (list (flip-variances (f t)))] + [_ null]) + (list (f rng))))] + [#:idxs (f) + (combine-frees + (append (map (compose flip-variances f) + (append (if rest (list rest) null) + (map Keyword-ty kws) + dom)) + (match drest + [(cons t (? symbol? bnd)) + (list (single-free-var bnd Contravariant) + (flip-variances (f t)))] + [(cons t _) + (list (flip-variances (f t)))] + [_ null]) + (list (f rng))))]] + [#:fold (f) (make-arr (map f dom) + (f rng) + (and rest (f rest)) + (and drest (cons (f (car drest)) (cdr drest))) + (map f kws))] + [#:walk (f) + (for-each f dom) + (f rng) + (when drest (f (car drest))) + (when rest (f rest)) + (for-each f kws)]) ;; arities : Listof[arr] (def-type Function ([arities (listof arr?)]) - [#:intern (map Rep-seq arities)] - [#:key 'procedure] - [#:frees (λ (f) (combine-frees (map f arities)))] - [#:fold-rhs (*Function (map type-rec-id arities))]) + [#:intern-key (map Rep-seq arities)] + [#:type-mask mask:procedure] + [#:frees (f) (combine-frees (map f arities))] + [#:fold (f) (make-Function (map f arities))] + [#:walk (f) (for-each f arities)]) -(def-type fld ([t Type/c] [acc identifier?] [mutable? boolean?]) - [#:frees (λ (f) (if mutable? (make-invariant (f t)) (f t)))] - [#:fold-rhs (*fld (type-rec-id t) acc mutable?)] - [#:intern (list (Rep-seq t) (hash-id acc) mutable?)]) +(def-rep fld ([t Type?] [acc identifier?] [mutable? boolean?]) + [#:intern-key (cons (hash-id acc) (Rep-seq t))] + [#:frees (f) (if mutable? (make-invariant (f t)) (f t))] + [#:fold (f) (make-fld (f t) acc mutable?)] + [#:walk (f) (f t)]) ;; name : identifier ;; parent : Struct @@ -370,109 +546,103 @@ [proc (or/c #f Function?)] [poly? boolean?] [pred-id identifier?]) - [#:intern (list (hash-id name) - (hash-id pred-id) - (and parent (Rep-seq parent)) - (map Rep-seq flds) - (and proc (Rep-seq proc)))] - [#:frees (λ (f) (combine-frees (map f (append (if proc (list proc) null) - (if parent (list parent) null) - flds))))] - [#:fold-rhs (*Struct name - (and parent (type-rec-id parent)) - (map type-rec-id flds) - (and proc (type-rec-id proc)) - poly? - pred-id)] + [#:intern-key (cons (hash-id name) (map Rep-seq flds))] + [#:frees (f) (combine-frees (map f (append (if proc (list proc) null) + (if parent (list parent) null) + flds)))] + [#:fold (f) (make-Struct name + (and parent (f parent)) + (map f flds) + (and proc (f proc)) + poly? + pred-id)] + [#:walk (f) + (f parent) + (for-each f flds) + (f proc)] ;; This should eventually be based on understanding of struct properties. - [#:key '(struct procedure)]) + [#:type-mask (mask-union mask:struct mask:procedure)]) ;; Represents prefab structs ;; key : prefab key encoding mutability, auto-fields, etc. ;; flds : the types of all of the prefab fields (def-type Prefab ([key prefab-key?] - [flds (listof Type/c)]) - [#:frees (λ (f) (combine-frees (map f flds)))] - [#:fold-rhs (*Prefab key (map type-rec-id flds))] - [#:key 'prefab]) + [flds (listof Type?)]) + [#:intern-key (cons key (map Rep-seq flds))] + [#:frees (f) (combine-frees (map f flds))] + [#:fold (f) (make-Prefab key (map f flds))] + [#:walk (f) (for-each f flds)] + [#:type-mask mask:prefab]) + +(def-type StructTypeTop () + #:base + [#:type-mask mask:struct-type]) ;; A structure type descriptor -(def-type StructTypeTop () [#:fold-rhs #:base] [#:key 'struct-type]) -(def-type StructType ([s (or/c F? B? Struct? Prefab?)]) [#:key 'struct-type]) +(def-type StructType ([s (or/c F? B? Struct? Prefab?)]) + [#:intern-key (Rep-seq s)] + [#:frees (f) (f s)] + [#:fold (f) (make-StructType (f s))] + [#:walk (f) (f s)] + [#:type-mask mask:struct-type] + [#:top StructTypeTop?]) + +(def-type StructTop ([name Struct?]) + [#:intern-key (Rep-seq name)] + [#:frees (f) (f name)] + [#:fold (f) (make-StructTop (f name))] + [#:walk (f) (f name)] + [#:type-mask (mask-union mask:struct mask:procedure)]) + + -;; the supertype of all of these values -(def-type BoxTop () [#:fold-rhs #:base] [#:key 'box]) -(def-type Weak-BoxTop () [#:fold-rhs #:base] [#:key 'weak-box]) -(def-type ChannelTop () [#:fold-rhs #:base] [#:key 'channel]) -(def-type Async-ChannelTop () [#:fold-rhs #:base] [#:key 'async-channel]) -(def-type VectorTop () [#:fold-rhs #:base] [#:key 'vector]) -(def-type HashtableTop () [#:fold-rhs #:base] [#:key 'hash]) -(def-type MPairTop () [#:fold-rhs #:base] [#:key 'mpair]) -(def-type StructTop ([name Struct?]) [#:key 'struct]) -(def-type ThreadCellTop () [#:fold-rhs #:base] [#:key 'thread-cell]) -(def-type Prompt-TagTop () [#:fold-rhs #:base] [#:key 'prompt-tag]) -(def-type Continuation-Mark-KeyTop () - [#:fold-rhs #:base] [#:key 'continuation-mark-key]) ;; v : Racket Value -(def-type Value (v) [#:frees #f] [#:fold-rhs #:base] - [#:key (cond [(or (eq? v 0) (eq? v 1)) 'number] - ;; other numbers don't work with the optimizations in subtype.rkt - ;; which assume that unions of numbers are subtyped in simple ways - [(boolean? v) 'boolean] - [(null? v) 'null] - [else #f])]) +;; contract will change to the following after +;; base types are redone: +(def-type Value ([val any/c]) + #:base + [#:intern-key val] + [#:type-mask + (match val + [(? number?) mask:number] + [#t mask:true] + [#f mask:false] + [(? symbol?) mask:symbol] + [(? string?) mask:string] + [(? char?) mask:char] + [(? null?) mask:null] + [(? void?) mask:void] + [_ mask:unknown])]) ;; elems : Listof[Type] -(def-type Union ([elems (and/c (listof Type/c) - (lambda (es) - (or (null? es) - (let-values ([(sorted? k) - (for/fold ([sorted? #t] - [last (car es)]) - ([e (cdr es)]) - (values - (and sorted? (type=/c 2))]) + #:no-provide + [#:intern-key (for/hash ([elem (in-list elems)]) (values elem #t))] + [#:frees (f) (combine-frees (map f elems))] + [#:fold (f) (apply Un (map f elems))] + [#:walk (f) (for-each f elems)] + [#:type-mask + (for/fold ([mask mask:bottom]) + ([elem (in-list elems)]) + (mask-union mask (Type-mask elem)))]) +(define (make-Union* elems) + (match elems + [(list) (make-Bottom)] + [(list t) t] + [_ (make-Union elems)])) ;; Intersection -(def-type Intersection ([elems (and/c (set/c Type/c) - (λ (s) (>= (set-count s) 2)))]) - [#:intern (for/set ([e (in-immutable-set elems)]) - (Rep-seq e))] - [#:frees (λ (f) (combine-frees (for/list ([elem (in-immutable-set elems)]) - (f elem))))] - [#:fold-rhs (let ([elems (for/list ([elem (in-immutable-set elems)]) - (type-rec-id elem))]) - (apply -unsafe-intersect elems))] - [#:key (let () - (define d - (let loop ([ts (set->list elems)] [res null]) - (cond [(null? ts) res] - [else - (define k (Type-key (car ts))) - (cond [(not k) (list #f)] - [(pair? k) (loop (cdr ts) (append k res))] - [else (loop (cdr ts) (cons k res))])]))) - (define d* (remove-duplicates d)) - (if (and (pair? d*) (null? (cdr d*))) (car d*) d*))]) +(def-type Intersection ([elems (and/c (listof Type?) (length>=/c 2))]) + [#:intern-key (for/hash ([elem (in-list elems)]) (values elem #t))] + [#:frees (f) (combine-frees (map f elems))] + [#:fold (f) (apply -unsafe-intersect (map f elems))] + [#:walk (f) (for-each f elems)] + [#:type-mask + (for/fold ([mask mask:unknown]) + ([elem (in-list elems)]) + (mask-intersect mask (Type-mask elem)))]) ;; constructor for intersections ;; in general, intersections should be built @@ -484,46 +654,28 @@ (match ts [(list) (cond - [(set-empty? elems) (Univ)] + [(set-empty? elems) (make-Univ)] ;; size = 1 ? [(= 1 (set-count elems)) (set-first elems)] ;; size > 1, build an intersection - [else (*Intersection elems)])] + [else (make-Intersection (set->list elems))])] [(cons t ts) (match t [(? Bottom?) t] [(Univ:) (loop elems ts)] - [(Intersection: ts*) (loop (set-union elems ts*) ts)] + [(Intersection: ts*) (loop elems (append ts* ts))] [t (cond [(for/or ([elem (in-immutable-set elems)]) (not (overlap? elem t))) - (*Union (list))] + (make-Bottom)] [else (loop (set-add elems t) ts)])])]))) -(def-type Univ () [#:frees #f] [#:fold-rhs #:base]) - -;; in : Type -;; out : Type -(def-type Param ([in Type/c] [out Type/c]) - [#:key 'procedure] - [#:frees (λ (f) (combine-frees (list (f out) (flip-variances (f in)))))]) - -;; key : Type -;; value : Type -(def-type Hashtable ([key Type/c] [value Type/c]) [#:key 'hash] - [#:frees (λ (f) (combine-frees (list (make-invariant (f key)) (make-invariant (f value)))))]) - -(def-type Refinement ([parent Type/c] [pred identifier?]) - [#:key (Type-key parent)] - [#:intern (list (Rep-seq parent) (hash-id pred))] - [#:fold-rhs (*Refinement (type-rec-id parent) pred)] - [#:frees (λ (f) (f parent))]) - - -;; Syntax -;; t : Type -;; t is the type of the result of syntax-e, not the result of syntax->datum -(def-type Syntax ([t Type/c]) [#:key 'syntax]) +(def-type Refinement ([parent Type?] [pred identifier?]) + [#:intern-key (cons (hash-id pred) (Rep-seq parent))] + [#:frees (f) (f parent)] + [#:fold (f) (make-Refinement (f parent) pred)] + [#:walk (f) (f parent)] + [#:type-mask (Type-mask parent)]) ;; A Row used in type instantiation ;; For now, this should not appear in user code. It's used @@ -531,38 +683,45 @@ ;; class types. ;; ;; invariant: all clauses are sorted by the key name -(def-type Row ([inits (listof (list/c symbol? Type/c boolean?))] - [fields (listof (list/c symbol? Type/c))] - [methods (listof (list/c symbol? Type/c))] - [augments (listof (list/c symbol? Type/c))] - [init-rest (or/c Type/c #f)]) +(def-rep Row ([inits (listof (list/c symbol? Type? boolean?))] + [fields (listof (list/c symbol? Type?))] + [methods (listof (list/c symbol? Type?))] + [augments (listof (list/c symbol? Type?))] + [init-rest (or/c Type? #f)]) #:no-provide - [#:frees (λ (f) (combine-frees - (map f (append (map cadr inits) - (map cadr fields) - (map cadr methods) - (map cadr augments) - (if init-rest (list init-rest) null)))))] - [#:fold-rhs (match (list inits fields methods augments init-rest) - [(list - (list (list init-names init-tys reqd) ___) - (list (list fname fty) ___) - (list (list mname mty) ___) - (list (list aname aty) ___) - init-rest) - (*Row - (map list - init-names - (map type-rec-id init-tys) - reqd) - (map list fname (map type-rec-id fty)) - (map list mname (map type-rec-id mty)) - (map list aname (map type-rec-id aty)) - (if init-rest (type-rec-id init-rest) #f))])]) + [#:intern-key + (let ([intern (λ (l) (list-update l 1 Rep-seq))]) + (list (map intern inits) + (map intern fields) + (map intern methods) + (map intern augments) + (and init-rest (Rep-seq init-rest))))] + [#:frees (f) + (let ([extract-frees (λ (l) (f (second l)))]) + (combine-frees + (append (map extract-frees inits) + (map extract-frees fields) + (map extract-frees methods) + (map extract-frees augments) + (if init-rest (list (f init-rest)) null))))] + [#:fold (f) + (let ([update (λ (l) (list-update l 1 f))]) + (make-Row (map update inits) + (map update fields) + (map update methods) + (map update augments) + (and init-rest (f init-rest))))] + [#:walk (f) + (let ([walk (λ (l) (f (second l)))]) + (for-each walk inits) + (for-each walk fields) + (for-each walk methods) + (for-each walk augments) + (when init-rest (f init-rest)))]) -;; Supertype of all Class types, cannot instantiate -;; or subclass these -(def-type ClassTop () [#:fold-rhs #:base] [#:key 'class]) +(def-type ClassTop () + #:base + [#:type-mask mask:class]) ;; row-ext : Option<(U F B Row)> ;; row : Row @@ -574,35 +733,58 @@ (def-type Class ([row-ext (or/c #f F? B? Row?)] [row Row?]) #:no-provide - [#:frees (λ (f) (combine-frees - ;; FIXME: is this correct? - `(,@(or (and (F? row-ext) (list (f row-ext))) - '()) - ,(f row))))] - [#:key 'class] - [#:fold-rhs (match (list row-ext row) - [(list row-ext row) - (*Class - (and row-ext (type-rec-id row-ext)) - (type-rec-id row))])]) + [#:intern-key (cons (and row-ext (Rep-seq row-ext)) (Rep-seq row))] + [#:frees (f) + (combine-frees + (append (if row-ext (list (f row-ext)) null) + (list (f row))))] + [#:fold (f) (make-Class (and row-ext (f row-ext)) + (f row))] + [#:walk (f) + (when row-ext (f row-ext)) + (f row)] + [#:type-mask mask:class] + [#:top ClassTop?]) -;; cls : Class -(def-type Instance ([cls Type/c]) [#:key 'instance]) + +;;-------------------------- +;; Instance (of a class) +;;-------------------------- + + +;; not structural because it has special subtyping, +; not just simple structural subtyping +(def-type Instance ([cls Type?]) + [#:intern-key (Rep-seq cls)] + [#:frees (f) (f cls)] + [#:fold (f) (make-Instance (f cls))] + [#:walk (f) (f cls)] + [#:type-mask mask:instance]) ;; interp: ;; name is the id of the signature ;; extends is the extended signature or #f ;; mapping maps variables in a signature to their types -;; This is not a type because signatures are not values -(def-type Signature ([name identifier?] - [extends (or/c identifier? #f)] - [mapping (listof (cons/c identifier? (or/c promise? Type/c)))]) - [#:frees (lambda (f) null)] - [#:fold-rhs (*Signature name extends mapping)]) +;; This is not a type because signatures do not correspond to any values +(def-rep Signature ([name identifier?] + [extends (or/c identifier? #f)] + [mapping (listof (cons/c identifier? Type?))]) + [#:intern-key (hash-id name)] + [#:frees (f) (combine-frees (map (match-lambda + [(cons _ t) (f t)]) + mapping))] + [#:fold (f) (make-Signature name extends (map (match-lambda + [(cons id t) (cons id (f t))]) + mapping))] + [#:walk (f) (for-each (match-lambda + [(cons _ t) (f t)]) + mapping)]) + + +(def-type UnitTop () + #:base + [#:type-mask mask:unit]) -;; The supertype of all units, ie values recognized by the -;; predicate unit? -(def-type UnitTop () [#:fold-rhs #:base] [#:key 'unit]) ;; interp: imports is the list of imported signatures ;; exports is the list of exported signatures @@ -611,191 +793,142 @@ (def-type Unit ([imports (listof Signature?)] [exports (listof Signature?)] [init-depends (listof Signature?)] - [result SomeValues/c]) - [#:frees (lambda (f) (f result))] - [#:fold-rhs (*Unit (map type-rec-id imports) - (map type-rec-id exports) - (map type-rec-id init-depends) - (type-rec-id result))]) + [result SomeValues?]) + [#:intern-key (list* (Rep-seq result) + (map Rep-seq imports) + (map Rep-seq exports) + (map Rep-seq init-depends))] + [#:frees (f) (f result)] + [#:fold (f) (make-Unit (map f imports) + (map f exports) + (map f init-depends) + (f result))] + [#:walk (f) + (for-each f imports) + (for-each f exports) + (for-each f init-depends) + (f result)] + [#:type-mask mask:unit] + [#:top UnitTop?]) ;; sequences ;; includes lists, vectors, etc ;; tys : sequence produces this set of values at each step -(def-type Sequence ([tys (listof Type/c)]) - [#:intern (map Rep-seq tys)] - [#:frees (λ (f) (combine-frees (map f tys)))] - [#:key #f] [#:fold-rhs (*Sequence (map type-rec-id tys))]) - -(def-type Future ([t Type/c]) [#:key 'future]) - -;; body: the type of the body -;; handler: the type of the prompt handler -;; prompts with this tag will return a union of `body` -;; and the codomains of `handler` -(def-type Prompt-Tagof ([body Type/c] [handler Type/c]) - [#:frees (λ (f) (combine-frees (list (make-invariant (f body)) - (make-invariant (f handler)))))] - [#:key 'prompt-tag]) - -;; value: the type of allowable values -(def-type Continuation-Mark-Keyof ([value Type/c]) - [#:frees (λ (f) (make-invariant (f value)))] - [#:key 'continuation-mark-key]) +(def-type Sequence ([tys (listof Type?)]) + [#:intern-key (map Rep-seq tys)] + [#:frees (f) (combine-frees (map f tys))] + [#:fold (f) (make-Sequence (map f tys))] + [#:walk (f) (for-each f tys)]) ;; Distinction ;; comes from define-new-subtype ;; nm: a symbol representing the name of the type ;; id: a symbol created with gensym -;; ty: a type for the representation, where this will be a subtype of ty -(def-type Distinction ([nm symbol?] [id symbol?] [ty Type/c]) - [#:frees (λ (f) (f ty))] - [#:intern (list (Rep-seq ty) nm id)] - [#:fold-rhs (*Distinction nm id (type-rec-id ty))] - [#:key (Type-key ty)]) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; remove-dups: List[Type] -> List[Type] -;; removes duplicate types from a SORTED list -(define/cond-contract (remove-dups types) - ((listof Rep?) . -> . (listof Rep?)) - (cond [(null? types) types] - [(null? (cdr types)) types] - [(type-equal? (car types) (cadr types)) (remove-dups (cdr types))] - [else (cons (car types) (remove-dups (cdr types)))])) +;; ty: a type for the representation (i.e. each distinction +;; is a subtype of its ty) +(def-type Distinction ([nm symbol?] [id symbol?] [ty Type?]) + [#:intern-key (list* nm id (Rep-seq ty))] + [#:frees (f) (f ty)] + [#:fold (f) (make-Distinction nm id (f ty))] + [#:walk (f) (f ty)] + [#:type-mask (Type-mask ty)]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define ((sub-f st) e) - (prop-case (#:Type st - #:Prop (sub-f st) - #:PathElem (sub-pe st)) - e)) +;;************************************************************ +;; Helpers: Type Variable Abstraction/Instantiation +;;************************************************************ +;; used for abstracting/instantiating type variables +;; it recursively folds over the 'start' Rep, and as it +;; passes structs which introduce type variables it increments +;; the depth being tracked (the 'lvl'). When it raches type variables +;; or DeBruijns (dependending on whether we are abstracting or instantiating) +;; it transforms them with f +(define (type-binder-transform f start abstracting?) + (define dbound-fn (if abstracting? values F-n)) + (define not-abstracting? (not abstracting?)) + (let rec/lvl ([cur start] [lvl 0]) + (let rec ([cur cur]) + (match cur + [(F: name*) #:when abstracting? (f name* make-B lvl cur)] + [(B: idx) #:when not-abstracting? (f idx (λ (x) x) lvl cur)] + [(Union: elems) + ;; prevents duplicates, which apparently is needed to avoid + ;; infinite loops here...? + (define seen (make-hasheq)) + (define ts + (for*/fold ([ts null]) + ([elem (in-list elems)] + [elem (in-value (rec elem))] + [seq (in-value (Rep-seq elem))]) + (cond + [(hash-ref seen seq #f) ts] + [else (hash-set! seen seq #t) + (cons elem ts)]))) + (match ts + [(list) (make-Bottom)] + [(list t) t] + [_ (make-Union ts)])] + [(arr: dom rng rest drest kws) + (make-arr (map rec dom) + (rec rng) + (and rest (rec rest)) + (if drest + (cons (rec (car drest)) + (let ([c (cdr drest)]) + (f c dbound-fn lvl c))) + #f) + (map rec kws))] + [(Mu: body) (make-Mu (rec/lvl body (add1 lvl)))] + [(ValuesDots: rs dty dbound) + (make-ValuesDots (map rec rs) + (rec dty) + (f dbound dbound-fn lvl dbound))] + [(ListDots: dty dbound) + (make-ListDots (rec dty) + (f dbound dbound-fn lvl dbound))] + [(PolyRow: constraints body) + (make-PolyRow constraints (rec/lvl body (add1 1 lvl)))] + [(PolyDots: n body) + (make-PolyDots n (rec/lvl body (+ n lvl)))] + [(Poly: n body) + (make-Poly n (rec/lvl body (+ n lvl)))] + [_ (Rep-fold rec cur)])))) -(define ((sub-o st) e) - (object-case (#:Type st - #:Object (sub-o st) - #:PathElem (sub-pe st)) - e)) - -(define ((sub-pe st) e) - (pathelem-case (#:Type st - #:PathElem (sub-pe st)) - e)) - -(define ((sub-t st) e) - (type-case (#:Type st - #:Prop (sub-f st)) - e)) - - -;; abstract-many : Names Type -> Type -;; where n is the length of names -(define (abstract-many names ty) - ;; mapping : dict[Type -> Natural] - (define (nameTo mapping type) - (let loop ([outer 0] [ty type]) - (define (sb t) (loop outer t)) - ;; transform : Name (Integer -> a) a -> a - ;; apply `mapping` to `name*`, returning `default` if it's not there - ;; use `f` to wrap the result - ;; note that this takes into account the value of `outer` - (define (transform name* f default) - (cond [(assq name* mapping) - => (λ (pr) - (f (+ (cdr pr) outer)))] - [else default])) - (type-case - (#:Type sb #:Prop (sub-f sb) #:Object (sub-o sb)) - ty - [#:F name* (transform name* *B ty)] - ;; necessary to avoid infinite loops - [#:Union elems (*Union (remove-dups (sort (map sb elems) type (listof symbol?) Type? Type?) (define n (length names)) (define mapping (for/list ([nm (in-list names)] [i (in-range n 0 -1)]) (cons nm (sub1 i)))) - (nameTo mapping ty)) + ;; transform : symbol (Integer -> a) a -> a + ;; apply `mapping` to `name*`, returning `default` if it's not there + ;; use `f` to wrap the result + ;; note that this takes into account the value of the outer lvl + (define (transform name* fn lvl default) + (cond [(assq name* mapping) + => (λ (pr) (fn (+ (cdr pr) lvl)))] + [else default])) + (type-binder-transform transform ty #t)) -;; instantiate-many : List[Type] Type -> Type -;; where n is the length of types -;; all of the types MUST be Fs -(define (instantiate-many images ty) - ;; mapping : dict[Natural -> Type] - (define (replace mapping type) - (let loop ([outer 0] [ty type]) - ;; transform : Integer (Name -> a) a -> a - ;; apply `mapping` to `idx`, returning `default` if it's not there - ;; use `f` to wrap the result - ;; note that this takes into account the value of `outer` - (define (transform idx f default) - (cond [(assf (lambda (v) (eqv? (+ v outer) idx)) mapping) - => (lambda (pr) (f (cdr pr)))] - [else default])) - (define (sb t) (loop outer t)) - (define sf (sub-f sb)) - (type-case - (#:Type sb #:Prop sf #:Object (sub-o sb)) - ty - [#:B idx (transform idx values ty)] - ;; necessary to avoid infinite loops - [#:Union elems (*Union (remove-dups (sort (map sb elems) type (listof Type?) Type? Type?) (define n (length images)) (define mapping (for/list ([img (in-list images)] [i (in-range n 0 -1)]) (cons (sub1 i) img))) - (replace mapping ty)) + ;; transform : Integer (Name -> a) a -> a + ;; apply `mapping` to `n`, returning `default` if it's not there + ;; use `f` to wrap the result + ;; note that this takes into account the value of the outer `lvl` + (define (transform n fn lvl default) + (cond [(assf (λ (v) (eqv? (+ v lvl) n)) mapping) + => (λ (pr) (fn (cdr pr)))] + [else default])) + (type-binder-transform transform ty #f)) (define (abstract name ty) (abstract-many (list name) ty)) @@ -805,7 +938,7 @@ ;; the 'smart' constructor (define (Mu* name body) - (let ([v (*Mu (abstract name body))]) + (let ([v (make-Mu (abstract name body))]) (hash-set! name-table v name) v)) @@ -813,7 +946,7 @@ (define (Mu-body* name t) (match t [(Mu: body) - (instantiate (*F name) body)])) + (instantiate (make-F name) body)])) ;; the 'smart' constructor ;; @@ -829,7 +962,7 @@ ;; (define (Poly* names body #:original-names [orig names]) (if (null? names) body - (let ([v (*Poly (length names) (abstract-many names body))]) + (let ([v (make-Poly (length names) (abstract-many names body))]) (hash-set! name-table v orig) v))) @@ -839,12 +972,12 @@ [(Poly: n body) (unless (= (length names) n) (int-err "Wrong number of names: expected ~a got ~a" n (length names))) - (instantiate-many (map *F names) body)])) + (instantiate-many (map make-F names) body)])) ;; the 'smart' constructor (define (PolyDots* names body) (if (null? names) body - (let ([v (*PolyDots (length names) (abstract-many names body))]) + (let ([v (make-PolyDots (length names) (abstract-many names body))]) (hash-set! name-table v names) v))) @@ -854,7 +987,7 @@ [(PolyDots: n body) (unless (= (length names) n) (int-err "Wrong number of names: expected ~a got ~a" n (length names))) - (instantiate-many (map *F names) body)])) + (instantiate-many (map make-F names) body)])) ;; Constructor and destructor for row polymorphism ;; @@ -863,14 +996,14 @@ ;; a time. This may change in the future. ;; (define (PolyRow* names constraints body #:original-names [orig names]) - (let ([v (*PolyRow constraints (abstract-many names body))]) + (let ([v (make-PolyRow constraints (abstract-many names body))]) (hash-set! name-table v orig) v)) (define (PolyRow-body* names t) (match t [(PolyRow: constraints body) - (instantiate-many (map *F names) body)])) + (instantiate-many (map make-F names) body)])) (print-struct #t) @@ -1023,24 +1156,24 @@ ;; This is a custom constructor for Row types ;; Sorts all clauses by the key (the clause name) (define (Row* inits fields methods augments init-rest) - (*Row inits - (sort-row-clauses fields) - (sort-row-clauses methods) - (sort-row-clauses augments) - init-rest)) + (make-Row inits + (sort-row-clauses fields) + (sort-row-clauses methods) + (sort-row-clauses augments) + init-rest)) ;; Class* ;; This is a custom constructor for Class types that ;; doesn't require writing make-Row everywhere (define/cond-contract (Class* row-var inits fields methods augments init-rest) (-> (or/c F? B? Row? #f) - (listof (list/c symbol? Type/c boolean?)) - (listof (list/c symbol? Type/c)) - (listof (list/c symbol? Type/c)) - (listof (list/c symbol? Type/c)) - (or/c Type/c #f) + (listof (list/c symbol? Type? boolean?)) + (listof (list/c symbol? Type?)) + (listof (list/c symbol? Type?)) + (listof (list/c symbol? Type?)) + (or/c Type? #f) Class?) - (*Class row-var (Row* inits fields methods augments init-rest))) + (make-Class row-var (Row* inits fields methods augments init-rest))) ;; Class:* ;; This match expander replaces the built-in matching with @@ -1082,7 +1215,7 @@ ;; sorts the given field of a Row by the member name (define (sort-row-clauses clauses) - (sort clauses symbol Type +;; must be applied to a Mu +(define/cond-contract (unfold t) + (Mu? . -> . Type?) + (match t + [(Mu-unsafe: body) (instantiate t body)] + [t (error 'unfold "not a mu! ~a" t)])) diff --git a/typed-racket-lib/typed-racket/rep/values-rep.rkt b/typed-racket-lib/typed-racket/rep/values-rep.rkt new file mode 100644 index 00000000..0829046c --- /dev/null +++ b/typed-racket-lib/typed-racket/rep/values-rep.rkt @@ -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))]) diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt index 15a85efb..359a3ff1 100644 --- a/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt +++ b/typed-racket-lib/typed-racket/static-contracts/combinators/name.rkt @@ -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?) diff --git a/typed-racket-lib/typed-racket/typecheck/check-below.rkt b/typed-racket-lib/typed-racket/typecheck/check-below.rkt index 02a7d704..a167f35b 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-below.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-below.rkt @@ -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] diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index d9d01911..e4ff8525 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -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) diff --git a/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt index 5d592e52..c46f0051 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt @@ -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])] diff --git a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt index c18abe8f..04617bb3 100644 --- a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/error-message.rkt b/typed-racket-lib/typed-racket/typecheck/error-message.rkt index fb630947..22bb22b2 100644 --- a/typed-racket-lib/typed-racket/typecheck/error-message.rkt +++ b/typed-racket-lib/typed-racket/typecheck/error-message.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt b/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt index f425a0c3..1da78d5f 100644 --- a/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt +++ b/typed-racket-lib/typed-racket/typecheck/find-annotation.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt b/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt index f402200a..858fd426 100644 --- a/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt +++ b/typed-racket-lib/typed-racket/typecheck/possible-domains.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt b/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt index 795ef846..8beb068f 100644 --- a/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt +++ b/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt @@ -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) diff --git a/typed-racket-lib/typed-racket/typecheck/signatures.rkt b/typed-racket-lib/typed-racket/typecheck/signatures.rkt index cb3781f1..f28d6263 100644 --- a/typed-racket-lib/typed-racket/typecheck/signatures.rkt +++ b/typed-racket-lib/typed-racket/typecheck/signatures.rkt @@ -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?))])) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt index 3a5ea3e0..903f12de 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt @@ -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")) + diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index 4369c1e3..38dd850c 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -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))] diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt index f9361fac..2183ec8a 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-keywords.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt index 9bef361d..8f06abf7 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt @@ -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^ diff --git a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt index 74bd13de..aa3bd0ea 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt @@ -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" diff --git a/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt b/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt index bf01c273..1fd4e72c 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-apply.rkt @@ -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^) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt b/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt index c2cda2b1..b65b7808 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-envops.rkt @@ -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)]))])) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 00de9951..ae0fff6e 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt b/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt index ecdf43d5..62b3f9ac 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt @@ -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) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt b/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt index 477c7365..8159c2b9 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt @@ -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-)))) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-if.rkt b/typed-racket-lib/typed-racket/typecheck/tc-if.rkt index a9bdf3cd..bffd06d8 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-if.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-if.rkt @@ -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)) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt index c8bc7d57..88c6df6f 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt @@ -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))))) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 0472dd86..5f7f5736 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -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)] diff --git a/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt b/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt index d258cbf4..a7d17343 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt @@ -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) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-send.rkt b/typed-racket-lib/typed-racket/typecheck/tc-send.rkt index f4a6703d..b8b3ab4b 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-send.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-send.rkt @@ -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" diff --git a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt index a9193a8c..9aa2796c 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-structs.rkt @@ -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)))) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt b/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt index 029bff92..640bc28e 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-subst.rkt @@ -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)]))) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index aade0448..4c4c064d 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -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") diff --git a/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt b/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt index 4ffc9659..710ea3ac 100644 --- a/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt +++ b/typed-racket-lib/typed-racket/typecheck/toplevel-trampoline.rkt @@ -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? diff --git a/typed-racket-lib/typed-racket/types/abbrev.rkt b/typed-racket-lib/typed-racket/types/abbrev.rkt index ad2d7561..d26e0752 100644 --- a/typed-racket-lib/typed-racket/types/abbrev.rkt +++ b/typed-racket-lib/typed-racket/types/abbrev.rkt @@ -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)) diff --git a/typed-racket-lib/typed-racket/types/base-abbrev.rkt b/typed-racket-lib/typed-racket/types/base-abbrev.rkt index 4ea253a4..b1461d16 100644 --- a/typed-racket-lib/typed-racket/types/base-abbrev.rkt +++ b/typed-racket-lib/typed-racket/types/base-abbrev.rkt @@ -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* (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 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) ...) - keywordoptkey 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) ...) - keywordlist #'(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 Row diff --git a/typed-racket-lib/typed-racket/types/current-seen.rkt b/typed-racket-lib/typed-racket/types/current-seen.rkt index 2c952245..cad1bf99 100644 --- a/typed-racket-lib/typed-racket/types/current-seen.rkt +++ b/typed-racket-lib/typed-racket/types/current-seen.rkt @@ -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))))) diff --git a/typed-racket-lib/typed-racket/types/kw-types.rkt b/typed-racket-lib/typed-racket/types/kw-types.rkt index 164c4d2e..745d47f4 100644 --- a/typed-racket-lib/typed-racket/types/kw-types.rkt +++ b/typed-racket-lib/typed-racket/types/kw-types.rkt @@ -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" diff --git a/typed-racket-lib/typed-racket/types/match-expanders.rkt b/typed-racket-lib/typed-racket/types/match-expanders.rkt index b5357190..aba92208 100644 --- a/typed-racket-lib/typed-racket/types/match-expanders.rkt +++ b/typed-racket-lib/typed-racket/types/match-expanders.rkt @@ -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)))) diff --git a/typed-racket-lib/typed-racket/types/overlap.rkt b/typed-racket-lib/typed-racket/types/overlap.rkt index 7f40ddf1..ebe1373f 100644 --- a/typed-racket-lib/typed-racket/types/overlap.rkt +++ b/typed-racket-lib/typed-racket/types/overlap.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/types/path-type.rkt b/typed-racket-lib/typed-racket/types/path-type.rkt index 747b8145..09cb4f10 100644 --- a/typed-racket-lib/typed-racket/types/path-type.rkt +++ b/typed-racket-lib/typed-racket/types/path-type.rkt @@ -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]))) diff --git a/typed-racket-lib/typed-racket/types/printer.rkt b/typed-racket-lib/typed-racket/types/printer.rkt index dc4866f7..4e7e90ac 100644 --- a/typed-racket-lib/typed-racket/types/printer.rkt +++ b/typed-racket-lib/typed-racket/types/printer.rkt @@ -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 -> Listof Listof @@ -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) - diff --git a/typed-racket-lib/typed-racket/types/prop-ops.rkt b/typed-racket-lib/typed-racket/types/prop-ops.rkt index 1b5e5fbd..442c2603 100644 --- a/typed-racket-lib/typed-racket/types/prop-ops.rkt +++ b/typed-racket-lib/typed-racket/types/prop-ops.rkt @@ -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 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 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)])) \ No newline at end of file diff --git a/typed-racket-lib/typed-racket/types/resolve.rkt b/typed-racket-lib/typed-racket/types/resolve.rkt index 1d79a291..e4dd1d25 100644 --- a/typed-racket-lib/typed-racket/types/resolve.rkt +++ b/typed-racket-lib/typed-racket/types/resolve.rkt @@ -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)) diff --git a/typed-racket-lib/typed-racket/types/structural.rkt b/typed-racket-lib/typed-racket/types/structural.rkt deleted file mode 100644 index c00c1e6d..00000000 --- a/typed-racket-lib/typed-racket/types/structural.rkt +++ /dev/null @@ -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)) diff --git a/typed-racket-lib/typed-racket/types/substitute.rkt b/typed-racket-lib/typed-racket/types/substitute.rkt index d3b57524..3beab6f1 100644 --- a/typed-racket-lib/typed-racket/types/substitute.rkt +++ b/typed-racket-lib/typed-racket/types/substitute.rkt @@ -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)]) diff --git a/typed-racket-lib/typed-racket/types/remove.rkt b/typed-racket-lib/typed-racket/types/subtract.rkt similarity index 60% rename from typed-racket-lib/typed-racket/types/remove.rkt rename to typed-racket-lib/typed-racket/types/subtract.rkt index ff7cd61f..ec4c1dd7 100644 --- a/typed-racket-lib/typed-racket/types/remove.rkt +++ b/typed-racket-lib/typed-racket/types/subtract.rkt @@ -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] diff --git a/typed-racket-lib/typed-racket/types/subtype.rkt b/typed-racket-lib/typed-racket/types/subtype.rkt index fcf14df6..7a83058b 100644 --- a/typed-racket-lib/typed-racket/types/subtype.rkt +++ b/typed-racket-lib/typed-racket/types/subtype.rkt @@ -1,47 +1,97 @@ #lang racket/base (require (except-in "../utils/utils.rkt" infer) racket/match racket/function racket/lazy-require - racket/list racket/set - (prefix-in c: (contract-req)) - (rep type-rep prop-rep object-rep rep-utils) + racket/list + (contract-req) + (rep type-rep prop-rep object-rep + core-rep type-mask values-rep rep-utils + free-variance) (utils tc-utils early-return) - (types utils resolve base-abbrev match-expanders - numeric-tower substitute current-seen prefab signatures) - (for-syntax racket/base syntax/parse racket/sequence)) + (types utils resolve match-expanders current-seen + numeric-tower substitute prefab signatures) + (for-syntax racket/base syntax/parse racket/sequence) + (rename-in "base-abbrev.rkt" + [-> t->] + [->* t->*])) (lazy-require ("union.rkt" (Un)) ("../infer/infer.rkt" (infer)) ("../typecheck/tc-subst.rkt" (restrict-values))) -(define subtype-cache (make-hash)) -(define-syntax-rule (handle-failure e) - e) +(provide/cond-contract + [subtype (-> Type? Type? boolean?)] + [subresult (-> Result? Result? boolean?)] + [subval (-> SomeValues? SomeValues? boolean?)] + [type-compare? (-> (or/c Type? SomeValues?) (or/c Type? SomeValues?) boolean?)] + [subtypes (-> (listof Type?) (listof Type?) boolean?)] + [subtypes/varargs (-> (listof Type?) (listof Type?) (or/c Type? #f) boolean?)]) -;; is s a subtype of t? + +;;************************************************************ +;; Public Interface to Subtyping +;;************************************************************ + +;; is t1 a subtype of t2? ;; type type -> boolean -(define/cond-contract (subtype s t) - (c:-> (c:or/c Type/c SomeValues/c) (c:or/c Type/c SomeValues/c) boolean?) - (and (subtype* (current-seen) s t) #t)) +(define (subtype t1 t2) + (define res (and (subtype* (seen) t1 t2) #t)) + res) + + +;; is v1 a subval of v2? +;; SomeValue? SomeValue -> boolean +;; (i.e. subtyping on SomeValues) +(define (subval v1 v2) + (and (subval* (seen) v1 v2) #t)) + +;; are t1 and t2 equivalent types (w.r.t. subtyping) +(define (type-compare? t1 t2) + (or (equal? t1 t2) (and (subtype t1 t2) + (subtype t2 t1)))) ;; are all the s's subtypes of all the t's? ;; [type] [type] -> boolean -(define (subtypes s t) (and (subtypes* (current-seen) s t) #t)) +(define (subtypes t1s t2s) (and (subtypes* (seen) t1s t2s) #t)) + +(define (subresult r1 r2) (and (subresult* (seen) r1 r2) #t)) + +;;************************************************************ +;; General Subtyping Helpers +;;************************************************************ + ;; check subtyping for two lists of types ;; List[(cons Number Number)] listof[type] listof[type] -> Opt[List[(cons Number Number)]] -(define (subtypes* A ss ts) - (cond [(and (null? ss) (null? ts) A)] - [(or (null? ss) (null? ts)) #f] - [(subtype* A (car ss) (car ts)) +(define (subtypes* A t1s t2s) + (cond [(and (null? t1s) (null? t2s) A)] + [(or (null? t1s) (null? t2s)) #f] + [(subtype* A (car t1s) (car t2s)) => - (lambda (A*) (subtypes* A* (cdr ss) (cdr ts)))] + (λ (A*) (subtypes* A* (cdr t1s) (cdr t2s)))] + [else #f])) + +(define (subresults* A rs1 rs2) + (cond [(and (null? rs1) (null? rs2) A)] + [(or (null? rs1) (null? rs2)) #f] + [(subresult* A (car rs1) (car rs2)) + => + (λ (A*) (subresults* A* (cdr rs1) (cdr rs2)))] + [else #f])) + +(define (subvals* A vs1 vs2) + (cond [(and (null? vs1) (null? vs2)) A] + [(or (null? vs1) (null? vs2)) #f] + [(subval* A (car vs1) (car vs2)) + => + (λ (A*) (subvals* A* (cdr vs1) (cdr vs2)))] [else #f])) ;; check if s is a supertype of any element of ts (define (supertype-of-one/arr A s ts) - (ormap (lambda (e) (arr-subtype*/no-fail A e s)) ts)) + (for/or ([t (in-list ts)]) + (arr-subtype*/no-fail A t s))) (define-syntax (let*/and stx) (syntax-parse stx @@ -56,16 +106,30 @@ (define-syntax-class sub* (pattern e:expr)) (syntax-parse stx - [(_ init (s:sub* . args) ...+) + [(_ init (s:sub* args:expr ... (~optional (~seq #:unless unless:expr) + #:defaults ([unless #'#f]))) + ...+) (with-syntax ([(A* ... A-last) (generate-temporaries #'(s ...))]) (with-syntax ([(clauses ...) (for/list ([s (in-syntax #'(s ...))] - [args (in-syntax #'(args ...))] + [args (in-syntax #'((args ...) ...))] + [skip-tst (in-syntax #'(unless ...))] [A (in-syntax #'(init A* ...))] [A-next (in-syntax #'(A* ... A-last))]) - #`[#,A-next (#,s #,A . #,args)])]) - (syntax/loc stx (let*/and (clauses ...) - A-last))))])) + (cond + [(equal? (syntax-e #'tst) #f) + #`[#,A-next (#,s #,A . #,args)]] + [else + #`[#,A-next (or (and #,skip-tst #,A) + (#,s #,A . #,args))]]))]) + (syntax/loc stx (let*/and (clauses ...) + A-last))))])) + + +;;************************************************************ +;; Function Subtyping Helpers +;;************************************************************ + ;; kw-subtypes : (Listof (Pairof Num Num)) (Listof Keyword) (Listof Keyword) ;; -> (Option (Listof (Pairof Num Num))) @@ -77,109 +141,134 @@ ;; Note that in terms of width, s-kws may have more keywords (i.e., F_s accepts ;; all keywords that F_t does) but the types in s-kws must be supertypes of those ;; in t-kws (i.e., F_s domain types are at least as permissive as those of F_t). -(define (kw-subtypes* A0 s-kws t-kws) - (let loop ([A A0] [s s-kws] [t t-kws]) +(define (kw-subtypes* A kws1 kws2) + (let loop ([A A] [kws1 kws1] [kws2 kws2]) (and A - (match* (s t) - [((cons (Keyword: ks ts rs) rest-s) (cons (Keyword: kt tt rt) rest-t)) - (cond [(eq? kt ks) + (match* (kws1 kws2) + [((cons (Keyword: k1 t1 r1) rest1) (cons (Keyword: k2 t2 r2) rest2)) + (cond [(eq? k2 k1) (and ;; if t is optional, s must be as well - (or rt (not rs)) - (loop (subtype* A tt ts) rest-s rest-t))] + (or r2 (not r1)) + (loop (subtype* A t2 t1) rest1 rest2))] ;; optional extra keywords in s are ok ;; we just ignore them - [(and (not rs) (keyword -(define (arr-subtype*/no-fail A0 s t) - (match* (s t) - ;; the really simple case - [((arr: s1 s2 #f #f '()) - (arr: t1 t2 #f #f '())) - (subtype-seq A0 - (subtypes* t1 s1) - (subtype* (restrict-values s2 t1) t2))] - [((arr: s1 s2 #f #f s-kws) - (arr: t1 t2 #f #f t-kws)) - (subtype-seq A0 - (subtypes* t1 s1) - (kw-subtypes* s-kws t-kws) - (subtype* (restrict-values s2 t1) t2))] - [((arr: s-dom s-rng s-rest #f s-kws) - (arr: t-dom t-rng #f #f t-kws)) - (subtype-seq A0 - (subtypes*/varargs t-dom s-dom s-rest) - (kw-subtypes* s-kws t-kws) - (subtype* (restrict-values s-rng t-dom) t-rng))] - [((arr: s-dom s-rng #f #f s-kws) - (arr: t-dom t-rng t-rest #f t-kws)) - #f] - [((arr: s-dom s-rng s-rest #f s-kws) - (arr: t-dom t-rng t-rest #f t-kws)) - (subtype-seq A0 - (subtypes*/varargs t-dom s-dom s-rest) - (subtype* t-rest s-rest) - (kw-subtypes* s-kws t-kws) - (subtype* (restrict-values s-rng t-dom) t-rng))] - ;; handle ... varargs when the bounds are the same - [((arr: s-dom s-rng #f (cons s-drest dbound) s-kws) - (arr: t-dom t-rng #f (cons t-drest dbound) t-kws)) - (subtype-seq A0 - (subtype* t-drest s-drest) - (subtypes* t-dom s-dom) - (kw-subtypes* s-kws t-kws) - (subtype* (restrict-values s-rng t-dom) t-rng))] - [(_ _) #f])) - -;; check subtyping of props, so that predicates subtype correctly -(define (prop-subtype* A0 s t) - (match* (s t) - [(f f) A0] - [((FalseProp:) t) A0] - [(s (TrueProp:)) A0] - [((TypeProp: o t1) (TypeProp: o t2)) - (subtype* A0 t1 t2)] - [((NotTypeProp: o t1) (NotTypeProp: o t2)) - (subtype* A0 t2 t1)] - [(_ _) #f])) - -(define (subtypes/varargs args dom rst) - (handle-failure (and (subtypes*/varargs null args dom rst) #t))) - -(define (subtypes*/varargs A0 argtys dom rst) - (let loop-varargs ([dom dom] [argtys argtys] [A A0]) - (cond - [(not A) #f] - [(and (null? dom) (null? argtys)) A] - [(null? argtys) #f] - [(and (null? dom) rst) - (cond [(subtype* A (car argtys) rst) => (lambda (A) (loop-varargs dom (cdr argtys) A))] - [else #f])] - [(null? dom) #f] - [(subtype* A (car argtys) (car dom)) => (lambda (A) (loop-varargs (cdr dom) (cdr argtys) A))] - [else #f]))) - -;(trace subtypes*/varargs) +;; combine-arrs +;; +;; Checks if this function is defined by an uneccessary case-> +;; matching the following pattern: +;; τ0 -> σ ∧ τ1 -> σ ∧ τn -> σ ... +;; and if so, returns the combined function type: +;; (∪ τ0 τ1 ... τn)-> σ +;; amk: would it be better to simplify function types ahead of time +;; for cases like this where there is a preferable normal form? (define/cond-contract (combine-arrs arrs) - (c:-> (c:listof arr?) (c:or/c #f arr?)) + (-> (listof arr?) (or/c #f arr?)) (match arrs [(list (and a1 (arr: dom1 rng1 #f #f '())) (arr: dom rng #f #f '()) ...) (cond [(null? dom) (make-arr dom1 rng1 #f #f '())] [(not (apply = 1 (length dom1) (map length dom))) #f] - [(not (for/and ([rng2 (in-list rng)]) (type-equal? rng1 rng2))) + [(not (for/and ([rng2 (in-list rng)]) (equal? rng1 rng2))) #f] [else (make-arr (apply map Un (cons dom1 dom)) rng1 #f #f '())])] [_ #f])) +;; simple co/contra-variance for -> +(define/cond-contract (arr-subtype*/no-fail A arr1 arr2) + (-> list? arr? arr? any/c) + (match* (arr1 arr2) + ;; the really simple case + [((arr: dom1 rng1 #f #f '()) + (arr: dom2 rng2 #f #f '())) + (subtype-seq A + (subtypes* dom2 dom1) + (subval* (restrict-values rng1 dom2) rng2))] + [((arr: dom1 rng1 #f #f kws1) + (arr: dom2 rng2 #f #f kws2)) + (subtype-seq A + (subtypes* dom2 dom1) + (kw-subtypes* kws1 kws2) + (subval* (restrict-values rng1 dom2) rng2))] + [((arr: dom1 rng1 rest1 #f kws1) + (arr: dom2 rng2 #f #f kws2)) + (subtype-seq A + (subtypes*/varargs dom2 dom1 rest1) + (kw-subtypes* kws1 kws2) + (subval* (restrict-values rng1 dom2) rng2))] + [((arr: dom1 rng1 #f #f kws1) + (arr: dom2 rng2 rest2 #f kws2)) + #f] + [((arr: dom1 rng1 rest1 #f kws1) + (arr: dom2 rng2 rest2 #f kws2)) + (subtype-seq A + (subtypes*/varargs dom2 dom1 rest1) + (subtype* rest2 rest1) + (kw-subtypes* kws1 kws2) + (subval* (restrict-values rng1 dom2) rng2))] + ;; handle ... varargs when the bounds are the same + [((arr: dom1 rng1 #f (cons drest1 dbound) kws1) + (arr: dom2 rng2 #f (cons drest2 dbound) kws2)) + (subtype-seq A + (subtype* drest2 drest1) + (subtypes* dom2 dom1) + (kw-subtypes* kws1 kws2) + (subval* (restrict-values rng1 dom2) rng2))] + [(_ _) #f])) + + +;;************************************************************ +;; Prop 'Subtyping' +;;************************************************************ + +;; check subtyping of props, so that predicates subtype correctly +(define (prop-subtype* A p1 p2) + (match* (p1 p2) + [(p p) A] + [((? FalseProp?) t) A] + [(_ (? TrueProp?)) A] + [((TypeProp: o1 t1) + (TypeProp: o2 t2)) + #:when (equal? o1 o2) + (subtype* A t1 t2)] + [((NotTypeProp: o1 t1) + (NotTypeProp: o2 t2)) + #:when (equal? o1 o2) + (subtype* A t2 t1)] + [(_ _) #f])) + +(define (subtypes/varargs args dom rst) + (and (subtypes*/varargs null args dom rst) #t)) + +(define (subtypes*/varargs A argtys dom rst) + (let loop-varargs ([dom dom] [argtys argtys] [A A]) + (cond + [(not A) #f] + [(and (null? dom) (null? argtys)) A] + [(null? argtys) #f] + [(and (null? dom) rst) + (cond [(subtype* A (car argtys) rst) => (λ (A) (loop-varargs dom (cdr argtys) A))] + [else #f])] + [(null? dom) #f] + [(subtype* A (car argtys) (car dom)) => (λ (A) (loop-varargs (cdr dom) (cdr argtys) A))] + [else #f]))) + + +;;************************************************************ +;; Struct Helpers +;;************************************************************ + + (define-match-expander NameStruct: (lambda (stx) (syntax-case stx () @@ -191,17 +280,17 @@ _ _))]))) (define (subtype/flds* A flds flds*) - (for/fold ([A A]) ([f (in-list flds)] [f* (in-list flds*)] #:break (not A)) - (and - A - (match* (f f*) - [((fld: t _ #t) (fld: t* _ #t)) - (subtype-seq A - (subtype* t* t) - (subtype* t t*))] - [((fld: t _ #f) (fld: t* _ #f)) - (subtype* A t t*)] - [(_ _) #f])))) + (for/fold ([A A]) + ([f (in-list flds)] [f* (in-list flds*)] + #:break (not A)) + (match* (f f*) + [((fld: t _ #t) (fld: t* _ #t)) + (subtype-seq A + (subtype* t* t) + (subtype* t t*))] + [((fld: t _ #f) (fld: t* _ #f)) + (subtype* A t t*)] + [(_ _) #f]))) (define (unrelated-structs s1 s2) (define (in-hierarchy? s par) @@ -221,532 +310,471 @@ [(Struct: _ (? Struct? p) _ _ _ _) (in-hierarchy? p par)] [(Struct: _ (Poly: _ p) _ _ _ _) (in-hierarchy? p par)] [(Struct: _ #f _ _ _ _) #f] - [_ (int-err "wtf is this? ~a" s)]))) + [_ (int-err "what is this?!?! ~a" s)]))) (not (or (in-hierarchy? s1 s2) (in-hierarchy? s2 s1)))) -(define/cond-contract (type-equiv? A0 s t) - (c:-> list? Type? Type? c:any/c) - (subtype-seq A0 - (subtype* s t) - (subtype* t s))) -(define bottom-key (Rep-seq -Bottom)) -(define top-key (Rep-seq Univ)) +;;************************************************************ +;; Values Subtyping +;;************************************************************ + + +(define/cond-contract (subval* A v1 v2) + (-> (listof (cons/c Type? Type?)) SomeValues? SomeValues? + any/c) + (match* (v1 v2) + ;; subtyping on values is pointwise, except special case for Bottom + [((or (Values: (list (Result: (== -Bottom) _ _))) + (Values: (list (Result: _ (PropSet: (? FalseProp?) (? FalseProp?)) _)))) + _) + A] + [((Values: results1) (Values: results2)) + (subresults* A results1 results2)] + [((ValuesDots: rs1 dty1 dbound) + (ValuesDots: rs2 dty2 dbound)) + (subtype-seq A + (subresults* rs1 rs2) + (subtype* dty1 dty2))] + [((AnyValues: prop1) (AnyValues: prop2)) + (prop-subtype* A prop1 prop2)] + [((or (Values: (list (Result: _ ps1 _) ...)) + (ValuesDots: (list (Result: _ ps1 _) ...) _ _)) + (AnyValues: prop2)) + (ormap (match-lambda + [(PropSet: p1+ p1-) + (subtype-seq A + (prop-subtype* p1+ prop2) + (prop-subtype* p1- prop2))]) + ps1)] + [(_ _) #f])) + +;;************************************************************ +;; Result Subtyping +;;************************************************************ + +(define/cond-contract (subresult* A res1 res2) + (-> (listof (cons/c Type? Type?)) Result? Result? + any/c) + (match* (res1 res2) + [((Result: t1 (PropSet: p1+ p1-) o1) + (Result: t2 (PropSet: p2+ p2-) o2)) + (and (or (equal? o1 o2) (Empty? o2) (not o2)) + (subtype-seq A + (subtype* t1 t2) + (prop-subtype* p1+ p2+) + (prop-subtype* p1- p2-)))])) + +;;************************************************************ +;; Type Subtyping +;;************************************************************ + +(define/cond-contract (type-equiv? A t1 t2) + (-> list? Type? Type? any/c) + (subtype-seq A + (subtype* t1 t2) + (subtype* t2 t1))) ;; the algorithm for recursive types transcribed directly from TAPL, pg 305 ;; List[(cons Number Number)] type type -> List[(cons Number Number)] or #f ;; is s a subtype of t, taking into account previously seen pairs A -(define/cond-contract (subtype* A s t) - (c:-> (c:listof (c:cons/c fixnum? fixnum?)) Type? Type? c:any/c) - (define ss (Rep-seq s)) - (define st (Rep-seq t)) +;; +;; <><> the seen list (A) should be updated for the following +;; types as they are encountered: +;; needs-resolved? types (Mus, Names, Apps), +;; Instances, and Structs (Prefabs?) +(define/cond-contract (subtype* A t1 t2) + (-> (listof (cons/c Type? Type?)) Type? Type? (or/c #f list?)) (early-return - #:return-when (or (eq? ss st) (seen? ss st A)) A - (define cr (let ([inner (hash-ref subtype-cache st #f)]) - (if inner - (hash-ref inner ss 'missing) - 'missing))) + #:return-when (seen? t1 t2 A) A + #:return-when (Univ? t2) A + ;; error is top and bot + #:return-when (or (type-equal? t1 Err) + (type-equal? t2 Err)) A + #:return-when (type-equal? t1 -Bottom) A + (define mask1 (Type-mask t1)) + (define mask2 (Type-mask t2)) + #:return-when (disjoint-masks? mask1 mask2) #f + #:return-when (type-equal? t1 t2) A + (define t1-subtype-cache (Type-subtype-cache t1)) + (define cr (hash-ref t1-subtype-cache (Rep-seq t2) 'missing)) #:return-when (boolean? cr) (and cr A) - (define ks (Type-key s)) - (define kt (Type-key t)) - #:return-when (and (symbol? ks) (symbol? kt) (not (eq? ks kt))) #f - #:return-when (and (symbol? ks) (pair? kt) (not (memq ks kt))) #f - #:return-when - (and (pair? ks) (pair? kt) - (for/and ([i (in-list ks)]) (not (memq i kt)))) - #f - #:return-when (eq? ss bottom-key) A - #:return-when (eq? st top-key) A - (define A0 (remember s t A)) - (define r - ;; FIXME -- make this go into only the places that need it -- slows down new-metrics.rkt significantly - (update-current-seen A0 - (match* (s t) - ;; these cases are above as special cases - ;; [((Union: (list)) _) A0] ;; this is extremely common, so it goes first - ;; [(_ (Univ:)) A0] - ;; error is top and bot - [(_ (Error:)) A0] - [((Error:) _) A0] - ;; (Un) is bot - [(_ (Union: (list))) #f] - ;; value types - [((Value: v1) (Value: v2)) - #:when (equal? v1 v2) A0] - [((Intersection: ss) t) - (and - (for/or ([s (in-immutable-set ss)]) - (subtype* A0 s t)) - A0)] - [(s (Intersection: ts)) - (and - (for/fold ([A A0]) - ([t (in-immutable-set ts)] - #:break (not A)) - (subtype* A s t)) - A0)] - ;; values are subtypes of their "type" - [((Value: v) (Base: _ _ pred _)) (if (pred v) A0 #f)] - ;; tvars are equal if they are the same variable - [((F: t) (F: t*)) (if (eq? t t*) A0 #f)] - ;; Avoid needing to resolve things that refer to different structs. - ;; Saves us from non-termination - ;; Must happen *before* the sequence cases, which sometimes call `resolve' in match expanders - [((or (? Struct? s1) (NameStruct: s1)) (or (? Struct? s2) (NameStruct: s2))) - #:when (unrelated-structs s1 s2) - #f] - ;; similar case for structs and base types, which are obviously unrelated - [((Base: _ _ _ _) (or (? Struct? s1) (NameStruct: s1))) - #f] - [((or (? Struct? s1) (NameStruct: s1)) (Base: _ _ _ _)) - #f] - ;; same for all values. - [((Value: (? (negate struct?) _)) (or (? Struct? s1) (NameStruct: s1))) - #f] - [((or (? Struct? s1) (NameStruct: s1)) (Value: (? (negate struct?) _))) - #f] - ;; from define-new-subtype - [((Distinction: nm1 id1 t1) (app resolve (Distinction: nm2 id2 t2))) - #:when (and (equal? nm1 nm2) (equal? id1 id2)) - (subtype* A0 t1 t2)] - [((Distinction: _ _ t1) t2) - (subtype* A0 t1 t2)] - ;; sequences are covariant - [((Sequence: ts) (Sequence: ts*)) - (subtypes* A0 ts ts*)] - [((Listof: t) (Sequence: (list t*))) - (subtype* A0 t t*)] - [((Pair: t1 t2) (Sequence: (list t*))) - (subtype-seq A0 (subtype* t1 t*) (subtype* t2 (-lst t*)))] - [((MListof: t) (Sequence: (list t*))) - (subtype* A0 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*))) - (subtype-seq A0 - (subtype* t1 t*) - (subtype* t2 (simple-Un -Null (make-MPairTop))) - (subtype* t2 t))] - ;; Note: this next case previously used the List: match expander, but - ;; using that would cause an infinite loop in certain cases - ;; (i.e., Struct types, see PR 14364) because the expander - ;; uses `resolve`. This is not normally a problem, but during - ;; subtyping it's dangerous to call functions that can cause - ;; substitution and thus more subtyping checks. - ;; - ;; Instead, we can just check for Null here since combined with - ;; the Pair: case above and resolution of types like Mu, all the - ;; List: cases should be covered. - [((Value: '()) (Sequence: (list t*))) A0] - [((HeterogeneousVector: ts) (Sequence: (list t*))) - (subtypes* A0 ts (map (λ (_) t*) ts))] - [((Vector: t) (Sequence: (list t*))) - (subtype* A0 t t*)] - [((Base: 'FlVector _ _ _) (Sequence: (list t*))) - (subtype* A0 -Flonum t*)] - [((Base: 'ExtFlVector _ _ _) (Sequence: (list t*))) - (subtype* A0 -ExtFlonum t*)] - [((Base: 'FxVector _ _ _) (Sequence: (list t*))) - (subtype* A0 -Fixnum t*)] - [((Base: 'String _ _ _) (Sequence: (list t*))) - (subtype* A0 -Char t*)] - [((Base: 'Bytes _ _ _) (Sequence: (list t*))) - (subtype* A0 -Byte t*)] - [((Base: 'Input-Port _ _ _) (Sequence: (list t*))) - (subtype* A0 -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))))) - (subtype* A0 type t*)] - [((Base: _ _ _ #t) (Sequence: (list t*))) - (define type - ;; FIXME: thread the store through here - (for/or ((t (in-list (list -Byte -Index -NonNegFixnum -Nat)))) - (or (and (subtype* A0 s t) t)))) - (if type - (subtype* A0 type t*) - #f)] - [((Hashtable: k v) (Sequence: (list k* v*))) - (subtypes* A0 (list k v) (list k* v*))] - [((Set: t) (Sequence: (list t*))) - (subtype* A0 t t*)] - ;; special-case for case-lambda/union with only one argument - [((Function: arr1) (Function: (list arr2))) - (cond [(null? arr1) #f] - [else - (define comb (combine-arrs arr1)) - (or (and comb (arr-subtype*/no-fail A0 comb arr2)) - (supertype-of-one/arr A0 arr2 arr1))])] - ;; case-lambda - [((Function: arr1) (Function: arr2)) - (if (null? arr1) #f - (let loop-arities ([A* A0] - [arr2 arr2]) - (cond - [(null? arr2) A*] - [(supertype-of-one/arr A* (car arr2) arr1) => (lambda (A) (loop-arities A (cdr arr2)))] - [else #f])))] - ;; recur structurally on pairs - [((Pair: a d) (Pair: a* d*)) - (subtypes* A0 (list a d) (list a* d*))] - ;; recur structurally on dotted lists, assuming same bounds - [((ListDots: s-dty dbound) (ListDots: t-dty dbound*)) - (and (eq? dbound dbound*) - (subtype* A0 s-dty t-dty))] - ;; For dotted lists and regular lists, we check that (All (dbound) s-dty) is a subtype - ;; of t-elem, so that no matter what dbound is instatiated with s-dty is still a subtype - ;; of t-elem. We cannot just replace dbound with Univ because of variance issues. - [((ListDots: s-dty dbound) (Listof: t-elem)) - (subtype* A0 (-poly (dbound) s-dty) t-elem)] - ;; quantification over two types preserves subtyping - [((Poly: ns b1) (Poly: ms b2)) - #:when (= (length ns) (length ms)) - ;; substitute ns for ms in b2 to make it look like b1 - (subtype* A0 b1 (subst-all (make-simple-substitution ms (map make-F ns)) b2))] - [((PolyDots: (list ns ... n-dotted) b1) - (PolyDots: (list ms ... m-dotted) b2)) + (define result + (match* (t1 t2) + ;; if this works, we're done, otherwise wait until after unions + ;; are explored to break the intersection apart + [((Intersection: t1s) _) #:when (for/or ([t1 (in-list t1s)]) + (subtype* A t1 t2)) + A] + [(_ (Intersection: t2s)) + (for/fold ([A A]) + ([t2 (in-list t2s)] + #:break (not A)) + (subtype* A t1 t2))] + ;; from define-new-subtype + [((Distinction: nm1 id1 t1) (app resolve (Distinction: nm2 id2 t2))) + #:when (and (equal? nm1 nm2) (equal? id1 id2)) + (subtype* A t1 t2)] + [((Distinction: _ _ t1) t2) (subtype* A t1 t2)] + ;; tvars are equal if they are the same variable + [((F: var1) (F: var2)) (and (eq? var1 var2) A)] + ;; structural types of the same kind can be checked by simply + ;; referencing the field variances and performing the + ;; appropriate recursive calls + [((? structural? t1) (? structural? t2)) + #:when (eq? (Rep-name t1) + (Rep-name t2)) + (for/fold ([A A]) + ([v (in-list (Type-variances t1))] + [t1 (in-list (Rep-values t1))] + [t2 (in-list (Rep-values t2))] + #:break (not A)) (cond - [(< (length ns) (length ms)) - (define-values (short-ms rest-ms) (split-at ms (length ns))) - ;; substitute ms for ns in b1 to make it look like b2 - (define subst - (hash-set (make-simple-substitution ns (map make-F short-ms)) - n-dotted (i-subst/dotted (map make-F rest-ms) (make-F m-dotted) m-dotted))) - (subtype* A0 (subst-all subst b1) b2)] - [else - (define-values (short-ns rest-ns) (split-at ns (length ms))) - ;; substitute ns for ms in b2 to make it look like b1 - (define subst - (hash-set (make-simple-substitution ms (map make-F short-ns)) - m-dotted (i-subst/dotted (map make-F rest-ns) (make-F n-dotted) n-dotted))) - (subtype* A0 b1 (subst-all subst b2))])] - [((PolyDots: (list ns ... n-dotted) b1) - (Poly: (list ms ...) b2)) - #:when (<= (length ns) (length ms)) - ;; substitute ms for ns in b1 to make it look like b2 - (define subst - (hash-set (make-simple-substitution ns (map make-F (take ms (length ns)))) - n-dotted (i-subst (map make-F (drop ms (length ns)))))) - (subtype* A0 (subst-all subst b1) b2)] - [((Refinement: par _) t) - (subtype* A0 par t)] - ;; use unification to see if we can use the polytype here - [((Poly: vs b) s) - #:when (infer vs null (list b) (list s) Univ) - A0] - [((PolyDots: (list vs ... vdotted) b) s) - #:when (infer vs (list vdotted) (list b) (list s) Univ) - A0] - [(s (or (Poly: vs b) (PolyDots: vs b))) - #:when (null? (fv b)) - (subtype* A0 s b)] - ;; rec types, applications and names (that aren't the same) - [((? needs-resolving? s) other) - (let ([s* (resolve-once s)]) - (if (Type/c? s*) ;; needed in case this was a name that hasn't been resolved yet - (subtype* A0 s* other) - #f))] - [(other (? needs-resolving? t)) - (let ([t* (resolve-once t)]) - (if (Type/c? t*) ;; needed in case this was a name that hasn't been resolved yet - (subtype* A0 other t*) - #f))] - ;; for unions, we check the cross-product - ;; some special cases for better performance - ;; first, if both types are numeric, they will be built from the same base types - ;; so we can check for simple set inclusion of the union components - [((Base: _ _ _ #t) (Union: l2)) - #:when (eq? kt 'number) - (and (memq s l2) A0)] - [((Union: l1) (Union: l2)) - #:when (and (eq? ks 'number) (eq? kt 'number)) - ;; l1 should be a subset of l2 - ;; since union elements are sorted, a linear scan works - (let loop ([l1 l1] [l2 l2]) - (cond [(null? l1) - A0] - [(null? l2) - #f] - [(eq? (car l1) (car l2)) - (loop (cdr l1) (cdr l2))] - [else - (loop l1 (cdr l2))]))] - [((Union: elems) t) - (and - (andmap (λ (elem) (subtype* A0 elem t)) elems) - A0)] - [(s (Union: elems)) - (and (ormap (λ (elem) (subtype* A0 s elem)) elems) - A0)] - ;; subtyping on immutable structs is covariant - [((Struct: nm _ flds proc _ _) (Struct: nm* _ flds* proc* _ _)) - #:when (free-identifier=? nm nm*) - (let ([A (cond [(and proc proc*) (subtype* A0 proc proc*)] - [proc* #f] - [else A0])]) - (and A (subtype/flds* A flds flds*)))] - [((Struct: nm _ _ _ _ _) (StructTop: (Struct: nm* _ _ _ _ _))) - #:when (free-identifier=? nm nm*) - A0] - ;; All struct-type types are subtypes of the struct type top type - [((StructType: _) (StructTypeTop:)) A0] - ;; Promises are covariant - [((Promise: s) (Promise: t)) - (subtype* A0 s t)] - ;ephemerons are covariant - [((Ephemeron: s) (Ephemeron: t)) - (subtype* A0 s t)] - [((CustodianBox: s) (CustodianBox: t)) - (subtype* A0 s t)] - [((Set: t) (Set: t*)) (subtype* A0 t t*)] - ;; Evts are covariant - [((Evt: t) (Evt: t*)) (subtype* A0 t t*)] - [((Base: 'Semaphore _ _ _) (Evt: t)) - (subtype* A0 s t)] - [((Base: 'Output-Port _ _ _) (Evt: t)) - (subtype* A0 s t)] - [((Base: 'Input-Port _ _ _) (Evt: t)) - (subtype* A0 s t)] - [((Base: 'TCP-Listener _ _ _) (Evt: t)) - (subtype* A0 s t)] - [((Base: 'Thread _ _ _) (Evt: t)) - (subtype* A0 s t)] - [((Base: 'Subprocess _ _ _) (Evt: t)) - (subtype* A0 s t)] - [((Base: 'Will-Executor _ _ _) (Evt: t)) - (subtype* A0 s t)] - [((Base: 'LogReceiver _ _ _) (Evt: t)) - (subtype* A0 - (make-HeterogeneousVector - (list -Symbol -String Univ - (Un (-val #f) -Symbol))) - t)] - ;; FIXME: change Univ to Place-Message-Allowed if/when that type is defined - [((Base: 'Place _ _ _) (Evt: (== Univ))) - #t] - [((Base: 'Base-Place-Channel _ _ _) (Evt: (== Univ))) - #t] - [((CustodianBox: t) (Evt: t*)) - ;; Note that it's the whole box type that's being - ;; compared against t* here - (subtype* A0 s t*)] - [((Channel: t) (Evt: t*)) (subtype* A0 t t*)] - [((Async-Channel: t) (Evt: t*)) (subtype* A0 t t*)] - ;; Invariant types - [((Box: s) (Box: t)) (type-equiv? A0 s t)] - [((Box: _) (BoxTop:)) A0] - [((Weak-Box: s) (Weak-Box: t)) (type-equiv? A0 s t)] - [((Weak-Box: _) (Weak-BoxTop:)) A0] - [((ThreadCell: s) (ThreadCell: t)) (type-equiv? A0 s t)] - [((ThreadCell: _) (ThreadCellTop:)) A0] - [((Channel: s) (Channel: t)) (type-equiv? A0 s t)] - [((Channel: _) (ChannelTop:)) A0] - [((Async-Channel: s) (Async-Channel: t)) (type-equiv? A0 s t)] - [((Async-Channel: _) (Async-ChannelTop:)) A0] - [((Vector: s) (Vector: t)) (type-equiv? A0 s t)] - [((Vector: _) (VectorTop:)) A0] - [((HeterogeneousVector: _) (VectorTop:)) A0] - [((HeterogeneousVector: (list e ...)) (Vector: e*)) - (for/fold ((A A0)) ((e (in-list e)) #:break (not A)) - (and A (type-equiv? A e e*)))] - [((HeterogeneousVector: (list s* ...)) (HeterogeneousVector: (list t* ...))) - (if (= (length s*) (length t*)) - (for/fold ((A A0)) ((s (in-list s*)) (t (in-list t*)) #:break (not A)) - (type-equiv? A s t)) - #f)] - [((MPair: s1 s2) (MPair: t1 t2)) - (subtype-seq A0 - (type-equiv? s1 t1) - (type-equiv? s2 t2))] - [((MPair: _ _) (MPairTop:)) A0] - [((Hashtable: s1 s2) (Hashtable: t1 t2)) - (subtype-seq A0 - (type-equiv? s1 t1) - (type-equiv? s2 t2))] - [((Hashtable: _ _) (HashtableTop:)) A0] - [((Prompt-Tagof: s1 s2) (Prompt-Tagof: t1 t2)) - (subtype-seq A0 - (type-equiv? s1 t1) - (type-equiv? s2 t2))] - [((Prompt-Tagof: _ _) (Prompt-TagTop:)) A0] - [((Continuation-Mark-Keyof: s) (Continuation-Mark-Keyof: t)) - (type-equiv? A0 s t)] - [((Continuation-Mark-Keyof: _) (Continuation-Mark-KeyTop:)) A0] - ;; subtyping on structs follows the declared hierarchy - [((Struct: nm (? Type/c? parent) _ _ _ _) other) - (subtype* A0 parent other)] - [((Prefab: k1 ss) (Prefab: k2 ts)) - (and (prefab-key-subtype? k1 k2) - (and (>= (length ss) (length ts)) - (for/fold ([A A0]) - ([s (in-list ss)] - [t (in-list ts)] - [mut? (in-list (prefab-key->field-mutability k2))] - #:break (not A)) - (and A - (if mut? - (subtype-seq A - (subtype* t s) - (subtype* s t)) - (subtype* A s t))))))] - ;; subtyping on values is pointwise, except special case for Bottom - [((Values: (list (Result: (== -Bottom) _ _))) _) - A0] - [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] - [((ValuesDots: s-rs s-dty dbound) (ValuesDots: t-rs t-dty dbound)) - (subtype-seq A0 - (subtypes* s-rs t-rs) - (subtype* s-dty t-dty))] - [((AnyValues: s-f) (AnyValues: t-f)) - (prop-subtype* A0 s-f t-f)] - [((or (Values: (list (Result: _ fs _) ...)) - (ValuesDots: (list (Result: _ fs _) ...) _ _)) - (AnyValues: t-f)) - (for/or ([f (in-list fs)]) - (match f - [(PropSet: f+ f-) - (subtype-seq A0 - (prop-subtype* f+ t-f) - (prop-subtype* f- t-f))]))] - [((Result: t (PropSet: ft ff) o) (Result: t* (PropSet: ft* ff*) o)) - (subtype-seq A0 - (subtype* t t*) - (prop-subtype* ft ft*) - (prop-subtype* ff ff*))] - [((Result: t (PropSet: ft ff) o) (Result: t* (PropSet: ft* ff*) (Empty:))) - (subtype-seq A0 - (subtype* t t*) - (prop-subtype* ft ft*) - (prop-subtype* ff ff*))] - ;; subtyping on other stuff - [((Syntax: t) (Syntax: t*)) - (subtype* A0 t t*)] - [((Future: t) (Future: t*)) - (subtype* A0 t t*)] - [((Param: s-in s-out) (Param: t-in t-out)) - (subtype-seq A0 - (subtype* t-in s-in) - (subtype* s-out t-out))] - [((Param: in out) t) - (subtype* A0 (cl->* (-> out) (-> in -Void)) t)] - [((Instance: (? needs-resolving? s)) other) - (let ([s* (resolve-once s)]) - (if (Type/c? s*) - (subtype* A0 (make-Instance s*) other) - #f))] - [(other (Instance: (? needs-resolving? t))) - (let ([t* (resolve-once t)]) - (if (Type/c? t*) - (subtype* A0 other (make-Instance t*)) - #f))] - [((Instance: (Class: _ _ field-map method-map augment-map _)) - (Instance: (Class: _ _ field-map* method-map* augment-map* _))) - (define (subtype-clause? map map*) - (and (for/and ([key+type (in-list map*)]) + [(eq? v Covariant) + (subtype* A t1 t2)] + [(eq? v Invariant) + (type-equiv? A t1 t2)] + [else ;; Contravariant + (subtype* A t2 t1)]))] + ;; If the type has a registered top type predicate, let's check it! + [((? has-top-type?) _) #:when ((top-type-pred t1) t2) A] + ;; quantification over two types preserves subtyping + [((Poly: ns b1) (Poly: ms b2)) + #:when (= (length ns) (length ms)) + ;; substitute ns for ms in b2 to make it look like b1 + (subtype* A b1 (subst-all (make-simple-substitution ms (map make-F ns)) b2))] + [((PolyDots: (list ns ... n-dotted) b1) + (PolyDots: (list ms ... m-dotted) b2)) + (cond + [(< (length ns) (length ms)) + (define-values (short-ms rest-ms) (split-at ms (length ns))) + ;; substitute ms for ns in b1 to make it look like b2 + (define subst + (hash-set (make-simple-substitution ns (map make-F short-ms)) + n-dotted (i-subst/dotted (map make-F rest-ms) (make-F m-dotted) m-dotted))) + (subtype* A (subst-all subst b1) b2)] + [else + (define-values (short-ns rest-ns) (split-at ns (length ms))) + ;; substitute ns for ms in b2 to make it look like b1 + (define subst + (hash-set (make-simple-substitution ms (map make-F short-ns)) + m-dotted (i-subst/dotted (map make-F rest-ns) (make-F n-dotted) n-dotted))) + (subtype* A b1 (subst-all subst b2))])] + [((PolyDots: (list ns ... n-dotted) b1) + (Poly: (list ms ...) b2)) + #:when (<= (length ns) (length ms)) + ;; substitute ms for ns in b1 to make it look like b2 + (define subst + (hash-set (make-simple-substitution ns (map make-F (take ms (length ns)))) + n-dotted (i-subst (map make-F (drop ms (length ns)))))) + (subtype* A (subst-all subst b1) b2)] + ;; use unification to see if we can use the polytype here + [((Poly: vs1 b1) _) + #:when (infer vs1 null (list b1) (list t2) Univ) + A] + [((PolyDots: (list vs1 ... vdotted1) b1) _) + #:when (infer vs1 (list vdotted1) (list b1) (list t2) Univ) + A] + [(_ (or (Poly: vs2 b2) + (PolyDots: vs2 b2))) + #:when (null? (fv b2)) + (subtype* A t1 b2)] + ;; recur structurally on dotted lists, assuming same bounds + [((ListDots: dty1 dbound1) (ListDots: dty2 dbound2)) + (and (eq? dbound1 dbound2) + (subtype* A dty1 dty2))] + ;; For dotted lists and regular lists, we check that (All + ;; (dbound) s-dty) is a subtype of t-elem, so that no matter + ;; what dbound is instatiated with s-dty is still a subtype of + ;; t-elem. We cannot just replace dbound with Univ because of + ;; variance issues. + [((ListDots: dty1 dbound1) (Listof: t2-elem)) + (subtype* A (-poly (dbound1) dty1) t2-elem)] + [((Value: v) (Base: _ _ pred _)) (if (pred v) A #f)] + [((? resolvable?) _) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (let ([t1 (resolve-once t1)]) + ;; check needed for if a name that hasn't been resolved yet + (and (Type? t1) (subtype* A t1 t2)))))] + [(_ (? resolvable?)) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (let ([t2 (resolve-once t2)]) + ;; check needed for if a name that hasn't been resolved yet + (and (Type? t2) (subtype* A t1 t2)))))] + [((Union: elems) t) + (for/fold ([A A]) + ([elem (in-list elems)] + #:break (not A)) + (subtype* A elem t))] + [(s (Union: elems)) + (and (ormap (λ (elem) (subtype* A s elem)) elems) A)] + ;; intersections as subtypes need to be handled after some forms (e.g. Unions) + ;; otherwise we will get the wrong answer for + ;; queries such as: (∩ A B) <: (U String (∩ A B)) + [((Intersection: t1s) _) + (for/or ([t1 (in-list t1s)]) + (subtype* A t1 t2))] + ;; Avoid needing to resolve things that refer to different structs. + ;; Saves us from non-termination + ;; Must happen *before* the sequence cases, which sometimes call `resolve' in match expanders + [((or (? Struct? s1) (NameStruct: s1)) + (or (? Struct? s2) (NameStruct: s2))) + #:when (unrelated-structs s1 s2) + #f] + ;; same for all values. + [((Value: (? (negate struct?) _)) (or (? Struct? s1) (NameStruct: s1))) + #f] + [((or (? Struct? s1) (NameStruct: s1)) (Value: (? (negate struct?) _))) + #f] + ;; sequences are covariant + [((Sequence: ts1) (Sequence: ts2)) (subtypes* A ts1 ts2)] + [((Hashtable: k1 v1) (Sequence: (list k2 v2))) + (subtype-seq A + (subtype* k1 k2) + (subtype* v1 v2))] + ;; special-case for case-lambda/union with only one argument + [((Function: arr1) (Function: (list arr2))) + (cond [(null? arr1) #f] + [else + (define comb (combine-arrs arr1)) + (or (and comb (arr-subtype*/no-fail A comb arr2)) + (supertype-of-one/arr A arr2 arr1))])] + ;; case-lambda + [((Function: arrs1) (Function: arrs2)) + (if (null? arrs1) #f + (let loop-arities ([A A] + [arrs2 arrs2]) + (cond + [(null? arrs2) A] + [(supertype-of-one/arr A (car arrs2) arrs1) + => (λ (A) (loop-arities A (cdr arrs2)))] + [else #f])))] + [((Refinement: t1-parent _) _) + (subtype* A t1-parent t2)] + ;; subtyping on immutable structs is covariant + [((Struct: nm1 _ flds1 proc1 _ _) (Struct: nm2 _ flds2 proc2 _ _)) + #:when (free-identifier=? nm1 nm2) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (let ([A (cond [(and proc1 proc2) (subtype* A proc1 proc2)] + [proc2 #f] + [else A])]) + (and A (subtype/flds* A flds1 flds2)))))] + [((Struct: nm1 _ _ _ _ _) (StructTop: (Struct: nm2 _ _ _ _ _))) + #:when (free-identifier=? nm1 nm2) + A] + ;; vector special cases + [((HeterogeneousVector: elems1) (Vector: t2)) + (for/fold ([A A]) + ([elem1 (in-list elems1)] #:break (not A)) + (type-equiv? A elem1 t2))] + [((HeterogeneousVector: elems1) (HeterogeneousVector: elems2)) + (cond [(= (length elems1) + (length elems2)) + (for/fold ([A A]) + ([elem1 (in-list elems1)] + [elem2 (in-list elems2)] + #:break (not A)) + (type-equiv? A elem1 elem2))] + [else #f])] + ;; subtyping on structs follows the declared hierarchy + [((Struct: nm1 (? Type? parent1) _ _ _ _) _) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (subtype* A parent1 t2)))] + [((Prefab: k1 ss) (Prefab: k2 ts)) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (and (prefab-key-subtype? k1 k2) + (and (>= (length ss) (length ts)) + (for/fold ([A A]) + ([s (in-list ss)] + [t (in-list ts)] + [mut? (in-list (prefab-key->field-mutability k2))] + #:break (not A)) + (and A + (if mut? + (subtype-seq A + (subtype* t s) + (subtype* s t)) + (subtype* A s t))))))))] + ;; subtyping on other stuff + [((Param: in1 out1) _) + (subtype* A (cl->* (t-> out1) (t-> in1 -Void)) t2)] + ;; homogeneous Sequence call helper for remaining cases + ;; that are subtypes of a homogeneous Sequence + [(_ (Sequence: (list seq-t))) (homo-sequence-subtype A t1 seq-t)] + ;; events call off to helper for remaining cases + [(_ (Evt: evt-t)) (event-subtype A t1 evt-t)] + [((Instance: (? resolvable? t1*)) _) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (let ([t1* (resolve-once t1*)]) + (and (Type? t1*) + (subtype* A (make-Instance t1*) t2)))))] + [(_ (Instance: (? resolvable? t2*))) + (let ([A (remember t1 t2 A)]) + (with-updated-seen A + (let ([t2* (resolve-once t2*)]) + (and (Type? t2*) + (subtype* A t1 (make-Instance t2*))))))] + [((Instance: (Class: _ _ field-map method-map augment-map _)) + (Instance: (Class: _ _ field-map* method-map* augment-map* _))) + (define (subtype-clause? map map*) + (and (for/and ([key+type (in-list map*)]) + (match-define (list key type) key+type) + (assq key map)) + (let/ec escape + (for/fold ([A A]) + ([key+type (in-list map)]) (match-define (list key type) key+type) - (assq key map)) - (let/ec escape - (for/fold ([A A0]) - ([key+type (in-list map)]) - (match-define (list key type) key+type) - (define result (assq (car key+type) map*)) - (or (and (not result) A) - (let ([type* (cadr result)]) - (or (subtype* A type type*) - (escape #f)))))))) - (and ;; Note that init & augment clauses don't matter for objects - (subtype-clause? method-map method-map*) - (subtype-clause? field-map field-map*))] - [((? Class?) (ClassTop:)) A0] - [((Class: row inits fields methods augments init-rest) - (Class: row* inits* fields* methods* augments* init-rest*)) - ;; TODO: should the result be folded instead? - (define sub (curry subtype* A)) - ;; check that each of inits, fields, methods, etc. are - ;; equal by sorting and checking type equality - (define (equal-clause? clause clause* [inits? #f]) - (cond - [(not inits?) - (match-define (list (list names types) ...) clause) - (match-define (list (list names* types*) ...) clause*) - (and (= (length names) (length names*)) - (andmap equal? names names*) - (andmap sub types types*))] - [else - (match-define (list (list names types opt?) ...) - clause) - (match-define (list (list names* types* opt?*) ...) - clause*) - (and (= (length names) (length names*)) - (andmap equal? names names*) - (andmap sub types types*) - (andmap equal? opt? opt?*))])) - ;; There is no non-trivial width subtyping on class types, but it's - ;; possible for two "equal" class types to look different - ;; in the representation. We deal with that here. - (and (or (and (or (Row? row) (not row)) - (or (Row? row*) (not row*))) - (equal? row row*)) - (equal-clause? inits inits* #t) - (equal-clause? fields fields*) - (equal-clause? methods methods*) - (equal-clause? augments augments*) - (or (and init-rest init-rest* - (sub init-rest init-rest*)) - (and (not init-rest) (not init-rest*))))] - [((? Unit?) (UnitTop:)) A0] - ;; For Unit types invoke-types are covariant - ;; imports and init-depends are covariant in that importing fewer - ;; signatures results in a subtype - ;; exports conversely are contravariant, subtypes export more signatures - [((Unit: imports exports init-depends t) (Unit: imports* exports* init-depends* t*)) - (and (check-sub-signatures? imports* imports) - (check-sub-signatures? exports exports*) - (check-sub-signatures? init-depends* init-depends) - (subtype-seq A0 - (subtype* t t*)))] - ;; otherwise, not a subtype - [(_ _) #f]))) - (when (null? A) - (hash-set! - (hash-ref! subtype-cache st (lambda () (make-hash))) - ss (and r #t))) - r)) + (define result (assq (car key+type) map*)) + (or (and (not result) A) + (let ([type* (cadr result)]) + (or (subtype* A type type*) + (escape #f)))))))) + (and ;; Note that init & augment clauses don't matter for objects + (subtype-clause? method-map method-map*) + (subtype-clause? field-map field-map*))] + [((Class: row inits fields methods augments init-rest) + (Class: row* inits* fields* methods* augments* init-rest*)) + ;; TODO: should the result be folded instead? + (define (sub t1 t2) (subtype* A t1 t2)) + ;; check that each of inits, fields, methods, etc. are + ;; equal by sorting and checking type equality + (define (equal-clause? clause clause* [inits? #f]) + (cond + [(not inits?) + (match-define (list (list names types) ...) clause) + (match-define (list (list names* types*) ...) clause*) + (and (= (length names) (length names*)) + (andmap equal? names names*) + (andmap sub types types*))] + [else + (match-define (list (list names types opt?) ...) + clause) + (match-define (list (list names* types* opt?*) ...) + clause*) + (and (= (length names) (length names*)) + (andmap equal? names names*) + (andmap sub types types*) + (andmap equal? opt? opt?*))])) + ;; There is no non-trivial width subtyping on class types, but it's + ;; possible for two "equal" class types to look different + ;; in the representation. We deal with that here. + (and (or (and (or (Row? row) (not row)) + (or (Row? row*) (not row*))) + (equal? row row*)) + (equal-clause? inits inits* #t) + (equal-clause? fields fields*) + (equal-clause? methods methods*) + (equal-clause? augments augments*) + (or (and init-rest init-rest* + (sub init-rest init-rest*)) + (and (not init-rest) (not init-rest*) + A)))] + ;; For Unit types invoke-types are covariant + ;; imports and init-depends are covariant in that importing fewer + ;; signatures results in a subtype + ;; exports conversely are contravariant, subtypes export more signatures + [((Unit: imports1 exports1 init-depends1 t1) + (Unit: imports2 exports2 init-depends2 t2)) + (and (check-sub-signatures? imports2 imports1) + (check-sub-signatures? exports1 exports2) + (check-sub-signatures? init-depends2 init-depends1) + (subval* A t1 t2))] + ;; otherwise, not a subtype + [(_ _) #f])) + (when (null? A) (hash-set! t1-subtype-cache (Rep-seq t2) (and result #t))) + result)) -(define (type-compare? a b) - (or (type-equal? a b) - (and (subtype a b) (subtype b a)))) +;;************************************************************ +;; Other Subtyping Special Cases +;;************************************************************ -;; List[(cons Number Number)] type type -> maybe[List[(cons Number Number)]] -(define subtype*/no-fail subtype*) +(define seq-base-types `((FlVector . ,-Flonum) + (ExtFlVector . ,-ExtFlonum) + (FxVector . ,-Fixnum) + (String . ,-Char) + (Bytes . ,-Byte) + (Input-Port . ,-Nat))) -(provide/cond-contract - [subtype (c:-> (c:or/c Type/c SomeValues/c) (c:or/c Type/c SomeValues/c) boolean?)] - [type-compare? (c:-> (c:or/c Type/c SomeValues/c) (c:or/c Type/c SomeValues/c) boolean?)] - [subtypes (c:-> (c:listof (c:or/c Type/c SomeValues/c)) - (c:listof (c:or/c Type/c SomeValues/c)) - boolean?)] - [subtypes/varargs (c:-> (c:listof Type/c) (c:listof Type/c) (c:or/c Type/c #f) boolean?)]) +;; Homo-sequence-subtype +;; is t a subtype of (Sequence: seq-t)? +(define/cond-contract (homo-sequence-subtype A t seq-t) + (-> list? Type? Type? any/c) + (match t + [(Pair: t1 t2) + (subtype-seq A + (subtype* t1 seq-t) + (subtype* t2 (-lst seq-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) + (subtype-seq A + (subtype* t1 seq-t) + (subtype* t2 (simple-Un -Null (make-MPairTop))) + (subtype* t2 (make-Sequence (list seq-t))))] + [(Value: '()) A] + [(HeterogeneousVector: ts) + (subtypes* A ts (make-list (length ts) seq-t))] + [(or (Vector: t) (Set: t)) (subtype* A t seq-t)] + [(Base: kind _ _ _) #:when (assq kind seq-base-types) + (subtype* A (cdr (assq kind seq-base-types)) seq-t)] + [(Value: (? exact-nonnegative-integer? n)) + (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))))) + (subtype* A type seq-t)] + [(Base: _ _ _ #t) + (define type + ;; FIXME: thread the store through here + (for/or ((num-t (in-list (list -Byte -Index -NonNegFixnum -Nat)))) + (or (and (subtype* A t num-t) num-t)))) + (if type + (subtype* A type seq-t) + #f)] + [_ #f])) -;(require racket/trace) -;(trace subtype*) -;(trace supertype-of-one/arr) -;(trace arr-subtype*/no-fail) -;(trace subtype*/no-fail) -;(trace subtypes*) -;(trace subtype) -;(subtype (-> Univ B) (-> Univ Univ)) -;(subtype (make-poly '(a) (make-tvar 'a)) (make-lst N)) +;; event-subtype +;; returns if t is a subtype of (Evt: evt-t) +(define/cond-contract (event-subtype A t evt-t) + (-> list? Type? Type? (or/c list? #f)) + (match t + [(Base: kind _ _ _) #:when (memq kind '(Semaphore + Output-Port + Input-Port + TCP-Listener + Thread + Subprocess + Will-Executor)) + (subtype* A t evt-t)] + ;; FIXME: change Univ to Place-Message-Allowed if/when that type is defined + [(Base: kind _ _ _) #:when (and (Univ? evt-t) + (memq kind '(Place Base-Place-Channel))) + A] + [(Base: 'LogReceiver _ _ _) + (subtype* A + (make-HeterogeneousVector + (list -Symbol -String Univ + (Un (-val #f) -Symbol))) + evt-t)] + [(CustodianBox: _) + ;; Note that it's the whole box type that's being + ;; compared against t* here + (subtype* A t evt-t)] + [(or (Channel: t) + (Async-Channel: t)) + (subtype* A t evt-t)] + [_ #f])) -;;problem: -;; (subtype (make-Mu 'x (make-Syntax (make-Union (list (make-Base 'Number #'number? number?) (make-F 'x))))) (make-Syntax (make-Univ))) diff --git a/typed-racket-lib/typed-racket/types/tc-error.rkt b/typed-racket-lib/typed-racket/types/tc-error.rkt index 28a193cc..12633039 100644 --- a/typed-racket-lib/typed-racket/types/tc-error.rkt +++ b/typed-racket-lib/typed-racket/types/tc-error.rkt @@ -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)] diff --git a/typed-racket-lib/typed-racket/types/tc-result.rkt b/typed-racket-lib/typed-racket/types/tc-result.rkt index 4280c10e..f2aff49b 100644 --- a/typed-racket-lib/typed-racket/types/tc-result.rkt +++ b/typed-racket-lib/typed-racket/types/tc-result.rkt @@ -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?)] diff --git a/typed-racket-lib/typed-racket/types/type-table.rkt b/typed-racket-lib/typed-racket/types/type-table.rkt index da997f39..0b0e18d8 100644 --- a/typed-racket-lib/typed-racket/types/type-table.rkt +++ b/typed-racket-lib/typed-racket/types/type-table.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/types/union.rkt b/typed-racket-lib/typed-racket/types/union.rkt index 00c1f322..59b5f8d5 100644 --- a/typed-racket-lib/typed-racket/types/union.rkt +++ b/typed-racket-lib/typed-racket/types/union.rkt @@ -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 -->] [->* -->*] @@ -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])]))) \ No newline at end of file + (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)])]))) diff --git a/typed-racket-lib/typed-racket/types/utils.rkt b/typed-racket-lib/typed-racket/types/utils.rkt index 16ab53dd..dc789d11 100644 --- a/typed-racket-lib/typed-racket/types/utils.rkt +++ b/typed-racket-lib/typed-racket/types/utils.rkt @@ -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)] ) diff --git a/typed-racket-lib/typed-racket/utils/primitive-comparison.rkt b/typed-racket-lib/typed-racket/utils/primitive-comparison.rkt new file mode 100644 index 00000000..736f921e --- /dev/null +++ b/typed-racket-lib/typed-racket/utils/primitive-comparison.rkt @@ -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 idx1 idx2) #f] + [else ((unsafe-cdr (vector-ref prims idx1)) s1 s2)])) diff --git a/typed-racket-lib/typed-racket/utils/utils.rkt b/typed-racket-lib/typed-racket/utils/utils.rkt index f73c9abb..12cd22d1 100644 --- a/typed-racket-lib/typed-racket/utils/utils.rkt +++ b/typed-racket-lib/typed-racket/utils/utils.rkt @@ -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)])) diff --git a/typed-racket-more/typed/racket/sandbox.rkt b/typed-racket-more/typed/racket/sandbox.rkt index 6b96c83e..c7c5e318 100644 --- a/typed-racket-more/typed/racket/sandbox.rkt +++ b/typed-racket-more/typed/racket/sandbox.rkt @@ -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) diff --git a/typed-racket-test/fail/pr13209.rkt b/typed-racket-test/fail/pr13209.rkt index 9bba8b82..e379e2aa 100644 --- a/typed-racket-test/fail/pr13209.rkt +++ b/typed-racket-test/fail/pr13209.rkt @@ -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 diff --git a/typed-racket-test/succeed/type-printer-single-level.rkt b/typed-racket-test/succeed/type-printer-single-level.rkt index 7794788c..9ef52a57 100644 --- a/typed-racket-test/succeed/type-printer-single-level.rkt +++ b/typed-racket-test/succeed/type-printer-single-level.rkt @@ -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")) diff --git a/typed-racket-test/unit-tests/check-below-tests.rkt b/typed-racket-test/unit-tests/check-below-tests.rkt index a8591fa7..b2245ae7 100644 --- a/typed-racket-test/unit-tests/check-below-tests.rkt +++ b/typed-racket-test/unit-tests/check-below-tests.rkt @@ -33,7 +33,7 @@ (for-each check-object os)] [(tc-any-results: f) (check-prop f)] - [(? Type/c?) + [(? Type?) (void)])) diff --git a/typed-racket-test/unit-tests/class-tests.rkt b/typed-racket-test/unit-tests/class-tests.rkt index c8c443e1..2b0a9254 100644 --- a/typed-racket-test/unit-tests/class-tests.rkt +++ b/typed-racket-test/unit-tests/class-tests.rkt @@ -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% diff --git a/typed-racket-test/unit-tests/contract-tests.rkt b/typed-racket-test/unit-tests/contract-tests.rkt index ba0267c3..6a13a605 100644 --- a/typed-racket-test/unit-tests/contract-tests.rkt +++ b/typed-racket-test/unit-tests/contract-tests.rkt @@ -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) diff --git a/typed-racket-test/unit-tests/generalize-tests.rkt b/typed-racket-test/unit-tests/generalize-tests.rkt index 9eb2a3cd..cdbba86f 100644 --- a/typed-racket-test/unit-tests/generalize-tests.rkt +++ b/typed-racket-test/unit-tests/generalize-tests.rkt @@ -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)) diff --git a/typed-racket-test/unit-tests/metafunction-tests.rkt b/typed-racket-test/unit-tests/metafunction-tests.rkt index 497f0321..c88ef811 100644 --- a/typed-racket-test/unit-tests/metafunction-tests.rkt +++ b/typed-racket-test/unit-tests/metafunction-tests.rkt @@ -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))))) ) )) diff --git a/typed-racket-test/unit-tests/parse-type-tests.rkt b/typed-racket-test/unit-tests/parse-type-tests.rkt index 66d0d3ad..ec6f9777 100644 --- a/typed-racket-test/unit-tests/parse-type-tests.rkt +++ b/typed-racket-test/unit-tests/parse-type-tests.rkt @@ -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"] diff --git a/typed-racket-test/unit-tests/prop-tests.rkt b/typed-racket-test/unit-tests/prop-tests.rkt index 725283ea..2f9620c0 100644 --- a/typed-racket-test/unit-tests/prop-tests.rkt +++ b/typed-racket-test/unit-tests/prop-tests.rkt @@ -59,7 +59,7 @@ -ff -ff) - (test-opposite #:not-complementary #:contradictory + (test-opposite #:complementary #:contradictory -ff -tt) diff --git a/typed-racket-test/unit-tests/remove-intersect-tests.rkt b/typed-racket-test/unit-tests/remove-intersect-tests.rkt index 0b92257c..5b31f7ef 100644 --- a/typed-racket-test/unit-tests/remove-intersect-tests.rkt +++ b/typed-racket-test/unit-tests/remove-intersect-tests.rkt @@ -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)) diff --git a/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt b/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt index 3cc36db3..aaa7ae5f 100644 --- a/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt +++ b/typed-racket-test/unit-tests/special-env-typecheck-tests.rkt @@ -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 diff --git a/typed-racket-test/unit-tests/subtype-tests.rkt b/typed-racket-test/unit-tests/subtype-tests.rkt index 0671040e..831af426 100644 --- a/typed-racket-test/unit-tests/subtype-tests.rkt +++ b/typed-racket-test/unit-tests/subtype-tests.rkt @@ -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))] diff --git a/typed-racket-test/unit-tests/type-printer-tests.rkt b/typed-racket-test/unit-tests/type-printer-tests.rkt index 047698e7..ae7f4c23 100644 --- a/typed-racket-test/unit-tests/type-printer-tests.rkt +++ b/typed-racket-test/unit-tests/type-printer-tests.rkt @@ -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)") diff --git a/typed-racket-test/unit-tests/typecheck-tests.rkt b/typed-racket-test/unit-tests/typecheck-tests.rkt index bdb2ef3a..69385f5e 100644 --- a/typed-racket-test/unit-tests/typecheck-tests.rkt +++ b/typed-racket-test/unit-tests/typecheck-tests.rkt @@ -28,13 +28,20 @@ (define (cross-phase-failure-check-infos* cpf) (map (λ (args) (apply check-info args)) (cross-phase-failure-check-infos cpf)))) +(module custom-ret racket/base + (require typed-racket/utils/utils + (rename-in (types prop-ops tc-result) [ret raw-ret])) + (provide tc-ret) + (define (tc-ret . args) + (reduce-tc-results/subsumption (apply raw-ret args)))) + ;; Functions for testing correct behavior of typechecking (module tester racket/base (require (submod ".." cross-phase-failure) typed-racket/utils/utils racket/base racket/match - (types tc-result printer) + (rename-in (types prop-ops tc-result printer) [ret raw-ret]) syntax/parse (for-template (only-in typed-racket/typed-racket do-standard-inits)) (typecheck typechecker check-below) @@ -44,10 +51,9 @@ test-literal test-literal/fail test test/proc test/fail) - (do-standard-inits) (print-complex-props? #t) - + ;; tr-expand: syntax? -> syntax? ;; Expands out a form and annotates it with necesarry TR machinery. (define (tr-expand stx) @@ -89,9 +95,9 @@ [(_ _) ""])) (raise (cross-phase-failure - #:actual result - #:expected golden - (string-append base-message extra-message1 extra-message2))))) + #:actual result + #:expected golden + (string-append base-message extra-message1 extra-message2))))) ;; test: syntax? tc-results? [(option/c tc-results?)] ;; [(listof (list id type))] -> void? @@ -173,11 +179,13 @@ 'cross-phase-failure "evaluator.rkt" (except-in "test-utils.rkt" private) + 'custom-ret syntax/location syntax/srcloc (for-syntax racket/base syntax/parse - 'tester)) + 'tester + 'custom-ret)) (provide tests) (gen-test-main) @@ -193,16 +201,17 @@ tc-e/t tc-err tc-l - tc-l/err)) + tc-l/err + tc-ret)) (begin-for-syntax (define-splicing-syntax-class return - (pattern ty:expr #:attr v #'(ret ty)) + (pattern ty:expr #:attr v #'(tc-ret ty)) (pattern (~seq #:ret r:expr) #:attr v #'r)) (define-splicing-syntax-class err-return (pattern (~seq #:ret r:expr) #:attr v #'r) - (pattern (~seq) #:attr v #'(ret -Bottom))) + (pattern (~seq) #:attr v #'(tc-ret -Bottom))) (define-splicing-syntax-class expected (pattern (~seq #:expected v:expr)) @@ -236,10 +245,6 @@ ;;Constructs the syntax that calls eval and returns the answer to the user (define-syntax (tc-e stx) (syntax-parse stx - [(_ code:expr #:proc p) - (quasisyntax/loc stx - (test-phase1 code - (test/proc (quote-syntax code) p)))] [(_ code:expr return:return ex:expected env:extend-env) (quasisyntax/loc stx (test-phase1 code @@ -247,7 +252,7 @@ (define-syntax (tc-e/t stx) (syntax-parse stx - [(_ e t) (syntax/loc stx (tc-e e #:ret (ret t -true-propset)))])) + [(_ e t) (syntax/loc stx (tc-e e #:ret (tc-ret t)))])) ;; check that a literal typechecks correctly (define-syntax (tc-l stx) @@ -315,7 +320,7 @@ (prefix-in r: (only-in racket/base let-values)) ;; Needed for constructing TR types in expected values (for-syntax - (rep type-rep prop-rep object-rep) + (rep core-rep type-rep prop-rep object-rep values-rep) (base-env base-structs) (rename-in (types abbrev union numeric-tower prop-ops utils resolve) [Un t:Un] @@ -335,7 +340,7 @@ e])) (define (-path t var) - (ret t + (tc-ret t (-PS (-not-type var (-val #f)) (-is-type var (-val #f))) (make-Path null var)))) @@ -528,7 +533,7 @@ [tc-e/t (lambda: ([x : Number] [y : Boolean]) 3) (t:-> -Number -Boolean -PosByte : -true-propset)] [tc-e/t (lambda () 3) (t:-> -PosByte : -true-propset)] - [tc-e (values 3 4) #:ret (ret (list -PosByte -PosByte) (list -true-propset -true-propset))] + [tc-e (values 3 4) #:ret (tc-ret (list -PosByte -PosByte) (list -true-propset -true-propset))] [tc-e (cons 3 4) (-pair -PosByte -PosByte)] [tc-e (cons 3 (ann '() : (Listof Integer))) (make-Listof -Integer)] [tc-e (void) -Void] @@ -536,11 +541,11 @@ [tc-e (void #t #f '(1 2 3)) -Void] [tc-e/t #() (make-HeterogeneousVector (list))] [tc-err #(3) - #:ret (ret (make-HeterogeneousVector (list -Integer -Integer))) - #:expected (ret (make-HeterogeneousVector (list -Integer -Integer)))] + #:ret (tc-ret (make-HeterogeneousVector (list -Integer -Integer))) + #:expected (tc-ret (make-HeterogeneousVector (list -Integer -Integer)))] [tc-err #(3 4 5) - #:ret (ret (make-HeterogeneousVector (list -Integer -Integer))) - #:expected (ret (make-HeterogeneousVector (list -Integer -Integer)))] + #:ret (tc-ret (make-HeterogeneousVector (list -Integer -Integer))) + #:expected (tc-ret (make-HeterogeneousVector (list -Integer -Integer)))] [tc-e/t #(3 4 5) (make-HeterogeneousVector (list -Integer -Integer -Integer))] [tc-e/t '(2 3 4) (-lst* -PosByte -PosByte -PosByte)] [tc-e/t '(2 3 #t) (-lst* -PosByte -PosByte (-val #t))] @@ -549,8 +554,8 @@ [tc-e (vector) (make-HeterogeneousVector (list))] [tc-e (vector) #:ret (tc-any-results -tt) #:expected (tc-any-results #f)] [tc-err (vector) - #:ret (ret -Integer) - #:expected (ret -Integer)] + #:ret (tc-ret -Integer) + #:expected (tc-ret -Integer)] [tc-e (vector-immutable 2 "3" #t) (make-HeterogeneousVector (list -Integer -String -Boolean))] [tc-e (make-vector 4 1) (-vec -Integer)] [tc-e (build-vector 4 (lambda (x) 1)) (-vec -Integer)] @@ -573,16 +578,16 @@ (make-Poly '(a) (t:-> (make-Listof (-v a)) (-v a)))] [tc-e/t (plambda: (a) ([l : (Listof a)]) (car l)) (make-Poly '(a) (t:-> (make-Listof (-v a)) (-v a)))] - [tc-e/t (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (t:-> -Number -Number -Number)] + [tc-e/t (case-lambda: [([a : Number] [b : Number]) (+ a b)]) (t:-> -Number -Number -Number : -true-propset)] [tc-e/t (tr:case-lambda [([a : Number] [b : Number]) (+ a b)]) - (t:-> -Number -Number -Number)] + (t:-> -Number -Number -Number : -true-propset)] [tc-e/t (let: ([x : Number 5]) x) -Number] [tc-e (let-values ([(x) 4]) (+ x 1)) -PosIndex] [tc-e (let-values ([(x y) (values 3 #t)]) (and (= x 1) (not y))) - #:ret (ret -Boolean -false-propset)] + #:ret (tc-ret -Boolean -false-propset)] [tc-e/t (values 3) -PosByte] - [tc-e (values) #:ret (ret null)] - [tc-e (values 3 #f) #:ret (ret (list -PosByte (-val #f)) (list -true-propset -false-propset))] + [tc-e (values) #:ret (tc-ret null)] + [tc-e (values 3 #f) #:ret (tc-ret (list -PosByte (-val #f)) (list -true-propset -false-propset))] [tc-e (map #{values @ Symbol} '(a b c)) (-pair -Symbol (make-Listof -Symbol))] [tc-e (andmap add1 (ann '() (Listof Number))) (t:Un (-val #t) -Number)] [tc-e (ormap add1 (ann '() (Listof Number))) (t:Un (-val #f) -Number)] @@ -621,9 +626,9 @@ [tc-e/t (begin0 #t) (-val #t)] [tc-e/t (begin0 #t 3) (-val #t)] [tc-e/t #t (-val #t)] - [tc-e #f #:ret (ret (-val #f) -false-propset)] + [tc-e #f #:ret (tc-ret (-val #f) -false-propset)] [tc-e/t '#t (-val #t)] - [tc-e '#f #:ret (ret (-val #f) -false-propset)] + [tc-e '#f #:ret (tc-ret (-val #f) -false-propset)] [tc-e/t (if #f 'a 3) -PosByte] [tc-e/t (if #f #f #t) (t:Un (-val #t))] [tc-e (when #f 3) -Void] @@ -633,7 +638,7 @@ [(null? x) 1])) -One] [tc-e/t (lambda: ([x : Number] . [y : Number *]) (car y)) - (->* (list -Number) -Number -Number)] + (->* (list -Number) -Number -Number : -true-propset)] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3) -Number] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4 5) -Number] [tc-e ((lambda: ([x : Number] . [y : Number *]) (car y)) 3 4) -Number] @@ -645,12 +650,12 @@ (->* (list -Number) -Boolean -Boolean)] [tc-e ((lambda: ([x : Number] . [y : Boolean *]) (car y)) 3) -Boolean] [tc-e (apply (lambda: ([x : Number] . [y : Boolean *]) (car y)) 3 '(#f)) -Boolean] - [tc-e (lambda args (void)) #:ret (ret (t:-> -String -Void) -true-propset) - #:expected (ret (t:-> -String -Void) -true-propset)] + [tc-e (lambda args (void)) #:ret (tc-ret (t:-> -String -Void) -true-propset) + #:expected (tc-ret (t:-> -String -Void) -true-propset)] [tc-e (lambda (x y . z) (+ x y (+ (length z)))) - #:ret (ret (t:-> -Byte -Index -Number) -true-propset) - #:expected (ret (t:-> -Byte -Index -Number) -true-propset)] + #:ret (tc-ret (t:-> -Byte -Index -Number) -true-propset) + #:expected (tc-ret (t:-> -Byte -Index -Number) -true-propset)] [tc-e/t (let: ([x : Number 3]) (when (number? x) #t)) @@ -676,8 +681,10 @@ -Number] [tc-e/t (let ([x 1]) x) -One] - [tc-e (let ([x 1]) (boolean? x)) #:ret (ret -Boolean -false-propset)] - [tc-e (boolean? number?) #:ret (ret -Boolean -false-propset)] + [tc-e (let ([x 1]) (boolean? x)) #:ret (tc-ret -Boolean -false-propset)] + [tc-e (let ([f : (-> Any Boolean : Number) number?]) + (boolean? f)) + #:ret (tc-ret -Boolean -false-propset)] [tc-e (let: ([x : (Option Number) #f]) x) (t:Un -Number (-val #f))] [tc-e (let: ([x : Any 12]) (not (not x))) -Boolean] @@ -763,7 +770,7 @@ -Number] - [tc-e null #:ret (ret (-val null) -true-propset (-id-path #'null))] + [tc-e null #:ret (tc-ret (-val null) -true-propset (-id-path #'null))] [tc-e/t (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) @@ -785,7 +792,7 @@ (if (string=? x 'foo) "foo" x)) - #:ret (ret (t:Un -String (-val 'foo)) -true-propset)] + #:ret (tc-ret (t:Un -String (-val 'foo)) -true-propset)] [tc-e/t (let: ([x : (U String 5) 5]) (if (eq? x 5) @@ -796,11 +803,11 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? x sym) 3 x)) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte -true-propset)] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (eq? sym x) 3 x)) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte -true-propset)] ;; equal? as predicate for symbols [tc-e/t (let: ([x : (Un 'foo Number) 'foo]) (if (equal? x 'foo) 3 x)) @@ -812,11 +819,11 @@ [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? x sym) 3 x)) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte -true-propset)] [tc-e (let* ([sym 'squarf] [x (if (= 1 2) 3 sym)]) (if (equal? sym x) 3 x)) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte -true-propset)] [tc-e/t (let: ([x : (Listof Symbol)'(a b c)]) (cond [(memq 'a x) => car] @@ -851,7 +858,7 @@ ;;; tests for and [tc-e (let: ([x : Any 1]) (and (number? x) (boolean? x))) - #:ret (ret -Boolean -false-propset)] + #:ret (tc-ret -Boolean -false-propset)] [tc-e (let: ([x : Any 1]) (and (number? x) x)) (t:Un -Number (-val #f))] [tc-e (let: ([x : Any 1]) (and x (boolean? x))) @@ -894,21 +901,21 @@ (boolean? y)) (if (boolean? x) 1 x) 4)) - #:ret (ret Univ -true-propset)] + #:ret (tc-ret Univ -true-propset)] [tc-e (let: ([x : Any 1]) (if (if ((lambda: ([x : Any]) x) 12) #t (boolean? x)) (if (boolean? x) 1 x) 4)) - #:ret (ret Univ -true-propset)] + #:ret (tc-ret Univ -true-propset)] ;; T-AbsPred [tc-e/t (let ([p? (lambda: ([x : Any]) (number? x))]) (lambda: ([x : Any]) (if (p? x) (add1 x) (add1 12)))) - (t:-> Univ -Number)] + (t:-> Univ -Number : -true-propset)] [tc-e/t (let ([p? (lambda: ([x : Any]) (not (number? x)))]) (lambda: ([x : Any]) (if (p? x) 12 (add1 x)))) - (t:-> Univ -Number : (-PS -tt (-is-type 0 -Number)))] + (t:-> Univ -Number : -true-propset)] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) 11 12))) @@ -917,11 +924,11 @@ [p? (lambda: ([x : Any]) (number? z))]) (lambda: ([x : Any]) (if (p? x) x 12))) (t:-> Univ Univ : (-PS (-not-type 0 (-val #f)) (-is-type 0 (-val #f))) - : (make-Path null '(0 0)))] + : (make-Path null '(0 . 0)))] [tc-e/t (let* ([z (ann 1 : Any)] [p? (lambda: ([x : Any]) (not (number? z)))]) (lambda: ([x : Any]) (if (p? x) (ann (add1 7) Any) 12))) - (t:-> Univ Univ)] + (t:-> Univ Univ : -true-propset)] [tc-e/t (let* ([z 1] [p? (lambda: ([x : Any]) (not (number? z)))]) (lambda: ([x : Any]) (if (p? x) x 12))) @@ -930,21 +937,21 @@ [p? (lambda: ([x : Any]) z)]) (lambda: ([x : Any]) (if (p? x) x 12))) (t:-> Univ Univ : (-PS (-not-type 0 (-val #f)) (-is-type 0 (-val #f))) - : (make-Path null '(0 0)))] + : (make-Path null '(0 . 0)))] [tc-e (not 1) - #:ret (ret -Boolean -false-propset)] + #:ret (tc-ret -Boolean -false-propset)] [tc-err ((lambda () 1) 2) - #:ret (ret (-val 1) -true-propset)] + #:ret (tc-ret (-val 1) -true-propset)] [tc-err (apply (lambda () 1) '(2))] [tc-err ((lambda: ([x : Any] [y : Any]) 1) 2) - #:ret (ret (-val 1) -true-propset)] + #:ret (tc-ret (-val 1) -true-propset)] [tc-err (map map '(2))] [tc-err ((plambda: (a) ([x : (a -> a)] [y : a]) (x y)) 5)] [tc-err ((plambda: (a) ([x : a] [y : a]) x) 5)] [tc-err (ann 5 : String) - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] ;; these don't work because the type annotation gets lost in marshalling #| @@ -978,18 +985,18 @@ (: y Symbol) (define y x) y) - #:ret (ret -Symbol -true-propset) + #:ret (tc-ret -Symbol -true-propset) #:msg #rx"expected: String|expected: Symbol"] ;; Test ill-typed code in letrec RHS [tc-err (let () (: x String) (define x 'foo) x) - #:ret (ret -String -true-propset) + #:ret (tc-ret -String -true-propset) #:msg #rx"expected: String.*given: 'foo"] [tc-err (let ([x (add1 5)]) (set! x "foo") x) - #:ret (ret -Integer -true-propset)] + #:ret (tc-ret -Integer -true-propset)] ;; w-c-m [tc-e/t (with-continuation-mark ((inst make-continuation-mark-key Symbol)) 'mark @@ -1002,8 +1009,8 @@ [tc-err (with-continuation-mark 1 2 (5 4))] [tc-err (with-continuation-mark 'x 'y 'z) - #:ret (ret (-val 'z) -ff-propset) - #:expected (ret (-val 'z) #f #f)] + #:ret (tc-ret (-val 'z) -ff-propset) + #:expected (tc-ret (-val 'z) -ff-propset)] ;; call-with-values @@ -1016,14 +1023,13 @@ -Number] [tc-err (call-with-values (lambda () 1) (lambda: () 2)) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte -true-propset)] [tc-err (call-with-values (lambda () (values 2)) (lambda: ([x : Number] [y : Number]) (+ x y))) - #:ret (ret -Number)] + #:ret (tc-ret -Number)] [tc-err (call-with-values 5 - (lambda: ([x : Number] [y : Number]) (+ x y))) - #:ret (ret -Number)] + (lambda: ([x : Number] [y : Number]) (+ x y)))] [tc-err (call-with-values (lambda () (values 2)) 5)] [tc-err (call-with-values (lambda () (values 2 1)) @@ -1122,7 +1128,7 @@ (do: : Number ((x : (Listof Number) x (cdr x)) (sum : Number 0 (+ sum (car x)))) ((null? x) sum))) - #:ret (ret -Number -tt-propset -empty-obj)] + #:ret (tc-ret -Number)] [tc-e/t (if #f 1 'foo) (-val 'foo)] @@ -1135,14 +1141,14 @@ [tc-e (apply append (list 1) (list 2) (list 3) (list (list 1) (list "foo"))) (-pair (t:Un -String -PosByte) (-lst (t:Un -String -PosByte)))] [tc-e (plambda: (b ...) [y : b ... b] (apply append (map list y))) - #:ret (ret (-polydots (b) (->... (list) (b b) (-lst Univ))) -true-propset)] + #:ret (tc-ret (-polydots (b) (->... (list) (b b) (-lst Univ) : -true-propset)) -true-propset)] [tc-e/t (plambda: (b ...) [y : (Listof Integer) ... b] (apply append y)) - (-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer)))] + (-polydots (b) (->... (list) ((-lst -Integer) b) (-lst -Integer) : -true-propset))] [tc-err (plambda: (a ...) ([z : String] . [w : Number ... a]) (apply (plambda: (b) ([x : Number] . [y : Number ... a]) x) 1 1 1 1 w)) - #:ret (ret (-polydots (a) (->... (list -String) (-Number a) -Bottom)) -true-propset)] + #:ret (tc-ret (-polydots (a) (->... (list -String) (-Number a) -Bottom)) -true-propset)] [tc-err (plambda: (a ...) ([z : String] . [w : Number]) (apply (plambda: (b) ([x : Number] . [y : Number ... a]) x) @@ -1151,7 +1157,7 @@ [tc-e/t (plambda: (a ...) ([z : String] . [w : Number ... a]) (apply (plambda: (b ...) ([x : Number] . [y : Number ... b]) x) 1 w)) - (-polydots (a) ((list -String) (-Number a) . ->... . -Number))] + (-polydots (a) ((list -String) (-Number a) . ->... . -Number : -true-propset))] [tc-e (let ([f (plambda: (a ...) [w : a ... a] w)]) (f 1 "hello" #\c)) (-lst* -One -String -Char)] @@ -1159,11 +1165,11 @@ [tc-e/t (inst (plambda: (a) ([x : a]) x) Integer) (make-Function (list (make-arr* (list -Integer) -Integer - #:props (-PS (-not-type (list 0 0) (-val #f)) - (-is-type (list 0 0) (-val #f))) - #:object (make-Path null (list 0 0)))))] + #:props (-PS (-not-type (cons 0 0) (-val #f)) + (-is-type (cons 0 0) (-val #f))) + #:object (make-Path null (cons 0 0)))))] [tc-e/t (inst (plambda: (a) [x : a *] (apply list x)) Integer) - ((list) -Integer . ->* . (-lst -Integer))] + ((list) -Integer . ->* . (-lst -Integer) : -true-propset)] ;; instantiating dotted terms [tc-e/t (inst (plambda: (a ...) [xs : a ... a] 3) Integer Boolean Integer) @@ -1187,9 +1193,9 @@ ;; error tests [tc-err (+ 3 #f)] [tc-err (let: ([x : Number #f]) x) - #:ret (ret -Number -true-propset)] + #:ret (tc-ret -Number -true-propset)] [tc-err (let: ([x : Number #f]) (+ 1 x)) - #:ret (ret -Number)] + #:ret (tc-ret -Number)] [tc-err (let: ([x : Any '(foo)]) @@ -1197,14 +1203,14 @@ (if (list? x) (add1 x) 12))) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte -true-propset)] [tc-err (let*: ([x : Any 1] [f : (-> Void) (lambda () (set! x 'foo))]) (if (number? x) (begin (f) (add1 x)) 12)) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte -true-propset)] [tc-err (ann 3 (Rec a a))] [tc-err (ann 3 (Rec a (U a 3)))] @@ -1279,14 +1285,14 @@ (apply y zs)) ys))) (-polydots (a) ((list) ((list) (a a) . ->... . -Number) . ->* . - ((list) (a a) . ->... . (-lst -Number)) : -true-propset))] + ((list) (a a) . ->... . (-lst -Number) : -true-propset) : -true-propset))] [tc-e/t (plambda: (a ...) [ys : (a ... a -> Number) *] (lambda: [zs : a ... a] (map (lambda: ([y : (a ... a -> Number)]) (apply y zs)) ys))) (-polydots (a) ((list) ((list) (a a) . ->... . -Number) . ->* . - ((list) (a a) . ->... . (-lst -Number)) : -true-propset))] + ((list) (a a) . ->... . (-lst -Number) : -true-propset) : -true-propset))] [tc-e/t (lambda: ((x : (All (t) t))) ((inst (inst x (All (t) (t -> t))) @@ -1299,21 +1305,21 @@ [tc-e/t (inst (plambda: (a ...) [ys : Number ... a] (apply + ys)) Boolean String Number) - (-Number -Number -Number . t:-> . -Number)] + (-Number -Number -Number . t:-> . -Number : -true-propset)] [tc-e (assq 'foo #{'((a b) (foo bar)) :: (Listof (List Symbol Symbol))}) (t:Un (-val #f) (-lst* -Symbol -Symbol))] [tc-e/t (ann (lambda (x) x) (All (a) (a -> a))) (-poly (a) (a . t:-> . a))] - [tc-e (apply values (list 1 2 3)) #:ret (ret (list -One -PosByte -PosByte))] + [tc-e (apply values (list 1 2 3)) #:ret (tc-ret (list -One -PosByte -PosByte))] [tc-e/t (ann (if #t 3 "foo") Integer) -Integer] [tc-e/t (plambda: (a ...) ([x : Number] . [y : a ... a]) (andmap null? (map list y))) (-polydots (a) ((list -Number) (a a) . ->... . -Boolean))] - [tc-e (ann (error 'foo) (values Number Number)) #:ret (ret (list -Bottom -Bottom))] + [tc-e (ann (error 'foo) (values Number Number)) #:ret (tc-ret (list -Bottom -Bottom))] [tc-e (string->number "123") (t:Un (-val #f) -Number)] @@ -1327,10 +1333,10 @@ [tc-err (let: ([fact : (Number -> Number) (lambda: ([n : Number]) (if (zero? n) 1 (* n (fact (- n 1)))))]) (fact 20)) - #:ret (ret -Number)] + #:ret (tc-ret -Number)] [tc-err (ann (lambda: ([x : Any]) #f) (Any -> Boolean : String)) - #:ret (ret (make-pred-ty -String) -true-propset)] + #:ret (tc-ret (make-pred-ty -String) -true-propset)] [tc-e (time (+ 3 4)) -PosIndex] @@ -1344,7 +1350,7 @@ [user : Number] [gc : Number]) 'whatever)) - #:ret (ret (-val 'whatever) -true-propset)] + #:ret (tc-ret (-val 'whatever) -true-propset)] [tc-e (call-with-values (lambda () ((inst time-apply Number Number Number Number Number Number Number) @@ -1354,16 +1360,16 @@ [user : Number] [gc : Number]) 'whatever)) - #:ret (ret (-val 'whatever) -true-propset)] + #:ret (tc-ret (-val 'whatever) -true-propset)] [tc-e (let: ([l : (Listof Any) (list 1 2 3)]) (if (andmap number? l) (+ 1 (car l)) 7)) -Number] (tc-e (or (string->number "7") 7) - #:ret (ret -Number -true-propset)) + #:ret (tc-ret -Number -true-propset)) [tc-e (let ([x 1]) (if x x (add1 x))) - #:ret (ret -One -true-propset)] + #:ret (tc-ret -One -true-propset)] [tc-e (let: ([x : (U (Vectorof Integer) String) (vector 1 2 3)]) (if (vector? x) (vector-ref x 0) (string-length x))) -Integer] @@ -1393,12 +1399,12 @@ (vector-ref #("a" "b") (- x 1))) -String] [tc-err (string-append "bar" (if (zero? (ann 0.0 Float)) #f "foo")) - #:ret (ret -String)] + #:ret (tc-ret -String)] [tc-err (do: : Void ([j : Natural (+ i 'a) (+ j i)]) ((>= j 10)) #f) - #:ret (ret -Void -tt-propset -empty-obj)] + #:ret (tc-ret -Void)] [tc-err (apply +)] [tc-e/t (let ([x eof]) @@ -1411,7 +1417,7 @@ (ann (list (cons 1 2) (cons 2 3) (cons 4 5)) (Listof (Pairof Number Number)))) (-lst -Number)] [tc-err (list (values 1 2)) - #:ret (ret (-Tuple (list -Bottom)))] + #:ret (tc-ret (-Tuple (list -Bottom)))] ;; Lists [tc-e (list-update '("a" "b" "c") 1 (λ (x) "a")) (-lst -String)] @@ -1428,7 +1434,7 @@ ;;Path tests (tc-e (path-string? "foo") -Boolean) - (tc-e (path-string? (string->path "foo")) #:ret (ret -Boolean -true-propset)) + (tc-e (path-string? (string->path "foo")) #:ret (tc-ret -Boolean -true-propset)) (tc-e (bytes->path #"foo" 'unix) -SomeSystemPath) (tc-e (bytes->path #"foo") -Path) (tc-e (bytes->path-element #"foo") -Path) @@ -1446,8 +1452,8 @@ (tc-e (expand-user-path "foo") -Path) ;;String Tests - (tc-e (string? "a") #:ret (ret -Boolean -true-propset)) - (tc-e (string? 2) #:ret (ret -Boolean -false-propset)) + (tc-e (string? "a") #:ret (tc-ret -Boolean -true-propset)) + (tc-e (string? 2) #:ret (tc-ret -Boolean -false-propset)) (tc-e (string->immutable-string (string #\a #\b)) -String) (tc-e (string-length (make-string 5 #\z)) -Index) @@ -1505,8 +1511,8 @@ ;Symbols - (tc-e (symbol? 'foo) #:ret (ret -Boolean -true-propset)) - (tc-e (symbol? 2) #:ret (ret -Boolean -false-propset)) + (tc-e (symbol? 'foo) #:ret (tc-ret -Boolean -true-propset)) + (tc-e (symbol? 2) #:ret (tc-ret -Boolean -false-propset)) (tc-e (symbol-interned? 'foo) -Boolean) (tc-e (symbol-interned? (string->unreadable-symbol "bar")) -Boolean) @@ -1523,16 +1529,16 @@ (tc-e (string->symbol (symbol->string 'foo)) -Symbol) ;Booleans - (tc-e (not #f) #:ret (ret -Boolean -true-propset)) - (tc-e (false? #f) #:ret (ret -Boolean -true-propset)) - (tc-e (not #t) #:ret (ret -Boolean -false-propset)) + (tc-e (not #f) #:ret (tc-ret -Boolean -true-propset)) + (tc-e (false? #f) #:ret (tc-ret -Boolean -true-propset)) + (tc-e (not #t) #:ret (tc-ret -Boolean -false-propset)) ;; It's not clear why the following test doesn't work, ;; but it works fine in the real typechecker - ;(tc-e (false? #t) #:ret (ret -Boolean -false-propset)) + ;(tc-e (false? #t) #:ret (tc-ret -Boolean -false-propset)) - (tc-e (boolean? true) #:ret (ret -Boolean -true-propset)) - (tc-e (boolean? 6) #:ret (ret -Boolean -false-propset)) + (tc-e (boolean? #t) #:ret (tc-ret -Boolean -true-propset)) + (tc-e (boolean? 6) #:ret (tc-ret -Boolean -false-propset)) (tc-e (immutable? (cons 3 4)) -Boolean) (tc-e (boolean=? #t false) -Boolean) @@ -1571,24 +1577,24 @@ (-opt (-pair -Bytes (-lst (-opt -Bytes))))) (tc-err (regexp-try-match "foo" "foobar") - #:ret (ret (t:Un (-val #f) (-pair -Bytes (-lst (t:Un (-val #f) -Bytes)))))) + #:ret (tc-ret (t:Un (-val #f) (-pair -Bytes (-lst (t:Un (-val #f) -Bytes)))))) (tc-e (regexp-try-match "foo" (open-input-string "foobar")) (-opt (-pair -Bytes (-lst (-opt -Bytes))))) (tc-err (regexp-match-peek "foo" "foobar") - #:ret (ret (t:Un (-val #f) (-pair -Bytes (-lst (t:Un (-val #f) -Bytes)))))) + #:ret (tc-ret (t:Un (-val #f) (-pair -Bytes (-lst (t:Un (-val #f) -Bytes)))))) (tc-e (regexp-match-peek "foo" (open-input-string "foobar")) (-opt (-pair -Bytes (-lst (-opt -Bytes))))) (tc-err (regexp-match-peek-immediate "foo" "foobar") - #:ret (ret (t:Un (-val #f) (-pair -Bytes (-lst (t:Un (-val #f) -Bytes)))))) + #:ret (tc-ret (t:Un (-val #f) (-pair -Bytes (-lst (t:Un (-val #f) -Bytes)))))) (tc-e (regexp-match-peek-immediate "foo" (open-input-string "foobar")) (-opt (-pair -Bytes (-lst (-opt -Bytes))))) [tc-e (regexp-match/end "foo" "foobar") - #:ret (ret (list (-opt (-pair -String (-lst (-opt -String)))) (-opt -Bytes)))] + #:ret (tc-ret (list (-opt (-pair -String (-lst (-opt -String)))) (-opt -Bytes)))] (tc-e (regexp-split "foo" "foobar") (-pair -String (-lst -String))) (tc-e (regexp-split "foo" #"foobar") (-pair -Bytes (-lst -Bytes))) @@ -1596,7 +1602,7 @@ (tc-e (regexp-split #"foo" #"foobar") (-pair -Bytes (-lst -Bytes))) (tc-err (regexp-split "foo" (path->string "foobar")) - #:ret (ret (-pair -String (-lst -String)))) + #:ret (tc-ret (-pair -String (-lst -String)))) (tc-e (regexp-replace "foo" "foobar" "rep") -String) (tc-e (regexp-replace #"foo" "foobar" "rep") -Bytes) @@ -1697,8 +1703,8 @@ ;Syntax - (tc-e (syntax? #'id) #:ret (ret -Boolean -true-propset)) - (tc-e (syntax? 2) #:ret (ret -Boolean -false-propset)) + (tc-e (syntax? #'id) #:ret (tc-ret -Boolean -true-propset)) + (tc-e (syntax? 2) #:ret (tc-ret -Boolean -false-propset)) (tc-e (syntax-source #'here) Univ) (tc-e (syntax-line #'here) (-opt -PosInt)) @@ -1715,17 +1721,17 @@ (tc-e (parameter-procedure=? current-input-port current-output-port) -Boolean) ;Namespaces - (tc-e (namespace? 2) #:ret (ret -Boolean -false-propset)) - (tc-e (namespace? (make-empty-namespace)) #:ret (ret -Boolean -true-propset)) + (tc-e (namespace? 2) #:ret (tc-ret -Boolean -false-propset)) + (tc-e (namespace? (make-empty-namespace)) #:ret (tc-ret -Boolean -true-propset)) - (tc-e (namespace-anchor? 3) #:ret (ret -Boolean -false-propset)) + (tc-e (namespace-anchor? 3) #:ret (tc-ret -Boolean -false-propset)) (tc-e/t (lambda: ((x : Namespace-Anchor)) (namespace-anchor? x)) - (t:-> -Namespace-Anchor -Boolean : -true-propset)) + (t:-> -Namespace-Anchor -True : -true-propset)) - (tc-e (variable-reference? 3) #:ret (ret -Boolean -false-propset)) + (tc-e (variable-reference? 3) #:ret (tc-ret -Boolean -false-propset)) (tc-e/t (lambda: ((x : Variable-Reference)) (variable-reference? x)) - (t:-> -Variable-Reference -Boolean : -true-propset)) + (t:-> -Variable-Reference -True : -true-propset)) (tc-e (system-type 'os) (one-of/c 'unix 'windows 'macosx)) (tc-e (system-type 'gc) (one-of/c 'cgc '3m)) @@ -1790,7 +1796,7 @@ (define-values (p std-out std-in std-err) (subprocess #f #f #f (string->path "/bin/bash"))) (subprocess? p)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) (tc-e (car (process "hello")) -Input-Port) @@ -1831,7 +1837,7 @@ (tc-e (compile-syntax #'(+ 1 2)) -Compiled-Expression) (tc-e (let: ((e : Compiled-Expression (compile #'(+ 1 2)))) (compiled-expression? e)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) (tc-e (let: ((e : Compiled-Expression (compile #'(module + racket 2)))) (compiled-module-expression? e)) -Boolean) @@ -1848,7 +1854,7 @@ (acc : (Any -> Any))) (make-impersonator-property 'prop))) (impersonator-property? prop)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) ;Security Guards (tc-e (make-security-guard (current-security-guard) @@ -1857,14 +1863,14 @@ -Security-Guard) (tc-e (let: ((s : Security-Guard (current-security-guard))) (security-guard? s)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) ;Custodians (tc-e (make-custodian) -Custodian) (tc-e (let: ((c : Custodian (current-custodian))) (custodian? c)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) (tc-e (let: ((c : (Custodian-Boxof Integer) (make-custodian-box (current-custodian) 1))) (custodian-box-value c)) -Int) @@ -1872,14 +1878,14 @@ (tc-e (make-thread-group) -Thread-Group) (tc-e (let: ((tg : Thread-Group (current-thread-group))) (thread-group? tg)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) ;Inspector (tc-e (make-inspector) -Inspector) (tc-e (let: ((i : Inspector (current-inspector))) (inspector? i)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) ;Continuation Prompt Tags ang Continuation Mark Sets ;; TODO: supporting default-continuation-prompt-tag means we need to @@ -1888,7 +1894,7 @@ (tc-e (let: ((pt : (Prompt-Tagof Integer Integer) (make-continuation-prompt-tag))) (continuation-marks #f pt)) -Cont-Mark-Set) (tc-e (let: ((set : Continuation-Mark-Set (current-continuation-marks))) - (continuation-mark-set? set)) #:ret (ret -Boolean -true-propset)) + (continuation-mark-set? set)) #:ret (tc-ret -Boolean -true-propset)) ;Logging (tc-e (make-logger 'name) -Logger) @@ -1936,13 +1942,13 @@ (-mu x (make-Evt x))) (tc-err (let: ([a : (U (Evtof Any) String) always-evt]) (if (handle-evt? a) a (string->symbol a))) - #:ret (ret (t:Un -Symbol (make-Evt Univ)))) + #:ret (tc-ret (t:Un -Symbol (make-Evt Univ)))) (tc-err (let: ([a : (U (Evtof Any) String) always-evt]) (if (channel-put-evt? a) a (string->symbol a))) - #:ret (ret (t:Un -Symbol (-mu x (make-Evt x))))) + #:ret (tc-ret (t:Un -Symbol (-mu x (make-Evt x))))) (tc-err (let: ([a : (U (Evtof Any) String) always-evt]) (if (semaphore-peek-evt? a) a (string->symbol a))) - #:ret (ret (t:Un -Symbol (-mu x (make-Evt x))))) + #:ret (tc-ret (t:Un -Symbol (-mu x (make-Evt x))))) ;Semaphores (tc-e (make-semaphore) -Semaphore) @@ -1985,7 +1991,7 @@ (pred : (Any -> Any)) (acc : (Any -> Any))) (make-struct-type-property 'prop))) (struct-type-property? prop)) - #:ret (ret -Boolean -true-propset)) + #:ret (tc-ret -Boolean -true-propset)) ;; Boxes [tc-e (box-cas! (box "foo") "bar" "baz") -Boolean] @@ -2003,7 +2009,7 @@ (: b2 (Weak-Boxof (U Symbol String))) (define b2 b1) (error "foo")) - #:msg #rx"expected: \\(Weak-Boxof \\(U Symbol String\\)\\)"] + #:msg #rx"expected: \\(Weak-Boxof \\(U String Symbol\\)\\)"] ;Wills (tc-e (make-will-executor) -Will-Executor) @@ -2057,7 +2063,7 @@ -Void) [tc-e (raise (exn:fail:contract "1" (current-continuation-marks))) (t:Un)] [tc-err (exn:fail:contract) - #:ret (ret (resolve (-struct-name #'exn:fail:contract)))] + #:ret (tc-ret (resolve (-struct-name #'exn:fail:contract)))] [tc-e (#%variable-reference) -Variable-Reference] [tc-e (#%variable-reference x) -Variable-Reference] [tc-e (#%variable-reference +) -Variable-Reference] @@ -2069,13 +2075,13 @@ [(x y) (add1 x)]) (case-> (Integer -> Integer) (Integer Integer -> Integer))) - #:ret (ret (cl->* (t:-> -Integer -Integer) + #:ret (tc-ret (cl->* (t:-> -Integer -Integer) (t:-> -Integer -Integer -Integer)) -true-propset)] [tc-e (let ([my-pred (λ () #f)]) (for/and: : Any ([i (in-range 4)]) (my-pred))) - #:ret (ret Univ -tt-propset -empty-obj)] + #:ret (tc-ret Univ)] [tc-e/t (let () (define: long : (List 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 Integer) @@ -2170,7 +2176,7 @@ [tc-e ((inst vector Index) 0) (-vec -Index)] [tc-err ((inst list Void) 1 2 3) - #:ret (ret (-lst -Void))] + #:ret (tc-ret (-lst -Void))] [tc-e ((inst list Any) 1 2 3) (-lst Univ)] @@ -2189,7 +2195,7 @@ [tc-err (let ((s (ann (set 2) Any))) (if (set? s) (ann s (Setof String)) ((inst set String)))) - #:ret (ret (-set -String))] + #:ret (tc-ret (-set -String))] [tc-e (split-at (list 0 2 3 4 5 6) 3) (list (-lst -Byte) (-lst -Byte))] @@ -2211,15 +2217,16 @@ (ann ((letrec ((x (lambda (acc v) (if v (list v) acc)))) x) null (list 'bad 'prog)) (Listof Symbol)) - #:ret (ret (-lst -Symbol) -tt-propset -empty-obj)] + #:ret (tc-ret (-lst -Symbol))] [tc-e (filter values empty) (-lst -Bottom)] [tc-e (lambda lst (map (plambda: (b) ([x : b]) x) lst)) - (-polydots (a) (->... (list) (a a) (make-ListDots a 'a))) - #:expected (ret (-polydots (a) (->... (list) (a a) (make-ListDots a 'a))))] + #:ret (tc-ret (-polydots (a) (->... (list) (a a) (make-ListDots a 'a)))) + #:expected (tc-ret (-polydots (a) (->... (list) (a a) (make-ListDots a 'a))))] - [tc-e/t (ann (lambda (x) #t) (All (a) Any)) - (-poly (a) Univ)] + [tc-e (ann (lambda (x) #t) (All (a) Any)) + #:ret (tc-ret (-poly (a) Univ)) + #:expected (tc-ret (-poly (a) Univ))] [tc-e ((inst filter Any Symbol) symbol? null) (-lst -Symbol)] @@ -2230,11 +2237,11 @@ [tc-e/t (ann (ann 'x Symbol) Symbol) -Symbol] [tc-err (lambda (x) x) - #:ret (ret (-poly (a) (cl->* (t:-> a a) (t:-> a a a)))) - #:expected (ret (-poly (a) (cl->* (t:-> a a) (t:-> a a a))))] + #:ret (tc-ret (-poly (a) (cl->* (t:-> a a) (t:-> a a a)))) + #:expected (tc-ret (-poly (a) (cl->* (t:-> a a) (t:-> a a a))))] [tc-err (plambda: (A) ((x : A)) x) - #:ret (ret (list -Symbol -Symbol)) - #:expected (ret (list -Symbol -Symbol))] + #:ret (tc-ret (list -Symbol -Symbol)) + #:expected (tc-ret (list -Symbol -Symbol))] [tc-e/t (case-lambda @@ -2244,8 +2251,8 @@ [tc-e (opt-lambda: ((x : Symbol 'a)) x) - #:ret (ret (t:-> -Symbol -Symbol) -true-propset) - #:expected (ret (t:-> -Symbol -Symbol) -true-propset)] + #:ret (tc-ret (t:-> -Symbol -Symbol) -true-propset) + #:expected (tc-ret (t:-> -Symbol -Symbol) -true-propset)] [tc-e/t (inst (ann (lambda (a) a) (All (a) (a -> a))) Symbol) (t:-> -Symbol -Symbol)] @@ -2260,7 +2267,7 @@ ;; note the propositions (Any -> Boolean : #:+ (Integer @ x) #:- (! Integer @ x)))) (if (f 'dummy) (add1 x) 2)) - (t:-> Univ -Integer : (-PS -tt (-is-type 0 -Integer)))] + (t:-> Univ -Integer : -true-propset)] ;; This test ensures that curried predicates have ;; the correct props so that they can be used for @@ -2281,9 +2288,9 @@ ;; (should not trigger an error with free-identifier=?) [tc-e (lambda (x) (lambda (y) y)) #:ret - (ret (t:-> Univ (t:-> Univ Univ : (-PS (-not-type (list 0 0) (-val #f)) - (-is-type (list 0 0) (-val #f))) - : (make-Path null (list 0 0))) + (tc-ret (t:-> Univ (t:-> Univ Univ : (-PS (-not-type (cons 0 0) (-val #f)) + (-is-type (cons 0 0) (-val #f))) + : (make-Path null (cons 0 0))) : -true-propset) -true-propset)] @@ -2291,8 +2298,7 @@ ;; written by the user [tc-e (let () - (: f (Any -> (Any -> Boolean : #:+ (Symbol @ 1 0) - #:- (! Symbol @ 1 0)) + (: f (Any -> (Any -> Boolean : #:+ (Symbol @ 1 0) #:- (! Symbol @ 1 0)) : #:+ Top #:- Bot)) (define f (λ (x) (λ (y) (symbol? x)))) (: b (U Symbol String)) @@ -2344,7 +2350,7 @@ (: x Real) (define x 3) (if ((negate pos?) x) x -5)) - #:ret (ret -NonPosReal -true-propset)] + #:ret (tc-ret -NonPosReal -true-propset)] [tc-err (hash-ref! (ann (make-hash) (HashTable #f (-> #t))) #f (lambda () #t))] @@ -2403,10 +2409,10 @@ [tc-e (dropf-right '("a" b "x" "y") string?) (-lst (t:Un -String (-val 'b)))] [tc-e (splitf-at '("a" b "x" "y") string?) - #:ret (ret (list (-lst -String) + #:ret (tc-ret (list (-lst -String) (-lst (t:Un -String (-val 'b)))))] [tc-e (splitf-at-right '("a" b "x" "y") string?) - #:ret (ret (list (-lst (t:Un -String (-val 'b))) + #:ret (tc-ret (list (-lst (t:Un -String (-val 'b))) (-lst -String)))] [tc-e (combinations '(1 2 1)) (-lst (-lst -PosByte))] [tc-e (combinations '(1 2 1) 2) (-lst (-lst -PosByte))] @@ -2477,9 +2483,9 @@ [tc-err (let-values ([(name _1 _2 getter setter _3 _4 _5) (struct-type-info struct:arity-at-least)]) (getter 'bad 0)) - #:ret (ret Univ)] + #:ret (tc-ret Univ)] [tc-err (struct-type-make-constructor 'bad) - #:ret (ret top-func)] + #:ret (tc-ret top-func)] [tc-err (struct-type-make-predicate 'bad)] [tc-e @@ -2493,7 +2499,7 @@ [tc-e (current-future) (-opt (-future Univ))] [tc-e (add1 (processor-count)) -PosInt] [tc-e (assert (current-future) future?) - #:ret (ret (-future Univ) -true-propset)] + #:ret (tc-ret (-future Univ) -true-propset)] [tc-e (futures-enabled?) -Boolean] [tc-e (place-enabled?) -Boolean] [tc-e (dynamic-place "a.rkt" 'a #:at #f) -Place] @@ -2557,17 +2563,13 @@ [y (in-list '("a" "b" "c"))] #:when (eq? x 'x)) (values x y)) - #:ret (ret (-HT -Symbol -String) - (-PS -tt -tt) - -empty-obj)] + #:ret (tc-ret (-HT -Symbol -String))] [tc-e (for*/hash: : (HashTable Symbol String) ([k (in-list '(x y z))] [v (in-list '("a" "b"))] #:when (eq? k 'x)) (values k v)) - #:ret (ret (-HT -Symbol -String) - (-PS -tt -tt) - -empty-obj)] + #:ret (tc-ret (-HT -Symbol -String))] ;; PR 13937 [tc-e (let () @@ -2602,16 +2604,16 @@ ;; call-with-input-string and friends - PR 14050 [tc-e (call-with-input-string "abcd" (lambda: ([input : Input-Port]) (values 'a 'b))) - #:ret (ret (list (-val 'a) (-val 'b)))] + #:ret (tc-ret (list (-val 'a) (-val 'b)))] [tc-e (call-with-input-bytes #"abcd" (lambda: ([input : Input-Port]) (values 'a 'b))) - #:ret (ret (list (-val 'a) (-val 'b)))] + #:ret (tc-ret (list (-val 'a) (-val 'b)))] [tc-e (lambda: ([x : (U (Parameter Symbol) Symbol)]) (if (parameter? x) (x) x)) - #:ret (ret (t:-> (t:Un (-Param -Symbol -Symbol) -Symbol) -Symbol)) - #:expected (ret (t:-> (t:Un (-Param -Symbol -Symbol) -Symbol) -Symbol))] + #:ret (tc-ret (t:-> (t:Un (-Param -Symbol -Symbol) -Symbol) -Symbol)) + #:expected (tc-ret (t:-> (t:Un (-Param -Symbol -Symbol) -Symbol) -Symbol))] ;; time-apply and similar functions (test improved inference) [tc-e (let () @@ -2620,7 +2622,7 @@ (f '(a b) "foo")) -String] [tc-e (time-apply (lambda: ([x : Symbol] [y : Symbol]) "foo") '(a b)) - #:ret (ret (list (-lst* -String) -Nat -Nat -Nat))] + #:ret (tc-ret (list (-lst* -String) -Nat -Nat -Nat))] ;; test kw function without type annotation [tc-e (let () (tr:define (f x #:y y) y) (f 'a #:y 'b)) Univ] @@ -2650,48 +2652,48 @@ [tc-e ((tr:lambda (x #:y y . args) y) 'a #:y 'b) Univ] [tc-e ((tr:lambda (x #:y [y 'y] . args) y) 'a #:y 'b) Univ] [tc-err (let () (tr:define (f x #:y y) (string-append x "foo")) (void)) - #:ret (ret -Void) + #:ret (tc-ret -Void) #:msg #rx"expected: String.*given: Any"] [tc-err (let () (tr:define (f x #:y y) y) (f "a")) - #:ret (ret Univ) + #:ret (tc-ret Univ) #:msg #rx"required keyword was not supplied"] ;; test lambdas with mixed type expressions, typed keywords, typed ;; optional arguments [tc-e (tr:lambda (x [y : String]) (string-append y "b")) - #:ret (ret (t:-> Univ -String -String) -true-propset)] + #:ret (tc-ret (t:-> Univ -String -String : -true-propset) -true-propset)] [tc-e (tr:lambda (x [y : String] . z) (string-append y "b")) - #:ret (ret (->* (list Univ -String) Univ -String) -true-propset)] + #:ret (tc-ret (->* (list Univ -String) Univ -String : -true-propset) -true-propset)] [tc-e (tr:lambda (x [y : String] . [z : String *]) (string-append y "b")) - #:ret (ret (->* (list Univ -String) -String -String) -true-propset)] + #:ret (tc-ret (->* (list Univ -String) -String -String : -true-propset) -true-propset)] [tc-e (tr:lambda (x [y : String]) : String (string-append y "b")) - #:ret (ret (t:-> Univ -String -String) -true-propset)] + #:ret (tc-ret (t:-> Univ -String -String : -true-propset) -true-propset)] [tc-e (tr:lambda (x z [y : String]) (string-append y "b")) - #:ret (ret (t:-> Univ Univ -String -String) -true-propset)] + #:ret (tc-ret (t:-> Univ Univ -String -String : -true-propset) -true-propset)] [tc-e (tr:lambda (x z [y : String] . w) (string-append y "b")) - #:ret (ret (->* (list Univ Univ -String) Univ -String) -true-propset)] + #:ret (tc-ret (->* (list Univ Univ -String) Univ -String : -true-propset) -true-propset)] [tc-e (tr:lambda (x z [y : String] . [w : String *]) (string-append y "b")) - #:ret (ret (->* (list Univ Univ -String) -String -String) -true-propset)] + #:ret (tc-ret (->* (list Univ Univ -String) -String -String : -true-propset) -true-propset)] [tc-e (tr:lambda (x z [y : String]) : String (string-append y "b")) - #:ret (ret (t:-> Univ Univ -String -String) -true-propset)] + #:ret (tc-ret (t:-> Univ Univ -String -String : -true-propset) -true-propset)] [tc-err (tr:lambda (x [y : String]) : Symbol (string-append y "b")) - #:ret (ret (t:-> Univ -String -Symbol) -true-propset) + #:ret (tc-ret (t:-> Univ -String -Symbol : -true-propset) -true-propset) #:msg "expected: Symbol.*given: String"] [tc-err (tr:lambda (x [y : String "a"] z) (string-append y "b")) #:msg "expected optional lambda argument"] [tc-e (tr:lambda (x [y : String "a"]) (string-append y "b")) - (->opt Univ [-String] -String)] + (->opt Univ [-String] (make-Values (list (make-Result -String -true-propset -empty-obj))))] [tc-e (tr:lambda (x [y : String "a"] . z) (string-append y "b")) - (->optkey Univ [-String] #:rest Univ -String)] + (->optkey Univ [-String] #:rest Univ (make-Values (list (make-Result -String -true-propset -empty-obj))))] [tc-e (tr:lambda (x [y : String "a"] . [z : String *]) (string-append y "b")) - (->optkey Univ [-String] #:rest -String -String)] + (->optkey Univ [-String] #:rest -String (make-Values (list (make-Result -String -true-propset -empty-obj))))] [tc-e (tr:lambda (x y [z : String "a"]) (string-append z "b")) - (->opt Univ Univ [-String] -String)] + (->opt Univ Univ [-String] (make-Values (list (make-Result -String -true-propset -empty-obj))))] [tc-e (tr:lambda (w x [y : String "y"] [z : String "z"]) (string-append y z)) - (->opt Univ Univ [-String -String] -String)] + (->opt Univ Univ [-String -String] (make-Values (list (make-Result -String -true-propset -empty-obj))))] [tc-e (tr:lambda (w [x : String] [y : String "y"] [z : String "z"]) (string-append x z)) - (->opt Univ -String [-String -String] -String)] + (->opt Univ -String [-String -String] (make-Values (list (make-Result -String -true-propset -empty-obj))))] [tc-e (tr:lambda (x #:y [y : String]) (string-append y "b")) (->key Univ #:y -String #t -String)] [tc-e (tr:lambda (x #:y [y : String] . z) (string-append y "b")) @@ -2737,14 +2739,14 @@ ;; get right in the expected result type and polymorphic types are ;; harder to test for equality. [tc-e ((inst (tr:lambda #:forall (A) (x [y : A]) y) String) 'a "foo") - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] [tc-e ((inst (tr:lambda #:∀ (A) (x [y : A]) y) String) 'a "foo") - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] [tc-e ((inst (tr:lambda #:forall (A ...) (x . [rst : A ... A]) rst) String) 'a "foo") (-lst* -String)] #| FIXME: does not work yet, TR thinks the type variable is unbound [tc-e (inst (tr:lambda #:forall (A) (x [y : A] [z : String "z"]) y) String) - #:ret (ret (->opt Univ -String [-String] -String) -true-propset)] + #:ret (tc-ret (->opt Univ -String [-String] -String) -true-propset)] |# ;; test `define` with mixed type annotations @@ -2773,9 +2775,9 @@ [tc-e (let ([y 'y] [x : String "foo"]) (string-append x "bar")) -String] [tc-e (let #:forall (A) ([x : A "foo"]) x) - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] [tc-e (let #:forall (A) ([y 'y] [x : A "foo"]) x) - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] [tc-e/t (let* ([x "foo"]) x) -String] [tc-e (let* ([x : String "foo"]) (string-append x "bar")) -String] @@ -2812,48 +2814,48 @@ (string-append x y)) -String] [tc-e (let loop ([x "x"]) x) - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] [tc-e (let loop ([x : String "x"]) x) - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] [tc-e (let/cc k "foo") -String] [tc-e (let/ec k "foo") -String] [tc-e (let/cc k : String (k "foo")) -String] [tc-e (let/ec k : String (k "foo")) -String] [tc-e (ann (do ([x : Integer 0 (add1 x)]) ((> x 10) x) (displayln x)) Integer) - #:ret (ret -Integer -tt-propset -empty-obj)] + #:ret (tc-ret -Integer)] [tc-e (do : Integer ([x : Integer 0 (add1 x)]) ((> x 10) x) (displayln x)) - #:ret (ret -Integer -tt-propset -empty-obj)] + #:ret (tc-ret -Integer)] [tc-e (tr:case-lambda [(x [y : String]) x]) - #:ret (ret (t:-> Univ -String Univ - : (-PS (-not-type (list 0 0) (-val #f)) - (-is-type (list 0 0) (-val #f))) - : (make-Path null (list 0 0))) + #:ret (tc-ret (t:-> Univ -String Univ + : (-PS (-not-type (cons 0 0) (-val #f)) + (-is-type (cons 0 0) (-val #f))) + : (make-Path null (cons 0 0))) -true-propset)] [tc-e (tr:case-lambda [(x [y : String] . rst) x]) - #:ret (ret (->* (list Univ -String) Univ Univ - : (-PS (-not-type (list 0 0) (-val #f)) - (-is-type (list 0 0) (-val #f))) - : (make-Path null (list 0 0))) + #:ret (tc-ret (->* (list Univ -String) Univ Univ + : (-PS (-not-type (cons 0 0) (-val #f)) + (-is-type (cons 0 0) (-val #f))) + : (make-Path null (cons 0 0))) -true-propset)] [tc-e (tr:case-lambda [(x [y : String] . [rst : String *]) x]) - #:ret (ret (->* (list Univ -String) -String Univ - : (-PS (-not-type (list 0 0) (-val #f)) - (-is-type (list 0 0) (-val #f))) - : (make-Path null (list 0 0))) + #:ret (tc-ret (->* (list Univ -String) -String Univ + : (-PS (-not-type (cons 0 0) (-val #f)) + (-is-type (cons 0 0) (-val #f))) + : (make-Path null (cons 0 0))) -true-propset)] [tc-e (tr:case-lambda #:forall (A) [([x : A]) x]) - #:ret (ret (-poly (A) + #:ret (tc-ret (-poly (A) (t:-> A A - : (-PS (-not-type (list 0 0) (-val #f)) - (-is-type (list 0 0) (-val #f))) - : (make-Path null (list 0 0)))) + : (-PS (-not-type (cons 0 0) (-val #f)) + (-is-type (cons 0 0) (-val #f))) + : (make-Path null (cons 0 0)))) -true-propset)] ;; PR 13651 and related [tc-e (tr:lambda #:forall (a ...) ([f : (-> String (values a ... a))]) (f "foo")) - #:ret (ret (-polydots (a) + #:ret (tc-ret (-polydots (a) (t:-> (t:-> -String (make-ValuesDots '() a 'a)) (make-ValuesDots '() a 'a))) -true-propset)] @@ -2861,7 +2863,7 @@ ((ann (lambda () (apply (inst values A B ... B) a b)) (-> (values A B ... B))))) String String Symbol) - #:ret (ret (t:-> -String -String -Symbol + #:ret (tc-ret (t:-> -String -String -Symbol (-values (list -String -String -Symbol))) -true-propset)] @@ -2959,7 +2961,7 @@ (let () (define-type-alias A (Listof B)) (define-type-alias B (Listof A)) "dummy") - #:ret (ret -String -true-propset)] + #:ret (tc-ret -String -true-propset)] [tc-e (let () (define-type-alias A (Listof B)) (define-type-alias B (U #f (Listof A))) (: a A) @@ -3009,47 +3011,47 @@ #:msg "type information"] ;; make sure no-binding cases like the middle expression are checked [tc-err (let () (define r "r") (string-append r 'foo) (define x "x") "y") - #:ret (ret -String -true-propset) + #:ret (tc-ret -String -true-propset) #:msg "expected: String.*given: 'foo"] ;; Polydotted types are not checking equality correctly [tc-err (ann (lambda () (let ([my-values values]) (my-values))) (All (A ...) (-> (Values Symbol ... A)))) - #:ret (ret (-polydots (A) (t:-> (-values-dots null -Symbol 'A))) -true-propset)] + #:ret (tc-ret (-polydots (A) (t:-> (-values-dots null -Symbol 'A))) -true-propset)] [tc-e (list 'x) - #:ret (ret (-Tuple (list -Symbol))) - #:expected (ret (-Tuple (list -Symbol)) #f #f)] + #:ret (tc-ret (-Tuple (list -Symbol))) + #:expected (tc-ret (-Tuple (list -Symbol)) #f #f)] [tc-e (list 'y) - #:ret (ret (-lst -Symbol)) - #:expected (ret (-lst -Symbol) #f #f)] + #:ret (tc-ret (-lst -Symbol)) + #:expected (tc-ret (-lst -Symbol) #f #f)] [tc-e (reverse (list 'x 'y)) - #:ret (ret (-Tuple (list (-val 'y) (-val 'x)))) - #:expected (ret (-Tuple (list (-val 'y) (-val 'x))) #f #f)] + #:ret (tc-ret (-Tuple (list (-val 'y) (-val 'x)))) + #:expected (tc-ret (-Tuple (list (-val 'y) (-val 'x))) #f #f)] [tc-err (vector 1 2) - #:ret (ret (make-HeterogeneousVector (list -Byte -Byte)) -false-propset -empty-obj) - #:expected (ret (make-HeterogeneousVector (list -Byte -Byte)) -false-propset #f)] + #:ret (tc-ret (make-HeterogeneousVector (list -Byte -Byte)) -false-propset -empty-obj) + #:expected (tc-ret (make-HeterogeneousVector (list -Byte -Byte)) -false-propset #f)] [tc-err (values 'x) - #:ret (ret (list -Symbol -Symbol)) - #:expected (ret (list -Symbol -Symbol) (list #f #f ) (list #f #f))] + #:ret (tc-ret (list -Symbol -Symbol)) + #:expected (tc-ret (list -Symbol -Symbol) (list #f #f ) (list #f #f))] [tc-err (values 'x 'y 'z) - #:ret (ret (list -Symbol -Symbol)) - #:expected (ret (list -Symbol -Symbol) (list #f #f ) (list #f #f))] + #:ret (tc-ret (list -Symbol -Symbol)) + #:expected (tc-ret (list -Symbol -Symbol) (list #f #f ) (list #f #f))] [tc-err (values 'y) - #:ret (ret (list -Symbol) (list -tt-propset) (list -empty-obj) Univ 'B) - #:expected (ret (list -Symbol) (list #f ) (list #f) Univ 'B)] + #:ret (tc-ret (list -Symbol) (list -true-propset) (list -empty-obj) Univ 'B) + #:expected (tc-ret (list -Symbol) (list #f ) (list #f) Univ 'B)] [tc-err (values (values 'x 'y)) - #:ret (ret (-val 'x)) - #:expected (ret (-val 'x) #f #f)] + #:ret (tc-ret (-val 'x)) + #:expected (tc-ret (-val 'x) #f #f)] [tc-err (if (random) (values 1 2) 3) - #:ret (ret (-val 3) -tt-propset) - #:expected (ret (-val 3) #f #f)] + #:ret (tc-ret (-val 3) -true-propset) + #:expected (tc-ret (-val 3) #f #f)] [tc-err (let* ([x 42] @@ -3058,7 +3060,7 @@ (if #t (add1 "") 0)) - #:ret (ret -Bottom)] + #:ret (tc-ret -Bottom)] [tc-e (let: ([x : Any 4]) @@ -3122,8 +3124,8 @@ (Number -> Number))) (define z (lambda (a) a)) (z "y")) - #:ret (ret -String -ff-propset) - #:expected (ret -String #f #f)] + #:ret (tc-ret -String -ff-propset) + #:expected (tc-ret -String -ff-propset)] [tc-err (let () @@ -3132,14 +3134,14 @@ (-> Symbol #:b Symbol Symbol))) (define z (lambda (a #:b b) a)) (z "y" #:b "y")) - #:ret (ret -String -ff-propset) - #:expected (ret -String #f #f)] + #:ret (tc-ret -String -ff-propset) + #:expected (tc-ret -String -ff-propset)] [tc-e/t (lambda (x) (unless (number? x) (error 'foo))) - (t:-> Univ -Void : (-PS (-is-type 0 -Number) (-is-type 0 -Number)))] + (t:-> Univ -Void : (-PS (-is-type 0 -Number) -ff))] [tc-e (let ([x : (U) (error 'fail)]) @@ -3149,12 +3151,12 @@ [tc-err (let ([f (lambda (x y) y)]) (f 1)) - #:ret (ret Univ -tt-propset)] + #:ret (tc-ret Univ)] [tc-err (let ([f (lambda (x y) y)]) (f 1 2 3)) - #:ret (ret -PosByte -true-propset)] + #:ret (tc-ret -PosByte)] [tc-err (case-lambda @@ -3162,107 +3164,107 @@ ((x . y) 'x) (w (first w))) #:ret - (ret (cl->* (->* (list -Symbol -Symbol) -Symbol -Symbol) + (tc-ret (cl->* (->* (list -Symbol -Symbol) -Symbol -Symbol) (->* (list) -String -String))) #:expected - (ret (cl->* (->* (list -Symbol -Symbol) -Symbol -Symbol) + (tc-ret (cl->* (->* (list -Symbol -Symbol) -Symbol -Symbol) (->* (list) -String -String)))] [tc-e (case-lambda [() 1] [args 2]) - #:ret (ret (t:-> (-val 1)) -true-propset) - #:expected (ret (t:-> (-val 1)) #f)] + #:ret (tc-ret (t:-> (-val 1)) -true-propset) + #:expected (tc-ret (t:-> (-val 1)) #f)] [tc-e (case-lambda [(x . y) 2] [args 1]) - #:ret (ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) -true-propset) - #:expected (ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) #f)] + #:ret (tc-ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) -true-propset) + #:expected (tc-ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) #f)] [tc-e (case-lambda [(x) 2] [args 1]) - #:ret (ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) -true-propset) - #:expected (ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) #f)] + #:ret (tc-ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) -true-propset) + #:expected (tc-ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 2))) #f)] [tc-err (case-lambda [(x . y) 1] [args 2]) - #:ret (ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 1))) -true-propset) - #:expected (ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 1))) #f)] + #:ret (tc-ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 1))) -true-propset) + #:expected (tc-ret (cl->* (t:-> (-val 1)) (t:-> Univ (-val 1))) #f)] ;; typecheck-fail should fail [tc-err (typecheck-fail #'stx "typecheck-fail") #:msg #rx"typecheck-fail"] [tc-err (string-append (typecheck-fail #'stx "typecheck-fail") "bar") - #:ret (ret -String) + #:ret (tc-ret -String) #:msg #rx"typecheck-fail"] [tc-e (let: ([f : (All (b ...) (Any ... b -> Any)) (lambda x 'x)]) (lambda xs (apply f xs))) - #:ret (ret (->* (list) Univ Univ)) - #:expected (ret (->* (list) Univ Univ))] + #:ret (tc-ret (->* (list) Univ Univ)) + #:expected (tc-ret (->* (list) Univ Univ))] [tc-e (let: ([f : (All (b ...) (Any ... b -> Any)) (lambda x 'x)]) (lambda xs (apply f (ann (cons 'y xs) (cons Symbol (Listof Any)))))) - #:ret (ret (->* (list) Univ Univ)) - #:expected (ret (->* (list) Univ Univ))] + #:ret (tc-ret (->* (list) Univ Univ)) + #:expected (tc-ret (->* (list) Univ Univ))] [tc-e (let: ([f : (All (b ...) (Any ... b -> Any)) (lambda x 'x)]) (lambda xs (apply f 'y xs))) - #:ret (ret (->* (list) Univ Univ)) - #:expected (ret (->* (list) Univ Univ))] + #:ret (tc-ret (->* (list) Univ Univ)) + #:expected (tc-ret (->* (list) Univ Univ))] [tc-err (let: ([f : (case->) (case-lambda)]) (apply f empty)) - #:ret (ret -Bottom) + #:ret (tc-ret -Bottom) #:msg #rx"has no cases"] [tc-err (let: ([f : (All (A) (case->)) (case-lambda)]) (apply f empty)) - #:ret (ret -Bottom) + #:ret (tc-ret -Bottom) #:msg #rx"has no cases"] [tc-err (let: ([f : (All (A ...) (case->)) (case-lambda)]) (apply f empty)) - #:ret (ret -Bottom) + #:ret (tc-ret -Bottom) #:msg #rx"has no cases"] [tc-err (let: ([f : (case->) (case-lambda)]) (apply f empty)) - #:ret (ret -Bottom) + #:ret (tc-ret -Bottom) #:msg #rx"has no cases"] [tc-err (let: ([f : (All (A) (case->)) (case-lambda)]) (apply f empty)) - #:ret (ret -Bottom) + #:ret (tc-ret -Bottom) #:msg #rx"has no cases"] [tc-err (let: ([f : (All (A ...) (case->)) (case-lambda)]) (apply f empty)) - #:ret (ret -Bottom) + #:ret (tc-ret -Bottom) #:msg #rx"has no cases"] [tc-e/t (let: ([f : (All (a) (a a * -> Void)) (λ _ (void))]) (plambda: (A B ...) ([xs : (List Any A ... B)]) (apply f xs))) - (-polydots (a b) (t:-> (-pair Univ (make-ListDots a 'b)) -Void))] + (-polydots (a b) (t:-> (-pair Univ (make-ListDots a 'b)) -Void : -true-propset))] [tc-e/t (let: ([f : (All (a) (a a * -> Void)) (λ _ (void))]) (plambda: (A B ...) ([xs : (List A ... B)]) (apply f (first xs) xs))) - (-polydots (a b) (t:-> (make-ListDots a 'b) -Void))] + (-polydots (a b) (t:-> (make-ListDots a 'b) -Void : -true-propset))] [tc-e/t (let () @@ -3287,7 +3289,7 @@ (* x x)) 'x) -Symbol - #:expected (ret -Symbol)] + #:expected (tc-ret -Symbol)] [tc-e (ann (for/list ([z #"foobar"]) (add1 z)) (Listof Integer)) @@ -3296,33 +3298,33 @@ [tc-e (lambda (a . b) (apply values a b)) - #:ret (ret (-polydots (A B ...) (->... (list A) (B B) (-values-dots (list A) B 'B)))) - #:expected (ret (-polydots (A B ...) (->... (list A) (B B) (-values-dots (list A) B 'B)))) + #:ret (tc-ret (-polydots (A B ...) (->... (list A) (B B) (-values-dots (list A) B 'B)))) + #:expected (tc-ret (-polydots (A B ...) (->... (list A) (B B) (-values-dots (list A) B 'B)))) ] [tc-e (tr:lambda (x #:y [y 3]) x) - #:ret (ret (->key Univ #:y Univ #f Univ) -true-propset) - #:expected (ret (->key Univ #:y Univ #f Univ) #f)] + #:ret (tc-ret (->key Univ #:y Univ #f Univ) -true-propset) + #:expected (tc-ret (->key Univ #:y Univ #f Univ) #f)] [tc-err (lambda xs (plambda: (b) ([x : Any]) 3)) - #:ret (ret (-polydots (a) (->... (list) (a a) (-values-dots (list) a 'a)))) - #:expected (ret (-polydots (a) (->... (list) (a a) (-values-dots (list) a 'a))))] + #:ret (tc-ret (-polydots (a) (->... (list) (a a) (-values-dots (list) a 'a)))) + #:expected (tc-ret (-polydots (a) (->... (list) (a a) (-values-dots (list) a 'a))))] [tc-e (tr:lambda xs (tr:lambda (x) (apply values (map (tr:lambda (z) (tr:lambda (y) (symbol? x))) xs)))) #:ret - (ret (-polydots (a ...) + (tc-ret (-polydots (a ...) (->... (list) (a a) (-values (list (t:-> Univ (-values-dots (list) (t:-> Univ -Boolean - : (-PS (-is-type (list 1 0) -Symbol) -tt)) 'a))))))) + : (-PS (-is-type (cons 1 0) -Symbol) -tt)) 'a))))))) #:expected - (ret (-polydots (a ...) + (tc-ret (-polydots (a ...) (->... (list) (a a) (-values @@ -3330,38 +3332,38 @@ (t:-> Univ (-values-dots (list) - (t:-> Univ -Boolean : (-PS (-is-type (list 1 0) -Symbol) -tt)) 'a)))))))] + (t:-> Univ -Boolean : (-PS (-is-type (cons 1 0) -Symbol) -tt)) 'a)))))))] [tc-err (inst (eval '3) Any) - #:ret (ret -Bottom)] + #:ret (tc-ret -Bottom)] [tc-err (lambda xs (inst (apply values (plambda: (b) ([x : b]) x) xs) Symbol)) - #:ret (ret (-polydots (a ...) (->... (list) (a a) + #:ret (tc-ret (-polydots (a ...) (->... (list) (a a) (-values-dots (list (t:-> -Symbol -Symbol)) a 'a)))) - #:expected (ret (-polydots (a ...) + #:expected (tc-ret (-polydots (a ...) (->... (list) (a a) (-values-dots (list (t:-> -Symbol -Symbol)) a 'a))))] [tc-err (lambda xs (andmap (lambda: ([x : (Vectorof Any)]) x) xs)) - #:ret (ret (-polydots (a ...) (->... (list) ((-vec a) a) (t:Un (-val #f) (-vec Univ))))) - #:expected (ret (-polydots (a ...) (->... (list) ((-vec a) a) + #:ret (tc-ret (-polydots (a ...) (->... (list) ((-vec a) a) (t:Un (-val #f) (-vec Univ))))) + #:expected (tc-ret (-polydots (a ...) (->... (list) ((-vec a) a) (t:Un (-val #f) (-vec Univ)))))] [tc-err (lambda xs (andmap (lambda: ([x : #f]) x) xs)) - #:ret (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f)))) - #:expected (ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f))))] + #:ret (tc-ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f)))) + #:expected (tc-ret (-polydots (a ...) (->... (list) ((-val #f) a) (-val #f))))] [tc-e ((letrec ([lp (lambda (x) lp)]) lp) 'y) - #:ret (ret (t:-> -Symbol Univ) -true-propset) - #:expected (ret (t:-> -Symbol Univ) #f #f)] + #:ret (tc-ret (t:-> -Symbol Univ) -true-propset) + #:expected (tc-ret (t:-> -Symbol Univ) #f #f)] [tc-e (list (vector 1 2 3)) - #:ret (ret (-seq (-vec Univ))) - #:expected (ret (-seq (-vec Univ)))] + #:ret (tc-ret (-seq (-vec Univ))) + #:expected (tc-ret (-seq (-vec Univ)))] ;; PR 14557 - apply union of functions with different return values [tc-err @@ -3375,11 +3377,11 @@ (: f (U (-> (values String Symbol)) (-> (values Void Void)))) (define (f) (values "foo" 'bar)) (f)) - #:ret (ret (list (t:Un -String -Void) (t:Un -Symbol -Void)))] + #:ret (tc-ret (list (t:Un -String -Void) (t:Un -Symbol -Void)))] [tc-e (syntax->datum #`(#,(lambda (x) x))) - #:ret (ret Univ)] + #:ret (tc-ret Univ)] [tc-e (stx->list #'(a . b)) - #:ret (ret (t:Un (-lst (-Syntax Univ)) (-val #f)))] + #:ret (tc-ret (t:Un (-lst (-Syntax Univ)) (-val #f)))] [tc-e/t (lambda (x) @@ -3390,8 +3392,8 @@ (g x) x) (t:-> Univ -String - : (-PS (-and (-is-type '(0 0) -String) (-not-type '(0 0) (-val #f))) -ff) - : (make-Path null '(0 0)))] + : (-PS (-and (-is-type '(0 . 0) -String) (-not-type '(0 . 0) (-val #f))) -ff) + : (make-Path null '(0 . 0)))] ;; PR 14576 [tc-e @@ -3411,15 +3413,15 @@ (let: ([foo : (All (b ...) ((List (List b ... b) ... b) -> (List (List b ... b) ... b))) (lambda (x) x)]) (foo (list (list)))) - #:ret (ret -Bottom)] + #:ret (tc-ret -Bottom)] ;; PR 14580 [tc-err (let: ([foo : (All (b ...) ((List (List b ... b) ... b) -> (List (List b ... b) ... b))) (lambda (x) x)]) (foo (list (list "string" 'symbol)))) - #:ret (ret (-lst* (-lst* -String))) - #:expected (ret (-lst* (-lst* -String)))] + #:ret (tc-ret (-lst* (-lst* -String))) + #:expected (tc-ret (-lst* (-lst* -String)))] ;; PR 13898 [tc-err @@ -3475,7 +3477,7 @@ (: y String) (define y (for/fold: ((x : String null)) ((v : String null)) x)) y) - #:ret (ret -String -true-propset) + #:ret (tc-ret -String -true-propset) #:msg #rx"expected: String.*given: (Null|'\\(\\))"] ;; PR 14493 @@ -3502,13 +3504,13 @@ [tc-e (with-handlers ([exn:fail? (λ (exn) 4)]) 5) - #:ret (ret -Nat -true-propset) - #:expected (ret -Nat #f)] + #:ret (tc-ret -Nat -true-propset) + #:expected (tc-ret -Nat #f)] [tc-e (with-handlers ([exn:fail? (λ (exn) #f)]) 5) - #:ret (ret Univ -tt-propset) - #:expected (ret Univ #f)] + #:ret (tc-ret Univ) + #:expected (tc-ret Univ #f)] [tc-e (with-handlers ([void (λ: ([x : Any]) #t)]) #f) -Boolean] @@ -3523,13 +3525,13 @@ [tc-err (with-handlers ([string? (lambda (e) (string-append e "bar"))]) (raise "foo")) - #:ret (ret -String) + #:ret (tc-ret -String) #:msg #rx"expected: String.*given: Any"] [tc-e (with-handlers ([string? (lambda: ([e : String]) (string-append e "bar"))] [symbol? (lambda (x) (symbol->string x))]) (raise 'foo)) - #:ret (ret -String)] + #:ret (tc-ret -String)] [tc-err (raise (λ ([x : Number]) (add1 x)))] @@ -3702,7 +3704,7 @@ (t:-> -RealZero (t:Un (-val #t) -InexactRealNan) : -true-propset)] [tc-e/t (lambda: ([x : Positive-Integer]) (zero? x)) - (t:-> -PosInt -Boolean : -false-propset)] + (t:-> -PosInt -False : -false-propset)] [tc-e/t (lambda: ([x : Natural]) (zero? x)) (t:-> -Nat -Boolean : (-PS (-is-type 0 (-val 0)) (-not-type 0 (-val 0))))] @@ -3716,9 +3718,9 @@ (t:-> -Fixnum -Boolean : (-PS (-is-type 0 -NegFixnum) (-is-type 0 -NonNegFixnum)))] [tc-e (< (ann 0 Integer) +inf.0) - #:ret (ret -Boolean -true-propset)] + #:ret (tc-ret -Boolean -true-propset)] [tc-e (> -inf.0 (ann 0 Exact-Rational)) - #:ret (ret -Boolean -false-propset)] + #:ret (tc-ret -Boolean -false-propset)] [tc-e/t (lambda: ([x : Flonum]) (and (<= +inf.f x) x)) (t:-> -Flonum (t:Un (-val #f) (-val +inf.0)) : (-PS (-is-type 0 (-val +inf.0)) (-not-type 0 (-val +inf.0))))] @@ -3744,11 +3746,11 @@ [tc-e/t (lambda: ([x : One]) (let ([f (plambda: (a ...) [w : a ... a] w)]) (f x "hello" #\c))) - (t:-> -One (-lst* -One -String -Char))] + (t:-> -One (-lst* -One -String -Char) : -true-propset)] [tc-e/t (lambda: ([x : Positive-Integer]) (< x 1)) - (t:-> -PosInt -Boolean : -false-propset)] + (t:-> -PosInt -False : -false-propset)] [tc-e/t (lambda: ([x : Integer]) (>= x 1)) (t:-> -Integer -Boolean : (-PS (-is-type 0 -PosInt) (-is-type 0 -NonPosInt)))] @@ -3757,7 +3759,7 @@ (t:-> -NonNegFlonum -Boolean : (-PS (-is-type 0 -FlonumZero) (-is-type 0 -PosFlonum)))] [tc-e/t (lambda: ([x : Byte]) (if (< 0 x) x 1)) - (t:-> -Byte -PosByte : (-PS (-is-type (list 0 0) -Byte) -ff))] + (t:-> -Byte -PosByte : (-PS (-is-type (cons 0 0) -Byte) -ff))] [tc-e/t ((inst values Any) "a") -String] [tc-e ((inst second Any Any Any) (list "a" "b")) -String] @@ -3878,8 +3880,8 @@ ;; Need an `ann` here because TR doesn't typecheck the literal ".." ;; with a precise enough type to satisfy Module-Path [tc-e (ann `(submod ".." bar ,(ann ".." "..")) Module-Path) - #:ret (ret -Module-Path) - #:expected (ret -Module-Path)] + #:ret (tc-ret -Module-Path) + #:expected (tc-ret -Module-Path)] [tc-e/t (ann '(lib "foo") Module-Path) -Module-Path] [tc-err (begin (ann '(submod ".." bar ".") Module-Path) (error "foo"))] @@ -3891,7 +3893,7 @@ ;; PR 15138 [tc-e (for*/lists: ((xs : (Listof Symbol))) ((x '(a b c))) x) - #:ret (ret (-lst -Symbol) (-PS -tt -ff) -empty-obj)] + #:ret (tc-ret (-lst -Symbol) (-PS -tt -ff) -empty-obj)] [tc-e (for*/fold: ((xs : (Listof Symbol) '())) ((x '(a b c))) (cons x xs)) (-lst -Symbol)]