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

Speed up --check-pkg-deps

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-30 23:06:00 +02:00
parent ff12ed2af4
commit 8e460716ed
2 changed files with 66 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.travis.yml
View File

@ -50,6 +50,7 @@ before_script:
# packages without it getting stuck on a confirmation prompt.
script:
- raco test -x -p extensible-parser-specifications
- raco setup --check-pkg-deps --no-zo --no-launcher --no-install --no-post-install --no-docs --pkgs extensible-parser-specifications
after_success:
- raco setup --check-pkg-deps --pkgs extensible-parser-specifications

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

@ -8,22 +8,36 @@
(for-syntax racket/base
syntax/parse
racket/stxparam
racket/syntax)
(for-meta 2
racket/base
syntax/parse
racket/syntax
phc-toolkit/untyped
(prefix-in syntax/parse: syntax/parse/private/residual-ct)))
racket/syntax
phc-toolkit/untyped)
(for-meta 2 (prefix-in syntax/parse: syntax/parse/private/residual-ct))
(for-meta 2 racket/base)
(for-meta 2 syntax/parse)
(for-meta 2 racket/syntax)
(for-meta 2 phc-toolkit/untyped))
(define-simple-macro (define-syntax/parse+simple [name . args] . body)
#:with name-forward (format-id #'name "~a-forward-attributes" #'name)
#:with tmp-forward (format-id #'tmp "~a-forward-attributes" #'tmp)
(begin
(begin-for-syntax
(define/syntax-parse+simple [tmp . args] . body)
(define-syntax name-forward (make-rename-transformer #'tmp-forward)))
(define-syntax name tmp)))
#;(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))
[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)
@ -47,39 +61,39 @@
[(_ [name (~var cls (static syntax/parse:stxclass? "a syntax class"))]
. body)
#:with colon-stxclass (format-id #'cls ":~a" #'cls)
#:with name-forward (format-id #'name "~a-forward-attributes" #'name)
(with-disappeared-uses
(let ()
(define c (syntax-local-value/record #'cls syntax/parse:stxclass?))
(define attrs (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))
#'(begin
(define (name stx2)
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
(syntax-parse stx2
[(_ . colon-stxclass) . body])))
(define (private-simple-api stx/arg attr-name/arg …)
(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 ()
[(_)
#`(private-simple-api
stx
(attribute #,(datum->syntax stx3 'attr-name))
…)]
[(_ forward-args-prefix)
#`(private-simple-api
stx
(attribute #,(format-id stx3 "~a.~a"
#'forward-args-prefix
'attr-name))
…)])))))])))
(with-arrows
(define/with-syntax name-forward
(format-id/record #'name "~a-forward-attributes" #'name))
(define c (syntax-local-value/record #'cls syntax/parse:stxclass?))
(define attrs (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))
#'(begin
(define (name stx2)
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
(syntax-parse stx2
[(_ . colon-stxclass) . body])))
(define (private-simple-api stx/arg attr-name/arg …)
(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 ()
[(_)
#`(private-simple-api
stx
(attribute #,(datum->syntax stx3 'attr-name))
…)]
[(_ forward-args-prefix)
#`(private-simple-api
stx
(attribute #,(format-id stx3 "~a.~a"
#'forward-args-prefix
'attr-name))
…)]))))])))