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

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

@ -61,50 +61,53 @@
#`(#,(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))) (syntax/parse:stxclass-attrs c)))
(syntax/parse:stxclass-attrs c))) (define/with-syntax (attr-name …) (map syntax/parse:attr-name attrs))
(define/with-syntax (attr-name …) (map syntax/parse:attr-name attrs)) (define/with-syntax (attr-name/ctx …)
(define/with-syntax (attr-name/ctx …) (stx-map (λ (a) (datum->syntax #'body (syntax-e a)))
(stx-map (λ (a) (datum->syntax #'body (syntax-e a))) #'(attr-name …)))
#'(attr-name …))) (define-temp-ids "~a/arg" (attr-name …))
(define-temp-ids "~a/arg" (attr-name …)) (define/with-syntax (attr-depth …)
(define/with-syntax (attr-depth …) (map syntax/parse:attr-depth attrs))
(map syntax/parse:attr-depth attrs)) (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 …))) (syntax/top-loc this-syntax
#'(begin (begin
(define (name stx2) (define (name stx2)
(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) (with-arrows
(syntax-parse stx2 (syntax-parameterize ([stx (make-rename-transformer #'stx2)])
[(_ colon-stxclass) . body]))) (syntax-parse stx2
(define def-private-simple-api [(_ colon-stxclass) . body]))))
(syntax-parameterize ([stx (make-rename-transformer #'stx/arg)]) (define def-private-simple-api
(syntax-parse #'nothing (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
[(~bind [(attr-name/ctx attr-depth) attr-name/arg] …) (syntax-parse #'nothing
. body]))) [(~bind [(attr-name/ctx attr-depth) attr-name/arg] …)
(define-syntax (name-forward stx3) . body])))
(syntax-case stx3 () (define-syntax (name-forward stx3)
[(_) (syntax-case stx3 ()
#`(private-simple-api [(_)
stx (quasisyntax/top-loc stx3
(attribute #,(datum->syntax stx3 'attr-name)) (private-simple-api
…)] stx
[(_ forward-args-prefix) (attribute #,(datum->syntax stx3 'attr-name))
(identifier? #'forward-args-prefix) …))]
#`(private-simple-api [(_ forward-args-prefix)
stx (identifier? #'forward-args-prefix)
(attribute #,(format-id stx3 "~a.~a" (quasisyntax/top-loc stx3
#'forward-args-prefix (private-simple-api
'attr-name)) stx
…)]))))]))) (attribute #,(format-id stx3 "~a.~a"
#'forward-args-prefix
'attr-name))
…))]))))])))