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

syntax/parse: add hpat:single; {single,head}-pattern types disjoint

Browse Source
This commit is contained in:
Ryan Culpepper 2018-08-10 17:15:01 +02:00
parent 5ab82ccdd4
commit 769dfb9e34
4 changed files with 41 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -223,6 +223,8 @@
[(pat:post pattern)
(pattern-factorable? pattern)]
;; ----
[(hpat:single inner)
(pattern-factorable? inner)]
[(hpat:var/p _ _ _ _ _ (scopts _ commit? _ _))
commit?]
[(hpat:seq inner)
@ -303,6 +305,8 @@
[(and (pat:post? a) (pat:post? b))
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
;; ---
[(and (hpat:single? a) (hpat:single? b))
(pattern-equal? (hpat:single-pattern a) (hpat:single-pattern 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))
(bound-id/f-equal? (hpat:var/p-name a) (hpat:var/p-name b))
@ -460,6 +464,7 @@
[(action:undo stmts) (list '~undo)]
[(action:ord ap _ _) (list '~ord (pattern->sexpr ap))]
[(action:post ap) (list '~post (pattern->sexpr ap))]
[(hpat:single sp) (pattern->sexpr sp)]
[(hpat:var/p name parser _ _ _ _)
(cond [(and parser (regexp-match #rx"^parser-(.*)$" (symbol->string (syntax-e parser))))
=> (lambda (m) (format-symbol "~a:~a" (or name '_) (cadr m)))]

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

@ -748,6 +748,7 @@ Conventions:
(syntax-case stx ()
[(fdh hpat)
(syntax-case #'hpat ()
[#s(hpat:single sp) #'(first-desc:S sp)]
[#s(hpat:var/p _ _ _ _ _ #s(scopts _ _ _ desc)) #'(quote desc)]
[#s(hpat:seq lp) #'(first-desc:L lp)]
[#s(hpat:describe _hp desc _t? _r)
@ -756,7 +757,7 @@ Conventions:
[#s(hpat:commit hp) #'(first-desc:H hp)]
[#s(hpat:ord hp _ _) #'(first-desc:H hp)]
[#s(hpat:post hp) #'(first-desc:H hp)]
[_ #'(first-desc:S hpat)])]))
[_ #'#f])]))
(define-syntax (first-desc:L stx)
(syntax-case stx ()
@ -845,6 +846,11 @@ Conventions:
(syntax-case stx ()
[(parse:H x cx rest-x rest-cx rest-pr head pr es k)
(syntax-case #'head ()
[#s(hpat:single pattern)
#'(parse:S x cx
;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq)
#s(pat:pair pattern #s(internal-rest-pattern))
pr es (lambda (rest-x rest-cx rest-pr) k))]
[#s(hpat:describe pattern description transparent? role)
#`(let ([es* (es-add-thing pr description transparent? role es)]
[pr* (if 'transparent? pr (ps-add-opaque pr))])
@ -968,12 +974,7 @@ Conventions:
(with ([fail-handler fail-to-succeed]
[cut-prompt fail-to-succeed]) ;; to be safe
(parse:H x cx rest-x rest-cx rest-pr subpattern pr es
(fh0 undo-stack (failure* pr0 es0)))))]
[_
#'(parse:S x cx
;; FIXME: consider proper-list-pattern? (yes is consistent with ~seq)
#s(pat:pair head #s(internal-rest-pattern))
pr es (lambda (rest-x rest-cx rest-pr) k))])]))
(fh0 undo-stack (failure* pr0 es0)))))])]))
;; (parse:dots x cx EH-pattern S-pattern pr es k) : expr[Ans]
;; In k: attrs(EH-pattern, S-pattern) are bound.
@ -981,14 +982,14 @@ Conventions:
(syntax-case stx ()
;; == Specialized cases
;; -- (x ... . ())
[(parse:dots x cx (#s(ehpat (attr0) #s(pat:svar name) #f #f))
[(parse:dots x cx (#s(ehpat (attr0) #s(hpat:single #s(pat:svar name)) #f #f))
#s(pat:datum ()) pr es k)
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es void #f #f)])
(case status
((ok) (let-attributes ([attr0 result]) k))
(else (fail result))))]
;; -- (x:sc ... . ()) where sc is an integrable stxclass like id or expr
[(parse:dots x cx (#s(ehpat (attr0) #s(pat:integrated _name pred? desc role) #f #f))
[(parse:dots x cx (#s(ehpat (attr0) #s(hpat:single #s(pat:integrated _name pred? desc role)) #f #f))
#s(pat:datum ()) pr es k)
#'(let-values ([(status result) (predicate-ellipsis-parser x cx pr es pred? desc role)])
(case status

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

@ -99,6 +99,7 @@ A SideClause is just an ActionPattern
#|
A HeadPattern is one of
(hpat:single SinglePattern)
(hpat:var/p Id Id Arguments (Listof IAttr) Stx scopts)
(hpat:seq ListPattern)
(hpat:action ActionPattern HeadPattern)
@ -114,6 +115,7 @@ A HeadPattern is one of
(hpat:peek-not HeadPattern)
|#
(define-struct hpat:single (pattern) #:prefab)
(define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab)
(define-struct hpat:seq (inner) #:prefab)
(define-struct hpat:action (action inner) #:prefab)
@ -182,7 +184,8 @@ A RepConstraint is one of
(action:post? x)))
(define (head-pattern? x)
(or (hpat:var/p? x)
(or (hpat:single? x)
(hpat:var/p? x)
(hpat:seq? x)
(hpat:action? x)
(hpat:and? x)
@ -205,6 +208,12 @@ A RepConstraint is one of
(or (single-pattern? x)
(head-pattern? x)))
(define (coerce-head-pattern p)
(if (head-pattern? p) p (hpat:single p)))
(define (head-pattern-not-single? hp)
(and (head-pattern? hp) (not (hpat:single? hp))))
;; check-pattern : *Pattern -> *Pattern
;; Does attr computation to catch errors, but returns same pattern.
(define (check-pattern p)
@ -291,6 +300,8 @@ A RepConstraint is one of
(pattern-attrs sp)]
;; -- H patterns
[(hpat:single sp)
(pattern-attrs sp)]
[(hpat:var/p name _ _ nested-attrs _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:reflect _ _ _ name nested-attrs)
@ -367,6 +378,7 @@ A RepConstraint is one of
[(action:post sp) (pattern-has-cut? sp)]
;; -- H patterns
[(hpat:single sp) (pattern-has-cut? sp)]
[(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
[(hpat:reflect _ _ _ name nested-attrs) #f]
[(hpat:seq lp) (pattern-has-cut? lp)]
@ -570,6 +582,7 @@ A RepConstraint is one of
;; hpat-nullable : HeadPattern -> AbsNullable
(define/memo (hpat-nullable hp)
(match hp
[(hpat:single sp) 'no]
[(hpat:seq lp) (lpat-nullable lp)]
[(hpat:action ap hp) (hpat-nullable hp)]
[(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))]
@ -579,7 +592,6 @@ A RepConstraint is one of
[(hpat:commit hp) (hpat-nullable hp)]
[(hpat:ord hp _ _) (hpat-nullable hp)]
[(hpat:post hp) (hpat-nullable hp)]
[(? pattern? hp) 'no]
[_ 'unknown]))
;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable

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

@ -416,7 +416,7 @@
;; parse-head-pattern : stx DeclEnv -> HeadPattern
(define (parse-head-pattern stx decls)
(parse-*-pattern stx decls #t #f))
(coerce-head-pattern (parse-*-pattern stx decls #t #f)))
;; parse-action-pattern : Stx DeclEnv -> ActionPattern
(define (parse-action-pattern stx decls)
@ -978,7 +978,7 @@
(car patterns)]
[else
(cond [(ormap head-pattern? patterns)
(create-hpat:or patterns)]
(create-hpat:or (map coerce-head-pattern patterns))]
[else
(create-pat:or patterns)])]))
@ -1204,25 +1204,25 @@
;; ============================================================
;; Fixup pass
(define (fixup-rhs the-rhs allow-head? expected-attrs)
(define (fixup-rhs the-rhs head? expected-attrs)
(match the-rhs
[(rhs attrs tr? desc vs defs commit? delimit-cut?)
(define vs* (for/list ([v (in-list vs)]) (fixup-variant v allow-head? expected-attrs)))
(define vs* (for/list ([v (in-list vs)]) (fixup-variant v head? expected-attrs)))
(rhs attrs tr? desc vs* defs commit? delimit-cut?)]))
(define (fixup-variant v allow-head? expected-attrs)
(define (fixup-variant v head? expected-attrs)
(match v
[(variant stx sattrs p defs)
(parameterize ((current-syntax-context stx))
(define p*
(parameterize ((stxclass-lookup-config 'yes))
(fixup-pattern p allow-head?)))
(fixup-pattern p head?)))
;; (eprintf "~v\n===>\n~v\n\n" p p*)
;; Called just for error-reporting
(reorder-iattrs expected-attrs (pattern-attrs p*))
(variant stx sattrs p* defs))]))
(define (fixup-pattern p0 allow-head?)
(define (fixup-pattern p0 head?)
(define (S p) (fixup p #f))
(define (S* p) (fixup p #t))
(define (A/S* p) (if (action-pattern? p) (A p) (S* p)))
@ -1304,7 +1304,7 @@
[(pat:and/fixup stx ps)
(let ([ps (for/list ([p (in-list ps)])
(cond [(action-pattern? p) (A p)]
[allow-head? (H p)]
[(head-pattern? p) (H p)]
[else (I p)]))])
(parse-pat:and/k stx ps))]
[(pat:or _ ps _)
@ -1326,6 +1326,9 @@
(define (H p)
(match p
[(hpat:single sp)
(let ([sp (fixup sp #t)])
(if (head-pattern? sp) sp (hpat:single sp)))]
;; [(hpat:var/p name parser argu nested-attrs role scopts)
;; (hpat:var/p name parser argu nested-attrs role scopts)]
;; [(hpat:reflect obj argu attr-decls name nested-attrs)
@ -1360,7 +1363,7 @@
;; Default: no sub-patterns, just return
[p p]))
(if allow-head? (H p0) (S p0)))
(if head? (H p0) (S p0)))
;; ============================================================