119 lines
4.8 KiB
Racket
119 lines
4.8 KiB
Racket
#lang racket/base
|
|
|
|
(provide define-syntax/parse+simple
|
|
(for-syntax define/syntax-parse+simple))
|
|
|
|
(require phc-toolkit/untyped
|
|
syntax/parse/define
|
|
(for-syntax racket/base
|
|
syntax/parse
|
|
racket/stxparam
|
|
racket/syntax
|
|
phc-toolkit/untyped
|
|
"parameters.rkt")
|
|
(for-meta 2 (prefix-in syntax/parse: syntax/parse/private/residual-ct))
|
|
(for-meta 2 racket/base)
|
|
(for-meta 2 racket/list)
|
|
(for-meta 2 racket/syntax)
|
|
(for-meta 2 syntax/parse)
|
|
(for-meta 2 syntax/parse/experimental/template)
|
|
(for-meta 2 phc-toolkit/untyped))
|
|
|
|
(define-syntax/parse (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))))
|
|
|
|
(begin-for-syntax
|
|
(define-syntax (define/syntax-parse+simple stx)
|
|
(syntax-parse stx
|
|
[(_ (name:name-or-curry . args)
|
|
(~optional (~seq #:define-splicing-syntax-class define-splicing:id))
|
|
(~optional (~seq #:define-syntax-class define-class:id))
|
|
. body)
|
|
(let ()
|
|
(define introducer (make-syntax-introducer))
|
|
(define/with-syntax args-stxclass
|
|
(or (attribute define-class)
|
|
(introducer (datum->syntax #'args 'args-stxclass) 'add)))
|
|
(define/with-syntax body-introduced
|
|
(introducer #'body 'add))
|
|
(template
|
|
(begin
|
|
(?? (define-splicing-syntax-class define-splicing
|
|
#:auto-nested-attributes
|
|
(pattern {~seq . args})))
|
|
(define-syntax-class args-stxclass
|
|
#:auto-nested-attributes
|
|
(pattern args))
|
|
(define/syntax-parse+simple/stxclass [name . args-stxclass]
|
|
. 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
|
|
(syntax-parser-with-arrows
|
|
[(_ [name:name-or-curry
|
|
. (~var cls (static syntax/parse:stxclass? "a syntax class"))]
|
|
. body)
|
|
#:with colon-stxclass (format-id #'cls ":~a" #'cls)
|
|
#:with name-forward (format-id/record #'name.id
|
|
"~a-forward-attributes" #'name.id)
|
|
(define c (syntax-local-value/record #'cls syntax/parse:stxclass?))
|
|
(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/ctx …)
|
|
(stx-map (λ (a) (datum->syntax #'body (syntax-e a)))
|
|
#'(attr-name …)))
|
|
(define-temp-ids "~a/arg" (attr-name …))
|
|
(define/with-syntax (attr-depth …)
|
|
(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 …)))
|
|
(syntax/top-loc this-syntax
|
|
(begin
|
|
(define (name stx2)
|
|
(with-arrows
|
|
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
|
(syntax-parse stx2
|
|
[(_ . colon-stxclass) . body]))))
|
|
(define def-private-simple-api
|
|
(syntax-parameterize ([stx (make-rename-transformer #'stx/arg)])
|
|
(syntax-parse #'nothing
|
|
[(~bind [(attr-name/ctx attr-depth) attr-name/arg] …)
|
|
. body])))
|
|
(define-syntax (name-forward stx3)
|
|
(syntax-case stx3 ()
|
|
[(_)
|
|
(quasisyntax/top-loc stx3
|
|
(private-simple-api
|
|
stx
|
|
(attribute #,(datum->syntax stx3 'attr-name))
|
|
…))]
|
|
[(_ forward-args-prefix)
|
|
(identifier? #'forward-args-prefix)
|
|
(quasisyntax/top-loc stx3
|
|
(private-simple-api
|
|
stx
|
|
(attribute #,(format-id stx3 "~a.~a"
|
|
#'forward-args-prefix
|
|
'attr-name))
|
|
…))]))))]))) |