From 066e4356b44e53743e71232bd2eb9b37efdd2a4d Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 22 Jan 2015 14:22:11 -0500
Subject: [PATCH] Support type alias definitions in class bodies

---
 .../typed-racket/env/type-alias-helper.rkt    | 13 ++++---
 .../typecheck/check-class-unit.rkt            | 10 +++++-
 .../typed-racket/typecheck/internal-forms.rkt |  5 ++-
 typed-racket-test/unit-tests/class-tests.rkt  | 36 ++++++++++++++++++-
 4 files changed, 54 insertions(+), 10 deletions(-)

diff --git a/typed-racket-lib/typed-racket/env/type-alias-helper.rkt b/typed-racket-lib/typed-racket/env/type-alias-helper.rkt
index aae1304e..716864b8 100644
--- a/typed-racket-lib/typed-racket/env/type-alias-helper.rkt
+++ b/typed-racket-lib/typed-racket/env/type-alias-helper.rkt
@@ -13,7 +13,7 @@
          racket/list
          racket/match
          syntax/id-table
-         syntax/kerncase
+         syntax/parse
          (for-template
           (typecheck internal-forms)
           racket/base))
@@ -231,12 +231,11 @@
 ;; Syntax -> Syntax Syntax Syntax Option<Integer>
 ;; Parse a type alias internal declaration
 (define (parse-type-alias form)
-  (kernel-syntax-case* form #f
-    (define-type-alias-internal values)
-    [(define-values ()
-       (begin (quote-syntax (define-type-alias-internal nm ty args))
-              (#%plain-app values)))
-     (values #'nm #'ty (syntax-e #'args))]
+  (syntax-parse form
+    #:literal-sets (kernel-literals)
+    #:literals (values)
+    [t:type-alias
+     (values #'t.name #'t.type (syntax-e #'t.args))]
     ;; this version is for `let`-like bodies
     [(begin (quote-syntax (define-type-alias-internal nm ty args))
             (#%plain-app values))
diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
index aa794040..8d130b6c 100644
--- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
@@ -12,7 +12,7 @@
          syntax/stx
          "signatures.rkt"
          (private parse-type syntax-properties)
-         (env lexical-env tvar-env global-env)
+         (env lexical-env tvar-env global-env type-alias-helper)
          (types utils abbrev union subtype resolve generalize)
          (typecheck check-below internal-forms)
          (utils tc-utils)
@@ -338,6 +338,14 @@
   (define top-level-exprs
     (trawl-for-property make-methods-stx tr:class:top-level-property))
 
+  ;; Set up type aliases before any types get parsed
+  (define type-aliases
+    (filter (syntax-parser [t:type-alias #t] [_ #f])
+            (syntax->list (hash-ref parse-info 'initializer-body))))
+
+  (define-values (alias-names alias-map) (get-type-alias-info type-aliases))
+  (register-all-type-aliases alias-names alias-map)
+
   ;; Filter top level expressions into several groups, each processed
   ;; into appropriate data structures
   ;;
diff --git a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
index a11abf7d..46df1ddc 100644
--- a/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
@@ -75,7 +75,10 @@
 (define-syntax-class internal^
    #:attributes (value)
    #:literal-sets (kernel-literals internal-form-literals)
-   (pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values)))))
+   (pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values))))
+   ;; for use in forms like classes that transform definitions
+   (pattern (let-values ([() (begin (quote-syntax value:expr) (#%plain-app values))])
+              (#%plain-app void))))
 
 (define-syntax (define-internal-classes stx)
   (define-syntax-class clause
diff --git a/typed-racket-test/unit-tests/class-tests.rkt b/typed-racket-test/unit-tests/class-tests.rkt
index 45d9b80f..2015ab4b 100644
--- a/typed-racket-test/unit-tests/class-tests.rkt
+++ b/typed-racket-test/unit-tests/class-tests.rkt
@@ -1800,4 +1800,38 @@
              (: y (Object (field [x Any])))
              (define y x)
              (error "foo"))
-           #:msg "parse error in type"]))
+           #:msg "parse error in type"]
+   ;; Test type aliases inside class bodies
+   [tc-e (class object%
+           (super-new)
+           (define-type-alias X String)
+           (: x X)
+           (define x "foo"))
+         (-class)]
+   [tc-e (class object%
+           (super-new)
+           (define-type-alias (F X) (Listof X))
+           (: x (F String))
+           (define x (list "foo")))
+         (-class)]
+   [tc-err (let ()
+             (class object%
+               (super-new)
+               (define-type-alias X String)
+               (: x X)
+               (define x "foo"))
+             (: x2 X)
+             (define x2 "bar")
+             (error "foo"))
+           #:msg "type name `X' is unbound"]
+   [tc-e (let ()
+           (class object%
+             (super-new)
+             (define-type-alias X String)
+             (: x X)
+             (define x "foo"))
+           (define-type-alias X Symbol)
+           (: x2 X)
+           (define x2 'bar)
+           (void))
+         -Void]))