From 1be1fb5e18fdcfa52b7d6b0e4a520820ab573a51 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Mon, 10 Jun 2013 18:17:32 -0400
Subject: [PATCH] Add parsing for (Object ...) types into Instances

original commit: c47531569a204c789d00c413abc70494738b137a
---
 .../base-env/base-types-extra.rkt             |  2 +-
 .../typed-racket/private/parse-type.rkt       | 38 ++++++++++++++++++-
 .../unit-tests/parse-type-tests.rkt           | 13 +++++++
 3 files changed, 51 insertions(+), 2 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
index 27e987de..9fe186bc 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
@@ -16,7 +16,7 @@
 ;; special type names that are not bound to particular types
 (define-other-types
   -> ->* case-> U Rec All Opaque Vector
-  Parameterof List List* Class Values Instance Refinement
+  Parameterof List List* Class Object Values Instance Refinement
   pred Struct Struct-Type Top Bot)
 
 (provide (rename-out [All ∀]
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
index 83839b50..7ae5ae70 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt
@@ -44,6 +44,7 @@
 (define-literal-syntax-class #:for-label quote)
 (define-literal-syntax-class #:for-label cons)
 (define-literal-syntax-class #:for-label Class)
+(define-literal-syntax-class #:for-label Object)
 (define-literal-syntax-class #:for-label Refinement)
 (define-literal-syntax-class #:for-label Instance)
 (define-literal-syntax-class #:for-label List)
@@ -249,6 +250,8 @@
        (-pair (parse-type #'fst) (parse-type #'rst))]
       [(:Class^ e ...)
        (parse-class-type stx)]
+      [(:Object^ e ...)
+       (parse-object-type stx)]
       [(:Refinement^ p?:id)
        (match (lookup-type/lexical #'p?)
          [(and t (Function: (list (arr: (list dom) _ #f #f '()))))
@@ -538,6 +541,24 @@
 (define (flatten-class-clause stx)
   (flatten (map stx->list (stx->list stx))))
 
+(define-splicing-syntax-class object-type-clauses
+  #:description "Object type clause"
+  #:attributes (field-names field-types method-names method-types)
+  #:literals (field)
+  (pattern (~seq (~or (field field-clause:field-or-method-type ...)
+                      method-clause:field-or-method-type)
+                 ...)
+           #:with field-names (flatten-class-clause #'((field-clause.label ...) ...))
+           #:with field-types (flatten-class-clause #'((field-clause.type ...) ...))
+           #:with method-names #'(method-clause.label ...)
+           #:with method-types #'(method-clause.type ...)
+           #:fail-when
+           (check-duplicate-identifier (syntax->list #'field-names))
+           "duplicate field or init-field clause"
+           #:fail-when
+           (check-duplicate-identifier (syntax->list #'method-names))
+           "duplicate method clause"))
+
 (define-splicing-syntax-class class-type-clauses
   #:description "Class type clause"
   #:attributes (self extends-types
@@ -647,7 +668,22 @@
   (define merged-methods (append checked-super-methods checked-methods))
   (values merged-fields merged-methods))
 
-;; Syntax (Syntax -> Type) -> Type
+;; Syntax -> Type
+;; Parse a (Object ...) type
+;; This is an alternative way to write down an Instance type
+(define (parse-object-type stx)
+  (syntax-parse stx
+    [(kw clause:object-type-clauses)
+     (add-disappeared-use #'kw)
+     (define fields (map list
+                         (stx-map syntax-e #'clause.field-names)
+                         (stx-map parse-type #'clause.field-types)))
+     (define methods (map list
+                          (stx-map syntax-e #'clause.method-names)
+                          (stx-map parse-type #'clause.method-types)))
+     (make-Instance (make-Class #f null fields methods))]))
+
+;; Syntax -> Type
 ;; Parse a (Class ...) type
 (define (parse-class-type stx)
   (syntax-parse stx
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
index 9bbe7f4b..0c9ce181 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/parse-type-tests.rkt
@@ -247,6 +247,19 @@
    [FAIL (Class #:extends (Class [m (Number -> Number)])
                 #:extends (Class [m (String -> String)])
                 (field [x Number]))]
+   ;; Test Object types
+   [(Object) (make-Instance (make-Class #f null null null))]
+   [(Object [m (Number -> Number)])
+    (make-Instance (make-Class #f null null `((m ,(t:-> N N)))))]
+   [(Object [m (Number -> Number)] (field [f Number]))
+    (make-Instance (make-Class #f null `((f ,N)) `((m ,(t:-> N N)))))]
+   [FAIL (Object foobar)]
+   [FAIL (Object [x UNBOUND])]
+   [FAIL (Object [x Number #:random-keyword])]
+   [FAIL (Object (random-clause [x Number]))]
+   [FAIL (Object [x Number] [x Number])]
+   [FAIL (Object (field [x Number]) (field [x Number]))]
+   [FAIL (Object [x Number] [x Number])]
    ))
 
 ;; FIXME - add tests for parse-values-type, parse-tc-results