From 3a63c8175e18e4e8e78e3760cec644fd78f1470a Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 24 Oct 2013 14:27:05 -0400
Subject: [PATCH] Add abbreviation for classes and use in base-env

original commit: 98a2d248c0589e4b8d3663566adff7b66da6be6b
---
 .../typed-racket/base-env/base-env.rkt        |  5 +-
 .../typed-racket/types/abbrev.rkt             | 60 +++++++++++++++++++
 2 files changed, 63 insertions(+), 2 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
index d0fec520..42f8df2d 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
@@ -21,7 +21,6 @@
  (only-in (types abbrev) [-Boolean B] [-Symbol Sym])
  (only-in (types numeric-tower) [-Number N])
  (only-in (rep type-rep)
-          make-Class
           make-ClassTop
           make-Instance
           make-Name
@@ -963,7 +962,9 @@
 [struct-type? (make-pred-ty (make-StructTypeTop))]
 
 ;; Section 6.2 (Classes)
-[object% (make-Class #f null null null null)]
+[object% (-class)]
+
+;; Section 6.11 (Object, Class, and Interface Utilities)
 [is-a? (-> Univ (make-ClassTop) -Boolean)]
 
 ;; Section 9.1
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt
index 26f39487..ecb66540 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/types/abbrev.rkt
@@ -17,6 +17,8 @@
          ;; Using this form so all-from-out works
          "base-abbrev.rkt" "match-expanders.rkt"
 
+         (for-syntax racket/base syntax/parse)
+
          ;; for base type contracts and predicates
          ;; use '#%place to avoid the other dependencies of `racket/place`
          (for-template
@@ -267,3 +269,61 @@
 
 (define-syntax-rule (->opt args ... [opt ...] res)
   (opt-fn (list args ...) (list opt ...) res))
+
+;; class utilities
+
+(begin-for-syntax
+ (define-syntax-class names+types
+   #:attributes (data)
+   (pattern [(name:id type) ...]
+            #:with data #'(list (list (quote name) type) ...)))
+
+ (define-syntax-class names+types+opt
+   #:attributes (data no-opts)
+   (pattern [(name:id type opt?) ...]
+            #:with data #'(list (list (quote name) type opt?) ...)
+            #:with no-opts #'(list (list (quote name) type) ...)))
+
+ (define-splicing-syntax-class -class-clause
+   #:attributes (inits fields methods augments)
+   (pattern (~seq #:init sub-clauses:names+types+opt)
+            #:with inits #'sub-clauses.data
+            #:with fields #'null
+            #:with methods #'null
+            #:with augments #'null)
+   (pattern (~seq #:init-field sub-clauses:names+types+opt)
+            #:with inits #'sub-clauses.data
+            #:with fields #'sub-clauses.no-opts
+            #:with methods #'null
+            #:with augments #'null)
+   (pattern (~seq #:method sub-clauses:names+types)
+            #:with inits #'null
+            #:with fields #'null
+            #:with methods #'sub-clauses.data
+            #:with augments #'null)
+   (pattern (~seq #:field sub-clauses:names+types)
+            #:with inits #'null
+            #:with fields #'sub-clauses.data
+            #:with methods #'null
+            #:with augments #'null)
+   (pattern (~seq #:augment sub-clauses:names+types)
+            #:with inits #'null
+            #:with fields #'null
+            #:with methods #'null
+            #:with augments #'sub-clauses.data)))
+
+(define-syntax (-class stx)
+  (syntax-parse stx
+    [(_ (~or (~optional (~seq #:row var:expr)
+                        #:defaults ([var #'#f]))
+             ?clause:-class-clause) ...)
+     #'(make-Class
+        var
+        (append ?clause.inits ...)
+        (append ?clause.fields ...)
+        (append ?clause.methods ...)
+        (append ?clause.augments ...))]))
+
+(define-syntax-rule (-object . ?clauses)
+  (make-Instance (-class . ?clauses)))
+