suzanne.soy/phc-toolkit
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases Wiki Activity

Moved ~rx-id from phc-graph

Browse Source
This commit is contained in:
Georges Dupéron 2017-07-14 01:21:58 +02:00
parent 232eaa4317
commit 902b858c5b
1 changed files with 19 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
syntax-parse.rkt
View File

@ -36,6 +36,7 @@
~with ~with
~attr ~attr
~or-bug ~or-bug
~rx-id
(rename-out [~or-bug ~either]) (rename-out [~or-bug ~either])
define-simple-macro define-simple-macro
;template/loc ;template/loc
@ -99,10 +100,10 @@
(define/with-syntax name (define/with-syntax name
(format-id #'kw "~a" (keyword->string (syntax-e #'kw)))) (format-id #'kw "~a" (keyword->string (syntax-e #'kw))))
#`(#,base-pattern (~seq (~and name kw) pat ...) #`(#,base-pattern (~seq (~and name kw) pat ...)
#,@(if name? #,@(if name?
#`(#:name #,(format "the ~a keyword" #`(#:name #,(format "the ~a keyword"
(syntax-e #'kw))) (syntax-e #'kw)))
#'())))])) #'())))]))
(define-syntax ~optkw (define-syntax ~optkw
(pattern-expander (pattern-expander
@ -293,4 +294,17 @@
#:attributes (id) #:attributes (id)
(pattern id:id) (pattern id:id)
(pattern (:name-or-curry . curry-args)))) (pattern (:name-or-curry . curry-args))))
(require 'm-name-or-curry)) (require 'm-name-or-curry)
(define (match-id [rx : Regexp] [id : Identifier])
(let ([m (regexp-match rx (symbol->string (syntax-e id)))])
(and m (map (λ ([% : (U #f String)])
(and % (datum->syntax id (string->symbol %) id id)))
(cdr m)))))
(define-syntax ~rx-id
(pattern-expander
(λ (stx)
(syntax-case stx ()
[(_ rx . g*)
#'(~and x:id
{~parse g* (match-id rx #'x)})])))))