From 985b540cccf0af19c6ad93ee22d5ca00dc011c33 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay.mccarthy@gmail.com>
Date: Mon, 18 Jan 2016 19:34:58 -0500
Subject: [PATCH] prep for expandable

---
 remix/data0.rkt                  |   3 +
 remix/static-interface0.rkt      | 315 +++++++++++++++----------------
 remix/tests/static-interface.rkt |  23 +--
 3 files changed, 162 insertions(+), 179 deletions(-)
 create mode 100644 remix/data0.rkt

diff --git a/remix/data0.rkt b/remix/data0.rkt
new file mode 100644
index 0000000..0edb1d4
--- /dev/null
+++ b/remix/data0.rkt
@@ -0,0 +1,3 @@
+#lang racket/base
+
+;; xxx data (fixed set of interfaces)
diff --git a/remix/static-interface0.rkt b/remix/static-interface0.rkt
index 1fe1135..64e52dd 100644
--- a/remix/static-interface0.rkt
+++ b/remix/static-interface0.rkt
@@ -31,175 +31,158 @@
     (provide interface-member))
   (require (submod "." interface-member)
            (for-syntax
-            (submod "." interface-member)))
+            (submod "." interface-member))))
 
-  (define-syntax (phase1:static-interface stx)
-    (syntax-parse stx
-      #:literals (remix:#%brackets)
-      [(_si 
-        ;; XXX make expandable position
-        (remix:#%brackets
-         lhs:interface-member rhs:id
-         (~optional
-          (~seq #:is rhs-dt:id)
-          #:defaults ([rhs-dt #'#f])))
-        ...
-        (~optional
-         (~seq #:extensions
-               extension ...)
-         #:defaults ([[extension 1] '()])))
-       (with-syntax* ([int-name (or (syntax-local-name) 'static-interface)]
-                      [(def-rhs ...)
-                       (for/list ([lhs (in-list
-                                        (map syntax->datum
-                                             (syntax->list #'(lhs ...))))])
-                         (format-id #f "~a-~a-for-def" #'int-name
-                                    (if (keyword? lhs) (keyword->string lhs)
-                                        lhs)))]
-                      [(full-def-rhs ...)
-                       (for/list ([def-rhs (in-list (syntax->list #'(def-rhs ...)))]
-                                  [rhs-dt (in-list (syntax->list #'(rhs-dt ...)))])
-                         (if (syntax-e rhs-dt)
-                             (list def-rhs '#:is rhs-dt)
-                             (list def-rhs)))])
-         (syntax/loc stx
-           (let ()
-             (define int-id->orig
-               (make-immutable-hasheq
-                (list (cons 'lhs (cons #'rhs #'rhs-dt))
-                      ...)))
-             (define available-ids
-               (sort (hash-keys int-id->orig)
-                     string<=?
-                     #:key ~a))
-             (define (get-rhs stx x)
-               (define xv (syntax->datum x))
-               (hash-ref int-id->orig
-                         xv
-                         (λ ()
-                           (raise-syntax-error
-                            'int-name
-                            (format "Unknown component ~v, expected one of ~v"
-                                    xv
-                                    available-ids)
-                            stx
-                            x))))
-             (define (get-rhs-id stx x)
-               (car (get-rhs stx x)))
-             (define (get-rhs-is stx x)
-               (define r (cdr (get-rhs stx x)))
-               (if (syntax-e r)
-                   r
-                   #f))
-             (define (get-rhs-def stx x-stx)
-               (define xd (get-rhs-is stx x-stx))
-               (with-syntax* ([xb (get-rhs-id stx x-stx)]
-                              [x-def
-                               (if xd xd #'remix:stx)]
-                              [x-def-v
-                               (if xd #'xb #'(make-rename-transformer #'xb))])
-                 (quasisyntax/loc stx
-                   (remix:def (remix:#%brackets x-def #,x-stx) x-def-v))))
-             (singleton-struct
-              #:methods gen:static-interface
-              [(define (static-interface-members _)
-                 available-ids)]
-              #:methods remix:gen:dot-transformer
-              [(define (dot-transform _ stx)
-                 (syntax-parse stx
-                   [(_dot me:id (x:interface-member . args))
+(define-syntax static-interface
+  (singleton-struct
+   #:property prop:procedure
+   (λ (_ stx)
+     (raise-syntax-error 'static-interface "Illegal outside def" stx))
+   #:methods remix:gen:def-transformer
+   [(define (def-transform _ stx)
+      (syntax-parse stx
+        #:literals (remix:#%brackets)
+        [(_def (remix:#%brackets me:id the-si:id)
+           ;; XXX make expandable position
+           (remix:#%brackets
+            lhs:interface-member rhs:id
+            (~optional
+             (~seq #:is rhs-dt:id)
+             #:defaults ([rhs-dt #'#f])))
+           ...
+           (~optional
+            (~seq #:extensions
+                  extension ...)
+            #:defaults ([[extension 1] '()])))
+         (with-syntax* ([int-name (or (syntax-local-name) 'static-interface)]
+                        [(def-rhs ...)
+                         (for/list ([lhs (in-list
+                                          (map syntax->datum
+                                               (syntax->list #'(lhs ...))))])
+                           (format-id #f "~a-~a-for-def" #'int-name
+                                      (if (keyword? lhs) (keyword->string lhs)
+                                          lhs)))]
+                        [(full-def-rhs ...)
+                         (for/list ([def-rhs (in-list (syntax->list #'(def-rhs ...)))]
+                                    [rhs-dt (in-list (syntax->list #'(rhs-dt ...)))])
+                           (if (syntax-e rhs-dt)
+                               (list def-rhs '#:is rhs-dt)
+                               (list def-rhs)))])
+           (syntax/loc stx
+             (remix:def
+              (remix:#%brackets remix:stx the-si)
+              (let ()
+                (define int-id->orig
+                  (make-immutable-hasheq
+                   (list (cons 'lhs (cons #'rhs #'rhs-dt))
+                         ...)))
+                (define available-ids
+                  (sort (hash-keys int-id->orig)
+                        string<=?
+                        #:key ~a))
+                (define (get-rhs stx x)
+                  (define xv (syntax->datum x))
+                  (hash-ref int-id->orig
+                            xv
+                            (λ ()
+                              (raise-syntax-error
+                               'int-name
+                               (format "Unknown component ~v, expected one of ~v"
+                                       xv
+                                       available-ids)
+                               stx
+                               x))))
+                (define (get-rhs-id stx x)
+                  (car (get-rhs stx x)))
+                (define (get-rhs-is stx x)
+                  (define r (cdr (get-rhs stx x)))
+                  (if (syntax-e r)
+                      r
+                      #f))
+                (define (get-rhs-def stx x-stx)
+                  (define xd (get-rhs-is stx x-stx))
+                  (with-syntax* ([xb (get-rhs-id stx x-stx)]
+                                 [x-def
+                                  (if xd xd #'remix:stx)]
+                                 [x-def-v
+                                  (if xd #'xb #'(make-rename-transformer #'xb))])
                     (quasisyntax/loc stx
-                      (remix:#%app (remix:#%app (remix:#%dot me x)) . args))]
-                   [(_dot me:id x:interface-member)
-                    (get-rhs-id stx #'x)]
-                   [(_dot me:id . (~and x+more (x:interface-member . more)))
-                    (quasisyntax/loc stx
-                      (remix:block
-                       #,(get-rhs-def stx #'x)
-                       #,(syntax/loc #'x+more
-                           (remix:#%dot x . more))))]))]
-              #:methods remix:gen:app-dot-transformer
-              [(define (app-dot-transform _ stx)
-                 (syntax-parse stx
-                   [(_app (_dot me:id (x:interface-member . args)) . body)
-                    (quasisyntax/loc stx
-                      (remix:#%app
-                       (remix:#%app (remix:#%app (remix:#%dot me x)) . args)
-                       . body))]
-                   [(_app (_dot me:id x:interface-member) . body)
-                    (quasisyntax/loc stx
-                      (#,(get-rhs-id stx #'x) . body))]
-                   [(_app (_dot me:id x:interface-member . more) . body)
-                    (quasisyntax/loc stx
-                      (remix:block
-                       #,(get-rhs-def stx #'x)
-                       (remix:#%app (remix:#%dot x . more) . body)))]))]
-              #:methods remix:gen:def-transformer
-              [(define (def-transform _ stx)
-                 (syntax-parse stx
-                   #:literals (remix:#%brackets)
-                   [(def (remix:#%brackets me:id i:id) . body)
-                    (with-syntax ([real-i (generate-temporary #'i)])
-                      (syntax/loc stx
-                        (begin
-                          (remix:def real-i . body)
-                          (remix:def (remix:#%brackets remix:stx def-rhs)
-                                     (λ (stx)
-                                       (syntax-parse stx
-                                         [_:id
-                                          (syntax/loc stx
-                                            (rhs real-i))]
-                                         [(_ . blah)
-                                          (syntax/loc stx
-                                            (rhs real-i . blah))])))
-                          ...
-                          (remix:def (remix:#%brackets remix:stx i)
-                                     (phase1:static-interface
-                                      (remix:#%brackets lhs . full-def-rhs)
-                                      ...
-                                      #:extensions
-                                      ;; NB I don't pass on other
-                                      ;; extensions... I don't think
-                                      ;; it can possibly make sense,
-                                      ;; because I don't know what
-                                      ;; they might be.
-                                      #:property prop:procedure
-                                      (λ (_ stx)
-                                        (syntax-parse stx
-                                          [_:id
-                                           (syntax/loc stx
-                                             real-i)]
-                                          [(_ . blah)
-                                           (syntax/loc stx
-                                             (real-i . blah))])))))))]))]
-              extension ...))))])))
+                      (remix:def (remix:#%brackets x-def #,x-stx) x-def-v))))
+                (singleton-struct
+                 #:methods gen:static-interface
+                 [(define (static-interface-members _)
+                    available-ids)]
+                 #:methods remix:gen:dot-transformer
+                 [(define (dot-transform _ stx)
+                    (syntax-parse stx
+                      [(_dot me:id (x:interface-member . args))
+                       (quasisyntax/loc stx
+                         (remix:#%app (remix:#%app (remix:#%dot me x)) . args))]
+                      [(_dot me:id x:interface-member)
+                       (get-rhs-id stx #'x)]
+                      [(_dot me:id . (~and x+more (x:interface-member . more)))
+                       (quasisyntax/loc stx
+                         (remix:block
+                          #,(get-rhs-def stx #'x)
+                          #,(syntax/loc #'x+more
+                              (remix:#%dot x . more))))]))]
+                 #:methods remix:gen:app-dot-transformer
+                 [(define (app-dot-transform _ stx)
+                    (syntax-parse stx
+                      [(_app (_dot me:id (x:interface-member . args)) . body)
+                       (quasisyntax/loc stx
+                         (remix:#%app
+                          (remix:#%app (remix:#%app (remix:#%dot me x)) . args)
+                          . body))]
+                      [(_app (_dot me:id x:interface-member) . body)
+                       (quasisyntax/loc stx
+                         (#,(get-rhs-id stx #'x) . body))]
+                      [(_app (_dot me:id x:interface-member . more) . body)
+                       (quasisyntax/loc stx
+                         (remix:block
+                          #,(get-rhs-def stx #'x)
+                          (remix:#%app (remix:#%dot x . more) . body)))]))]
+                 #:methods remix:gen:def-transformer
+                 [(define (def-transform _ stx)
+                    (syntax-parse stx
+                      #:literals (remix:#%brackets)
+                      [(__def (remix:#%brackets me:id i:id) . body)
+                       (with-syntax ([real-i (generate-temporary #'i)])
+                         (syntax/loc stx
+                           (begin
+                             (remix:def real-i . body)
+                             (remix:def (remix:#%brackets remix:stx def-rhs)
+                                        (λ (stx)
+                                          (syntax-parse stx
+                                            [_:id
+                                             (syntax/loc stx
+                                               (rhs real-i))]
+                                            [(_ . blah)
+                                             (syntax/loc stx
+                                               (rhs real-i . blah))])))
+                             ...
+                             (remix:def (remix:#%brackets static-interface i)
+                                        (remix:#%brackets lhs . full-def-rhs)
+                                        ...
+                                        #:extensions
+                                        ;; NB I don't pass on other
+                                        ;; extensions... I don't think
+                                        ;; it can possibly make sense,
+                                        ;; because I don't know what
+                                        ;; they might be.
+                                        #:property prop:procedure
+                                        (λ (_ stx)
+                                          (syntax-parse stx
+                                            [_:id
+                                             (syntax/loc stx
+                                               real-i)]
+                                            [(_ . blah)
+                                             (syntax/loc stx
+                                               (real-i . blah))]))))))]))]
+                 extension ...)))))]))]))
 
-(define-syntax (define-phase0-def->phase1-macro stx)
-  (syntax-parse stx
-    [(_ base:id)
-     (with-syntax ([phase0:base (format-id #'base "phase0:~a" #'base)]
-                   [phase1:base (format-id #'base "phase1:~a" #'base)])
-       (syntax/loc stx
-         (define-syntax phase0:base
-           (singleton-struct
-            #:property prop:procedure
-            (λ (_ stx)
-              (raise-syntax-error 'base "Illegal outside def" stx))
-            #:methods remix:gen:def-transformer
-            [(define (def-transform _ stx)
-               (syntax-parse stx
-                 #:literals (remix:#%brackets)
-                 [(def (remix:#%brackets me:id i:id) . body)
-                  (syntax/loc stx
-                    (remix:def (remix:#%brackets remix:stx i)
-                               (phase1:base . body)))]))]))))]))
-
-(define-phase0-def->phase1-macro static-interface)
-
-(provide (rename-out [phase0:static-interface static-interface])
-         (for-syntax (rename-out [phase1:static-interface static-interface])
-                     gen:static-interface
+(provide static-interface
+         (for-syntax gen:static-interface
                      static-interface?
                      static-interface-members))
 
-;; xxx data (fixed set of interfaces)
diff --git a/remix/tests/static-interface.rkt b/remix/tests/static-interface.rkt
index 64a0af6..ba70f91 100644
--- a/remix/tests/static-interface.rkt
+++ b/remix/tests/static-interface.rkt
@@ -10,20 +10,18 @@
 ;; with particular functions.
 (def (example-f x y) x)
 (def (example-g x y) y)
-(def [stx example^]
-  (static-interface
-   [f example-f]
-   [g example-g]))
+(def [static-interface example^]  
+  [f example-f]
+  [g example-g])
 (module+ test
   {(example^.f 1 2) ≡ 1}
   {(example^.g 1 2) ≡ 2})
 
 ;; These static interfaces allow nesting
 (def example2-h 19)
-(def [stx example2^]
-  (static-interface
-   [fg example^]
-   [h example2-h]))
+(def [static-interface example2^]  
+  [fg example^]
+  [h example2-h])
 (module+ test
   {(example2^.fg.f 1 2) ≡ 1}
   {(example2^.fg.g 1 2) ≡ 2}
@@ -52,11 +50,10 @@
 ;; static-interface, rather than the binding itself. In that case, we
 ;; use the keyword #:is and specify another def transformer for
 ;; contexts where the value is in tail position.
-(def [stx example3^]
-  (static-interface
-   ;; NB Perhaps it would be more punny to us [def id]?
-   [fg example2-fg #:is example^]
-   [h example2-h]))
+(def [static-interface example3^]
+  ;; NB Perhaps it would be more punny to us [def id]?
+  [fg example2-fg #:is example^]
+  [h example2-h])
 (def example2-fg 1)
 (module+ test
   {(example3^.fg.f 2) ≡ 1}