suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add pattern-expanders to syntax/parse

Browse Source
This commit is contained in:
AlexKnauth 2014-08-20 15:13:37 -04:00 committed by Ryan Culpepper
parent 89690c6de9
commit 81cc6bf4d0
6 changed files with 165 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
pkgs/racket-pkgs/racket-doc/syntax/scribblings/parse/patterns.scrbl
View File

@ -1033,3 +1033,46 @@ definition in a @racket[~do] block.
[(a b (~do (printf "a was ~s\n" #'a)) c:id) 'ok])
]
}
@;{--------}
@section{Pattern Expanders}
@defproc[(pattern-expander [proc (-> syntax? syntax?)]) pattern-expander?]{
returns a pattern-expander that uses @racket[proc] to transform the pattern.
@myexamples[
(define-syntax ~foo
(pattern-expander
(syntax-rules ()
[(_ pat) pat])))
]}
@defthing[prop:pattern-expander (struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]{
a struct-type property for pattern-expanders.
@myexamples[
(begin-for-syntax
(struct thing (proc pattern-expander) #:transparent
#:property prop:procedure (struct-field-index proc)
#:property prop:pattern-expander (λ (this) (thing-pattern-expander this))))
(define-syntax ~foo
(thing
(lambda (stx) #'"I am the macro ~foo")
(lambda (stx) #'"I am the pattern-expander ~foo")))
]}
@defproc[(pattern-expander? [v any/c]) boolean?]{
returns @racket[#t] if @racket[v] is a pattern expander, otherwise returns @racket[#f].
}
@defproc[(pattern-expander-proc [pat-exp pattern-expander?]) (-> syntax? syntax?)]{
returns the transformer procedure used by @racket[pat-exp].
}
@defproc[(syntax-local-syntax-parse-pattern-introduce [stx syntax?]) syntax?]{
like @racket[syntax-local-introduce], but for pattern-expanders.
}

34
pkgs/racket-pkgs/racket-test/tests/stxparse/test.rkt
View File

@ -542,3 +542,37 @@
#:attributes (a)
[pattern ((~seq (~optional :one #:defaults [(a 'bar)])))])
(void)))
;; from http://lists.racket-lang.org/users/archive/2014-June/063095.html
(test-case "pattern-expanders"
(let ()
(define-splicing-syntax-class binding #:literals (=)
[pattern (~seq name:id = expr:expr)])
(define-syntax ~separated
(pattern-expander
(lambda (stx)
(syntax-case stx ()
[(separated sep pat)
(with-syntax ([ooo '...])
#'((~seq pat (~or (~peek-not _)
(~seq sep (~peek _))))
ooo))]))))
(define-splicing-syntax-class bindings
[pattern (~separated (~datum /) b:binding)
#:with (name ...) #'(b.name ...)
#:with (expr ...) #'(b.expr ...)])
(define (parse-my-let stx)
(syntax-parse stx
[(_ bs:bindings body)
#'(let ([bs.name bs.expr] ...)
body)]))
(check-equal? (syntax->datum
(parse-my-let #'(my-let (x = 1 / y = 2 / z = 3)
(+ x y z))))
(syntax->datum #'(let ([x 1] [y 2] [z 3])
(+ x y z))))
))

6
racket/collects/syntax/parse/pre.rkt
View File

@ -1,10 +1,12 @@
#lang racket/base
(require "private/sc.rkt"
"private/litconv.rkt"
"private/lib.rkt")
"private/lib.rkt"
(for-syntax "private/pattern-expander.rkt"))
(provide (except-out (all-from-out "private/sc.rkt")
define-integrable-syntax-class
syntax-parser/template
parser/rhs)
(all-from-out "private/litconv.rkt")
(all-from-out "private/lib.rkt"))
(all-from-out "private/lib.rkt")
(for-syntax (all-from-out "private/pattern-expander.rkt")))

31
racket/collects/syntax/parse/private/pattern-expander-prop.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket/base
(require racket/contract/base)
(define-values (prop:pattern-expander pattern-expander? get-proc-getter)
(make-struct-type-property 'pattern-expander))
(define (pattern-expander-proc pat-expander)
(define get-proc (get-proc-getter pat-expander))
(get-proc pat-expander))
(define current-syntax-parse-pattern-introducer
(make-parameter
(lambda (stx)
(error 'syntax-local-syntax-parse-pattern-introduce "not expanding syntax-parse pattern"))))
(define (syntax-local-syntax-parse-pattern-introduce stx)
((current-syntax-parse-pattern-introducer) stx))
(provide (contract-out
[prop:pattern-expander
(struct-type-property/c (-> pattern-expander? (-> syntax? syntax?)))]
[pattern-expander?
(-> any/c boolean?)]
[pattern-expander-proc
(-> pattern-expander? (-> syntax? syntax?))]
[current-syntax-parse-pattern-introducer
(parameter/c (-> syntax? syntax?))]
[syntax-local-syntax-parse-pattern-introduce
(-> syntax? syntax?)]
))

25
racket/collects/syntax/parse/private/pattern-expander.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(provide prop:pattern-expander
pattern-expander
pattern-expander?
pattern-expander-proc
syntax-local-syntax-parse-pattern-introduce
)
(require "pattern-expander-prop.rkt")
(module pattern-expander-struct racket/base
(require racket/contract/base)
(require (only-in "pattern-expander-prop.rkt" prop:pattern-expander))
(struct pattern-expander (proc) #:transparent
#:property prop:pattern-expander
(λ (this) (pattern-expander-proc this))) ; needs to be wrapped in (λ (this) (_ this))
(provide (contract-out
[struct pattern-expander ([proc (-> syntax? syntax?)])]
)))
(require (only-in 'pattern-expander-struct pattern-expander))

29
racket/collects/syntax/parse/private/rep.rkt
View File

@ -17,7 +17,8 @@
"rep-data.rkt"
"rep-patterns.rkt"
syntax/parse/private/residual-ct ;; keep abs. path
"kws.rkt")
"kws.rkt"
"pattern-expander-prop.rkt")
;; Error reporting
;; All entry points should have explicit, mandatory #:context arg
@ -435,6 +436,8 @@
;; parse-*-pattern : stx DeclEnv boolean boolean -> Pattern
(define (parse-*-pattern stx decls allow-head? allow-action?)
(define (recur stx)
(parse-*-pattern stx decls allow-head? allow-action?))
(define (check-head! x)
(unless allow-head?
(wrong-syntax stx "head pattern not allowed here"))
@ -449,6 +452,30 @@
~seq ~optional ~! ~bind ~fail ~parse ~do
~post ~peek ~peek-not ~delimit-cut ~commit ~reflect
~splicing-reflect)
[id
(and (identifier? #'id)
(not (safe-name? #'id))
(pattern-expander? (syntax-local-value #'id (λ () #f))))
(let* ([proc (pattern-expander-proc (syntax-local-value #'id))]
[introducer (make-syntax-introducer)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
(proc mstx))]
[result (syntax-local-introduce (introducer mresult))])
(disappeared! #'id)
(recur result))]
[(id . rst)
(and (identifier? #'id)
(not (safe-name? #'id))
(pattern-expander? (syntax-local-value #'id (λ () #f))))
(let* ([proc (pattern-expander-proc (syntax-local-value #'id))]
[introducer (make-syntax-introducer)]
[mstx (introducer (syntax-local-introduce stx))]
[mresult (parameterize ([current-syntax-parse-pattern-introducer introducer])
(proc mstx))]
[result (syntax-local-introduce (introducer mresult))])
(disappeared! #'id)
(recur result))]
[wildcard
(wildcard? #'wildcard)
(begin (disappeared! stx)