From a8d40530f4bf1bc868ea5608e7f273ea1861768b Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Tue, 24 Nov 2009 20:58:13 +0000
Subject: [PATCH] checkpoint new macro stuff

svn: r17050
---
 collects/honu/private/debug.ss |   2 +-
 collects/honu/private/honu.ss  |   1 +
 collects/honu/private/macro.ss | 211 +++++++++++++++++++++++++++++++--
 3 files changed, 206 insertions(+), 8 deletions(-)

diff --git a/collects/honu/private/debug.ss b/collects/honu/private/debug.ss
index 49f1314323..40baf40a26 100644
--- a/collects/honu/private/debug.ss
+++ b/collects/honu/private/debug.ss
@@ -4,7 +4,7 @@
 
 (provide debug)
 
-(define-for-syntax verbose? #f)
+(define-for-syntax verbose? #t)
 (define-syntax (debug stx)
   (if verbose?
     (syntax-case stx ()
diff --git a/collects/honu/private/honu.ss b/collects/honu/private/honu.ss
index dd8a1ea7a4..931bcfb78e 100644
--- a/collects/honu/private/honu.ss
+++ b/collects/honu/private/honu.ss
@@ -126,6 +126,7 @@
                  (let ([v (syntax-local-value (stx-car first) (lambda () #f))])
                    (and (honu-transformer? v) v))]
                 [else #f]))))
+     (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
      (or (bound-transformer stx)
          (special-transformer stx)))
    
diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss
index 1dd5b15182..90a0c9ee1c 100644
--- a/collects/honu/private/macro.ss
+++ b/collects/honu/private/macro.ss
@@ -1,8 +1,12 @@
 #lang scheme/base
 
 (require "honu.ss"
-         (for-syntax "debug.ss")
-         (for-syntax scheme/base))
+         (for-syntax "debug.ss"
+                     scheme/base
+                     syntax/parse
+                     syntax/stx
+                     scheme/pretty
+                     scheme/trace))
 
 (provide honu-macro)
 
@@ -21,6 +25,9 @@
        (loop out #'(rest1 rest ...))]
       [(foo) out])))
 
+(define-syntax (semicolon stx)
+  stx)
+
 (define-for-syntax (extract-patterns pattern)
   (let loop ([out '()]
              [in pattern])
@@ -36,6 +43,29 @@
                #'(rest1 rest ...)))]
       [(foo) (reverse (cons #'foo out))])))
 
+#|
+(define-for-syntax (convert stx)
+  (syntax-case stx (...)
+    [(_ x ...)
+     |#
+
+(define-for-syntax (fix-template stx) stx)
+
+#|
+(define-for-syntax (fix-template stx)
+  [(any \;
+            (... ...) rest1 rest ...)
+       (loop (cons #'(semicolon any (... ..)))
+             #'(rest1 rest ...))]
+      [((any1 any ...) rest1 rest ...)
+       (loop (loop out #'(any1 any ...))
+             #'(rest1 rest ...))]
+      |#
+
+
+;; x = 1 + y; ...
+
+#;
 (define-honu-syntax honu-macro
   (lambda (stx ctx)
     (debug "Original macro: ~a\n" (syntax->datum stx))
@@ -47,7 +77,10 @@
        (with-syntax ([(conventions ...)
                       (extract-conventions #'(pattern ...))]
                      [(raw-patterns ...)
-                      (extract-patterns #'(pattern ...))])
+                      (extract-patterns #'(pattern ...))]
+                     [(fixed-template ...)
+                      (fix-template #'(template ...))])
+         (debug "new template ~a\n" (syntax->datum #'(fixed-template ...)))
          (values
            (syntax/loc
              stx
@@ -80,7 +113,7 @@
                                [(name pattern ...)
                                 #'(honu-unparsed-block
                                     #f obj 'obj #f ctx
-                                    template ...)]))
+                                    fixed-template ...)]))
 
                    (let ([result (syntax-case stx
                                    #;
@@ -92,7 +125,7 @@
                                    [(name raw-patterns ...)
                                     #'(honu-unparsed-block
                                         #f obj 'obj #f ctx
-                                        template ...)]
+                                        fixed-template ...)]
                                    [else 'fail-boat])])
                      (debug "result was ~a\n" result))
                    (syntax-case stx (honu-literal ...)
@@ -100,7 +133,7 @@
                       (values
                         #'(honu-unparsed-block
                             #f obj 'obj #f ctx
-                            template ...)
+                            fixed-template ...)
                         #'rrest)])))
                #;
                (define-honu-syntax name
@@ -115,7 +148,171 @@
                                   (values
                                     #'(honu-unparsed-block
                                         #f obj 'obj #f ctx
-                                        template ...)
+                                        fixed-template ...)
                                     #'rrest)])))))
            #'rest))])
     ))
+
+(define-for-syntax (delimiter? x) #f)
+
+(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this"))
+;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap"))
+;; just a phase 0 identifier
+(define wrapped #f)
+(define unwrap #f)
+
+;; rename this to wrap
+(define-for-syntax (pull stx)
+  (define (reverse-syntax stx)
+    (with-syntax ([(x ...) (reverse (syntax->list stx))])
+      #'(x ...)))
+  (define-syntax-class ellipses-class
+                       (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  ;; use this if you are defining your own ellipses identifier
+  #;
+  (define-syntax-class ellipses-class
+                       #:literals (...)
+                       (pattern my-ellipses))
+  (if (not (stx-pair? stx))
+    stx
+    (let ([stx (reverse (syntax->list stx))])
+      ;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...))
+      ;; (printf "stx is ~a\n" stx)
+      ;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
+      (syntax-parse stx
+        [(ellipses1:ellipses-class ellipses:ellipses-class ... x ...)
+         (with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))])
+           (reverse-syntax
+             (with-syntax ([wrapped #'wrapped]
+                           [original
+                            (with-syntax ([(ellipses* ...) (map (lambda (_)
+                                                            #'((... ...) (... ...)))
+                                                          (syntax->list #'(ellipses1 ellipses ...)))]
+                                          [(x-new ...) (generate-temporaries #'(x ...))])
+                              (reverse-syntax #'(ellipses* ... x-new ...)))]
+                           #;
+                           [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))])
+               #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))]
+        [(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))])
+                   (reverse-syntax #'(x* ...)))]))))
+
+(begin-for-syntax (trace pull))
+
+(define-for-syntax (unpull stx)
+  (define-syntax-class ellipses-class
+    (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  (syntax-parse stx
+                #:literals (wrapped unwrap)
+                [(unwrap (wrapped x ... y) ...)
+                 (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
+                   (with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))]
+                                 [(y* ...) (map unpull (syntax->list #'(y ...)))])
+                     #'(x1* ... y* ...)))]
+                [(unwrap . x) (raise-syntax-error 'unpull "unhandled unwrap ~a" stx)]
+                [(x ...) (with-syntax ([(x* ...) (map unpull (syntax->list #'(x ...)))])
+                           #'(x* ...))]
+                [else stx]))
+
+;; rename this to unwrap
+#;
+(define-syntax (unpull stx)
+  (define-syntax-class ellipses-class
+                       (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+  (define (do-it stx)
+    (syntax-parse stx
+      #:literals (wrapped)
+      [((wrapped x ... y) ...)
+       (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
+         #'(x1 ... y ...))]
+      [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
+       (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+         #'(x* ...  ellipses1 ellipses ...))]
+      [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+                 #'(x* ...))]
+      [else stx]))
+  (syntax-case stx ()
+    [(_ x ...) (do-it #'(x ...))]))
+
+;; (provide unpull)
+#;
+(define-honu-syntax unpull
+  (lambda (stx ctx)
+    (define-syntax-class ellipses-class
+      (pattern x:id #:when (free-identifier=? #'x #'(... ...))))
+    (define (do-it stx)
+      (syntax-parse stx
+                    #:literals (wrapped)
+                    [((wrapped x ... y) ...)
+                     (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))])
+                       #'(x1 ... y ...))]
+                    [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...)
+                     (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+                       #'(x* ...  ellipses1 ellipses ...))]
+                    [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
+                               (printf "x* is ~a\n" #'(x* ...))
+                               #'(x* ...))]
+                    [else stx]))
+    (syntax-case stx ()
+      [(_ x ...) (values (do-it #'(x ...))
+                         #'())])))
+ 
+#;
+(define-syntax (test stx)
+  (syntax-case stx ()
+    [(_ x ...)
+     (begin
+       (pretty-print (syntax->datum (pull #'(x ...))))
+       (pretty-print (syntax->datum (unpull (pull #'(x ...)))))
+       #'1)]))
+
+(define-syntax (my-syntax stx)
+  (syntax-case stx ()
+    [(_ name pattern template)
+     (with-syntax ([wrap-it (pull #'template)])
+       #'(define-syntax (name stx)
+           (syntax-case stx ()
+             [pattern #'wrap-it]
+             [else (raise-syntax-error 'name (format "~a does not match pattern ~a"
+                                                     (syntax->datum stx)
+                                                     'pattern))]
+             )))]))
+
+(define-syntax (test2 stx)
+  (syntax-case stx ()
+    [(_ x ...)
+     (begin
+       (with-syntax ([pulled (pull #'(x ...))])
+         #'(unpull pulled)))]))
+
+(define-honu-syntax honu-macro
+  (lambda (stx ctx)
+    (syntax-case stx (#%parens #%braces)
+      [(_ (#%parens honu-literal ...)
+          (#%braces (#%braces name pattern ...))
+          (#%braces (#%braces template ...))
+          . rest)
+       (with-syntax ([pulled (pull #'(template ...))])
+         (values
+          #'(define-honu-syntax name
+              (lambda (stx ctx)
+                (syntax-case stx (honu-literal ...)
+                  [(name pattern ... . rrest)
+                   (with-syntax ([(out (... ...)) (unpull #'pulled)])
+                     (values
+                      #'(honu-unparsed-block
+                         #f obj 'obj #f ctx
+                         out (... ...))
+                      #'rrest))])))
+          #'rest))])))
+
+;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...))
+;; (guz display (#%parens 1 2 3 4))
+
+;; (local-expand stx 'expression (list #'wrapped))
+
+#|
+(begin-for-syntax
+  (trace pull))
+(test display (#%parens x))
+(test display (#%parens x ... ...) ...)
+|#