From c45aba592d7541351490c701ef74d9c16ad1a688 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 4 Aug 2010 11:21:01 -0600 Subject: [PATCH] allow comma in templates --- collects/honu/core/private/macro.rkt | 82 +++++++++++++++++++++------- collects/honu/core/private/parse.rkt | 4 +- collects/honu/private/function.honu | 4 +- collects/honu/private/struct.honu | 2 +- 4 files changed, 68 insertions(+), 24 deletions(-) diff --git a/collects/honu/core/private/macro.rkt b/collects/honu/core/private/macro.rkt index 75ce186000..a6a5dd9894 100644 --- a/collects/honu/core/private/macro.rkt +++ b/collects/honu/core/private/macro.rkt @@ -86,23 +86,52 @@ [else (list)])) (define-for-syntax (fix-template stx) - (syntax-parse stx #:literals (honu-:) - [(variable:identifier honu-: class:identifier rest ...) - (with-syntax ([(rest* ...) (fix-template #'(rest ...))]) - (datum->syntax stx (cons #'(~var variable class #:attr-name-separator "_") - #'(rest* ...)) - stx) - #; - #'((~var variable class) rest* ...))] - [(one rest ...) - (with-syntax ([one* (fix-template #'one)] - [(rest* ...) (fix-template #'(rest ...))]) - (datum->syntax stx (cons #'one* - #'(rest* ...)) - stx) - #; - #'(one* rest* ...))] - [else stx])) + (define (fix-classes stx) + (syntax-parse stx #:literals (honu-:) + [(variable:identifier honu-: class:identifier rest ...) + (with-syntax ([(rest* ...) (fix-template #'(rest ...))]) + (datum->syntax stx (cons #'(~var variable class #:attr-name-separator "_") + #'(rest* ...)) + stx) + #; + #'((~var variable class) rest* ...))] + [(one rest ...) + (with-syntax ([one* (fix-template #'one)] + [(rest* ...) (fix-template #'(rest ...))]) + (datum->syntax stx (cons #'one* + #'(rest* ...)) + stx) + #; + #'(one* rest* ...))] + [else stx])) + ;; removes commas from a pattern + (define (fix-commas stx) + (syntax-parse stx + #:literals (honu-comma + [ellipses ...]) + [(a honu-comma ellipses rest ...) + (with-syntax ([a* (fix-commas #'a)] + [(rest* ...) (fix-commas #'(rest ...))]) + (datum->syntax stx + `((~seq ,#'a* (~optional |,|)) ... ,@#'(rest* ...)) + stx stx) + #; + (datum->syntax stx + (cons + #'a* + (cons + #'(... ...) + #'(rest* ...))) + stx stx))] + [(z rest ...) + (with-syntax ([z* (fix-commas #'z)] + [(rest* ...) (fix-commas #'(rest ...))]) + (datum->syntax stx + (cons #'z* #'(rest* ...)) + stx stx))] + [else stx])) + (define all-fixes (compose fix-commas fix-classes)) + (all-fixes stx)) #| (define-for-syntax (fix-template stx) @@ -466,11 +495,25 @@ (define foobar 0) - (define-honu-syntax honu-macro (lambda (stx ctx) (define-splicing-syntax-class patterns #:literal-sets ([cruft #:phase (syntax-local-phase-level)]) + #; + [pattern (~seq x ...) + #:with (template ...) '() + #:with (code ...) '() + #:with (fixed ...) '() + #:when (begin + (printf "Trying to parse ~a\n" (syntax->datum #'(x ...))) + #f)] + #; + [pattern (~seq (#%braces template ...) + (#%braces code ...)) + #:with (fixed ...) '() + #:when (begin + (printf "Got template as ~a. Code is ~a\n" (syntax->datum #'(template ...)) (syntax->datum #'(code ...))) + #f)] [pattern (~seq (#%braces template ...) (#%braces code ...)) #:with (fixed ...) (fix-template #'(template ...))]) @@ -495,7 +538,7 @@ [your-braces (datum->syntax #'name '#%braces #'name)] #; [your-parens (datum->syntax #'name '#%parens #'name)]) - + ;;(printf "Ok macro3 go!\n") #; #'(define-honu-syntax name (lambda (stx ctx) @@ -517,6 +560,7 @@ (lambda (stx ctx) #; (printf "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx)) + (printf "~a pattern is ~a\n" 'name '(pattern.fixed ... ...)) (syntax-parse stx #:literal-sets ([cruft #:at name]) #:literals (foobar literals ...) diff --git a/collects/honu/core/private/parse.rkt b/collects/honu/core/private/parse.rkt index 7d4efa04a2..8db7b4bf03 100644 --- a/collects/honu/core/private/parse.rkt +++ b/collects/honu/core/private/parse.rkt @@ -149,7 +149,7 @@ #f)] [pattern (~seq (~var e (expression-simple context)) - (~var dx (debug-here (format "call 1 ~a" #'e))) + (~var dx (debug-here (format "call 1 ~a" (syntax->datum #'e)))) (#%parens (~seq (~var dz (debug-here (format "call 2"))) (~var arg (ternary context)) @@ -346,7 +346,7 @@ (define-splicing-syntax-class (ternary context) #:literals (honu-? honu-:) [pattern (~seq (~var condition (expression-1 context)) - (~var x1 (debug-here (format "ternary 1 ~a\n" #'condition.result))) + (~var x1 (debug-here (format "ternary 1 ~a\n" (syntax->datum #'condition.result)))) (~optional (~seq honu-? (~var on-true (ternary context)) honu-: (~var on-false (ternary context)))) (~var x2 (debug-here "ternary 2")) diff --git a/collects/honu/private/function.honu b/collects/honu/private/function.honu index 7160f60c9f..ee768e0249 100644 --- a/collects/honu/private/function.honu +++ b/collects/honu/private/function.honu @@ -2,8 +2,8 @@ provide function; macro function () - { _ name:identifier (args:identifier ...) { body ... } } + { _ name:identifier (args:identifier , ...) { body ... } } { #sx scheme:syntax #sx(define (name_result args_result ...) (honu-unparsed-begin body ...)) } - { _ (args:identifier ...) { body ... }} + { _ (args:identifier , ...) { body ... }} { #sx scheme:syntax #sx(lambda (args_result ...) (honu-unparsed-begin body ...)) } diff --git a/collects/honu/private/struct.honu b/collects/honu/private/struct.honu index c7cf89cf38..c75eb5a050 100644 --- a/collects/honu/private/struct.honu +++ b/collects/honu/private/struct.honu @@ -4,7 +4,7 @@ require (forSyntax "struct-patterns.honu"); provide struct; macro struct () { - _ name {field:structField ...} ; + _ name {field:structField, ...} ; } { schemeSyntax#sx(honu-struct name (field_name_result ...)) }