honu-syntax supports commas

collects/honu/main.rkt

@@ -68,6 +68,8 @@
                      identifier expression
                      (rename-out (semicolon \;
                                             )
+                                 (ellipses-comma ec)
+                                 (expression-comma expression_comma)
                                  (parse-an-expr parse)
                                  (... scheme:...)
                                  (honu-body:class body)

collects/honu/private/literals.rkt

@@ -16,4 +16,5 @@
                 honu-= honu-+= honu--= honu-*= honu-/= honu-%=
                 honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
                 honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
-                honu-? honu-: honu-comma honu-. #%braces #%parens colon)
+                honu-? honu-: honu-comma honu-. #%braces #%parens colon
+                ellipses-comma)

collects/honu/private/macro.rkt

@@ -69,9 +69,9 @@
 
 (define-for-syntax (fix-template stx)
   (syntax-parse stx #:literals (honu-:)
-    [(variable:id honu-: class:id rest ...)
+    [(variable:identifier honu-: class:identifier rest ...)
      (with-syntax ([(rest* ...) (fix-template #'(rest ...))])
-       (datum->syntax stx (cons #'(~var variable class)
+       (datum->syntax stx (cons #'(~var variable class #:attr-name-separator "_")
                                 #'(rest* ...))
                       stx)
        #;
@@ -426,6 +426,7 @@
                  (with-syntax ([(fixed ...) (fix-template #'(template ...))]
                                [your-parens (datum->syntax #'name '#%parens #'name)])
 
+                   #;
                    #'(define-honu-syntax name
                        (lambda (stx ctx)
                          (syntax-parse stx #:literals (your-parens literals ...)
@@ -438,7 +439,7 @@
                               (let ([result (honu-unparsed-begin code ...)])
                                 (lambda () result))
                               #'(rrest (... ...)))])))
-                   #;
+                   (printf "Original pattern ~a" (syntax->datum #'(fixed ... rrest (... ...))))
                    (syntax/loc stx
                                (define-honu-syntax name
                                  (lambda (stx ctx)

collects/honu/private/more.ss

@@ -2,15 +2,79 @@
 
 (require "honu-typed-scheme.ss"
          "literals.ss"
+         syntax/parse
          (for-syntax syntax/parse
                      syntax/stx
+                     racket/list
+                     (only-in racket (... scheme-ellipses))
                      "literals.ss")
          (for-template "honu-typed-scheme.ss"
                        "literals.ss"
+                       (only-in racket ...)
                        ))
 
 (provide (all-defined-out))
 
+(define (replace-commas stuff)
+    (syntax-parse stuff #:literals (ellipses-comma)
+      [((ellipses-comma z) thing blah ...)
+       (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
+         #'(z honu-comma rest ...))]
+      [((ellipses-comma z)) #'z]
+      [(z rest ...)
+       (with-syntax ([z* (replace-commas #'z)]
+                     [(rest* ...) (replace-commas #'(rest ...))])
+         #'(z* rest* ...))]
+      [else stuff]))
+
+(define-syntax (fix-template stuff)
+  (define (fix stuff)
+    (printf "Macro fix template for ~a\n" (syntax->datum stuff))
+    (syntax-parse stuff #:literals (ellipses-comma)
+      [(any ellipses-comma rest ...)
+       (define (addit item)
+         (with-syntax ([i item])
+           #'(i honu-comma)))
+       (define (remove-last list)
+         (take list (sub1 (length list))))
+       (define (add-commas stuff)
+         (remove-last (apply append (map syntax->list (map addit (syntax->list stuff))))))
+       (with-syntax ([(any* ...) (add-commas #'any)]
+                     [(rest* ...) (fix #'(rest ...))])
+         #'(any* ... rest* ...))]
+      [(one rest ...)
+       (with-syntax ([one* (fix #'one)]
+                     [(rest* ...) (fix #'(rest ...))])
+         (datum->syntax stuff (cons #'one*
+                                    #'(rest* ...))
+                        stuff)
+         #;
+         #'(one* rest* ...))]
+      [else stuff]))
+  (define (replace stuff)
+    (syntax-parse stuff #:literals (ellipses-comma)
+      [(a ellipses-comma rest ...)
+       (with-syntax ([a* (replace #'a)]
+                     [(rest* ...) (replace #'(rest ...))])
+         #'((ellipses-comma a*) (... ...) rest* ...))]
+      [(z rest ...)
+       (with-syntax ([z* (replace #'z)]
+                     [(rest* ...) (replace #'(rest ...))])
+         #'(z* rest* ...))]
+      [else stuff]))
+  
+  (printf "Do fix template for ~a\n" (syntax->datum stuff))
+  (syntax-parse stuff
+    [(_ blah)
+     (let ([replaced (replace #'blah)])
+       (printf "Replaced ~a\n" (syntax->datum replaced))
+       (with-syntax ([out2 replaced])
+         (let ([x #'(replace-commas #'out2)])
+           (printf "Final syntax ~a\n" (syntax->datum x))
+           x)))]
+    #;
+    [(_ blah ...) (fix #'(blah ...))]))
+
 (define-honu-syntax honu-syntax
   (lambda (stx ctx)
     (syntax-parse stx #:literals (semicolon #%parens)
@@ -23,13 +87,35 @@
                [(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
                [else (printf "~a is *not* a pattern variable\n" what)]))
 
+           #;
            (printf "Original code is ~a\n" (syntax->datum #'(expr ...)))
+           #;
            (printf "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...))))
+           #;
            (for-each show-pattern-variables (syntax->list #'(expr ...)))
            ;; outer is relative phase 1, inner is relative phase 0
+           #|
            #'#'(honu-unparsed-begin expr ...)
+           |#
+
+           #;
+           (syntax (fix-template (syntax (honu-unparsed-begin expr ...))))
+
+           #;
+           (with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
+             #'a)
+
+           #'(fix-template (honu-unparsed-begin expr ...))
+
+           #;
+           (let ([x #'(fix-template (honu-unparsed-begin expr ...))])
+             (printf "Final syntax ~a\n" (syntax->datum x))
+             x)
+
+           #;
+           #'(fix-template 1 2 3)
+
            #;
            (with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())])
              #'(honu-unparsed-begin out ...)))
          #'rest)])))
-

collects/honu/private/parse.rkt

@@ -14,10 +14,19 @@
          syntax/name
          syntax/stx
          (for-syntax "util.ss")
+         (for-syntax syntax/private/stxparse/runtime-prose
+                     syntax/private/stxparse/runtime
+                     )
          (for-template scheme/base))
 
 (provide (all-defined-out))
 
+(begin-for-syntax 
+  (current-failure-handler
+                         (lambda (_ f)
+                           (printf "Failure is ~a\n" (failure->sexpr (simplify-failure f)))
+                           (error 'failed "whatever"))))
+
 (define-syntax-class block
                      #:literals (#%braces)
   [pattern (#%braces statement ...)
@@ -110,10 +119,17 @@
 =======
                                    (list rest (syntax-object-position stx rest)
                                          (used))))]
-     
+     #;
+     [x:identifier (list #''() 0 #'x)]
+     #;
+     [else (fail)]
      [else (syntax-parse stx
+             [x:identifier (list #''() 1 #'x)]
+             #;
                         [(f . rest) (list #'rest 1 #'f)]
-                        [x:number (list #''() 0 #'x)]
+                        #;
+                        [x:number (list #''() 1 #'x)]
+                        [else (fail)]
                         )])))
 >>>>>>> allow macros to reparse their input
 
@@ -122,20 +138,42 @@
       [pattern (~seq f ...) #:with result])
     
 (define-splicing-syntax-class (call context)
-  #:literals (honu-comma)
+  #:literals (honu-comma #%parens)
-  [pattern (~seq (~var e (honu-expr context)) (#%parens (~seq (~var arg (ternary context))
+
-                                                              (~optional honu-comma)) ...))
+  #;
-           #:with call #'(e.result arg.result ...)])
+  [pattern (~seq (~var e identifier)
+                 (x (~var arg (expression-1 context)) ...)
+                 #;
+                 (#%parens (~var arg (expression-1 context)) ...))
+           #:with call 
+           (begin
+             (printf "Resulting call is ~a\n" (syntax->datum #'(e arg.result ...)))
+           #'(e arg.result ...))]
+
+  [pattern (~seq (~var e honu-identifier
+                       #;
+                       (honu-expr context))
+                 (x
+                  ;; #%parens
+                       (~seq (~var arg (ternary context))
+                             (~optional honu-comma)) ...))
+           #:with call 
+           (begin
+             (printf "Resulting call is ~a\n" (syntax->datum #'(e arg.result ...)))
+             #'(e arg.result ...))])
+
+(define-splicing-syntax-class honu-identifier
+  [pattern (~seq x:identifier) #:when (not (free-identifier=? #'honu-comma #'x))])
 
 (define-splicing-syntax-class (expression-last context)
                               #:literals (#%parens)
   [pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result]
+  #;
   [pattern (~seq (~var e (honu-transformer context))) #:with result #'e.result]
-
   [pattern (~seq (~var call (call context))) #:with result #'call.call]
   [pattern (~seq x:number) #:with result #'x]
   [pattern (~seq x:str) #:with result #'x]
-  [pattern (~seq x:identifier) #:with result #'x]
+  [pattern (~seq x:honu-identifier) #:with result #'x]
   #;
   [pattern (~seq (~var e (honu-expr context))) #:with result #'e.result]
   )
@@ -348,6 +386,10 @@
 (define-splicing-syntax-class expression
   [pattern (~seq (~var x (expression-1 the-expression-context)))])
 
+(define-splicing-syntax-class expression-comma
+  #:literals (honu-comma)
+  [pattern ((~seq (~var expr (expression-1 the-expression-context)) (~optional comma)) ...)])
+
 (define (parse-an-expr stx)
   (printf "Parse an expr ~a\n" (syntax->datum stx))
   (syntax-parse (with-syntax ([s stx])
@@ -363,6 +405,11 @@
 
 (define (parse-block-one/2 stx context)
   (define (parse-one stx context)
+    #;
+    (let-values ([(a b) (debug-parse #'(SQL_create_insert) ((~seq x:expression)))])
+      (printf "debug parse for ~a is ~a and ~a\n" 'SQL_create_insert a b))
+    (let-values ([(a b) (debug-parse stx ((~seq (~var x (expression-top context)))))])
+      (printf "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b))
     
     ;; (printf "~a\n" (syntax-class-parse function stx))
     (syntax-parse stx