suzanne.soy/extensible-parser-specifications
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed missing with-arrows, cleanup

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-07 00:58:28 +02:00
parent 9b90a03c02
commit 32a7685908
1 changed files with 50 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
private/define-syntax+simple-api.rkt
View File

@ -61,14 +61,13 @@
#`(#,(pat-name-or-curry (stx-car stx) new-name) . #,(gensym 'args)))) #`(#,(pat-name-or-curry (stx-car stx) new-name) . #,(gensym 'args))))
(define-syntax define/syntax-parse+simple/stxclass (define-syntax define/syntax-parse+simple/stxclass
(syntax-parser (syntax-parser-with-arrows
[(_ [name:name-or-curry [(_ [name:name-or-curry
(~var cls (static syntax/parse:stxclass? "a syntax class"))] (~var cls (static syntax/parse:stxclass? "a syntax class"))]
. body) . body)
#:with colon-stxclass (format-id #'cls ":~a" #'cls) #:with colon-stxclass (format-id #'cls ":~a" #'cls)
(with-arrows #:with name-forward (format-id/record #'name.id
(define/with-syntax name-forward "~a-forward-attributes" #'name.id)
(format-id/record #'name.id "~a-forward-attributes" #'name.id))
(define c (syntax-local-value/record #'cls syntax/parse:stxclass?)) (define c (syntax-local-value/record #'cls syntax/parse:stxclass?))
(define attrs (filter-not (λ (a) (is-clause-id-sym? (define attrs (filter-not (λ (a) (is-clause-id-sym?
(syntax/parse:attr-name a))) (syntax/parse:attr-name a)))
@ -83,11 +82,13 @@
(define/with-syntax def-private-simple-api (define/with-syntax def-private-simple-api
(change-name-or-curry #'name (change-name-or-curry #'name
#'(private-simple-api stx/arg attr-name/arg …))) #'(private-simple-api stx/arg attr-name/arg …)))
#'(begin (syntax/top-loc this-syntax
(begin
(define (name stx2) (define (name stx2)
(with-arrows
(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
(syntax-parse stx2 (syntax-parse stx2
[(_ colon-stxclass) . body]))) [(_ colon-stxclass) . body]))))
(define def-private-simple-api (define def-private-simple-api
(syntax-parameterize ([stx (make-rename-transformer #'stx/arg)]) (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
(syntax-parse #'nothing (syntax-parse #'nothing
@ -96,15 +97,17 @@
(define-syntax (name-forward stx3) (define-syntax (name-forward stx3)
(syntax-case stx3 () (syntax-case stx3 ()
[(_) [(_)
#`(private-simple-api (quasisyntax/top-loc stx3
(private-simple-api
stx stx
(attribute #,(datum->syntax stx3 'attr-name)) (attribute #,(datum->syntax stx3 'attr-name))
…)] …))]
[(_ forward-args-prefix) [(_ forward-args-prefix)
(identifier? #'forward-args-prefix) (identifier? #'forward-args-prefix)
#`(private-simple-api (quasisyntax/top-loc stx3
(private-simple-api
stx stx
(attribute #,(format-id stx3 "~a.~a" (attribute #,(format-id stx3 "~a.~a"
#'forward-args-prefix #'forward-args-prefix
'attr-name)) 'attr-name))
…)]))))]))) …))]))))])))