1#lang racket/base
2(require syntax/parse/private/residual-ct ;; keep abs. path
3         "rep-attrs.rkt"
4         "minimatch.rkt"
5         "tree-util.rkt"
6         racket/syntax)
7(provide (all-defined-out))
8
9;; Uses Arguments from kws.rkt
10
11;; ------------------------------------------------------------
12;; Stage 1: Parsing, first pass
13
14;; Pattern parsing is done (in rep.rkt) in two passes. In pass 1, stxclass refs
15;; are not required to be bound, and so patterns like `x:sc` and `(~var x sc)`
16;; are left as "fixup" patterns to be resolved in pass 2.
17
18;; SinglePattern ::=
19;; | (pat:any)
20;; | (pat:svar id)  -- "simple" var, no stxclass
21;; | (pat:var/p Id Id Arguments (Listof IAttr) Syntax SCOpts) -- var with parser
22;; | (pat:literal Id Syntax Syntax)
23;; | (pat:datum Datum)
24;; | (pat:action ActionPattern SinglePattern)
25;; | (pat:head HeadPattern SinglePattern)
26;; | (pat:dots (listof EllipsisHeadPattern) SinglePattern)
27;; | (pat:andu (Listof (U SinglePattern ActionPattern)))
28;; | (pat:or (listof IAttr) (listof SinglePattern) (listof (listof IAttr)))
29;; | (pat:not SinglePattern)
30;; | (pat:vector SinglePattern)
31;; | (pat:box SinglePattern)
32;; | (pat:pstruct key SinglePattern)
33;; | (pat:describe SinglePattern Syntax Boolean Syntax)
34;; | (pat:delimit SinglePattern)
35;; | (pat:commit SinglePattern)
36;; | (pat:reflect stx Arguments (listof SAttr) id (listof IAttr))
37;; | (pat:post SinglePattern)
38;; | (pat:integrated Id/#f Id String Syntax)
39;; | (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f)
40;; | (pat:and/fixup Syntax (Listof (U {S,H,A}Pattern)))
41
42;; ListPattern ::=
43;; | (pat:datum '())
44;; | (pat:action ActionPattern ListPattern)
45;; | (pat:head HeadPattern ListPattern)
46;; | (pat:pair SinglePattern ListPattern)
47;; | (pat:dots EllipsisHeadPattern ListPattern)
48
49;; ActionPattern ::=
50;; | (action:cut)
51;; | (action:fail Syntax Syntax)
52;; | (action:bind IAttr Syntax)
53;; | (action:and (Listof ActionPattern))
54;; | (action:parse SinglePattern Syntax)
55;; | (action:do (Listof Syntax))
56;; | (action:undo (Listof Syntax))
57;; | (action:post ActionPattern)
58
59;; HeadPattern ::=
60;; | (hpat:single SinglePattern)
61;; | (hpat:var/p Id Id Arguments (Listof IAttr) Syntax SCOpts)
62;; | (hpat:seq ListPattern)
63;; | (hpat:action ActionPattern HeadPattern)
64;; | (hpat:andu (Listof (U Headpattern ActionPattern))) -- at least one HeadPattern
65;; | (hpat:or (Listof IAttr) (Listof HeadPattern) (Listof (Listof IAttr)))
66;; | (hpat:describe HeadPattern Syntax/#f Boolean Syntax)
67;; | (hpat:delimit HeadPattern)
68;; | (hpat:commit HeadPattern)
69;; | (hpat:reflect Syntax Arguments (Listof SAttr) Id (Listof IAttr))
70;; | (hpat:post HeadPattern)
71;; | (hpat:peek HeadPattern)
72;; | (hpat:peek-not HeadPattern)
73
74;; EllipsisHeadPattern ::=
75;; | (ehpat (Listof IAttr) HeadPattern RepConstraint Boolean)
76
77;; RepConstraint ::=
78;; | (rep:once Syntax Syntax Syntax)
79;; | (rep:optional Syntax Syntax (Listof BindAction))
80;; | (rep:bounds Nat PosInt/+inf.0 Syntax Syntax Syntax)
81;; | #f
82
83;; BindAction ::= (action:bind IAttr Syntax)
84;; SideClause ::= ActionPattern
85
86;; ------------------------------------------------------------
87;; Stage 2: Parsing, pass 2
88
89;; SinglePattern ::= ....
90;; X (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f)
91;; X (pat:and/fixup Syntax (Listof (U {S,H,A}Pattern)))
92
93;; Note: pat:action can change to hpat:action; pat:andu cannot change.
94
95;; ------------------------------------------------------------
96;; Stage 3: Specialize pair patterns
97
98;; Rewrite (pat:head (hpat:single headp) tailp) => (pat:pair headp tailp).
99;; Rewrite (pat:head (hpat:seq lp[end]) tailp) -> lp[tailp].
100
101;; FIXME/TODO: also do the following:
102;; - add pat:seq-end
103;; - rewrite (pat:head (hpat:seq (pat:head h1 t1)) t2) => (pat:head h1 (pat:head (hpat:seq t1) t2))
104
105;; SinglePattern ::= ....
106;; + (pat:pair SinglePattern SinglePattern)
107
108;; ListPattern ::=
109;; + (pat:pair SinglePattern ListPattern)
110
111;; ------------------------------------------------------------
112;; Stage 4a: Normalize and patterns
113
114;; SinglePattern ::= ....
115;; X (pat:action ActionPattern SinglePattern)
116
117;; ActionPattern ::= ....
118;; X (action:and (Listof ActionPattern))
119
120;; HeadPattern ::=
121;; X (hpat:action ActionPattern HeadPattern)
122
123;; ------------------------------------------------------------
124;; Stage 4b: Add *:ord wrappers for *:and components
125
126;; SinglePattern ::= ....
127;; X (pat:andu (Listof (U SinglePattern ActionPattern)))
128;; + (pat:action ActionPattern SinglePattern)
129;; + (pat:and (Listof SinglePattern))
130;; + (pat:ord SinglePattern UninternedSymbol Nat)
131
132;; ActionPattern ::= ....
133;; + (action:ord ActionPattern UninternedSymbol Nat)
134;; + (action:and (Listof ActionPattern))
135
136;; HeadPattern ::= ....
137;; X (hpat:andu (Listof (U HeadPattern ActionPattern)))
138;; + (hpat:action ActionPattern HeadPattern)
139;; + (hpat:and HeadPattern SinglePattern)
140;; + (hpat:ord HeadPattern UninternedSymbol Nat)
141
142;; ------------------------------------------------------------
143;; Stage 5: Switch to pat:seq-end in list patterns
144
145;; ListPattern ::= ...
146;; X (pat:datum '())
147;; + (pat:seq-end)
148
149;; ------------------------------------------------------------
150
151(define-struct pat:any () #:prefab)
152(define-struct pat:svar (name) #:prefab)
153(define-struct pat:var/p (name parser argu nested-attrs role opts) #:prefab)
154(define-struct pat:literal (id input-phase lit-phase) #:prefab)
155(define-struct pat:datum (datum) #:prefab)
156(define-struct pat:action (action inner) #:prefab)
157(define-struct pat:head (head tail) #:prefab)
158(define-struct pat:dots (heads tail) #:prefab)
159(define-struct pat:andu (patterns) #:prefab)
160(define-struct pat:and (patterns) #:prefab)
161(define-struct pat:or (attrs patterns attrss) #:prefab)
162(define-struct pat:not (pattern) #:prefab)
163(define-struct pat:pair (head tail) #:prefab)
164(define-struct pat:vector (pattern) #:prefab)
165(define-struct pat:box (pattern) #:prefab)
166(define-struct pat:pstruct (key pattern) #:prefab)
167(define-struct pat:describe (pattern description transparent? role) #:prefab)
168(define-struct pat:delimit (pattern) #:prefab)
169(define-struct pat:commit (pattern) #:prefab)
170(define-struct pat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
171(define-struct pat:ord (pattern group index) #:prefab)
172(define-struct pat:post (pattern) #:prefab)
173(define-struct pat:integrated (name predicate description role) #:prefab)
174(define-struct pat:fixup (stx bind varname scname argu sep role parser*) #:prefab)
175(define-struct pat:and/fixup (stx patterns) #:prefab)
176(define-struct pat:seq-end () #:prefab)
177
178(define-struct action:cut () #:prefab)
179(define-struct action:fail (when message) #:prefab)
180(define-struct action:bind (attr expr) #:prefab)
181(define-struct action:and (patterns) #:prefab)
182(define-struct action:parse (pattern expr) #:prefab)
183(define-struct action:do (stmts) #:prefab)
184(define-struct action:undo (stmts) #:prefab)
185(define-struct action:ord (pattern group index) #:prefab)
186(define-struct action:post (pattern) #:prefab)
187
188(define-struct hpat:single (pattern) #:prefab)
189(define-struct hpat:var/p (name parser argu nested-attrs role scopts) #:prefab)
190(define-struct hpat:seq (inner) #:prefab)
191(define-struct hpat:action (action inner) #:prefab)
192(define-struct hpat:andu (patterns) #:prefab)
193(define-struct hpat:and (head single) #:prefab)
194(define-struct hpat:or (attrs patterns attrss) #:prefab)
195(define-struct hpat:describe (pattern description transparent? role) #:prefab)
196(define-struct hpat:delimit (pattern) #:prefab)
197(define-struct hpat:commit (pattern) #:prefab)
198(define-struct hpat:reflect (obj argu attr-decls name nested-attrs) #:prefab)
199(define-struct hpat:ord (pattern group index) #:prefab)
200(define-struct hpat:post (pattern) #:prefab)
201(define-struct hpat:peek (pattern) #:prefab)
202(define-struct hpat:peek-not (pattern) #:prefab)
203
204(define-struct ehpat (attrs head repc check-null?) #:prefab)
205(define-struct rep:once (name under-message over-message) #:prefab)
206(define-struct rep:optional (name over-message defaults) #:prefab)
207(define-struct rep:bounds (min max name under-message over-message) #:prefab)
208
209;; ============================================================
210
211(define (single-pattern? x)
212  (or (pat:any? x)
213      (pat:svar? x)
214      (pat:var/p? x)
215      (pat:literal? x)
216      (pat:datum? x)
217      (pat:action? x)
218      (pat:head? x)
219      (pat:dots? x)
220      (pat:andu? x)
221      (pat:and? x)
222      (pat:or? x)
223      (pat:not? x)
224      (pat:pair? x)
225      (pat:vector? x)
226      (pat:box? x)
227      (pat:pstruct? x)
228      (pat:describe? x)
229      (pat:delimit? x)
230      (pat:commit? x)
231      (pat:reflect? x)
232      (pat:ord? x)
233      (pat:post? x)
234      (pat:integrated? x)
235      (pat:fixup? x)
236      (pat:and/fixup? x)
237      (pat:seq-end? x)))
238
239(define (action-pattern? x)
240  (or (action:cut? x)
241      (action:bind? x)
242      (action:fail? x)
243      (action:and? x)
244      (action:parse? x)
245      (action:do? x)
246      (action:undo? x)
247      (action:ord? x)
248      (action:post? x)))
249
250(define (head-pattern? x)
251  (or (hpat:single? x)
252      (hpat:var/p? x)
253      (hpat:seq? x)
254      (hpat:action? x)
255      (hpat:andu? x)
256      (hpat:and? x)
257      (hpat:or? x)
258      (hpat:describe? x)
259      (hpat:delimit? x)
260      (hpat:commit? x)
261      (hpat:reflect? x)
262      (hpat:ord? x)
263      (hpat:post? x)
264      (hpat:peek? x)
265      (hpat:peek-not? x)))
266
267(define (ellipsis-head-pattern? x)
268  (ehpat? x))
269
270(define (single-or-head-pattern? x)
271  (or (single-pattern? x)
272      (head-pattern? x)))
273
274(define (*pattern? x)
275  (and (struct? x)
276       (or (single-pattern? x)
277           (action-pattern? x)
278           (head-pattern? x)
279           (ellipsis-head-pattern? x))))
280
281;; ============================================================
282
283(define (wf-S? x)
284  (match x
285    [(pat:any) #t]
286    [(pat:svar name) #t]
287    [(pat:var/p name parser argu nested-attrs role opts) #t]
288    [(pat:literal id input-phase lit-phase) #t]
289    [(pat:datum datum) #t]
290    [(pat:action ap sp) (and (wf-A? ap) (wf-S? sp))]
291    [(pat:head headp tailp) (and (wf-H? headp) (wf-S? tailp))]
292    [(pat:dots heads tailp) (and (andmap wf-EH? heads) (wf-S? tailp))]
293    [(pat:andu ps) (andmap wf-A/S? ps)]
294    [(pat:and ps) (andmap wf-S? ps)]
295    [(pat:or attrs ps attrss) (andmap wf-S? ps)]
296    [(pat:not sp) (wf-S? sp)]
297    [(pat:pair headp tailp) (and (wf-S? headp) (wf-S? tailp))]
298    [(pat:vector sp) (wf-S? sp)]
299    [(pat:box sp) (wf-S? sp)]
300    [(pat:pstruct key sp) (wf-S? sp)]
301    [(pat:describe sp description transparent? role) (wf-S? sp)]
302    [(pat:delimit sp) (wf-S? sp)]
303    [(pat:commit sp) (wf-S? sp)]
304    [(pat:reflect obj argu attr-decls name nested-attrs) #t]
305    [(pat:ord sp group index) (wf-S? sp)]
306    [(pat:post sp) (wf-S? sp)]
307    [(pat:integrated name predicate description role) #t]
308    [(pat:fixup stx bind varname scname argu sep role parser*) #t]
309    [(pat:and/fixup stx ps) (andmap wf-A/S/H? ps)]
310    [(pat:seq-end) #f] ;; Should only occur in ListPattern!
311    [_ #f]))
312
313(define (wf-L? x)
314  (match x
315    [(pat:datum '()) #t]
316    [(pat:seq-end) #t]
317    [(pat:action ap sp) (and (wf-A? ap) (wf-L? sp))]
318    [(pat:head headp tailp) (and (wf-H? headp) (wf-L? tailp))]
319    [(pat:dots heads tailp) (and (andmap wf-EH? heads) (wf-L? tailp))]
320    [(pat:pair headp tailp) (and (wf-S? headp) (wf-L? tailp))]
321    [_ #f]))
322
323(define (wf-A? x)
324  (match x
325    [(action:cut) #t]
326    [(action:fail cnd msg) #t]
327    [(action:bind attr expr) #t]
328    [(action:and ps) (andmap wf-A? ps)]
329    [(action:parse sp expr) (wf-S? sp)]
330    [(action:do stmts) #t]
331    [(action:undo stmts) #t]
332    [(action:ord sp group index) (wf-A? sp)]
333    [(action:post sp) (wf-A? sp)]
334    [_ #f]))
335
336(define (wf-H? x)
337  (match x
338    [(hpat:single sp) (wf-S? sp)]
339    [(hpat:var/p name parser argu nested-attrs role scopts) #t]
340    [(hpat:seq sp) (wf-L? sp)]
341    [(hpat:action ap sp) (and (wf-A? ap) (wf-H? sp))]
342    [(hpat:andu ps) (andmap wf-A/H? ps)]
343    [(hpat:and hp sp) (and (wf-H? hp) (wf-S? sp))]
344    [(hpat:or attrs ps attrss) (andmap wf-H? ps)]
345    [(hpat:describe sp description transparent? role) (wf-H? sp)]
346    [(hpat:delimit sp) (wf-H? sp)]
347    [(hpat:commit sp) (wf-H? sp)]
348    [(hpat:reflect obj argu attr-decls name nested-attrs) #t]
349    [(hpat:ord sp group index) (wf-H? sp)]
350    [(hpat:post sp) (wf-H? sp)]
351    [(hpat:peek sp) (wf-H? sp)]
352    [(hpat:peek-not sp) (wf-H? sp)]
353    [_ #f]))
354
355(define (wf-EH? x)
356  (match x
357    [(ehpat _ hp _ _) (wf-H? hp)]
358    [_ #f]))
359
360(define (wf-A/S? p)
361  (cond [(action-pattern? p) (wf-A? p)]
362        [(single-pattern? p) (wf-S? p)]
363        [else #f]))
364
365(define (wf-A/H? p)
366  (cond [(action-pattern? p) (wf-A? p)]
367        [(head-pattern? p) (wf-H? p)]
368        [else #f]))
369
370(define (wf-A/S/H? p)
371  (cond [(action-pattern? p) (wf-A? p)]
372        [(single-pattern? p) (wf-S? p)]
373        [(head-pattern? p) (wf-H? p)]
374        [else #f]))
375
376;; ============================================================
377
378;; pattern-transform : *Pattern (*Pattern -> *Pattern) -> *Pattern
379(define (pattern-transform p for-pattern [root? #t])
380  (define (for-node x) (if (*pattern? x) (for-pattern x) x))
381  (tree-transform p for-node root?))
382
383;; pattern-transform-preorder : *Pattern (*Pattern (X -> X) -> *Pattern) -> *Pattern
384(define (pattern-transform-preorder p for-pattern [root? #t])
385  (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
386  (tree-transform-preorder p for-node root?))
387
388;; pattern-reduce{,-left} : *Pattern (*Pattern -> X) (X ... -> X) -> X
389(define (pattern-reduce p for-pattern reduce [root? #t])
390  (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
391  (tree-reduce p for-node reduce root?))
392(define (pattern-reduce-left p for-pattern reduce [root? #t])
393  (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
394  (tree-reduce-left p for-node reduce root?))
395
396;; pattern-ormap : *Pattern (*Pattern -> X/#f) -> X/#f
397(define (pattern-ormap p for-pattern [root? #t])
398  (define (for-node x recur) (if (*pattern? x) (for-pattern x recur) (recur)))
399  (tree-ormap p for-node root?))
400
401;; ============================================================
402
403(define pattern? single-pattern?)
404
405(define (coerce-head-pattern p)
406  (if (head-pattern? p) p (hpat:single p)))
407
408(define (head-pattern-not-single? hp)
409  (and (head-pattern? hp) (not (hpat:single? hp))))
410
411;; check-pattern : *Pattern -> *Pattern
412;; Does attr computation to catch errors, but returns same pattern.
413(define (check-pattern p)
414  (void (pattern-attrs p))
415  p)
416
417;; pattern-attrs-table : Hasheq[*Pattern => (Listof IAttr)]
418(define pattern-attrs-table (make-weak-hasheq))
419
420;; pattern-attrs : *Pattern -> (Listof IAttr)
421(define (pattern-attrs p)
422  (define (for-pattern p recur)
423    (hash-ref! pattern-attrs-table p (lambda () (for-pattern* p recur))))
424  (define (for-pattern* p recur)
425    (match p
426      ;; -- S patterns
427      [(pat:svar name)
428       (list (attr name 0 #t))]
429      [(pat:var/p name _ _ nested-attrs _ _)
430       (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
431      [(pat:reflect _ _ _ name nested-attrs)
432       (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
433      [(pat:or iattrs ps _)
434       iattrs]
435      [(pat:not _)
436       null]
437      [(pat:integrated name _ _ _)
438       (if name (list (attr name 0 #t)) null)]
439      [(pat:fixup _ bind _ _ _ _ _ _)
440       (if bind (list (attr bind 0 #t)) null)]
441      ;; -- A patterns
442      [(action:bind attr expr)
443       (list attr)]
444      ;; -- H patterns
445      [(hpat:var/p name _ _ nested-attrs _ _)
446       (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
447      [(hpat:reflect _ _ _ name nested-attrs)
448       (if name (cons (attr name 0 #t) nested-attrs) nested-attrs)]
449      [(hpat:or iattrs ps _)
450       iattrs]
451      [(hpat:peek-not _)
452       null]
453      ;; EH patterns
454      [(ehpat iattrs _ _ _)
455       iattrs]
456      [_ (recur)]))
457  (pattern-reduce p for-pattern (lambda iattrss (append-iattrs iattrss))))
458
459;; ------------------------------------------------------------
460
461;; pattern-has-cut? : *Pattern -> Boolean
462;; Returns #t if p *might* cut (~!, not within ~delimit-cut).
463(define (pattern-has-cut? p)
464  (define (for-pattern p recur)
465    (match p
466      [(pat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
467      [(pat:not _) #f]
468      [(pat:delimit _) #f]
469      [(pat:commit _) #f]
470      [(pat:fixup _ _ _ _ _ _ _ _) #t]
471      [(action:cut) #t]
472      [(hpat:var/p _ _ _ _ _ opts) (not (scopts-delimit-cut? opts))]
473      [(hpat:delimit _) #f]
474      [(hpat:commit _) #f]
475      [_ (recur)]))
476  (pattern-reduce p for-pattern (lambda xs (ormap values xs))))
477
478;; ============================================================
479
480(define (create-pat:or ps)
481  (define attrss (map pattern-attrs ps))
482  (pat:or (union-iattrs attrss) ps attrss))
483
484(define (create-hpat:or ps)
485  (define attrss (map pattern-attrs ps))
486  (hpat:or (union-iattrs attrss) ps attrss))
487
488;; create-ehpat : HeadPattern RepConstraint Syntax -> EllipsisHeadPattern
489(define (create-ehpat head repc head-stx)
490  (let* ([iattrs0 (pattern-attrs head)]
491         [iattrs (repc-adjust-attrs iattrs0 repc)])
492    (define nullable (hpat-nullable head))
493    (define unbounded-iterations?
494      (cond [(rep:once? repc) #f]
495            [(rep:optional? repc) #f]
496            [(rep:bounds? repc) (eq? (rep:bounds-max repc) +inf.0)]
497            [else #t]))
498    (when (and (eq? nullable 'yes) unbounded-iterations?)
499      (when #f (wrong-syntax head-stx "nullable ellipsis-head pattern"))
500      (when #t (log-syntax-parse-error "nullable ellipsis-head pattern: ~e" head-stx)))
501    (ehpat iattrs head repc (case nullable [(yes unknown) unbounded-iterations?] [(no) #f]))))
502
503(define (repc-adjust-attrs iattrs repc)
504  (cond [(rep:once? repc)
505         iattrs]
506        [(rep:optional? repc)
507         (map attr-make-uncertain iattrs)]
508        [(or (rep:bounds? repc) (eq? #f repc))
509         (map increase-depth iattrs)]
510        [else
511         (error 'repc-adjust-attrs "INTERNAL ERROR: unexpected: ~e" repc)]))
512
513;; ----
514
515(define (action/head-pattern->list-pattern p)
516  (cond [(action-pattern? p)
517         (pat:action p (pat:any))]
518        [(hpat:seq? p)
519         ;; simplification: just extract list pattern from hpat:seq
520         (hpat:seq-inner p)]
521        [else
522         (pat:head p (pat:datum '()))]))
523
524(define (action-pattern->single-pattern a)
525  (pat:action a (pat:any)))
526
527(define (proper-list-pattern? p)
528  (or (and (pat:datum? p) (eq? (pat:datum-datum p) '()))
529      (and (pat:pair? p) (proper-list-pattern? (pat:pair-tail p)))
530      (and (pat:head? p) (proper-list-pattern? (pat:head-tail p)))
531      (and (pat:dots? p) (proper-list-pattern? (pat:dots-tail p)))
532      (and (pat:action? p) (proper-list-pattern? (pat:action-inner p)))))
533
534;; ----
535
536(define-syntax-rule (define/memo (f x) body ...)
537  (define f
538    (let ([memo-table (make-weak-hasheq)])
539      (lambda (x)
540        (hash-ref! memo-table x (lambda () body ...))))))
541
542;; ============================================================
543
544;; An AbsFail is a Nat encoding the bitvector { sub? : 1, post? : 1 }
545;; Finite abstraction of failuresets based on progress bins. That is:
546(define AF-NONE 0)  ;; cannot fail
547(define AF-SUB  1)  ;; can fail with progress < POST
548(define AF-POST 2)  ;; can fail with progress >= POST
549(define AF-ANY  3)  ;; can fail with progress either < or >= POST
550
551;; AF-nz? : AbsFail -> Boolean
552(define (AF-nz? af) (not (= af AF-NONE)))
553
554;; AF<? : AbsFail AbsFail -> Boolean
555;; True if every failure in af1 has strictly less progress than any failure in af2.
556;; Note: trivially satisfied if either side cannot fail.
557(define (AF<? af1 af2)
558  ;; (0, *), (*, 0), (1, 2)
559  (or (= af1 AF-NONE)
560      (= af2 AF-NONE)
561      (and (= af1 AF-SUB) (= af2 AF-POST))))
562
563;; pattern-AF-table : Hasheq[*Pattern => AbsFail]
564(define pattern-AF-table (make-weak-hasheq))
565
566;; pattern-AF : *Pattern -> AbsFail
567(define (pattern-AF p)
568  (define (for-pattern p recur)
569    (hash-ref pattern-AF-table p (lambda () (for-pattern* p recur))))
570  (define (for-pattern* p recur)
571    (cond [(pat:var/p? p) AF-ANY]
572          [(pat:literal? p) AF-SUB]
573          [(pat:datum? p) AF-SUB]
574          [(pat:head? p) AF-ANY]
575          [(pat:dots? p) AF-ANY]
576          [(pat:not? p) AF-SUB]
577          [(pat:pair? p) AF-SUB]
578          [(pat:vector? p) AF-SUB]
579          [(pat:box? p) AF-SUB]
580          [(pat:pstruct? p) AF-SUB]
581          [(pat:reflect? p) AF-ANY]
582          [(pat:post? p) (if (AF-nz? (pattern-AF (pat:post-pattern p))) AF-POST AF-NONE)]
583          [(pat:integrated? p) AF-SUB]
584          [(action:fail? p) AF-SUB]
585          [(action:parse? p) (if (AF-nz? (pattern-AF (action:parse-pattern p))) AF-SUB AF-NONE)]
586          [(action:ord? p) (pattern-AF (action:ord-pattern p))]
587          [(action:post? p) (if (AF-nz? (pattern-AF (action:post-pattern p))) AF-POST AF-NONE)]
588          [(head-pattern? p) AF-ANY] ;; this case should not be reachable
589          [else (recur)]))
590  (pattern-reduce-left p for-pattern bitwise-ior))
591
592;; pattern-cannot-fail? : *Pattern -> Boolean
593(define (pattern-cannot-fail? p)
594  (= (pattern-AF p) AF-NONE))
595
596;; pattern-can-fail? : *Pattern -> Boolean
597(define (pattern-can-fail? p)
598  (not (pattern-cannot-fail? p)))
599
600;; patterns-AF-sorted? : (Listof *Pattern) -> AF/#f
601;; Returns AbsFail (true) if any failure from pattern N+1 has strictly
602;; greater progress than any failure from patterns 0 through N.
603(define (patterns-AF-sorted? ps)
604  (for/fold ([af AF-NONE]) ([p (in-list ps)])
605    (define afp (pattern-AF p))
606    (and af (AF<? af afp) (bitwise-ior af afp))))
607
608;; ----
609
610;; patterns-cannot-fail? : (Listof SinglePattern) -> Boolean
611;; Returns true if the disjunction of the patterns always succeeds---and thus no
612;; failure-tracking needed. Note: beware cut!
613(define (patterns-cannot-fail? patterns)
614  (and (not (ormap pattern-has-cut? patterns))
615       (ormap pattern-cannot-fail? patterns)))
616
617;; ============================================================
618
619;; An AbsNullable is 'yes | 'no | 'unknown (3-valued logic)
620
621(define (3and a b)
622  (case a
623    [(yes) b]
624    [(no) 'no]
625    [(unknown) (case b [(yes unknown) 'unknown] [(no) 'no])]))
626
627(define (3or a b)
628  (case a
629    [(yes) 'yes]
630    [(no) b]
631    [(unknown) (case b [(yes) 'yes] [(no unknown) 'unknown])]))
632
633(define (3andmap f xs) (foldl 3and 'yes (map f xs)))
634(define (3ormap f xs) (foldl 3or 'no (map f xs)))
635
636;; lpat-nullable : ListPattern -> AbsNullable
637(define/memo (lpat-nullable lp)
638  (match lp
639    [(pat:datum '()) 'yes]
640    [(pat:action ap lp) (lpat-nullable lp)]
641    [(pat:head hp lp) (3and (hpat-nullable hp) (lpat-nullable lp))]
642    [(pat:pair sp lp) 'no]
643    [(pat:dots ehps lp) (3and (3andmap ehpat-nullable ehps) (lpat-nullable lp))]
644    ;; For hpat:and, handle the following which are not ListPatterns
645    [(pat:andu lps) (3andmap lpat-nullable (filter single-pattern? lps))]
646    [(pat:and lps) (3andmap lpat-nullable lps)]
647    [(pat:any) #t]
648    [_ 'unknown]))
649
650;; hpat-nullable : HeadPattern -> AbsNullable
651(define/memo (hpat-nullable hp)
652  (match hp
653    [(hpat:single sp) 'no]
654    [(hpat:seq lp) (lpat-nullable lp)]
655    [(hpat:action ap hp) (hpat-nullable hp)]
656    [(hpat:andu ps) (3andmap hpat-nullable (filter head-pattern? ps))]
657    [(hpat:and hp sp) (3and (hpat-nullable hp) (lpat-nullable sp))]
658    [(hpat:or _attrs hps _attrss) (3ormap hpat-nullable hps)]
659    [(hpat:describe hp _ _ _) (hpat-nullable hp)]
660    [(hpat:delimit hp) (hpat-nullable hp)]
661    [(hpat:commit hp) (hpat-nullable hp)]
662    [(hpat:ord hp _ _) (hpat-nullable hp)]
663    [(hpat:post hp) (hpat-nullable hp)]
664    [_ 'unknown]))
665
666;; ehpat-nullable : EllipsisHeadPattern -> AbsNullable
667(define (ehpat-nullable ehp)
668  (match ehp
669    [(ehpat _ hp repc _)
670     (3or (repc-nullable repc) (hpat-nullable hp))]))
671
672;; repc-nullable : RepConstraint -> AbsNullable
673(define (repc-nullable repc)
674  (cond [(rep:once? repc) 'no]
675        [(and (rep:bounds? repc) (> (rep:bounds-min repc) 0)) 'no]
676        [else 'yes]))
677
678;; ============================================================
679
680;; create-post-pattern : *Pattern -> *Pattern
681(define (create-post-pattern p)
682  (cond [(pattern-cannot-fail? p)
683         p]
684        [(pattern? p)
685         (pat:post p)]
686        [(head-pattern? p)
687         (hpat:post p)]
688        [(action-pattern? p)
689         (action:post p)]
690        [else (error 'syntax-parse "INTERNAL ERROR: create-post-pattern ~e" p)]))
691
692;; create-ord-pattern : *Pattern UninternedSymbol Nat -> *Pattern
693(define (create-ord-pattern p group index)
694  (cond [(pattern-cannot-fail? p)
695         p]
696        [(single-pattern? p)
697         (pat:ord p group index)]
698        [(head-pattern? p)
699         (hpat:ord p group index)]
700        [(action-pattern? p)
701         (action:ord p group index)]
702        [else (error 'syntax-parse "INTERNAL ERROR: create-ord-pattern ~e" p)]))
703
704;; ord-and-patterns : (Listof *Pattern) UninternedSymbol -> (Listof *Pattern)
705;; If at most one subpattern can fail, no need to wrap.  More
706;; generally, if possible failures are already consistent with and
707;; ordering, no need to wrap.
708(define (ord-and-patterns patterns group)
709  (cond [(patterns-AF-sorted? patterns) patterns]
710        [else
711         (for/list ([p (in-list patterns)] [index (in-naturals)])
712           (create-ord-pattern p group index))]))
713