suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

allow comma in templates

Browse Source
This commit is contained in:
Jon Rafkind 2010-08-04 11:21:01 -06:00
parent 86e7b98d65
commit c45aba592d
4 changed files with 68 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/honu/core/private/macro.rkt
View File

@ -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 ...)

4
collects/honu/core/private/parse.rkt
View File

@ -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"))

4
collects/honu/private/function.honu
View File

@ -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 ...)) }

2
collects/honu/private/struct.honu
View File

@ -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 ...))
}