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

Allow curried function definitions in (define/syntax-parse+simple ((id-or-curry curry-args) stx-args) …)

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-05 02:16:53 +02:00
parent c7fd8ed550
commit 99ca3ede0d
1 changed files with 25 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -9,24 +9,15 @@
syntax/parse syntax/parse
racket/stxparam racket/stxparam
racket/syntax racket/syntax
phc-toolkit/untyped) phc-toolkit/untyped
"parameters.rkt")
(for-meta 2 (prefix-in syntax/parse: syntax/parse/private/residual-ct)) (for-meta 2 (prefix-in syntax/parse: syntax/parse/private/residual-ct))
(for-meta 2 racket/base) (for-meta 2 racket/base)
(for-meta 2 syntax/parse) (for-meta 2 racket/list)
(for-meta 2 racket/syntax) (for-meta 2 racket/syntax)
(for-meta 2 syntax/parse)
(for-meta 2 phc-toolkit/untyped)) (for-meta 2 phc-toolkit/untyped))
#;(define-syntax/case (define-syntax/parse+simple [name . args] . body) ()
(with-format-ids/inject-binders
([name-forward #'name "~a-forward-attributes" #'name]
[tmp-forward #'tmp "~a-forward-attributes" #'tmp])
#'(begin
(begin-for-syntax
(inject-sub-range-binders ...
(define/syntax-parse+simple [tmp . args] . body)
(define-syntax name-forward (make-rename-transformer #'tmp-forward))))
(define-syntax name tmp))))
(define-syntax/parse (define-syntax/parse+simple (~optional (~and two #:2)) (define-syntax/parse (define-syntax/parse+simple (~optional (~and two #:2))
[name . args] . body) [name . args] . body)
(with-format-ids/inject-binders (with-format-ids/inject-binders
@ -55,17 +46,30 @@
(pattern args)) (pattern args))
(define/syntax-parse+simple/stxclass [name args-stxclass] (define/syntax-parse+simple/stxclass [name args-stxclass]
. body-introduced)))])) . body-introduced)))]))
(define-for-syntax (change-name-or-curry stx new-name)
(if (identifier? stx)
new-name
#`(#,(change-name-or-curry (stx-car stx) new-name) . #,(stx-cdr stx))))
#;(define-for-syntax (pat-name-or-curry stx new-name)
(if (identifier? stx)
new-name
#`(#,(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
[(_ [name (~var cls (static syntax/parse:stxclass? "a syntax class"))] [(_ [name:name-or-curry
(~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-arrows
(define/with-syntax name-forward (define/with-syntax name-forward
(format-id/record #'name "~a-forward-attributes" #'name)) (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 (syntax/parse:stxclass-attrs c)) (define attrs (filter-not (λ (a) (is-clause-id-sym?
(syntax/parse:attr-name a)))
(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)))
@ -73,12 +77,15 @@
(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
(change-name-or-curry #'name
#'(private-simple-api stx/arg attr-name/arg …)))
#'(begin #'(begin
(define (name stx2) (define (name stx2)
(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 (private-simple-api stx/arg attr-name/arg …) (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
[(~bind [(attr-name/ctx attr-depth) attr-name/arg] …) [(~bind [(attr-name/ctx attr-depth) attr-name/arg] …)
@ -91,6 +98,7 @@
(attribute #,(datum->syntax stx3 'attr-name)) (attribute #,(datum->syntax stx3 'attr-name))
…)] …)]
[(_ forward-args-prefix) [(_ forward-args-prefix)
(identifier? #'forward-args-prefix)
#`(private-simple-api #`(private-simple-api
stx stx
(attribute #,(format-id stx3 "~a.~a" (attribute #,(format-id stx3 "~a.~a"