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

syntax/parse: add multiple pattern-processing passes

Browse Source 
- pair specialization
- and/ord normalization, and cleanup
- add pat:seq-end to list-pattern
This commit is contained in:
Ryan Culpepper 2018-08-10 19:25:44 +02:00
parent 29e46bea78
commit 4b64cdef54
5 changed files with 464 additions and 393 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -222,6 +222,7 @@
(pattern-factorable? pattern)]
[(pat:post pattern)
(pattern-factorable? pattern)]
[(pat:seq-end) #t]
;; ----
[(hpat:single inner)
(pattern-factorable? inner)]
@ -304,6 +305,7 @@
(equal? (pat:ord-index a) (pat:ord-index b)))]
[(and (pat:post? a) (pat:post? b))
(pattern-equal? (pat:post-pattern a) (pat:post-pattern b))]
[(and (pat:seq-end? a) (pat:seq-end? b)) #t]
;; ---
[(and (hpat:single? a) (hpat:single? b))
(pattern-equal? (hpat:single-pattern a) (hpat:single-pattern b))]
@ -455,6 +457,7 @@
[(pat:commit sp) (list '~commit (pattern->sexpr sp))]
[(pat:ord pattern _ _) (list '~ord (pattern->sexpr pattern))]
[(pat:post sp) (list '~post (pattern->sexpr sp))]
[(pat:seq-end) '()]
[(action:cut) '~!]
[(action:fail cnd msg) (list '~fail)]
[(action:bind attr expr) (list '~bind)]

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

@ -539,7 +539,7 @@ Conventions:
(syntax-case stx ()
[(parse:S x cx pattern0 pr es k)
(syntax-case #'pattern0 ()
[#s(internal-rest-pattern)
[#s(pat:seq-end)
#`(k x cx pr)]
[#s(pat:any)
#'k]
@ -821,27 +821,6 @@ Conventions:
(parse:A x cx pattern pr* es k))]
[_ (wrong-syntax stx "internal error: bad A pattern: ~e" #'pattern0)])]))
(begin-for-syntax
;; convert-list-pattern : ListPattern id -> SinglePattern
;; Converts '() datum pattern at end of list to bind (cons stx index)
;; to rest-var.
(define (convert-list-pattern pattern end-pattern)
(syntax-case pattern ()
[#s(pat:datum ())
end-pattern]
[#s(pat:action action tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:action action tail))]
[#s(pat:head head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:head head tail))]
[#s(pat:dots head tail)
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
#'#s(pat:dots head tail))]
[#s(pat:pair head-part tail-part)
(with-syntax ([tail-part (convert-list-pattern #'tail-part end-pattern)])
#'#s(pat:pair head-part tail-part))])))
;; (parse:H x cx rest-x rest-cx rest-pr H-pattern pr es k)
;; In k: rest, rest-pr, attrs(H-pattern) are bound.
(define-syntax (parse:H stx)
@ -851,7 +830,7 @@ Conventions:
[#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))
#s(pat:pair pattern #s(pat:seq-end))
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)]
@ -926,11 +905,7 @@ Conventions:
(disjunct subattrs success (rest-x rest-cx rest-pr) (id ...)))
...)))]
[#s(hpat:seq pattern)
(with-syntax ([pattern
(convert-list-pattern
#'pattern
#'#s(internal-rest-pattern))])
#'(parse:S x cx pattern pr es (lambda (rest-x rest-cx rest-pr) k)))]
#'(parse:S x cx pattern pr es (lambda (rest-x rest-cx rest-pr) k))]
[#s(hpat:action action subpattern)
#'(parse:A x cx action pr es (parse:H x cx rest-x rest-cx rest-pr subpattern pr es k))]
[#s(hpat:delimit pattern)
@ -1188,7 +1163,7 @@ Conventions:
[ehpat+hstx-list
(apply append
(for/list ([alt (in-list alts)])
(parse*-ellipsis-head-pattern alt decls #t #:context stx)))]
(parse-EH-variant alt decls #t #:context stx)))]
[eh-alt+defs-list
(for/list ([ehpat+hstx (in-list ehpat+hstx-list)])
(let ([ehpat (car ehpat+hstx)]

15
racket/collects/syntax/parse/private/rep-attrs.rkt
View File

@ -73,13 +73,16 @@ of signatures easier for reified syntax-classes.
;; IAttr operations
;; append-iattrs : (listof (listof IAttr)) -> (listof IAttr)
;; Assumes that each sublist is duplicate-free.
(define (append-iattrs attrss)
(let* ([all (apply append attrss)]
[names (map attr-name all)]
[dup (check-duplicate-identifier names)])
(when dup
(wrong-syntax dup "duplicate attribute"))
all))
(cond [(null? attrss) null]
[(null? (cdr attrss)) (car attrss)]
[else
(let* ([all (apply append attrss)]
[names (map attr-name all)]
[dup (and (pair? names) (check-duplicate-identifier names))])
(when dup (wrong-syntax dup "duplicate attribute"))
all)]))
;; union-iattrs : (listof (listof IAttr)) -> (listof IAttr)
(define (union-iattrs attrss)

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

@ -2,49 +2,151 @@
(require syntax/parse/private/residual-ct ;; keep abs. path
"rep-attrs.rkt"
"minimatch.rkt"
"tree-util.rkt"
racket/syntax)
(provide (all-defined-out))
;; Uses Arguments from kws.rkt
;; ------------------------------------------------------------
;; Stage 1: Parsing, first pass
;; Pattern parsing is done (in rep.rkt) in two passes. In pass 1, stxclass refs
;; are not required to be bound, and so patterns like `x:sc` and `(~var x sc)`
;; are left as "fixup" patterns to be resolved in pass 2.
;; Uses Arguments from kws.rkt
;; SinglePattern ::=
;; | (pat:any)
;; | (pat:svar id) -- "simple" var, no stxclass
;; | (pat:var/p Id Id Arguments (Listof IAttr) Syntax SCOpts) -- var with parser
;; | (pat:literal Id Syntax Syntax)
;; | (pat:datum Datum)
;; | (pat:action ActionPattern SinglePattern)
;; | (pat:head HeadPattern SinglePattern)
;; | (pat:dots (listof EllipsisHeadPattern) SinglePattern)
;; | (pat:andu (Listof (U SinglePattern ActionPattern)))
;; | (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr)))
;; | (pat:not SinglePattern)
;; | (pat:vector SinglePattern)
;; | (pat:box SinglePattern)
;; | (pat:pstruct key SinglePattern)
;; | (pat:describe SinglePattern Syntax Boolean Syntax)
;; | (pat:delimit SinglePattern)
;; | (pat:commit SinglePattern)
;; | (pat:reflect stx Arguments (listof SAttr) id (listof IAttr))
;; | (pat:post SinglePattern)
;; | (pat:integrated Id/#f Id String Syntax)
;; | (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f)
;; | (pat:and/fixup Syntax (Listof (U {S,H,A}Pattern)))
#|
A SinglePattern is one of
(pat:any)
(pat:svar id) -- "simple" var, no stxclass
(pat:var/p Id Id Arguments (Listof IAttr) Stx scopts) -- var with parser
(pat:literal identifier Stx Stx)
(pat:datum datum)
(pat:action ActionPattern SinglePattern)
(pat:head HeadPattern SinglePattern)
(pat:dots (listof EllipsisHeadPattern) SinglePattern)
(pat:and (listof SinglePattern))
(pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr)))
(pat:not SinglePattern)
(pat:pair SinglePattern SinglePattern)
(pat:vector SinglePattern)
(pat:box SinglePattern)
(pat:pstruct key SinglePattern)
(pat:describe SinglePattern stx boolean stx)
(pat:delimit SinglePattern)
(pat:commit SinglePattern)
(pat:reflect stx Arguments (listof SAttr) id (listof IAttr))
(pat:ord SinglePattern UninternedSymbol Nat)
(pat:post SinglePattern)
(pat:integrated id/#f id string stx)
* (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f)
* (pat:and/fixup Syntax (Listof *Pattern))
;; ListPattern ::=
;; | (pat:datum '())
;; | (pat:action ActionPattern ListPattern)
;; | (pat:head HeadPattern ListPattern)
;; | (pat:pair SinglePattern ListPattern)
;; | (pat:dots EllipsisHeadPattern ListPattern)
A ListPattern is a subtype of SinglePattern; one of
(pat:datum '())
(pat:action ActionPattern ListPattern)
(pat:head HeadPattern ListPattern)
(pat:pair SinglePattern ListPattern)
(pat:dots EllipsisHeadPattern ListPattern)
|#
;; ActionPattern ::=
;; | (action:cut)
;; | (action:fail Syntax Syntax)
;; | (action:bind IAttr Syntax)
;; | (action:and (Listof ActionPattern))
;; | (action:parse SinglePattern Syntax)
;; | (action:do (Listof Syntax))
;; | (action:undo (Listof Syntax))
;; | (action:post ActionPattern)
;; HeadPattern ::=
;; | (hpat:single SinglePattern)
;; | (hpat:var/p Id Id Arguments (Listof IAttr) Syntax SCOpts)
;; | (hpat:seq ListPattern)
;; | (hpat:action ActionPattern HeadPattern)
;; | (hpat:andu (Listof (U Headpattern ActionPattern))) -- at least one HeadPattern
;; | (hpat:or (Listof IAttr) (Listof HeadPattern) (Listof (Listof IAttr)))
;; | (hpat:describe HeadPattern Syntax/#f Boolean Syntax)
;; | (hpat:delimit HeadPattern)
;; | (hpat:commit HeadPattern)
;; | (hpat:reflect Syntax Arguments (Listof SAttr) Id (Listof IAttr))
;; | (hpat:post HeadPattern)
;; | (hpat:peek HeadPattern)
;; | (hpat:peek-not HeadPattern)
;; EllipsisHeadPattern ::=
;; | (ehpat (Listof IAttr) HeadPattern RepConstraint Boolean)
;; RepConstraint ::=
;; | (rep:once Syntax Syntax Syntax)
;; | (rep:optional Syntax Syntax (Listof BindAction))
;; | (rep:bounds Nat PosInt/+inf.0 Syntax Syntax Syntax)
;; | #f
;; BindAction ::= (action:bind IAttr Syntax)
;; SideClause ::= ActionPattern
;; ------------------------------------------------------------
;; Stage 2: Parsing, pass 2
;; SinglePattern ::= ....
;; X (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f)
;; X (pat:and/fixup Syntax (Listof (U {S,H,A}Pattern)))
;; Note: pat:action can change to hpat:action; pat:andu cannot change.
;; ------------------------------------------------------------
;; Stage 3: Specialize pair patterns
;; Rewrite (pat:head (hpat:single headp) tailp) => (pat:pair headp tailp).
;; Rewrite (pat:head (hpat:seq lp[end]) tailp) -> lp[tailp].
;; FIXME/TODO: also do the following:
;; - add pat:seq-end
;; - rewrite (pat:head (hpat:seq (pat:head h1 t1)) t2) => (pat:head h1 (pat:head (hpat:seq t1) t2))
;; SinglePattern ::= ....
;; + (pat:pair SinglePattern SinglePattern)
;; ListPattern ::=
;; + (pat:pair SinglePattern ListPattern)
;; ------------------------------------------------------------
;; Stage 4a: Normalize and patterns
;; SinglePattern ::= ....
;; X (pat:action ActionPattern SinglePattern)
;; ActionPattern ::= ....
;; X (action:and (Listof ActionPattern))
;; HeadPattern ::=
;; X (hpat:action ActionPattern HeadPattern)
;; ------------------------------------------------------------
;; Stage 4b: Add *:ord wrappers for *:and components
;; SinglePattern ::= ....
;; X (pat:andu (Listof (U SinglePattern ActionPattern)))
;; + (pat:action ActionPattern SinglePattern)
;; + (pat:and (Listof SinglePattern))
;; + (pat:ord SinglePattern UninternedSymbol Nat)
;; ActionPattern ::= ....
;; + (action:ord ActionPattern UninternedSymbol Nat)
;; + (action:and (Listof ActionPattern))
;; HeadPattern ::= ....
;; X (hpat:andu (Listof (U HeadPattern ActionPattern)))
;; + (hpat:action ActionPattern HeadPattern)
;; + (hpat:and HeadPattern SinglePattern)
;; + (hpat:ord HeadPattern UninternedSymbol Nat)
;; ------------------------------------------------------------
;; Stage 5: Switch to pat:seq-end in list patterns
;; ListPattern ::= ...
;; X (pat:datum '())
;; + (pat:seq-end)
;; ------------------------------------------------------------
(define-struct pat:any () #:prefab)
(define-struct pat:svar (name) #:prefab)
@ -54,6 +156,7 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:action (action inner) #:prefab)
(define-struct pat:head (head tail) #:prefab)
(define-struct pat:dots (heads tail) #:prefab)
(define-struct pat:andu (patterns) #:prefab)
(define-struct pat:and (patterns) #:prefab)
(define-struct pat:or (attrs patterns attrss) #:prefab)
(define-struct pat:not (pattern) #:prefab)
@ -70,22 +173,7 @@ A ListPattern is a subtype of SinglePattern; one of
(define-struct pat:integrated (name predicate description role) #:prefab)
(define-struct pat:fixup (stx bind varname scname argu sep role parser*) #:prefab)
(define-struct pat:and/fixup (stx patterns) #:prefab)
#|
A ActionPattern is one of
(action:cut)
(action:fail stx stx)
(action:bind IAttr Stx)
(action:and (listof ActionPattern))
(action:parse SinglePattern stx)
(action:do (listof stx))
(action:undo (listof stx))
(action:ord ActionPattern UninternedSymbol Nat)
(action:post ActionPattern)
A BindAction is (action:bind IAttr Stx)
A SideClause is just an ActionPattern
|#
(define-struct pat:seq-end () #:prefab)
(define-struct action:cut () #:prefab)
(define-struct action:fail (when message) #:prefab)
@ -97,28 +185,11 @@ A SideClause is just an ActionPattern
(define-struct action:ord (pattern group index) #:prefab)
(define-struct action:post (pattern) #:prefab)
#|
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)
(hpat:and HeadPattern SinglePattern)
(hpat:or (listof IAttr) (listof HeadPattern) (listof (listof IAttr)))
(hpat:describe HeadPattern stx/#f boolean stx)
(hpat:delimit HeadPattern)
(hpat:commit HeadPattern)
(hpat:reflect stx Arguments (listof SAttr) id (listof IAttr))
(hpat:ord HeadPattern UninternedSymbol Nat)
(hpat:post HeadPattern)
(hpat:peek HeadPattern)
(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)
(define-struct hpat:andu (patterns) #:prefab)
(define-struct hpat:and (head single) #:prefab)
(define-struct hpat:or (attrs patterns attrss) #:prefab)
(define-struct hpat:describe (pattern description transparent? role) #:prefab)
@ -130,17 +201,6 @@ A HeadPattern is one of
(define-struct hpat:peek (pattern) #:prefab)
(define-struct hpat:peek-not (pattern) #:prefab)
#|
An EllipsisHeadPattern is
(ehpat (Listof IAttr) HeadPattern RepConstraint Boolean)
A RepConstraint is one of
(rep:once stx stx stx)
(rep:optional stx stx (listof BindAction))
(rep:bounds nat posint/+inf.0 stx stx stx)
#f
|#
(define-struct ehpat (attrs head repc check-null?) #:prefab)
(define-struct rep:once (name under-message over-message) #:prefab)
(define-struct rep:optional (name over-message defaults) #:prefab)
@ -157,6 +217,7 @@ A RepConstraint is one of
(pat:action? x)
(pat:head? x)
(pat:dots? x)
(pat:andu? x)
(pat:and? x)
(pat:or? x)
(pat:not? x)
@ -172,7 +233,8 @@ A RepConstraint is one of
(pat:post? x)
(pat:integrated? x)
(pat:fixup? x)
(pat:and/fixup? x)))
(pat:and/fixup? x)
(pat:seq-end? x)))
(define (action-pattern? x)
(or (action:cut? x)
@ -190,6 +252,7 @@ A RepConstraint is one of
(hpat:var/p? x)
(hpat:seq? x)
(hpat:action? x)
(hpat:andu? x)
(hpat:and? x)
(hpat:or? x)
(hpat:describe? x)
@ -208,6 +271,13 @@ A RepConstraint is one of
(or (single-pattern? x)
(head-pattern? x)))
(define (*pattern? x)
(and (struct? x)
(or (single-pattern? x)
(action-pattern? x)
(head-pattern? x)
(ellipsis-head-pattern? x))))
;; ============================================================
(define (wf-S? x)
@ -220,6 +290,7 @@ A RepConstraint is one of
[(pat:action ap sp) (and (wf-A? ap) (wf-S? sp))]
[(pat:head headp tailp) (and (wf-H? headp) (wf-S? tailp))]
[(pat:dots heads tailp) (and (andmap wf-EH? heads) (wf-S? tailp))]
[(pat:andu ps) (andmap wf-A/S? ps)]
[(pat:and ps) (andmap wf-S? ps)]
[(pat:or attrs ps attrss) (andmap wf-S? ps)]
[(pat:not sp) (wf-S? sp)]
@ -236,11 +307,13 @@ A RepConstraint is one of
[(pat:integrated name predicate description role) #t]
[(pat:fixup stx bind varname scname argu sep role parser*) #t]
[(pat:and/fixup stx ps) (andmap wf-A/S/H? ps)]
[(pat:seq-end) #f] ;; Should only occur in ListPattern!
[_ #f]))
(define (wf-L? x)
(match x
[(pat:datum '()) #t]
[(pat:seq-end) #t]
[(pat:action ap sp) (and (wf-A? ap) (wf-L? sp))]
[(pat:head headp tailp) (and (wf-H? headp) (wf-L? tailp))]
[(pat:dots heads tailp) (and (andmap wf-EH? heads) (wf-L? tailp))]
@ -266,6 +339,7 @@ A RepConstraint is one of
[(hpat:var/p name parser argu nested-attrs role scopts) #t]
[(hpat:seq sp) (wf-L? sp)]
[(hpat:action ap sp) (and (wf-A? ap) (wf-H? sp))]
[(hpat:andu ps) (andmap wf-A/H? ps)]
[(hpat:and hp sp) (and (wf-H? hp) (wf-S? sp))]
[(hpat:or attrs ps attrss) (andmap wf-H? ps)]
[(hpat:describe sp description transparent? role) (wf-H? sp)]
@ -301,6 +375,31 @@ A RepConstraint is one of
;; ============================================================
;; pattern-transform : *Pattern (*Pattern -> *Pattern) -> *Pattern
(define (pattern-transform p for-pattern [root? #t])
(define (for-node x) (if (*pattern? x) (for-pattern x) x))
(tree-transform p for-node root?))
;; pattern-transform-preorder : *Pattern (*Pattern (X -> X) -> *Pattern) -> *Pattern
(define (pattern-transform-preorder p for-pattern [root? #t])
(define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
(tree-transform-preorder p for-node root?))
;; pattern-reduce{,-left} : *Pattern (*Pattern -> X) (X ... -> X) -> X
(define (pattern-reduce p for-pattern reduce [root? #t])
(define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
(tree-reduce p for-node reduce root?))
(define (pattern-reduce-left p for-pattern reduce [root? #t])
(define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
(tree-reduce-left p for-node reduce root?))
;; pattern-ormap : *Pattern (*Pattern -> X/#f) -> X/#f
(define (pattern-ormap p for-pattern [root? #t])
(define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
(tree-ormap p for-node root?))
;; ============================================================
(define pattern? single-pattern?)
(define (coerce-head-pattern p)
@ -320,179 +419,63 @@ A RepConstraint is one of
;; pattern-attrs : *Pattern -> (Listof IAttr)
(define (pattern-attrs p)
(hash-ref! pattern-attrs-table p (lambda () (pattern-attrs* p))))
(define (for-pattern p recur)
(hash-ref! pattern-attrs-table p (lambda () (for-pattern* p recur))))
(define (for-pattern* p recur)
(match p
;; -- S patterns
[(pat:svar name)
(list (attr name 0 #t))]
[(pat:var/p name _ _ nested-attrs _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(pat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(pat:or iattrs ps _)
iattrs]
[(pat:not _)
null]
[(pat:integrated name _ _ _)
(if name (list (attr name 0 #t)) null)]
[(pat:fixup _ bind _ _ _ _ _ _)
(if bind (list (attr bind 0 #t)) null)]
;; -- A patterns
[(action:bind attr expr)
(list attr)]
;; -- H patterns
[(hpat:var/p name _ _ nested-attrs _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:or iattrs ps _)
iattrs]
[(hpat:peek-not _)
null]
;; EH patterns
[(ehpat iattrs _ _ _)
iattrs]
[_ (recur)]))
(pattern-reduce p for-pattern (lambda iattrss (append-iattrs iattrss))))
(define (pattern-attrs* p)
(match p
;; -- S patterns
[(pat:any)
null]
[(pat:svar name)
(list (attr name 0 #t))]
[(pat:var/p name _ _ nested-attrs _ _)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(pat:reflect _ _ _ name nested-attrs)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(pat:datum _)
null]
[(pat:literal _ _ _)
null]
[(pat:action a sp)
(append-iattrs (map pattern-attrs (list a sp)))]
[(pat:head headp tailp)
(append-iattrs (map pattern-attrs (list headp tailp)))]
[(pat:pair headp tailp)
(append-iattrs (map pattern-attrs (list headp tailp)))]
[(pat:vector sp)
(pattern-attrs sp)]
[(pat:box sp)
(pattern-attrs sp)]
[(pat:pstruct key sp)
(pattern-attrs sp)]
[(pat:describe sp _ _ _)
(pattern-attrs sp)]
[(pat:and ps)
(append-iattrs (map pattern-attrs ps))]
[(pat:or _ ps _)
(union-iattrs (map pattern-attrs ps))]
[(pat:not _)
null]
[(pat:dots headps tailp)
(append-iattrs (map pattern-attrs (append headps (list tailp))))]
[(pat:delimit sp)
(pattern-attrs sp)]
[(pat:commit sp)
(pattern-attrs sp)]
[(pat:ord sp _ _)
(pattern-attrs sp)]
[(pat:post sp)
(pattern-attrs sp)]
[(pat:integrated name _ _ _)
(if name (list (attr name 0 #t)) null)]
[(pat:fixup _ bind _ _ _ _ _ _)
(if bind (list (attr bind 0 #t)) null)]
[(pat:and/fixup _ ps)
(append-iattrs (map pattern-attrs ps))]
;; -- A patterns
[(action:cut)
null]
[(action:fail _ _)
null]
[(action:bind attr expr)
(list attr)]
[(action:and ps)
(append-iattrs (map pattern-attrs ps))]
[(action:parse sp _)
(pattern-attrs sp)]
[(action:do _)
null]
[(action:undo _)
null]
[(action:ord sp _ _)
(pattern-attrs sp)]
[(action:post sp)
(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)
(if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
[(hpat:seq lp)
(pattern-attrs lp)]
[(hpat:action a hp)
(append-iattrs (map pattern-attrs (list a hp)))]
[(hpat:describe hp _ _ _)
(pattern-attrs hp)]
[(hpat:and hp sp)
(append-iattrs (map pattern-attrs (list hp sp)))]
[(hpat:or _ ps _)
(union-iattrs (map pattern-attrs ps))]
[(hpat:delimit hp)
(pattern-attrs hp)]
[(hpat:commit hp)
(pattern-attrs hp)]
[(hpat:ord hp _ _)
(pattern-attrs hp)]
[(hpat:post hp)
(pattern-attrs hp)]
[(hpat:peek hp)
(pattern-attrs hp)]
[(hpat:peek-not hp)
null]
;; EH patterns
[(ehpat iattrs _ _ _)
iattrs]
))
;; ----
;; ------------------------------------------------------------
;; pattern-has-cut? : *Pattern -> Boolean
;; Returns #t if p *might* cut (~!, not within ~delimit-cut).
(define (pattern-has-cut? p)
(match p
;; -- S patterns
[(pat:any) #f]
[(pat:svar name) #f]
[(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
[(pat:reflect _ _ _ name nested-attrs) #f]
[(pat:datum _) #f]
[(pat:literal _ _ _) #f]
[(pat:action a sp) (or (pattern-has-cut? a) (pattern-has-cut? sp))]
[(pat:head headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))]
[(pat:pair headp tailp) (or (pattern-has-cut? headp) (pattern-has-cut? tailp))]
[(pat:vector sp) (pattern-has-cut? sp)]
[(pat:box sp) (pattern-has-cut? sp)]
[(pat:pstruct key sp) (pattern-has-cut? sp)]
[(pat:describe sp _ _ _) (pattern-has-cut? sp)]
[(pat:and ps) (ormap pattern-has-cut? ps)]
[(pat:or _ ps _) (ormap pattern-has-cut? ps)]
[(pat:not _) #f]
[(pat:dots headps tailp) (or (ormap pattern-has-cut? headps) (pattern-has-cut? tailp))]
[(pat:delimit sp) #f]
[(pat:commit sp) #f]
[(pat:ord sp _ _) (pattern-has-cut? sp)]
[(pat:post sp) (pattern-has-cut? sp)]
[(pat:integrated name _ _ _) #f]
[(pat:fixup _ _ _ _ _ _ _ _) #t]
[(pat:and/fixup _ ps) (ormap pattern-has-cut? ps)]
(define (for-pattern p recur)
(match p
[(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
[(pat:not _) #f]
[(pat:delimit _) #f]
[(pat:commit _) #f]
[(pat:fixup _ _ _ _ _ _ _ _) #t]
[(action:cut) #t]
[(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
[(hpat:delimit _) #f]
[(hpat:commit _) #f]
[_ (recur)]))
(pattern-reduce p for-pattern (lambda xs (ormap values xs))))
;; -- A patterns
[(action:cut) #t]
[(action:fail _ _) #f]
[(action:bind attr expr) #f]
[(action:and ps) (ormap pattern-has-cut? ps)]
[(action:parse sp _) (pattern-has-cut? sp)]
[(action:do _) #f]
[(action:undo _) #f]
[(action:ord sp _ _) (pattern-has-cut? sp)]
[(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)]
[(hpat:action a hp) (or (pattern-has-cut? a) (pattern-has-cut? hp))]
[(hpat:describe hp _ _ _) (pattern-has-cut? hp)]
[(hpat:and hp sp) (or (pattern-has-cut? hp) (pattern-has-cut? sp))]
[(hpat:or _ ps _) (ormap pattern-has-cut? ps)]
[(hpat:delimit hp) #f]
[(hpat:commit hp) #f]
[(hpat:ord hp _ _) (pattern-has-cut? hp)]
[(hpat:post hp) (pattern-has-cut? hp)]
[(hpat:peek hp) (pattern-has-cut? hp)]
[(hpat:peek-not hp) (pattern-has-cut? hp)]
;; EH patterns
[(ehpat _ hp _ _) (pattern-has-cut? hp)]
))
;; ----
;; ============================================================
(define (create-pat:or ps)
(define attrss (map pattern-attrs ps))
@ -556,7 +539,7 @@ A RepConstraint is one of
(lambda (x)
(hash-ref! memo-table x (lambda () body ...))))))
;; ----
;; ============================================================
;; An AbsFail is a Nat encoding the bitvector { sub? : 1, post? : 1 }
;; Finite abstraction of failuresets based on progress bins. That is:
@ -577,45 +560,34 @@ A RepConstraint is one of
(= af2 AF-NONE)
(and (= af1 AF-SUB) (= af2 AF-POST))))
;; pattern-absfail : *Pattern -> AbsFail
(define/memo (pattern-AF p)
(define (patterns-AF ps)
(for/fold ([af 0]) ([p (in-list ps)]) (bitwise-ior af (pattern-AF p))))
(cond [(pat:any? p) AF-NONE]
[(pat:svar? p) AF-NONE]
[(pat:var/p? p) AF-ANY]
[(pat:literal? p) AF-SUB]
[(pat:datum? p) AF-SUB]
[(pat:action? p) (bitwise-ior (pattern-AF (pat:action-action p))
(pattern-AF (pat:action-inner p)))]
[(pat:head? p) AF-ANY]
[(pat:dots? p) AF-ANY]
[(pat:and? p) (patterns-AF (pat:and-patterns p))]
[(pat:or? p) (patterns-AF (pat:or-patterns p))]
[(pat:not? p) AF-SUB]
[(pat:pair? p) AF-SUB]
[(pat:vector? p) AF-SUB]
[(pat:box? p) AF-SUB]
[(pat:pstruct? p) AF-SUB]
[(pat:describe? p) (pattern-AF (pat:describe-pattern p))]
[(pat:delimit? p) (pattern-AF (pat:delimit-pattern p))]
[(pat:commit? p) (pattern-AF (pat:commit-pattern p))]
[(pat:reflect? p) AF-ANY]
[(pat:ord? p) (pattern-AF (pat:ord-pattern p))]
[(pat:post? p) (if (AF-nz? (pattern-AF (pat:post-pattern p))) AF-POST AF-NONE)]
[(pat:integrated? p) AF-SUB]
;; Action patterns
[(action:cut? p) AF-NONE]
[(action:fail? p) AF-SUB]
[(action:bind? p) AF-NONE]
[(action:and? p) (patterns-AF (action:and-patterns p))]
[(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)]
[(action:do? p) AF-NONE]
[(action:undo? p) AF-SUB]
[(action:ord? p) (pattern-AF (action:ord-pattern p))]
[(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)]
;; Head patterns, eh patterns, etc
[else AF-ANY]))
;; pattern-AF-table : Hasheq[*Pattern => AbsFail]
(define pattern-AF-table (make-weak-hasheq))
;; pattern-AF : *Pattern -> AbsFail
(define (pattern-AF p)
(define (for-pattern p recur)
(hash-ref pattern-AF-table p (lambda () (for-pattern* p recur))))
(define (for-pattern* p recur)
(cond [(pat:var/p? p) AF-ANY]
[(pat:literal? p) AF-SUB]
[(pat:datum? p) AF-SUB]
[(pat:head? p) AF-ANY]
[(pat:dots? p) AF-ANY]
[(pat:not? p) AF-SUB]
[(pat:pair? p) AF-SUB]
[(pat:vector? p) AF-SUB]
[(pat:box? p) AF-SUB]
[(pat:pstruct? p) AF-SUB]
[(pat:reflect? p) AF-ANY]
[(pat:post? p) (if (AF-nz? (pattern-AF (pat:post-pattern p))) AF-POST AF-NONE)]
[(pat:integrated? p) AF-SUB]
[(action:fail? p) AF-SUB]
[(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)]
[(action:ord? p) (pattern-AF (action:ord-pattern p))]
[(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)]
[(head-pattern? p) AF-ANY] ;; this case should not be reachable
[else (recur)]))
(pattern-reduce-left p for-pattern bitwise-ior))
;; pattern-cannot-fail? : *Pattern -> Boolean
(define (pattern-cannot-fail? p)
@ -642,7 +614,7 @@ A RepConstraint is one of
(and (not (ormap pattern-has-cut? patterns))
(ormap pattern-cannot-fail? patterns)))
;; ----
;; ============================================================
;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic)
@ -670,6 +642,7 @@ A RepConstraint is one of
[(pat:pair sp lp) 'no]
[(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))]
;; For hpat:and, handle the following which are not ListPatterns
[(pat:andu lps) (3andmap lpat-nullable (filter single-pattern? lps))]
[(pat:and lps) (3andmap lpat-nullable lps)]
[(pat:any) #t]
[_ 'unknown]))
@ -680,6 +653,7 @@ A RepConstraint is one of
[(hpat:single sp) 'no]
[(hpat:seq lp) (lpat-nullable lp)]
[(hpat:action ap hp) (hpat-nullable hp)]
[(hpat:andu ps) (3andmap hpat-nullable (filter head-pattern? ps))]
[(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))]
[(hpat:or _attrs hps _attrss) (3ormap hpat-nullable hps)]
[(hpat:describe hp _ _ _) (hpat-nullable hp)]
@ -701,7 +675,7 @@ A RepConstraint is one of
[(and (rep:bounds? repc) (> (rep:bounds-min repc) 0)) 'no]
[else 'yes]))
;; ----
;; ============================================================
;; create-post-pattern : *Pattern -> *Pattern
(define (create-post-pattern p)
@ -719,7 +693,7 @@ A RepConstraint is one of
(define (create-ord-pattern p group index)
(cond [(pattern-cannot-fail? p)
p]
[(pattern? p)
[(single-pattern? p)
(pat:ord p group index)]
[(head-pattern? p)
(hpat:ord p group index)]
@ -736,9 +710,3 @@ A RepConstraint is one of
[else
(for/list ([p (in-list patterns)] [index (in-naturals)])
(create-ord-pattern p group index))]))
;; create-action:and : (Listof ActionPattern) -> ActionPattern
(define (create-action:and actions)
(match actions
[(list action) action]
[_ (action:and actions)]))

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

@ -38,7 +38,7 @@
#:decls DeclEnv/c
#:context syntax?
any)]
[parse*-ellipsis-head-pattern
[parse-EH-variant
(-> syntax? DeclEnv/c boolean?
#:context syntax?
any)]
@ -339,6 +339,7 @@
[(pattern p . rest)
(let-values ([(rest pattern defs)
(parse-pattern+sides #'p #'rest
#:simplify? #f
#:splicing? splicing?
#:decls decls0
#:context stx)])
@ -350,19 +351,26 @@
[sattrs (iattrs->sattrs attrs)])
(make variant stx sattrs pattern defs)))]))
;; parse-EH-variant : Syntax DeclEnv Boolean
;; -> (Listof (list EllipsisHeadPattern Syntax/EH-Alternative))
(define (parse-EH-variant stx decls allow-or? #:context [ctx (current-syntax-context)])
(parse*-ellipsis-head-pattern stx decls allow-or? #:context ctx))
;; parse-pattern+sides : stx stx <options> -> (values stx Pattern (listof stx))
;; Parses pattern, side clauses; desugars side clauses & merges with pattern
(define (parse-pattern+sides p-stx s-stx
#:splicing? splicing?
#:decls decls0
#:context ctx)
#:context ctx
#:simplify? [simplify? #t])
(let-values ([(rest decls defs sides)
(parse-pattern-directives s-stx
#:allow-declare? #t
#:decls decls0
#:context ctx)])
(let* ([pattern0 (parse-whole-pattern p-stx decls splicing? #:context ctx #:kind 'main)]
[pattern (combine-pattern+sides pattern0 sides splicing?)])
[pattern (combine-pattern+sides pattern0 sides splicing?)]
[pattern (if simplify? (simplify-pattern pattern) pattern)])
(values rest pattern defs))))
;; parse-whole-pattern : stx DeclEnv boolean -> Pattern
@ -389,15 +397,8 @@
;; combine-pattern+sides : Pattern (listof SideClause) -> Pattern
(define (combine-pattern+sides pattern sides splicing?)
(check-pattern
(cond [(pair? sides)
(define actions-pattern
(create-action:and (ord-and-patterns sides (gensym*))))
(define and-patterns
(ord-and-patterns (list pattern (pat:action actions-pattern (pat:any)))
(gensym*)))
(cond [splicing? (apply hpat:and and-patterns)]
[else (pat:and and-patterns)])]
[else pattern])))
(cond [splicing? (hpat:andu (cons pattern sides))]
[else (pat:andu (cons pattern sides))])))
;; gensym* : -> UninternedSymbol
;; Like gensym, but with deterministic name from compilation-local counter.
@ -590,9 +591,7 @@
[tailp (parse-single-pattern #'tail decls)])
(cond [(action-pattern? headp)
(pat:action headp tailp)]
[(head-pattern? headp)
(pat:head headp tailp)]
[else (pat:pair headp tailp)]))]
[else (pat:head (coerce-head-pattern headp) tailp)]))]
[#(a ...)
(let ([lp (parse-single-pattern (syntax/loc stx (a ...)) decls)])
(pat:vector lp))]
@ -701,7 +700,7 @@
(declenv-check-unbound decls name (syntax-e suffix) #:blame-declare? #t)
(define entry (declenv-lookup decls suffix))
(cond [(or (den:lit? entry) (den:datum-lit? entry))
(pat:and (list (pat:svar name) (parse-pat:id/entry id allow-head? entry)))]
(pat:andu (list (pat:svar name) (parse-pat:id/entry id allow-head? entry)))]
[else (parse-stxclass-use id allow-head? name suffix no-arguments "." #f)])])]
[(declenv-apply-conventions decls id)
=> (lambda (entry) (parse-pat:id/entry id allow-head? entry))]
@ -917,46 +916,28 @@
(define (parse-pat:and stx decls allow-head? allow-action?)
;; allow-action? = allowed to *return* pure action pattern;
;; all ~and patterns are allowed to *contain* action patterns
(define patterns0 (parse-cdr-patterns stx decls allow-head? #t))
(cond [(andmap action-pattern? patterns0)
(define patterns (parse-cdr-patterns stx decls allow-head? #t))
(cond [(andmap action-pattern? patterns)
(cond [allow-action?
(define patterns1 (ord-and-patterns patterns0 (gensym*)))
(action:and patterns1)]
(action:and patterns)]
[allow-head?
(wrong-syntax stx "expected at least one head or single-term pattern")]
[else
(wrong-syntax stx "expected at least one single-term pattern")])]
[(memq (stxclass-lookup-config) '(no try))
(pat:and/fixup stx patterns0)]
[else (parse-pat:and/k stx patterns0)]))
(pat:and/fixup stx patterns)]
[else (parse-pat:and/k stx patterns)]))
(define (parse-pat:and/k stx patterns0)
;; PRE: patterns0 not all action patterns
(define patterns1 (ord-and-patterns patterns0 (gensym*)))
(define-values (actions patterns) (split-prefix patterns1 action-pattern?))
(add-actions actions (parse-pat:and/k* stx (length actions) patterns)))
(define (parse-pat:and/k* stx actions-len patterns)
;; PRE: patterns non-empty, starts with non-action pattern
(cond [(null? (cdr patterns))
(car patterns)]
[(ormap head-pattern? patterns)
;; Check to make sure *all* are head patterns
(define (parse-pat:and/k stx patterns)
;; PRE: patterns not all action patterns
(cond [(ormap head-pattern? patterns)
;; Check to make sure *all* are head patterns (and action patterns)
(for ([pattern (in-list patterns)]
[pattern-stx (in-list (drop (stx->list (stx-cdr stx)) actions-len))])
[pattern-stx (in-list (stx->list (stx-cdr stx)))])
(unless (or (action-pattern? pattern) (head-pattern? pattern))
(wrong-syntax
pattern-stx
"single-term pattern not allowed after head pattern")))
(let ([p0 (car patterns)]
[lps (map action/head-pattern->list-pattern (cdr patterns))])
(hpat:and p0 (pat:and lps)))]
[else
(pat:and
(for/list ([p (in-list patterns)])
(if (action-pattern? p)
(action-pattern->single-pattern p)
p)))]))
(wrong-syntax pattern-stx "single-term pattern not allowed after head pattern")))
(hpat:andu patterns)]
[else (pat:andu patterns)]))
(define (split-prefix xs pred)
(let loop ([xs xs] [rprefix null])
@ -1024,7 +1005,7 @@
(syntax-case stx ()
[(_ clause ...)
(let ([clauses (check-bind-clause-list #'(clause ...) stx)])
(create-action:and clauses))]))
(action:and clauses))]))
(define (parse-pat:fail stx decls)
(syntax-case stx ()
@ -1105,7 +1086,7 @@
(parse*-optional-pattern stx decls h-optional-directive-table))
(create-hpat:or
(list head
(hpat:action (create-action:and defaults)
(hpat:action (action:and defaults)
(hpat:seq (pat:datum '()))))))
;; parse*-optional-pattern : stx DeclEnv table
@ -1202,7 +1183,7 @@
;; ============================================================
;; Fixup pass
;; Fixup pass (also does simplify-pattern)
(define (fixup-rhs the-rhs head? expected-attrs)
(match the-rhs
@ -1214,12 +1195,14 @@
(match v
[(variant stx sattrs p defs)
(parameterize ((current-syntax-context stx))
(define p*
(define p1
(parameterize ((stxclass-lookup-config 'yes))
(fixup-pattern p head?)))
;; (eprintf "~v\n===>\n~v\n\n" p p*)
(unless (if head? (wf-H? p*) (wf-S? p*))
;; (eprintf "~v\n===>\n~v\n\n" p p1)
(unless (if head? (wf-H? p1) (wf-S? p1))
(error 'fixup-variant "result is not well-formed"))
(define p* (simplify-pattern p1))
;; (eprintf "=2=>\n~v\n\n" p*)
;; Called just for error-reporting
(reorder-iattrs expected-attrs (pattern-attrs p*))
(variant stx sattrs p* defs))]))
@ -1227,7 +1210,8 @@
(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)))
(define (A/S p) (if (action-pattern? p) (A p) (S p)))
(define (A/H p) (if (action-pattern? p) (A p) (H p)))
(define (A p)
(match p
@ -1291,18 +1275,16 @@
[(pat:head headp tailp)
(pat:head (H headp) (S tailp))]
;; --- The following patterns may change if a subpattern switches to head pattern ----
[(pat:pair headp tailp)
(let ([headp (S* headp)] [tailp (S tailp)])
(if (head-pattern? headp) (pat:head headp tailp) (pat:pair headp tailp)))]
[(pat:pair headp tailp) (error 'fixup-pattern "internal error: pat:pair in stage 0")]
[(pat:action a sp)
(let ([a (A a)] [sp (I sp)])
(if (head-pattern? sp) (hpat:action a sp) (pat:action a sp)))]
[(pat:describe sp desc tr? role)
(let ([sp (I sp)])
(if (head-pattern? sp) (hpat:describe sp desc tr? role) (pat:describe sp desc tr? role)))]
[(pat:and ps)
(let ([ps (map I ps)])
(pat:and ps))]
[(pat:andu ps)
(let ([ps (map A/S ps)])
(pat:andu ps))]
[(pat:and/fixup stx ps)
(let ([ps (for/list ([p (in-list ps)])
(cond [(action-pattern? p) (A p)]
@ -1341,8 +1323,9 @@
(hpat:action (A a) (H hp))]
[(hpat:describe hp desc tr? role)
(hpat:describe (H hp) desc tr? role)]
[(hpat:and hp sp)
(hpat:and (H hp) (S sp))]
[(hpat:andu ps)
(let ([ps (map A/H ps)])
(hpat:andu ps))]
[(hpat:or _ ps _)
(create-hpat:or (map H ps))]
[(hpat:delimit hp)
@ -1368,6 +1351,145 @@
(if head? (H p0) (S p0)))
;; ============================================================
;; Simplify pattern
;;(begin (require racket/pretty) (pretty-print-columns 160))
;; simplify-pattern : *Pattern -> *Pattern
(define (simplify-pattern p0)
;;(eprintf "-- simplify --\n")
;;(eprintf "~a\n" (pretty-format p0))
(define p1 (simplify:specialize-pairs p0))
;; (eprintf "=1=>\n~a\n" (pretty-format p1))
(define p2 (simplify:normalize-and p1))
;;(eprintf "=2=>\n~a\n" (pretty-format p2))
(define p3 (simplify:order-and p2))
;;(eprintf "=3=>\n~a\n" (pretty-format p3))
(define p4 (simplify:add-seq-end p3))
;;(eprintf "=4=>\n~a\n" (pretty-format p4))
p4)
;; ----------------------------------------
;; Add pair patterns
(define (simplify:specialize-pairs p)
(define (for-pattern p)
(match p
[(pat:head (hpat:single headp) tailp)
(pat:pair headp tailp)]
[(pat:head (hpat:seq lp) tailp)
(list-pattern-replace-end lp tailp)]
[_ p]))
(pattern-transform p for-pattern))
;; list-pattern-replace-end : ListPattern {L,S}Pattern -> {L,S}Pattern
(define (list-pattern-replace-end lp endp)
(let loop ([lp lp])
(match lp
[(pat:datum '()) endp]
[(pat:seq-end) endp]
[(pat:action ap sp) (pat:action ap (loop sp))]
[(pat:head hp tp) (pat:head hp (loop tp))]
[(pat:dots hs tp) (pat:dots hs (loop tp))]
[(pat:pair hp tp) (pat:pair hp (loop tp))])))
;; ----------------------------------------
;; Normalize *:andu patterns, drop useless actions
(define (simplify:normalize-and p)
(define (pattern->list p)
(match p
[(pat:any) null]
[(pat:action ap sp) (append (pattern->list ap) (pattern->list sp))]
[(pat:andu ps) (apply append (map pattern->list ps))]
[(hpat:action ap hp) (append (pattern->list ap) (pattern->list hp))]
[(hpat:andu ps) (apply append (map pattern->list ps))]
[(action:and as) (apply append (map pattern->list as))]
[(action:do '()) null]
[(action:undo '()) null]
[_ (list p)]))
(define (for-pattern p)
(match p
[(pat:action ap sp)
(pat:andu (append (pattern->list ap) (pattern->list sp)))]
[(pat:andu ps)
(pat:andu (apply append (map pattern->list ps)))]
[(hpat:action ap hp)
(hpat:andu (append (pattern->list ap) (pattern->list hp)))]
[(hpat:andu ps)
(hpat:andu (apply append (map pattern->list ps)))]
[(action:post ap)
(match (pattern->list ap)
['() (action:and '())]
[(list ap*) (action:post ap*)]
[as* (action:post (action:and as*))])]
[_ p]))
(pattern-transform p for-pattern))
;; ----------------------------------------
;; Add *:ord and translate back to *:and, *:action
(define (simplify:order-and p)
(define (A->S p) (if (action-pattern? p) (pat:action p (pat:any)) p))
(define (for-pattern p)
(match p
[(pat:andu ps0)
(define ord-ps (ord-and-patterns ps0 (gensym*)))
(define-values (as ps) (split-pred action-pattern? ord-ps))
(define sp* (list->single-pattern (map A->S ps)))
(add-action-patterns as sp*)]
[(hpat:andu ps0)
(define ord-ps (ord-and-patterns ps0 (gensym*)))
(define-values (as ps) (split-pred action-pattern? ord-ps))
(match ps
['() (error 'simplify:order-ands "internal error: no head pattern")]
[(list hp) (add-action-patterns as hp)]
[(cons hp1 hps)
(define sp* (list->single-pattern (map action/head-pattern->list-pattern hps)))
(define hp* (hpat:and hp1 sp*))
(add-action-patterns as hp*)])]
[_ p]))
(pattern-transform p for-pattern))
;; add-action-patterns : (Listof ActionPattern) *Pattern -> *Pattern
(define (add-action-patterns as p)
(if (pair? as)
(let ([ap (list->action-pattern as)])
(cond [(single-pattern? p) (pat:action ap p)]
[(head-pattern? p) (hpat:action ap p)]))
p))
;; list->action-pattern : (Listof ActionPattern) -> ActionPattern
(define (list->action-pattern as)
(match as
[(list ap) ap]
[_ (action:and as)]))
;; list->single-pattern : (Listof SinglePattern) -> SinglePattern
(define (list->single-pattern ps)
(match ps
['() (pat:any)]
[(list p) p]
[_ (pat:and ps)]))
(define (split-pred pred? xs)
(let loop ([xs xs] [acc null])
(if (and (pair? xs) (pred? (car xs)))
(loop (cdr xs) (cons (car xs) acc))
(values (reverse acc) xs))))
;; ----------------------------------------
;; Add pat:seq-end to end of list-patterns in seq
(define (simplify:add-seq-end p)
(define (for-pattern p)
(match p
[(hpat:seq lp)
(hpat:seq (list-pattern-replace-end lp (pat:seq-end)))]
[_ p]))
(pattern-transform p for-pattern))
;; ============================================================
;; Parsing pattern directives