diff --git a/racket/collects/syntax/parse/private/opt.rkt b/racket/collects/syntax/parse/private/opt.rkt index d8ce3cf019..b569dcc9f3 100644 --- a/racket/collects/syntax/parse/private/opt.rkt +++ b/racket/collects/syntax/parse/private/opt.rkt @@ -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)] diff --git a/racket/collects/syntax/parse/private/parse.rkt b/racket/collects/syntax/parse/private/parse.rkt index 858e8b480d..609d0a48b4 100644 --- a/racket/collects/syntax/parse/private/parse.rkt +++ b/racket/collects/syntax/parse/private/parse.rkt @@ -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)] diff --git a/racket/collects/syntax/parse/private/rep-attrs.rkt b/racket/collects/syntax/parse/private/rep-attrs.rkt index 11fbe0a72d..9f465bc1ad 100644 --- a/racket/collects/syntax/parse/private/rep-attrs.rkt +++ b/racket/collects/syntax/parse/private/rep-attrs.rkt @@ -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) diff --git a/racket/collects/syntax/parse/private/rep-patterns.rkt b/racket/collects/syntax/parse/private/rep-patterns.rkt index 87a320666b..baae7793d2 100644 --- a/racket/collects/syntax/parse/private/rep-patterns.rkt +++ b/racket/collects/syntax/parse/private/rep-patterns.rkt @@ -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)])) diff --git a/racket/collects/syntax/parse/private/rep.rkt b/racket/collects/syntax/parse/private/rep.rkt index c40c903628..4a258b4f64 100644 --- a/racket/collects/syntax/parse/private/rep.rkt +++ b/racket/collects/syntax/parse/private/rep.rkt @@ -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 -> (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