vm.fail
OCaml parser combinator that compiles to direct recursive descent
6.5 kB
173 lines
1open Ir
2
3type error =
4 | Left_recursion of { loc : loc; name : string; path : string list }
5 | Ambiguous_alt of { loc : loc }
6
7let left_recursive_path env names expr =
8 let rec nullable = function
9 | Pure _ -> true
10 | Fail _ -> false
11 | Satisfy _ -> false
12 | Any _ -> false
13 | Eof _ -> true
14 | Token _ -> false
15 | Tokens _ -> false
16 | OneOf _ -> false
17 | NoneOf _ -> false
18 | Bind { p; _ } -> nullable p
19 | Map { p; _ } -> nullable p
20 | Apply { pf; px; _ } -> nullable pf && nullable px
21 | SeqLeft { p; q; _ } -> nullable p && nullable q
22 | SeqRight { p; q; _ } -> nullable p && nullable q
23 | Alt { p; q; _ } -> nullable p || nullable q
24 | Attempt { p; _ } -> nullable p
25 | Cut _ -> true
26 | Lookahead _ -> true
27 | NotFollowedBy _ -> true
28 | Many _ -> true
29 | Some_ { p; _ } -> nullable p
30 | SkipMany _ -> true
31 | SkipSome { p; _ } -> nullable p
32 | TakeWhile { at_least_one; _ } -> not at_least_one
33 | Optional _ -> true
34 | Option _ -> true
35 | SepBy _ -> true
36 | SepBy1 { p; sep; _ } -> nullable p && nullable sep
37 | EndBy _ -> true
38 | EndBy1 { p; sep; _ } -> nullable p && nullable sep
39 | ManyTill _ -> true
40 | Count _ -> false
41 | Between { open_; close; p; _ } -> nullable open_ && nullable p && nullable close
42 | ChainL _ -> true
43 | ChainL1 { p; _ } -> nullable p
44 | ChainR _ -> true
45 | ChainR1 { p; _ } -> nullable p
46 | Choice { ps; _ } -> List.exists nullable ps
47 | Label { p; _ } -> nullable p
48 | Memo { p; _ } -> nullable p
49 | Fix _ -> false
50 | Var { name; _ } ->
51 (match List.assoc_opt name env with
52 | Some e -> nullable e
53 | None -> false)
54 in
55 let rec check path = function
56 | Var { name; _ } when List.mem name names ->
57 Some (List.rev (name :: path))
58 | Var { name; _ } ->
59 (match List.assoc_opt name env with
60 | Some e -> check (name :: path) e
61 | None -> None)
62 | Bind { p; _ } -> check path p
63 | Map { p; _ } -> check path p
64 | Apply { pf; px; _ } ->
65 (match check path pf with
66 | Some _ as r -> r
67 | None -> if nullable pf then check path px else None)
68 | SeqLeft { p; q; _ } ->
69 (match check path p with
70 | Some _ as r -> r
71 | None -> if nullable p then check path q else None)
72 | SeqRight { p; q; _ } ->
73 (match check path p with
74 | Some _ as r -> r
75 | None -> if nullable p then check path q else None)
76 | Alt { p; q; _ } ->
77 (match check path p with
78 | Some _ as r -> r
79 | None -> check path q)
80 | Attempt { p; _ } -> check path p
81 | Lookahead { p; _ } -> check path p
82 | NotFollowedBy { p; _ } -> check path p
83 | Label { p; _ } -> check path p
84 | Many { p; _ } -> check path p
85 | Some_ { p; _ } -> check path p
86 | SkipMany { p; _ } -> check path p
87 | SkipSome { p; _ } -> check path p
88 | TakeWhile _ -> None
89 | Optional { p; _ } -> check path p
90 | Option { p; _ } -> check path p
91 | SepBy { p; _ } -> check path p
92 | SepBy1 { p; _ } -> check path p
93 | EndBy { p; _ } -> check path p
94 | EndBy1 { p; _ } -> check path p
95 | ManyTill { p; _ } -> check path p
96 | Count { p; _ } -> check path p
97 | Between { open_; _ } -> check path open_
98 | ChainL { p; _ } -> check path p
99 | ChainL1 { p; _ } -> check path p
100 | ChainR { p; _ } -> check path p
101 | ChainR1 { p; _ } -> check path p
102 | Choice { ps; _ } -> List.find_map (check path) ps
103 | Memo { p; _ } -> check path p
104 | Fix _ -> None
105 | Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _
106 | OneOf _ | NoneOf _ | Cut _ -> None
107 in
108 check [] expr
109
110let check_left_recursion env names expr =
111 match left_recursive_path env names expr with
112 | Some path -> Some (Left_recursion { loc = loc_of_expr expr; name = List.hd names; path })
113 | None -> None
114
115let is_wrapped_in_attempt = function
116 | Attempt _ -> true
117 | _ -> false
118
119let rec check_expr env = function
120 | Alt { loc; p; q } ->
121 let p_first = First_set.compute env p in
122 let q_first = First_set.compute env q in
123 let errs =
124 if is_wrapped_in_attempt p || is_wrapped_in_attempt q then
125 []
126 else if not (First_set.definitely_disjoint p_first q_first) then
127 [Ambiguous_alt { loc }]
128 else
129 []
130 in
131 errs @ check_expr env p @ check_expr env q
132 | Bind { p; _ } -> check_expr env p
133 | Map { p; _ } -> check_expr env p
134 | Apply { pf; px; _ } -> check_expr env pf @ check_expr env px
135 | SeqLeft { p; q; _ } -> check_expr env p @ check_expr env q
136 | SeqRight { p; q; _ } -> check_expr env p @ check_expr env q
137 | Attempt { p; _ } -> check_expr env p
138 | Lookahead { p; _ } -> check_expr env p
139 | NotFollowedBy { p; _ } -> check_expr env p
140 | Many { p; _ } -> check_expr env p
141 | Some_ { p; _ } -> check_expr env p
142 | SkipMany { p; _ } -> check_expr env p
143 | SkipSome { p; _ } -> check_expr env p
144 | TakeWhile _ -> []
145 | Optional { p; _ } -> check_expr env p
146 | Option { p; _ } -> check_expr env p
147 | SepBy { p; sep; _ } -> check_expr env p @ check_expr env sep
148 | SepBy1 { p; sep; _ } -> check_expr env p @ check_expr env sep
149 | EndBy { p; sep; _ } -> check_expr env p @ check_expr env sep
150 | EndBy1 { p; sep; _ } -> check_expr env p @ check_expr env sep
151 | ManyTill { p; end_; _ } -> check_expr env p @ check_expr env end_
152 | Count { p; _ } -> check_expr env p
153 | Between { open_; close; p; _ } -> check_expr env open_ @ check_expr env close @ check_expr env p
154 | ChainL { p; op; _ } -> check_expr env p @ check_expr env op
155 | ChainL1 { p; op; _ } -> check_expr env p @ check_expr env op
156 | ChainR { p; op; _ } -> check_expr env p @ check_expr env op
157 | ChainR1 { p; op; _ } -> check_expr env p @ check_expr env op
158 | Choice { ps; _ } -> List.concat_map (check_expr env) ps
159 | Label { p; _ } -> check_expr env p
160 | Memo { p; _ } -> check_expr env p
161 | Pure _ | Fail _ | Satisfy _ | Any _ | Eof _ | Token _ | Tokens _
162 | OneOf _ | NoneOf _ | Cut _ | Fix _ | Var _ -> []
163
164let error_loc = function
165 | Left_recursion { loc; _ } -> loc
166 | Ambiguous_alt { loc } -> loc
167
168let format_error = function
169 | Left_recursion { name; path; _ } ->
170 Printf.sprintf "left recursion detected: %s via %s"
171 name (String.concat " -> " path)
172 | Ambiguous_alt _ ->
173 "ambiguous alternation: branches may have overlapping first sets, wrap one in 'attempt'"