From 32c78065a58633de2b884bb8d81b81ea86066aa8 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 14 Mar 2014 13:18:59 -0400
Subject: [PATCH] Fix class typechecking for Name types

Fixed check-class-unit and get-field for the addition
of recursive Name types.
---
 .../typecheck/check-class-unit.rkt            | 15 +++++---
 .../typecheck/tc-app/tc-app-objects.rkt       | 36 +++++++++++--------
 .../typed-racket/unit-tests/class-tests.rkt   | 15 +++++++-
 3 files changed, 46 insertions(+), 20 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
index fab63ad4de..fb8dff0c6d 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
@@ -211,11 +211,16 @@
 ;;  we know by this point that #'form is an actual typed
 ;;  class produced by `class` due to the syntax property
 (define (check-class form [expected #f])
-  (match (and expected (resolve expected))
-    [(tc-result1: (and self-class-type (Class: _ _ _ _ _ _)))
-     (ret (parse-and-check form self-class-type))]
-    [(tc-result1: (Poly-names: ns body-type))
-     ;; FIXME: this case probably isn't quite right
+  (define expected-type
+    (match expected
+      [(tc-result1: type) (resolve type)]
+      [_ #f]))
+  (match expected-type
+    [(? Class? class-type)
+     (ret (parse-and-check form class-type))]
+    [(Poly-names: ns body-type)
+     ;; FIXME: make sure this case is correct, does it
+     ;; introduce the right names in scope?
      (check-class form (ret body-type))]
     [#f (ret (parse-and-check form #f))]
     [_ (check-below (ret (parse-and-check form #f)) expected)]))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
index 389942fde5..2a6e009f8a 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-objects.rkt
@@ -110,22 +110,30 @@
 (define (check-get-field meth obj)
   (define maybe-meth-sym
     (syntax-parse meth [(quote m:id) (syntax-e #'m)] [_ #f]))
-  (define obj-type (tc-expr obj))
+  (define obj-type (tc-expr/t obj))
   (unless maybe-meth-sym
     (tc-error/expr #:return (ret (Un))
                    "expected a symbolic method name, but got ~a" meth))
-  (match obj-type
-    ;; FIXME: handle unions and mu?
-    [(tc-result1: (and ty (Instance: (Class: _ _ (list fields ...) _ _ _))))
-     (cond [(assq maybe-meth-sym fields) =>
-            (λ (field-entry) (ret (cadr field-entry)))]
-           [else
-            (tc-error/expr #:return (ret (Un))
-                           "expected an object with field ~a, but got ~a"
-                           maybe-meth-sym ty)])]
-    [(tc-result1: t)
-     (tc-error/expr #:return (ret (Un))
-                    "expected an object value for get-field, got ~a" t)]))
+  (define (check obj-type)
+    (match (resolve obj-type)
+      ;; FIXME: handle unions and mu?
+      [(and ty (Instance: (Class: _ _ (list fields ...) _ _ _)))
+       (cond [(assq maybe-meth-sym fields) =>
+              (λ (field-entry) (ret (cadr field-entry)))]
+             [else
+              (tc-error/expr/fields "type mismatch"
+                                    #:return (ret (Un))
+                                    #:more "the object is missing an expected field"
+                                    "field" maybe-meth-sym
+                                    "object type" ty)])]
+      [(Instance: (? needs-resolving? type))
+       (check (make-Instance (resolve type)))]
+      [type
+       (tc-error/expr/fields "type mismatch"
+                             #:more "expected an object value for get-field"
+                             #:return (ret (Un))
+                             "given" type)]))
+  (check obj-type))
 
 ;; check-set-field : Syntax Syntax Syntax -> TCResult
 ;; type-check the `set-field!` operation on objects
@@ -156,7 +164,7 @@
                                                maybe-field-sym)
                                     #:return (ret (Un))
                                     "given" ty)])]
-      [(Instance: type)
+      [(Instance: (? needs-resolving? type))
        (check (make-Instance (resolve type)))]
       [type
        (tc-error/expr/fields "type mismatch"
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
index 68e34b4747..6b50c7abc3 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
@@ -132,7 +132,7 @@
                           (super-new)
                           (define/public (m) (get-field n this))))
              (void))
-           #:msg #rx"expected an object with field n"]
+           #:msg #rx"missing an expected field.*field: n"]
    ;; Fail, conflict with parent field
    [tc-err (let ()
              (: j% (Class (field [n Integer])
@@ -1278,4 +1278,17 @@
              (define/public (m . xs) (apply + xs)))
            (void))
          -Void]
+   ;; test that Name types are ok with get-field and as an
+   ;; expected type for class type-checking
+   [tc-e (let ()
+           (define-type-alias Foo%
+             (Class (init-field [x String])
+                                [m (-> (Instance Foo%) String)]))
+           (: foo% Foo%)
+           (define foo%
+             (class object% (super-new)
+               (init-field x)
+               (define/public (m a-foo) (get-field x a-foo))))
+           (void))
+         -Void]
    ))