diff --git a/collects/typed-racket/infer/infer-unit.rkt b/collects/typed-racket/infer/infer-unit.rkt index a05f16c6..c3b5015f 100644 --- a/collects/typed-racket/infer/infer-unit.rkt +++ b/collects/typed-racket/infer/infer-unit.rkt @@ -529,6 +529,8 @@ (cset-meet (cg e e*) (cg e* e))] [((ThreadCell: e) (ThreadCell: e*)) (cset-meet (cg e e*) (cg e* e))] + [((Promise: e) (Promise: e*)) + (cg e e*)] [((Ephemeron: e) (Ephemeron: e*)) (cg e e*)] [((CustodianBox: e) (CustodianBox: e*)) diff --git a/collects/typed-racket/rep/type-rep.rkt b/collects/typed-racket/rep/type-rep.rkt index 68cdebde..167eed7a 100644 --- a/collects/typed-racket/rep/type-rep.rkt +++ b/collects/typed-racket/rep/type-rep.rkt @@ -139,6 +139,9 @@ [#: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]) diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index 81958c00..92a5c60a 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -43,6 +43,7 @@ (define -box make-Box) (define -channel make-Channel) (define -thread-cell make-ThreadCell) +(define -Promise make-Promise) (define -set make-Set) (define -vec make-Vector) (define -future make-Future) diff --git a/collects/typed-racket/types/base-abbrev.rkt b/collects/typed-racket/types/base-abbrev.rkt index 15993e7b..fc25dc94 100644 --- a/collects/typed-racket/types/base-abbrev.rkt +++ b/collects/typed-racket/types/base-abbrev.rkt @@ -9,7 +9,7 @@ (for-template racket/base) (for-syntax racket/base syntax/parse racket/list)) -(provide (except-out (all-defined-out) Promise)) +(provide (all-defined-out)) ;Top and error types (define Univ (make-Univ)) @@ -22,13 +22,6 @@ (define ManyUniv Univ) -; Promise type -; TODO make this not a struct type, but the same as all other container types -(define Promise #f) -(define promise-id #'Promise) -(define -Promise - (lambda (t) - (make-Struct promise-id #f (list (make-fld t #'values #f)) #f #f #'promise? values #'values))) ;; Char type (needed because of how sequences are checked in subtype) diff --git a/collects/typed-racket/types/printer.rkt b/collects/typed-racket/types/printer.rkt index 2f914c74..fa293e8e 100644 --- a/collects/typed-racket/types/printer.rkt +++ b/collects/typed-racket/types/printer.rkt @@ -3,7 +3,7 @@ (require racket/require racket/match unstable/sequence racket/string racket/promise (prefix-in s: srfi/1) (path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt" - "rep/rep-utils.rkt" "types/abbrev.rkt" "types/subtype.rkt" + "rep/rep-utils.rkt" "types/subtype.rkt" "utils/utils.rkt" "utils/tc-utils.rkt") (for-syntax racket/base syntax/parse)) @@ -22,7 +22,6 @@ (provide print-multi-line-case-> special-dots-printing? print-complex-filters?) -;;TODO try to remove requirement on abbrev once promise is fixed ;; do we attempt to find instantiations of polymorphic types to print? ;; FIXME - currently broken @@ -238,9 +237,6 @@ (fp "~a" (cons 'List (tuple-elems t)))] [(Base: n cnt _ _ _) (fp "~s" n)] [(Opaque: pred _) (fp "(Opaque ~a)" (syntax->datum pred))] - [(Struct: (? (lambda (nm) (free-identifier=? promise-id nm))) - #f (list (fld: t _ _)) _ _ _ _ _) - (fp "(Promise ~a)" t)] [(Struct: nm par (list (fld: t _ _) ...) proc _ _ _ _) (fp "#(struct:~a ~a" nm t) (when proc @@ -257,6 +253,7 @@ [(Future: e) (fp "(Futureof ~a)" e)] [(Channel: e) (fp "(Channelof ~a)" e)] [(ThreadCell: e) (fp "(ThreadCellof ~a)" e)] + [(Promise: e) (fp "(Promise ~a)" e)] [(Ephemeron: e) (fp "(Ephemeronof ~a)" e)] [(CustodianBox: e) (fp "(CustodianBoxof ~a)" e)] [(Set: e) (fp "(Setof ~a)" e)] diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt index ae2b9ca0..9fbd3ffe 100644 --- a/collects/typed-racket/types/subtype.rkt +++ b/collects/typed-racket/types/subtype.rkt @@ -413,6 +413,9 @@ [((Struct: nm _ _ _ _ _ _ _) (StructTop: (Struct: nm* _ _ _ _ _ _ _))) (=> nevermind) (unless (free-identifier=? nm nm*) (nevermind)) A0] + ;; Promises are covariant + [((Promise: s) (Promise: t)) + (subtype* A0 s t)] ;ephemerons are covariant [((Ephemeron: s) (Ephemeron: t)) (subtype* A0 s t)] @@ -432,10 +435,6 @@ [((Struct: nm (? Type? parent) flds proc _ _ _ _) other) ;(dprintf "subtype - hierarchy : ~a ~a ~a\n" nm parent other) (subtype* A0 parent other)] - ;; Promises are covariant - [((Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t) _ _ _ _ _) - (Struct: (? (lambda (n) (free-identifier=? n promise-id))) _ (list t*) _ _ _ _ _)) - (subtype* A0 t t*)] ;; subtyping on values is pointwise [((Values: vals1) (Values: vals2)) (subtypes* A0 vals1 vals2)] ;; trivial case for Result