From 34aaa9d68dd25b5f75ab5aa4a8d1bb71863748e4 Mon Sep 17 00:00:00 2001
From: Fred Fu <moonsolo@gmail.com>
Date: Wed, 24 Feb 2021 17:26:12 -0500
Subject: [PATCH] fix subtyping between struct descriptor types &
 has-struct-property

a struct descriptor associcated with a property name should be a valid argument
to its property accessor
---
 typed-racket-lib/typed-racket/types/subtype.rkt   | 15 +++++++++------
 typed-racket-test/succeed/structs-has-subtype.rkt | 13 ++++++-------
 2 files changed, 15 insertions(+), 13 deletions(-)

diff --git a/typed-racket-lib/typed-racket/types/subtype.rkt b/typed-racket-lib/typed-racket/types/subtype.rkt
index 2db23cc63..422d83bc9 100644
--- a/typed-racket-lib/typed-racket/types/subtype.rkt
+++ b/typed-racket-lib/typed-racket/types/subtype.rkt
@@ -590,6 +590,8 @@
    (cons portable-fixnum? -NonNegFixnum)
    (cons values -Nat)))
 
+(define (valid-prop-name? name properties)
+  (and (free-id-set-member? properties name) (Struct-Property? (lookup-id-type/lexical name))))
 
 (define-rep-switch (subtype-cases A (#:switch t1) t2 obj)
   ;; NOTE: keep these in alphabetical order
@@ -1201,12 +1203,8 @@
      [(StructTop: (Struct: nm2 _ _ _ _ _ _))
       #:when (free-identifier=? nm1 nm2)
       A]
-     [(Has-Struct-Property: prop-name)
-      (cond
-        [(free-id-set-member? properties prop-name)
-         (match (lookup-id-type/lexical prop-name)
-           [(? Struct-Property?) A])]
-        [else #f])]
+     [(Has-Struct-Property: prop-name) #:when (valid-prop-name? prop-name properties)
+      A]
      [(Val-able: (? (negate struct?) _)) #f]
      ;; subtyping on structs follows the declared hierarchy
      [_ (cond
@@ -1223,6 +1221,11 @@
   [(case: StructType (StructType: t1*))
    (match t2
      [(StructTypeTop:) A]
+     [(Has-Struct-Property: prop-name)
+      (match t1*
+        [(Struct: _ _ _ _ _ _ properties) #:when (valid-prop-name? prop-name properties)
+         A]
+        [else #f])]
      [_ (continue<: A t1 t2 obj)])]
   [(case: Syntax (Syntax: elem1))
    (match t2
diff --git a/typed-racket-test/succeed/structs-has-subtype.rkt b/typed-racket-test/succeed/structs-has-subtype.rkt
index 280877df6..c2ee3719c 100644
--- a/typed-racket-test/succeed/structs-has-subtype.rkt
+++ b/typed-racket-test/succeed/structs-has-subtype.rkt
@@ -6,17 +6,16 @@
 (: prop-ins-to-num-ref (Some (X) (-> (Has-Struct-Property prop-ins-to-num) (-> X Number) : X) ))
 (define-values (prop-ins-to-num prop-ins-to-num? prop-ins-to-num-ref) (make-struct-type-property 'prop-ins-to-num))
 
-;; (: bar? : Any -> Boolean : (Has-Struct-Property prop-ins-to-num))
-;; (define bar? prop-ins-to-num?)
 
-
-; (struct (X Y) helloworld ([x : Y] [y : Y]) #:property prop-ins-to-num (cons 20 40))
-
-(struct posn ([x : Integer] [y : Integer])  #:property prop-ins-to-num (λ ([self : posn])
-                                                                         20))
+(struct posn ([x : Integer] [y : Integer])
+  #:property prop-ins-to-num
+  (λ ([self : posn])
+    20))
 
 (: p1 posn)
 (define p1 (posn 100 200))
 (posn-x p1)
+
+(prop-ins-to-num-ref struct:posn)
 (: val Number)
 (define val ((prop-ins-to-num-ref p1) p1))