From 2b3e3d11d53def296d837704ed226fa6e960bb6f Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 18 Apr 2014 23:35:23 -0400
Subject: [PATCH] Improve code for checking init args for TR classes

original commit: b2f9bf6e9eed9c1e71923225adb5340046c725b4
---
 .../typecheck/check-class-unit.rkt            | 60 +++++++++----------
 .../typed-racket/unit-tests/class-tests.rkt   |  5 +-
 2 files changed, 30 insertions(+), 35 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 a1055dfa..0937e7ed 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
@@ -11,6 +11,7 @@
          racket/syntax
          syntax/id-table
          syntax/parse
+         syntax/stx
          "signatures.rkt"
          (private parse-type syntax-properties type-annotation)
          (base-env class-prims)
@@ -928,27 +929,9 @@
                             init-args:id
                             init-val:expr)))
        (define init-name (syntax-e #'init-external))
-       (define init-type (car (dict-ref inits init-name '(#f))))
-       (cond [init-type
-              ;; Catch the exception because the error that is produced
-              ;; in the case of a type error is incomprehensible for a
-              ;; programmer looking at surface syntax. Raise a custom
-              ;; type error instead.
-              (with-handlers
-                  ([exn:fail:syntax?
-                    (λ (e) (tc-error/delayed "Default init value has wrong type"))])
-                (parameterize ([delay-errors? #f])
-                  (unless (equal? (syntax->datum #'init-val) '(quote #f))
-                    (tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
-             ;; If the type can't be found, it means that there was no
-             ;; expected type or no annotation was provided via (: ...).
-             ;;
-             ;; FIXME: is this the right place to raise this error, or
-             ;;        should it be caught earlier so that this function
-             ;;        can be simpler?
-             [else
-              (tc-error/delayed "Init argument ~a has no type annotation"
-                                init-name)])]
+       (check-init-arg init-name
+                       (car (dict-ref inits init-name '(#f)))
+                       #'init-val)]
       ;; init-field with default
       [(begin
          (quote ((~or (~datum declare-field-assignment)
@@ -967,18 +950,9 @@
        #:when (free-identifier=? #'x #'y)
        #:when (free-identifier=? #'obj1 #'obj2)
        (define init-name (syntax-e #'name))
-       (define init-type (car (dict-ref inits init-name '(#f))))
-       (cond [init-type
-              (with-handlers
-                  ([exn:fail:syntax?
-                    ;; FIXME: produce a better error message
-                    (λ (e) (tc-error/delayed "Default init value has wrong type"))])
-                (parameterize ([delay-errors? #f])
-                  (unless (equal? (syntax->datum #'init-val) '(quote #f))
-                    (tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
-             [else
-              (tc-error/delayed "Init argument ~a has no type annotation"
-                                init-name)])]
+       (check-init-arg init-name
+                       (car (dict-ref inits init-name '(#f)))
+                       #'init-val)]
       ;; any field or an init-field without default
       [(begin
          (quote ((~or (~datum declare-field-assignment)
@@ -1000,6 +974,26 @@
        (tc-expr simplified)]
       [_ (void)])))
 
+;; check-init-arg : Id Type Syntax -> Void
+;; Check the initialization of an init arg variable against the
+;; expected type provided by an annotation (or the default)
+(define (check-init-arg init-name init-type init-val)
+  (define thunk?
+    (and (stx-pair? init-val)
+         (free-identifier=? #'#%plain-lambda (stx-car init-val))))
+  (unless (equal? (syntax->datum init-val) '(quote #f))
+    (cond [thunk?
+           (define type
+             (tc-expr/check/t init-val (ret (->* null init-type))))
+           (match type
+             [(Function: (list (arr: _ (Values: (list (Result: result _ _)))
+                                     _ _ _)))
+              (check-below result init-type)]
+             [_ (int-err "unexpected init value ~a"
+                         (syntax->datum init-val))])]
+          [else
+           (tc-expr/check init-val (ret init-type))])))
+
 ;; synthesize-private-field-types : IdTable Dict Hash -> Void
 ;; Given top-level expressions in the class, synthesize types from
 ;; the initialization expressions for private fields.
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 dac0e96c..2487d4f4 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
@@ -808,7 +808,8 @@
    [tc-err (class object% (super-new)
              (: z Integer)
              (init [z "foo"]))
-           #:ret (ret (-class #:init ([z -Integer #t])))]
+           #:ret (ret (-class #:init ([z -Integer #t])))
+           #:msg #rx"expected: Integer.*given: String"]
    ;; test init field default value
    [tc-e (let ()
            (define c% (class object% (super-new)
@@ -1204,7 +1205,7 @@
              (super-new)
              (init-field [x : Z] [y : Z 0]))
            #:ret (ret (-poly (Z) (-class #:init-field ([x Z #f] [y Z #t]))))
-           #:msg #rx"Default init value has wrong type"]
+           #:msg #rx"expected: Z.*given: Zero"]
    ;; fails because default field value cannot be polymorphic
    [tc-err (class object%
              #:forall (Z)