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. # packages without it getting stuck on a confirmation prompt.
script: script:
- raco test -x -p extensible-parser-specifications - 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: after_success:
- raco setup --check-pkg-deps --pkgs extensible-parser-specifications - 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 (for-syntax racket/base
syntax/parse syntax/parse
racket/stxparam racket/stxparam
racket/syntax) racket/syntax
(for-meta 2 phc-toolkit/untyped)
racket/base (for-meta 2 (prefix-in syntax/parse: syntax/parse/private/residual-ct))
syntax/parse (for-meta 2 racket/base)
racket/syntax (for-meta 2 syntax/parse)
phc-toolkit/untyped (for-meta 2 racket/syntax)
(prefix-in syntax/parse: syntax/parse/private/residual-ct))) (for-meta 2 phc-toolkit/untyped))
(define-simple-macro (define-syntax/parse+simple [name . args] . body) #;(define-syntax/case (define-syntax/parse+simple [name . args] . body) ()
#:with name-forward (format-id #'name "~a-forward-attributes" #'name) (with-format-ids/inject-binders
#:with tmp-forward (format-id #'tmp "~a-forward-attributes" #'tmp) ([name-forward #'name "~a-forward-attributes" #'name]
(begin [tmp-forward #'tmp "~a-forward-attributes" #'tmp])
(begin-for-syntax #'(begin
(define/syntax-parse+simple [tmp . args] . body) (begin-for-syntax
(define-syntax name-forward (make-rename-transformer #'tmp-forward))) (inject-sub-range-binders ...
(define-syntax name tmp))) (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 (begin-for-syntax
(define-syntax (define/syntax-parse+simple stx) (define-syntax (define/syntax-parse+simple stx)
@ -47,39 +61,39 @@
[(_ [name (~var cls (static syntax/parse:stxclass? "a syntax class"))] [(_ [name (~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 name-forward (format-id #'name "~a-forward-attributes" #'name) (with-arrows
(with-disappeared-uses (define/with-syntax name-forward
(let () (format-id/record #'name "~a-forward-attributes" #'name))
(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 (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))
#'(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 (private-simple-api stx/arg attr-name/arg …)
(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] …)
. body]))) . body])))
(define-syntax (name-forward stx3) (define-syntax (name-forward stx3)
(syntax-case stx3 () (syntax-case stx3 ()
[(_) [(_)
#`(private-simple-api #`(private-simple-api
stx stx
(attribute #,(datum->syntax stx3 'attr-name)) (attribute #,(datum->syntax stx3 'attr-name))
…)] …)]
[(_ forward-args-prefix) [(_ forward-args-prefix)
#`(private-simple-api #`(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))
…)])))))]))) …)]))))])))