diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index c53b999793..9ed6fee74f 100644 --- a/collects/honu/main.rkt +++ b/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) diff --git a/collects/honu/private/literals.rkt b/collects/honu/private/literals.rkt index 50a8c2a22f..6689f0480e 100644 --- a/collects/honu/private/literals.rkt +++ b/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) diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 32de54e6ae..93e2a0f5e3 100644 --- a/collects/honu/private/macro.rkt +++ b/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) diff --git a/collects/honu/private/more.ss b/collects/honu/private/more.ss index 2df52ad8fe..a9dfdf2f44 100644 --- a/collects/honu/private/more.ss +++ b/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)]))) - diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index 1cdfc81a9a..f6a40da7c9 100644 --- a/collects/honu/private/parse.rkt +++ b/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) - [pattern (~seq (~var e (honu-expr context)) (#%parens (~seq (~var arg (ternary context)) - (~optional honu-comma)) ...)) - #:with call #'(e.result arg.result ...)]) + #:literals (honu-comma #%parens) + + #; + [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