From ae80c216c3438c7bb208788ab99ed890263a80e5 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Sat, 28 Dec 2013 20:38:38 -0500 Subject: [PATCH] Refine handling of types for struct-types - Added a top type for struct-types - Print struct-type types consistently - Add support for parsing struct-types - Allow polymorphism within a Struct-Type --- .../typed-racket/base-env/base-types-extra.rkt | 2 +- .../typed-racket/base-env/base-types.rkt | 1 + .../typed-racket-lib/typed-racket/infer/infer-unit.rkt | 5 +++++ .../typed-racket-lib/typed-racket/private/parse-type.rkt | 9 ++++++++- .../typed-racket-lib/typed-racket/rep/type-rep.rkt | 4 ++-- .../typed-racket-lib/typed-racket/types/printer.rkt | 5 ++++- .../typed-racket-lib/typed-racket/types/subtype.rkt | 2 ++ 7 files changed, 23 insertions(+), 5 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt index 06f4b32f97..de3455c51f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt @@ -17,7 +17,7 @@ (define-other-types -> case-> U Rec All Opaque Vector Parameterof List List* Class Values Instance Refinement - pred Struct) + pred Struct Struct-Type) (provide (rename-out [All ∀] [U Un] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt index 3e0b7e3273..17c6a9be7a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types.rkt @@ -113,6 +113,7 @@ [Thread-CellTop -Thread-CellTop] [Prompt-TagTop -Prompt-TagTop] [Continuation-Mark-KeyTop -Continuation-Mark-KeyTop] +[Struct-TypeTop (make-StructTypeTop)] [Keyword -Keyword] [Thread -Thread] [Resolved-Module-Path -Resolved-Module-Path] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt index f0ba6c3362..9d5d367d7b 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt @@ -583,6 +583,11 @@ [((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)) + (cset-meet (cg s t) (cg t s))] + ;; vectors are invariant - generate constraints *both* ways [((Vector: e) (Vector: e*)) (cset-meet (cg e e*) (cg e* e))] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt index 79f944fc7a..81e5192c30 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt @@ -180,7 +180,7 @@ (syntax-parse stx #:literals (t:Class t:Refinement t:Instance t:List t:List* cons t:pred t:-> : case-lambda t:case-> - t:Rec t:U t:All t:Opaque t:Parameter t:Vector quote t:Struct) + t:Rec t:U t:All t:Opaque t:Parameter t:Vector quote t:Struct t:Struct-Type) [t #:declare t (3d Type/c?) (attribute t.datum)] @@ -214,6 +214,13 @@ [(and s (? Struct?)) (make-StructTop s)] [_ (tc-error/delayed "Argument to Struct must be a structure type, got ~a" v) (Un)]))] + [((~and kw t:Struct-Type) t) + (add-disappeared-use #'kw) + (define v (parse-type #'t)) + (match (resolve v) + [(? Struct? s) (make-StructType s)] + [_ (tc-error/delayed "Argument to Struct-Type must be a structure type, got ~a" v) + (Un)])] [((~and kw t:Instance) t) (add-disappeared-use #'kw) (let ([v (parse-type #'t)]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt index ab0047cfc8..eff203634c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/rep/type-rep.rkt @@ -360,8 +360,8 @@ [#:key '(struct procedure)]) ;; A structure type descriptor -;; s : struct -(def-type StructType ([s Struct?]) [#:key 'struct-type]) +(def-type StructTypeTop () [#:fold-rhs #:base] [#:key 'struct-type]) +(def-type StructType ([s (or/c F? B? Struct?)]) [#:key 'struct-type]) ;; the supertype of all of these values (def-type BoxTop () [#:fold-rhs #:base] [#:key 'box]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt index 1158d4e73b..4c6e8940b9 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/printer.rkt @@ -273,7 +273,10 @@ (set-box! (current-print-unexpanded) (cons (car names) (unbox (current-print-unexpanded))))) (fp "~a" (car names))])] - [(StructType: (Struct: nm _ _ _ _ _)) (fp "(StructType ~a)" (syntax-e nm))] + [(StructType: (Struct: nm _ _ _ _ _)) (fp "(Struct-Type ~a)" (syntax-e nm))] + ;; this case occurs if the contained type is a type variable + [(StructType: ty) (fp "(Struct-Type ~a)" ty)] + [(StructTypeTop:) (fp "Struct-TypeTop")] [(StructTop: (Struct: nm _ _ _ _ _)) (fp "(Struct ~a)" (syntax-e nm))] [(BoxTop:) (fp "BoxTop")] [(ChannelTop:) (fp "ChannelTop")] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt index f90c2300ef..73e3b1f399 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/subtype.rkt @@ -460,6 +460,8 @@ [((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)]