From 33bb5bf17e526f29543ca114f39d6d374bcb1182 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay.mccarthy@gmail.com>
Date: Thu, 7 Jan 2016 20:23:15 -0500
Subject: [PATCH] a lot of progress on classes

---
 remix/class0.rkt      | 162 ++++++++++++++++++++++++++++++++++++------
 remix/exp/expand.rkt  |  44 ++++++++++++
 remix/stx0.rkt        |  14 ++++
 remix/tests/class.rkt |  20 ++++--
 4 files changed, 211 insertions(+), 29 deletions(-)
 create mode 100644 remix/exp/expand.rkt

diff --git a/remix/class0.rkt b/remix/class0.rkt
index dec8e9e..d9bf89c 100644
--- a/remix/class0.rkt
+++ b/remix/class0.rkt
@@ -1,14 +1,24 @@
 #lang racket/base
 (require (for-syntax racket/base
                      syntax/parse
+                     racket/syntax
+                     racket/generic
+                     racket/set
+                     syntax/id-set
                      remix/stx/singleton-struct0
                      (prefix-in remix: remix/stx0))
          racket/stxparam
+         racket/splicing
          remix/theory0
+         remix/static-interface0
          (prefix-in remix: remix/stx0))
 
 (struct object (interface->implementation rep))
 
+(begin-for-syntax
+  (define-generics interface
+    (interface-vtable interface)))
+
 (define-syntax interface
   (singleton-struct
    #:property prop:procedure
@@ -23,26 +33,39 @@
                     ;; XXX support properties?
                     ;; XXX make expandable position
                     v:id ...)
-         (syntax/loc stx
-           ;; XXX instead, make an int-vtable and then a separate int
-           ;; def transformer that looks at objects.
-           (remix:def (remix:#%brackets theory int)
-                      ;; XXX add a property for interfaces
-                      ;; XXX support defaults?
-                      v ...))]))]))
+         (with-syntax ([int-vtable
+                        (format-id #f "~a-vtable" #'int)]
+                       [(obj-v ...)
+                        (for/list ([v (in-list (syntax->list #'(v ...)))])
+                            (format-id #f "~a-~a" #'int v))])
+           (syntax/loc stx
+             (begin
+               (remix:def int-vtable-id (gensym 'int-vtable))
+               (remix:def (remix:#%brackets theory int-vtable)
+                          ;; XXX add a property for vtables
+                          ;; XXX support defaults?
+                          v ...)
+               (remix:def (obj-v o)
+                          (remix:def (remix:#%brackets int-vtable vt)
+                                     (hash-ref (object-interface->implementation o)
+                                               int-vtable-id))
+                          (remix:#%dot vt v))
+               ...
+               (remix:def (remix:#%brackets static-interface int)
+                          (remix:#%brackets v obj-v)
+                          ...
+                          #:extensions
+                          #:methods gen:interface
+                          [(define (interface-vtable _) #'int-vtable)]))))]))]))
 
-(define-syntax-parameter representation
-  (λ (stx)
-    (raise-syntax-error 'representation "Illegal outside class" stx)))
-(define-syntax-parameter new
-  (λ (stx)
-    (raise-syntax-error 'new "Illegal outside class" stx)))
-(define-syntax-parameter this
-  (λ (stx)
-    (raise-syntax-error 'this "Illegal outside class" stx)))
-(define-syntax-parameter implementation
-  (λ (stx)
-    (raise-syntax-error 'implementation "Illegal outside class" stx)))
+(begin-for-syntax
+  (define-generics class)
+  (struct class-expansion-data
+    (cls-id [rep-id #:mutable] new-id [new-found? #:mutable] interface-set))
+  (define (empty-class-expansion-data cls new-id)
+    (class-expansion-data cls #f new-id #f (mutable-bound-id-set)))
+  (define current-class-expansion-data
+    (make-parameter #f)))
 
 (define-syntax class
   (singleton-struct
@@ -51,14 +74,109 @@
      (raise-syntax-error 'class "Illegal outside def" stx))
    #:methods remix:gen:def-transformer
    [(define (def-transform _ stx)
-      ;; XXX ensure everything is expandable
-      ;; XXX
-      #'(void))]))
+      (syntax-parse stx
+        #:literals (remix:#%brackets remix:def class)
+        [(remix:def (remix:#%brackets class cls:id)
+                    body-expr ...)
+         (define ctxt (syntax-local-context))
+         (define cls-stop-list (list #'remix:def #'remix:#%brackets))
+         (with-syntax ([cls-new (format-id #f "~a-new" #'cls)]
+                       [cls-Current (format-id #f "~a-Current" #'cls)]
+                       [cls-alloc (format-id #f "~a-alloc" #'cls)])
+           (define the-ced (empty-class-expansion-data #'cls #'cls-new))
+           (with-syntax ([(new-body ...)
+                          (parameterize ([current-class-expansion-data the-ced])
+                            (for/list ([be (in-list (syntax->list #'(body-expr ...)))])
+                              (local-expand/capture-lifts
+                               be
+                               ctxt cls-stop-list)))])
+             (printf "after body local-expand\n")
+             (with-syntax ([((int cls-int-impl) ...)
+                            ;; XXX
+                            '()])
+               (syntax/loc stx
+                 (begin
+                   (remix:def (remix:#%brackets static-interface cls)
+                              (remix:#%brackets #:new cls-new)
+                              (remix:#%brackets int cls-int-impl)
+                              ...
+                              #:extensions
+                              #:methods gen:class
+                              [])
+                   (remix:def (remix:#%brackets static-interface cls-Current)
+                              (remix:#%brackets #:alloc cls-alloc))
+                   ;; XXX bind this
+                   (splicing-syntax-parameterize
+                       ([Current (rename-dot-transformer #'cls-Current)])
+                     new-body ...))))))]))]))
+
+(begin-for-syntax
+  (struct rename-dot-transformer (id)
+    #:methods remix:gen:dot-transformer
+    [(define/generic super-dt dot-transform)
+     (define (dot-transform rdt stx)
+       (super-dt (syntax-local-value (rename-dot-transformer-id rdt)) stx))]))
+
+(define-syntax (representation stx)
+  (cond
+    [(current-class-expansion-data)
+     => (λ (ced)
+          (syntax-parse stx
+            [(_ l:id)
+             ;; XXX ensure l is layout
+             (cond
+               [(class-expansion-data-rep-id ced)
+                (raise-syntax-error
+                 'representation
+                 (format "Duplicate definition of representation for class ~a"
+                         (syntax-e (class-expansion-data-cls-id ced)))
+                 stx)]
+               [else
+                (set-class-expansion-data-rep-id! ced #'l)])
+             #'(void)]))]
+    [else
+     (raise-syntax-error 'representation "Illegal outside class" stx)]))
+
+(define-syntax (new stx)
+  (cond
+    [(current-class-expansion-data)
+     => (λ (ced)
+          (syntax-parse stx
+            [(_ args . body)
+             (when (class-expansion-data-new-found? ced)
+               (raise-syntax-error
+                 'new
+                 (format "Duplicate definition of constructor for class ~a"
+                         (syntax-e (class-expansion-data-cls-id ced)))
+                 stx))
+             (set-class-expansion-data-new-found?! ced #t)
+             (with-syntax ([cls-new (class-expansion-data-new-id ced)])
+               (syntax/loc stx
+                 (remix:def (cls-new . args) . body)))]))]
+    [else
+     (raise-syntax-error 'new "Illegal outside class" stx)]))
+
+(define-syntax (implementation stx)
+  (cond
+    [(current-class-expansion-data)
+     => (λ (ced)
+          ;; XXX
+          #'(void))]
+    [else
+     (raise-syntax-error 'implementation "Illegal outside class" stx)]))
+
+(define-syntax-parameter Current
+  (λ (stx)
+    (raise-syntax-error 'Current "Illegal outside class definitions" stx)))
+(define-syntax-parameter this
+  (λ (stx)
+    (raise-syntax-error 'this "Illegal outside class definitions" stx)))
 
 (provide interface
          representation
          (rename-out [representation rep])
          new
+         Current
          this
          implementation
          (rename-out [implementation impl])
diff --git a/remix/exp/expand.rkt b/remix/exp/expand.rkt
new file mode 100644
index 0000000..ec7c165
--- /dev/null
+++ b/remix/exp/expand.rkt
@@ -0,0 +1,44 @@
+#lang racket/base
+(require (for-syntax racket/base
+                     syntax/parse)
+         racket/splicing)
+
+(begin-for-syntax
+  (define special-define-set
+    (make-parameter (box '())))
+  (define (add-to-boxed-list! b v)
+    (set-box! b (cons v (unbox b)))))
+
+(define-syntax (detect-special-defines stx)
+  (syntax-parse stx
+    [(_ body-expr ...)
+     (define the-b (box '()))
+     (define ctxt (syntax-local-context))
+     (printf "ctxt: ~v\n" ctxt)
+     (with-syntax ([(new-body-begin ...)
+                    (parameterize ([special-define-set the-b])
+                      (for/list ([be (in-list (syntax->list #'(body-expr ...)))])
+                        (local-expand/capture-lifts
+                         be
+                         ctxt
+                         (list #'define-values))))])
+       (with-syntax ([(d ...) (unbox the-b)])
+         (quasisyntax/loc stx
+           (begin
+             new-body-begin ...
+             (printf "Defined: ~a\n"
+                     '(d ...))))))]))
+
+(define-syntax (special-define stx)
+  (syntax-parse stx
+    [(_ x:id b:expr)
+     (printf "special-define ran!\n")
+     (add-to-boxed-list! (special-define-set) #'x)
+     (syntax/loc stx
+       (define x b))]))
+
+(detect-special-defines
+ (special-define x 1)
+ (special-define y 2))
+
+(+ x y)
diff --git a/remix/stx0.rkt b/remix/stx0.rkt
index 54f4ecb..b160616 100644
--- a/remix/stx0.rkt
+++ b/remix/stx0.rkt
@@ -183,6 +183,20 @@
         (syntax/loc stx
           (remix-block sf ... (the-#%braces s.tail-form ...)))])]))
 
+(require (for-syntax (prefix-in dangerous:stxparamkey: racket/private/stxparamkey)))
+(begin-for-syntax
+  (define (syntax-parameter? id)
+    ;; Copied from syntax-parameter-value
+    (let* ([v (syntax-local-value id (λ () #f))]
+           [v (if (set!-transformer? v)
+                      (set!-transformer-procedure v)
+                      v)])
+      (dangerous:stxparamkey:syntax-parameter? v)))
+  (define (syntax-local-value/maybe-syntax-parameter id)
+    (if (syntax-parameter? id)
+        (syntax-parameter-value id)
+        (syntax-local-value id (λ () #f)))))
+
 (begin-for-syntax
   (define-generics dot-transformer
     (dot-transform dot-transformer stx)))
diff --git a/remix/tests/class.rkt b/remix/tests/class.rkt
index b6439d1..10dcb6a 100644
--- a/remix/tests/class.rkt
+++ b/remix/tests/class.rkt
@@ -16,17 +16,18 @@
 ;; A class is a representation, a constructor, and implementations of
 ;; interfaces.
 (def [class Circle]
-  (def [rep] circle) ;; rep = representation
-  (def ([new] x y r)
-    (this.#:alloc [c (posn.#:alloc [x x] [y y])]
-                  [r r]))
+  (rep circle) ;; rep = representation
+  (new (x y r)
+   (Current.#:alloc
+    [c (posn.#:alloc [x x] [y y])]
+    [r r]))
   
   ;; xxx make a macro from "layout's fields implements this interface"
-  (def [implementation Circle<%>]
+  (implementation Circle<%>
     [(c) this.c]
     [(r) this.r])
   
-  (def [impl 2d<%>]
+  (impl 2d<%>
     [(translate x y)
      {this.#:set
       [c (this.c.#:set [x {x + this.c.x}]
@@ -35,7 +36,11 @@
      {3 * this.r * this.r}]))
 
 ;; XXX allow w/o #:new?, like layout
-#;(def [Circle C1] (Circle.#:new 1 2 3))
+
+;; XXX
+#;
+(def [Circle C1] (Circle.#:new 1 2 3))
+;; XXX
 #;
 (module+ test
   ;; If you know something is a particular class, then you can access
@@ -57,6 +62,7 @@
   {C1-as-Circ.c.y ≡ 2}
   {C1-as-Circ.r ≡ 3})
 
+;; XXX
 #;
 (module+ test
   ;; Like theories, you can define functions that are generic over an