[honu] analyze macro parameters at phase 2. temporarily break patterns

collects/honu/core/private/compile.rkt

@@ -116,6 +116,7 @@
 (define-syntax (racket-syntax stx)
   (syntax-case stx ()
     [(_ form)
+     (debug 2 "Racket syntax ~a\n" #'form)
      #'(parsed-syntax #'form)]))
 
 (begin-for-syntax

collects/honu/core/private/macro2.rkt

@@ -15,9 +15,14 @@
          (for-meta 2 syntax/parse
                      racket/base
                      macro-debugger/emit
+                     racket/syntax
+                     racket/set
+                     "literals.rkt"
+                     "debug.rkt"
                      (prefix-in phase2: "parse2.rkt")
                      (prefix-in phase2: "compile.rkt"))
          (prefix-in phase0: "compile.rkt")
+         racket/splicing
          "literals.rkt"
          "syntax.rkt"
          "debug.rkt"
@@ -26,6 +31,43 @@
          (for-syntax "honu-typed-scheme.rkt")
          syntax/parse)
 
+(module analysis racket/base
+  (require syntax/parse
+           (for-syntax racket/base
+                       "literals.rkt"
+                       syntax/parse))
+
+  (provide (all-defined-out))
+
+  (begin-for-syntax
+    (provide (all-defined-out))
+    (struct pattern-variable [name depth class] #:transparent)
+
+    ;; makes a syntax object with the right number of nested ellipses patterns
+    (define (pattern-variable->syntax variable)
+      (for/fold ([out (pattern-variable-name variable)])
+                ([depth (pattern-variable-depth variable)])
+                (with-syntax ([out out])
+                  #'(out (... ...))))))
+
+  (define-for-syntax (convert-pattern original-pattern new-names)
+    (define-splicing-syntax-class pattern-type
+        #:literal-sets (cruft)
+        [pattern (~seq name colon class)
+                 #:with (result ...)
+                 (with-syntax ([new-name (pattern-variable-name (hash-ref new-names (syntax-e #'name)))])
+                   #'((~var new-name class #:attr-name-separator "_")))]
+        [pattern (x:pattern-type ...) #:with (result ...) #'((x.result ... ...))]
+        [pattern x #:with (result ...) #'(x)])
+    (syntax-parse original-pattern
+      [(thing:pattern-type ...)
+       #'(thing.result ... ...)]))
+  
+  )
+
+(require (for-syntax (submod "." analysis)))
+
+#;
 (define-for-syntax (convert-pattern original-pattern new-names)
   (define-splicing-syntax-class pattern-type
     #:literal-sets (cruft)
@@ -49,6 +91,8 @@
       (with-syntax ([out out])
         #'(out (... ...))))))
 
+
+
 ;; reverse the syntax so that ellipses appear in front of the s-expr
 ;; then search for ellipses nodes and s-exprs of the form class:id %colon name:id
 ;; the output should match the ellipses depth, so for example
@@ -107,6 +151,59 @@
   (debug "Found variables ~a\n" variables)
   (for/list ([x variables]) x))
 
+(begin-for-syntax
+  (define-for-syntax (find-pattern-variables original-pattern)
+  (define (reverse-syntax input)
+    (syntax-parse input
+      [(x ...) (datum->syntax #'(x ...)
+                              (reverse (for/list ([x (syntax->list #'(x ...))])
+                                         (reverse-syntax x)))
+                              #'(x ...) #'(x ...))]
+      [x #'x]))
+  (define (merge set1 set2)
+    (debug "Merge ~a with ~a\n" set1 set2)
+    (set-union set1 set2))
+  (define (wrap-ellipses stuff)
+    (for/set ([variable stuff])
+      (pattern-variable (pattern-variable-name variable)
+                        (add1 (pattern-variable-depth variable))
+                        (pattern-variable-class variable))))
+  #;
+  (define (wrap-ellipses stuff)
+    (for/set ([name+result stuff])
+      (syntax-case name+result ()
+        [(name result)
+         #'((name (... ...))
+            (result (... ...)))])))
+  (define (find the-pattern)
+    (debug "Find in ~a\n" (syntax->datum the-pattern))
+    (define-splicing-syntax-class maybe
+                                  #:literal-sets (cruft)
+                                  #:literals ([ellipses ...])
+      [pattern (~seq class:id colon name:id)
+               #:attr result
+               (with-syntax ([name.result (format-id #'name "~a_result" #'name)])
+                             (set (pattern-variable #'name 0 #'class)))]
+      [pattern (~seq ellipses thing:maybe rest ...)
+               #:attr result
+               (merge (wrap-ellipses (attribute thing.result))
+                      (find #'(rest ...)))]
+      [pattern (x:maybe ...) #:attr result (apply set-union (attribute x.result))]
+      [pattern x #:attr result (set)])
+    (syntax-parse the-pattern
+      #:literals ([ellipses ...])
+      [(ellipses thing:maybe rest ...)
+       (debug "Ellipses case\n")
+       (merge (wrap-ellipses (attribute thing.result))
+              (find #'(rest ...)))]
+      [(thing:maybe rest ...)
+       (debug "Normal list case ~a\n" (attribute thing.result))
+       (merge (attribute thing.result) (find #'(rest ...)))]
+      [thing (set)]))
+  (define variables (find (reverse-syntax original-pattern)))
+  (debug "Found variables ~a\n" variables)
+  (for/list ([x variables]) x)))
+
 #;
 (define-for-syntax (find-pattern-variables original-pattern)
   (define-splicing-syntax-class pattern-type
@@ -132,7 +229,76 @@
      #;
      (honu->racket (parse-all #'(stuff ...)))])))
 
+(begin-for-syntax
+  (define-syntax (create-honu-macro stx)
+    (syntax-parse stx
+      [(_ (literal ...) (pattern ...) (action ...))
+       (define pattern-variables (find-pattern-variables #'(pattern ...)))
+
+       ;; only need a 1-to-1 mapping here
+       (define mapping (make-hash))
+       (for ([variable pattern-variables])
+         (debug "Update mapping for ~a\n" (pattern-variable-name variable))
+         (hash-set! mapping (syntax-e (pattern-variable-name variable))
+                    variable)) 
+       (debug "Create pattern\n")
+       (with-syntax ([(syntax-parse-pattern ...)
+                      (convert-pattern #'(pattern ...) mapping)]
+                     [((pattern-variable.name pattern-variable.result) ...)
+                      (for/list ([name pattern-variables])
+                        (debug "Create new pattern variable from ~a\n" name)
+                        (with-syntax ([name (pattern-variable->syntax name)]
+                                      [name.result (pattern-variable->syntax
+                                                     (pattern-variable (format-id (pattern-variable-name name)
+                                                                                  "~a_result"
+                                                                                  (pattern-variable-name name))
+                                                                       (pattern-variable-depth name)
+                                                                       (pattern-variable-class name)
+                                                                       ))])
+                          #'(name name.result)))])
+             (debug "Done with syntax\n")
+             (syntax (phase1:racket-syntax 
+                 (lambda (stx context-name)
+                   (define-literal-set local-literals (literal ...))
+                   (syntax-parse stx
+                     #:literal-sets ([cruft #:at name]
+                                     [local-literals #:at name])
+                     [(_ syntax-parse-pattern ... . more)
+                      (values
+                        ;; if the pattern is x:expression then x_result will
+                        ;; hold the parsed version of x, so we rebind x to
+                        ;; x_result so you can use just x in the template
+                        ;; instead of x_result. x_result is still there, too
+                        (with-syntax ([pattern-variable.name #'pattern-variable.result]
+                                      ...)
+                          (debug "~a = ~a\n" 'pattern-variable.name (syntax->datum #'pattern-variable.name)) ...
+                          (parse-stuff action ...))
+                        #'more #t)]
+                     [else (raise-syntax-error #f "Could not match macro" stx)])))))]))
+  )
+
 (provide honu-macro)
+(define-honu-syntax honu-macro
+  (lambda (code context)
+    (syntax-parse code #:literal-sets (cruft)
+      [(_ name (#%parens literal ...) (#%braces pattern ...) (#%braces action ...) . rest)
+       (values (phase1:racket-syntax
+                 ;; trampoline to phase 1
+                 (splicing-let-syntax ([make (lambda (stx)
+                                               (syntax-parse stx
+                                                 [(_ name)
+                                                  (define output 
+                                                    (create-honu-macro (literal ...)
+                                                                       (pattern ...)
+                                                                       (action ...)))
+                                                  (debug "Output from create macro ~a\n" output)
+                                                  (with-syntax ([output output])
+                                                    #'(define-honu-syntax name output))]))])
+                   (make name)))
+               #'rest
+               #t)])))
+
+#;
 (define-honu-syntax honu-macro 
   (lambda (code context)
     (debug "Macroize ~a\n" code)
@@ -253,8 +419,13 @@
                       [(syntax2* ...) #'something2])
           #'(%racket (unexpand (syntax1* ... syntax2* ...))))])]))
 
+;; honu-pattern should expand to
+;; (define-syntax honu-pattern ...)
+
 ;; creates a new syntax/parse pattern
 (provide honu-pattern)
+(define-honu-syntax honu-pattern (lambda (code context) #'f))
+#;
 (define-honu-syntax honu-pattern
   (lambda (code context)
     (define (generate-pattern name literals original-pattern maybe-out)