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

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]

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]

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))]

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)])

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 StructTypeTop () [#:fold-rhs #:base] [#:key 'struct-type])
-(def-type StructType ([s Struct?]) [#: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])

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")]

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)]