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

syntax/parse: add separate pattern for simple vars

Browse Source
This commit is contained in:
Ryan Culpepper 2016-05-04 19:38:57 -04:00
parent 678369f187
commit 91a03eecb3
4 changed files with 58 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
racket/collects/syntax/parse/private/opt.rkt
View File

@ -176,7 +176,8 @@
;; - if p can cut, then factoring changes which choice points are discarded (too few)
(match p
[(pat:any _as) #t]
[(pat:var _as _n _p _argu _na _ac commit? _r)
[(pat:svar _as _n) #t]
[(pat:var/p _as _n _p _argu _na _ac commit? _r)
;; commit? implies delimit-cut
commit?]
[(? pat:integrated?) #t]
@ -215,7 +216,7 @@
[(pat:post _as pattern)
(pattern-factorable? pattern)]
;; ----
[(hpat:var _as _name _parser _argu _na _ac commit? _role)
[(hpat:var/p _as _name _parser _argu _na _ac commit? _role)
commit?]
[(hpat:seq _as inner)
(pattern-factorable? inner)]
@ -236,11 +237,13 @@
(define (pattern-equal? a b)
(define result
(cond [(and (pat:any? a) (pat:any? b)) #t]
[(and (pat:var? a) (pat:var? b))
(and (free-id/f-equal? (pat:var-parser a) (pat:var-parser b))
(equal-iattrs? (pat:var-attrs a) (pat:var-attrs b))
(equal-argu? (pat:var-argu a) (pat:var-argu b))
(expr-equal? (pat:var-role a) (pat:var-role b)))]
[(and (pat:svar? a) (pat:svar? b))
(equal-iattrs? (pat:svar-attrs a) (pat:svar-attrs b))]
[(and (pat:var/p? a) (pat:var/p? b))
(and (free-id/f-equal? (pat:var/p-parser a) (pat:var/p-parser b))
(equal-iattrs? (pat:var/p-attrs a) (pat:var/p-attrs b))
(equal-argu? (pat:var/p-argu a) (pat:var/p-argu b))
(expr-equal? (pat:var/p-role a) (pat:var/p-role b)))]
[(and (pat:integrated? a) (pat:integrated? b))
(and (free-identifier=? (pat:integrated-predicate a)
(pat:integrated-predicate b))
@ -290,11 +293,11 @@
[(and (pat:post? a) (pat:post? b))
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
;; ---
[(and (hpat:var? a) (hpat:var? b))
(and (free-id/f-equal? (hpat:var-parser a) (hpat:var-parser b))
(equal-iattrs? (hpat:var-attrs a) (hpat:var-attrs b))
(equal-argu? (hpat:var-argu a) (hpat:var-argu b))
(expr-equal? (hpat:var-role a) (hpat:var-role b)))]
[(and (hpat:var/p? a) (hpat:var/p? b))
(and (free-id/f-equal? (hpat:var/p-parser a) (hpat:var/p-parser b))
(equal-iattrs? (hpat:var/p-attrs a) (hpat:var/p-attrs b))
(equal-argu? (hpat:var/p-argu a) (hpat:var/p-argu b))
(expr-equal? (hpat:var/p-role a) (hpat:var/p-role b)))]
[(and (hpat:seq? a) (hpat:seq? b))
(pattern-equal? (hpat:seq-inner a) (hpat:seq-inner b))]
;; ---
@ -399,7 +402,9 @@
[(pat:any _as) '_]
[(pat:integrated _as name pred desc _)
(format-symbol "~a:~a" (or name '_) desc)]
[(pat:var _as name parser _ _ _ _ _)
[(pat:svar _as name)
(syntax-e name)]
[(pat:var/p _as name parser _ _ _ _ _)
(cond [(and parser (regexp-match #rx"^parse-(.*)$" (symbol->string (syntax-e parser))))
=> (lambda (m)
(format-symbol "~a:~a" (or name '_) (cadr m)))]

14
racket/collects/syntax/parse/private/parse.rkt
View File

@ -499,10 +499,10 @@ Conventions:
k)]
[#s(pat:any _attrs)
#'k]
[#s(pat:var _attrs name #f _ () _ _ _)
[#s(pat:svar _attrs name)
#'(let-attributes ([#s(attr name 0 #t) (datum->syntax cx x cx)])
k)]
[#s(pat:var _attrs name parser argu (nested-a ...) attr-count commit? role)
[#s(pat:var/p _attrs name parser argu (nested-a ...) attr-count commit? role)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
@ -668,9 +668,9 @@ Conventions:
(syntax-case #'p ()
[#s(pat:any _as)
#''(any)]
[#s(pat:var _as name #f _ () _ _ _)
[#s(pat:svar _as name)
#''(any)]
[#s(pat:var _ ...)
[#s(pat:var/p _ ...)
#'#f] ;; FIXME: need access to (constant) description as field
[#s(pat:datum _as d)
#''(datum d)]
@ -784,7 +784,7 @@ Conventions:
(parse:H x cx rest-x rest-cx rest-pr pattern pr* es*
(let ([rest-pr (if 'transparent? rest-pr (ps-pop-opaque rest-pr))])
k)))]
[#s(hpat:var _attrs name parser argu (nested-a ...) attr-count commit? role)
[#s(hpat:var/p _attrs name parser argu (nested-a ...) attr-count commit? role)
(with-syntax ([(av ...) (generate-n-temporaries (syntax-e #'attr-count))]
[(name-attr ...)
(if (identifier? #'name)
@ -920,9 +920,7 @@ Conventions:
(syntax-case stx ()
;; == Specialized cases
;; -- (x ... . ())
[(parse:dots x cx (#s(ehpat (attr0)
#s(pat:var _attrs name #f _ () _ _ _)
#f))
[(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar _attrs name) #f))
#s(pat:datum () ()) pr es k)
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)])
(case status

37
racket/collects/syntax/parse/private/rep-patterns.rkt
View File

@ -22,7 +22,8 @@ A Base is (listof IAttr)
#|
A SinglePattern is one of
(pat:any Base)
(pat:var Base id id Arguments (listof IAttr) nat/#f bool stx)
(pat:svar Base id) -- "simple" var, no stxclass
(pat:var/p Base id id Arguments (Listof IAttr) nat/#f bool stx) -- var with parser
(pat:literal Base identifier ct-phase ct-phase)
(pat:datum Base datum)
(pat:action Base ActionPattern SinglePattern)
@ -51,7 +52,8 @@ A ListPattern is a subtype of SinglePattern; one of
|#
(define-struct pat:any (attrs) #:prefab)
(define-struct pat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct pat:svar (attrs name) #:prefab)
(define-struct pat:var/p (attrs name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct pat:literal (attrs id input-phase lit-phase) #:prefab)
(define-struct pat:datum (attrs datum) #:prefab)
(define-struct pat:action (attrs action inner) #:prefab)
@ -94,7 +96,7 @@ action:and is desugared below in create-* procedures
#|
A HeadPattern is one of
(hpat:var Base id id Arguments (listof IAttr) nat/#f bool stx)
(hpat:var/p Base id id Arguments (listof IAttr) nat/#f bool stx)
(hpat:seq Base ListPattern)
(hpat:action Base ActionPattern HeadPattern)
(hpat:and Base HeadPattern SinglePattern)
@ -109,7 +111,7 @@ A HeadPattern is one of
(hpat:peek-not Base HeadPattern)
|#
(define-struct hpat:var (attrs name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct hpat:var/p (attrs name parser argu nested-attrs attr-count commit? role) #:prefab)
(define-struct hpat:seq (attrs inner) #:prefab)
(define-struct hpat:action (attrs action inner) #:prefab)
(define-struct hpat:and (attrs head single) #:prefab)
@ -154,7 +156,8 @@ A SideClause is one of
(define (pattern? x)
(or (pat:any? x)
(pat:var? x)
(pat:svar? x)
(pat:var/p? x)
(pat:literal? x)
(pat:datum? x)
(pat:action? x)
@ -184,7 +187,7 @@ A SideClause is one of
(action:post? x)))
(define (head-pattern? x)
(or (hpat:var? x)
(or (hpat:var/p? x)
(hpat:seq? x)
(hpat:action? x)
(hpat:and? x)
@ -220,13 +223,13 @@ A SideClause is one of
#'(lambda (x)
(cond [(pred x) (accessor x)] ...
[else (raise-type-error 'pattern-attrs "pattern" x)])))]))
(mk-get-attrs pat:any pat:var pat:datum pat:literal pat:action pat:head
(mk-get-attrs pat:any pat:svar pat:var/p pat:datum pat:literal pat:action pat:head
pat:dots pat:and pat:or pat:not pat:describe
pat:pair pat:vector pat:box pat:pstruct
pat:delimit pat:commit pat:reflect pat:post pat:integrated
action:cut action:bind action:fail action:and action:parse
action:do action:post
hpat:var hpat:seq hpat:action hpat:and hpat:or hpat:describe
hpat:var/p hpat:seq hpat:action hpat:and hpat:or hpat:describe
hpat:optional hpat:delimit hpat:commit hpat:reflect hpat:post
hpat:peek hpat:peek-not
ehpat)))
@ -239,10 +242,13 @@ A SideClause is one of
(define (create-pat:any)
(make pat:any null))
(define (create-pat:var name parser argu nested-attrs attr-count commit? role)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-pat:svar name)
(let ([attrs (list (make attr name 0 #t))])
(make pat:svar attrs name)))
(define (create-pat:var/p name parser argu nested-attrs attr-count commit? role)
(let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make pat:var/p attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-pat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs
@ -338,10 +344,9 @@ A SideClause is one of
;; ----
(define (create-hpat:var name parser argu nested-attrs attr-count commit? role)
(let ([attrs
(if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-hpat:var/p name parser argu nested-attrs attr-count commit? role)
(let ([attrs (if name (cons (make attr name 0 #t) nested-attrs) nested-attrs)])
(make hpat:var/p attrs name parser argu nested-attrs attr-count commit? role)))
(define (create-hpat:reflect obj argu attr-decls name nested-attrs)
(let ([attrs

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

@ -653,7 +653,7 @@
(let* ([iattrs (id-pattern-attrs (eh-alternative-attrs alt) prefix)]
[attr-count (length iattrs)])
(list (create-ehpat
(create-hpat:var #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
(create-hpat:var/p #f (eh-alternative-parser alt) no-arguments iattrs attr-count #f #f)
(eh-alternative-repc alt))
(replace-eh-alternative-attrs
alt (iattrs->sattrs iattrs))))))]
@ -700,19 +700,19 @@
[else
(let-values ([(name suffix) (split-id/get-stxclass id decls)])
(cond [(stxclass? suffix)
(parse-pat:var* id allow-head? name suffix no-arguments "." #f #f)]
(parse-pat:var/sc id allow-head? name suffix no-arguments "." #f #f)]
[(or (den:lit? suffix) (den:datum-lit? suffix))
(create-pat:and
(list
(create-pat:var name #f no-arguments null #f #t #f)
(create-pat:svar name)
(parse-pat:id/entry id decls allow-head? suffix)))]
[(declenv-apply-conventions decls id)
=> (lambda (entry) (parse-pat:id/entry id decls allow-head? entry))]
[else (create-pat:var name #f no-arguments null #f #t #f)]))]))
=> (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
[else (create-pat:svar name)]))]))
;; parse-pat:id/entry : Identifier .... DeclEntry -> SinglePattern
;; Handle when meaning of identifier pattern is given by declenv entry.
(define (parse-pat:id/entry id decls allow-head? entry)
(define (parse-pat:id/entry id allow-head? entry)
(match entry
[(den:lit internal literal input-phase lit-phase)
(create-pat:literal literal input-phase lit-phase)]
@ -722,7 +722,7 @@
(let* ([pos-count (length (arguments-pargs argu))]
[kws (arguments-kws argu)]
[sc (get-stxclass/check-arity class class pos-count kws)])
(parse-pat:var* id allow-head? id sc argu "." role #f))]
(parse-pat:var/sc id allow-head? id sc argu "." role #f))]
[(den:class _n _c _a)
(error 'parse-pat:id
"(internal error) decls had leftover stxclass entry: ~s"
@ -737,8 +737,7 @@
(parse-pat:id/s id parser no-arguments attrs commit? "." #f)])]
[(den:delayed parser class)
(let ([sc (get-stxclass class)])
(parse-pat:var* id allow-head? id sc no-arguments "." #f parser))]))
(parse-pat:var/sc id allow-head? id sc no-arguments "." #f parser))]))
(define (parse-pat:var stx decls allow-head?)
(define name0
@ -775,11 +774,11 @@
(let ([sc (get-stxclass/check-arity scname sc+args-stx
(length (arguments-pargs argu))
(arguments-kws argu))])
(parse-pat:var* stx allow-head? name0 sc argu pfx role #f))]
(parse-pat:var/sc stx allow-head? name0 sc argu pfx role #f))]
[else ;; Just proper name
(create-pat:var name0 #f (arguments null null null) null #f #t #f)]))
(create-pat:svar name0)]))
(define (parse-pat:var* stx allow-head? name sc argu pfx role parser*)
(define (parse-pat:var/sc stx allow-head? name sc argu pfx role parser*)
;; if parser* not #f, overrides sc parser
(check-no-delimit-cut-in-not stx (stxclass-delimit-cut? sc))
(cond [(and (stxclass/s? sc)
@ -808,7 +807,7 @@
(define (parse-pat:id/s name parser argu attrs commit? pfx role)
(define prefix (name->prefix name pfx))
(define bind (name->bind name))
(create-pat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(create-pat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(define (parse-pat:id/s/integrate name integrate role)
(define bind (name->bind name))
@ -819,7 +818,7 @@
(define (parse-pat:id/h name parser argu attrs commit? pfx role)
(define prefix (name->prefix name pfx))
(define bind (name->bind name))
(create-hpat:var bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(create-hpat:var/p bind parser argu (id-pattern-attrs attrs prefix) (length attrs) commit? role))
(define (name->prefix id pfx)
(cond [(wildcard? id) #f]