vm.fail
OCaml parser combinator that compiles to direct recursive descent
14 kB
427 lines
1open Ppxlib
2open Ast_builder.Default
3open Ir
4
5let fresh =
6 let counter = ref 0 in
7 fun prefix ->
8 incr counter;
9 Printf.sprintf "%s_%d" prefix !counter
10
11let error_expr ~loc expected =
12 [%expr Error { Combin.pos = I.position input; expected = [%e expected] }]
13
14let expected_list ~loc strs =
15 elist ~loc (List.map (estring ~loc) strs)
16
17let ok_expr ~loc value input_e =
18 [%expr Ok ([%e value], [%e input_e])]
19
20let merge_errors_expr ~loc e1 e2 =
21 [%expr Combin.merge_errors [%e e1] [%e e2]]
22
23let pvar_s ~loc s = ppat_var ~loc { txt = s; loc }
24let evar_s ~loc s = evar ~loc s
25
26let mk_let_rec ~loc name params body rest =
27 let param_pats = List.map (pvar_s ~loc) params in
28 let func = List.fold_right (fun p e -> pexp_fun ~loc Nolabel None p e) param_pats body in
29 let vb = value_binding ~loc ~pat:(pvar_s ~loc name) ~expr:func in
30 pexp_let ~loc Recursive [vb] rest
31
32let rec compile ~loc env expr =
33 match expr with
34 | Pure { value; _ } ->
35 [%expr Ok ([%e value], input)]
36
37 | Fail { msg; _ } ->
38 error_expr ~loc (elist ~loc [estring ~loc msg])
39
40 | Satisfy { pred; label; loc } ->
41 let expected = match label with
42 | Some l -> elist ~loc [estring ~loc l]
43 | None -> [%expr ["<satisfy>"]]
44 in
45 [%expr
46 match I.peek input with
47 | Some tok when [%e pred] tok -> Ok (tok, I.advance input)
48 | _ -> [%e error_expr ~loc expected]]
49
50 | Any { loc } ->
51 [%expr
52 match I.peek input with
53 | Some tok -> Ok (tok, I.advance input)
54 | None -> [%e error_expr ~loc (elist ~loc [estring ~loc "<any>"])]]
55
56 | Eof { loc } ->
57 [%expr
58 match I.peek input with
59 | None -> Ok ((), input)
60 | Some _ -> [%e error_expr ~loc (elist ~loc [estring ~loc "<eof>"])]]
61
62 | Token { tok; loc } ->
63 [%expr
64 match I.peek input with
65 | Some t when t = [%e tok] -> Ok (t, I.advance input)
66 | _ -> [%e error_expr ~loc [%expr [I.show_token [%e tok]]]]]
67
68 | Tokens { toks; loc } ->
69 [%expr
70 let rec loop toks_list inp =
71 match toks_list with
72 | [] -> Ok ([%e toks], inp)
73 | t :: rest ->
74 match I.peek inp with
75 | Some t' when t = t' -> loop rest (I.advance inp)
76 | _ -> [%e error_expr ~loc [%expr [String.concat "" (List.map I.show_token [%e toks])]]]
77 in
78 loop [%e toks] input]
79
80 | OneOf { toks; loc } ->
81 [%expr
82 match I.peek input with
83 | Some t when List.mem t [%e toks] -> Ok (t, I.advance input)
84 | _ -> [%e error_expr ~loc [%expr List.map I.show_token [%e toks]]]]
85
86 | NoneOf { toks; loc } ->
87 [%expr
88 match I.peek input with
89 | Some t when not (List.mem t [%e toks]) -> Ok (t, I.advance input)
90 | _ -> [%e error_expr ~loc (elist ~loc [estring ~loc "<none_of>"])]]
91
92 | Bind { p; f; loc } ->
93 let p_code = compile ~loc env p in
94 [%expr
95 match [%e p_code] with
96 | Ok (x, inp) ->
97 let input = inp in
98 [%e f] x input
99 | Error e -> Error e]
100
101 | Map { f; p; loc } ->
102 let p_code = compile ~loc env p in
103 [%expr
104 match [%e p_code] with
105 | Ok (x, inp) -> Ok ([%e f] x, inp)
106 | Error e -> Error e]
107
108 | Apply { pf; px; loc } ->
109 let pf_code = compile ~loc env pf in
110 let px_code = compile ~loc env px in
111 [%expr
112 match [%e pf_code] with
113 | Ok (f, inp1) ->
114 let input = inp1 in
115 (match [%e px_code] with
116 | Ok (x, inp2) -> Ok (f x, inp2)
117 | Error e -> Error e)
118 | Error e -> Error e]
119
120 | SeqLeft { p; q; loc } ->
121 let p_code = compile ~loc env p in
122 let q_code = compile ~loc env q in
123 [%expr
124 match [%e p_code] with
125 | Ok (x, inp1) ->
126 let input = inp1 in
127 (match [%e q_code] with
128 | Ok (_, inp2) -> Ok (x, inp2)
129 | Error e -> Error e)
130 | Error e -> Error e]
131
132 | SeqRight { p; q; loc } ->
133 let p_code = compile ~loc env p in
134 let q_code = compile ~loc env q in
135 [%expr
136 match [%e p_code] with
137 | Ok (_, inp1) ->
138 let input = inp1 in
139 [%e q_code]
140 | Error e -> Error e]
141
142 | Alt { p; q; loc } ->
143 let p_first = First_set.compute [] p in
144 let q_first = First_set.compute [] q in
145 if First_set.definitely_disjoint p_first q_first &&
146 First_set.all_static p_first && First_set.all_static q_first then
147 compile_committed_alt ~loc env p q p_first q_first
148 else
149 compile_backtrack_alt ~loc env p q
150
151 | Attempt { p; loc } ->
152 let p_code = compile ~loc env p in
153 [%expr
154 let saved = input in
155 match [%e p_code] with
156 | Ok _ as r -> r
157 | Error e -> Error { e with Combin.pos = I.position saved }]
158
159 | Cut { loc } ->
160 [%expr Ok ((), input)]
161
162 | Lookahead { p; loc } ->
163 let p_code = compile ~loc env p in
164 [%expr
165 let saved = input in
166 match [%e p_code] with
167 | Ok (v, _) -> Ok (v, saved)
168 | Error e -> Error e]
169
170 | NotFollowedBy { p; loc } ->
171 let p_code = compile ~loc env p in
172 [%expr
173 let saved = input in
174 match [%e p_code] with
175 | Ok _ -> [%e error_expr ~loc (elist ~loc [estring ~loc "<not_followed_by>"])]
176 | Error _ -> Ok ((), saved)]
177
178 | Many { p; loc } ->
179 let p_code = compile ~loc env p in
180 [%expr
181 let rec loop acc input =
182 match [%e p_code] with
183 | Ok (x, inp) -> loop (x :: acc) inp
184 | Error _ -> Ok (List.rev acc, input)
185 in
186 loop [] input]
187
188 | Some_ { p; loc } ->
189 let p_code = compile ~loc env p in
190 [%expr
191 match [%e p_code] with
192 | Ok (x, inp) ->
193 let rec loop acc input =
194 match [%e p_code] with
195 | Ok (y, inp2) -> loop (y :: acc) inp2
196 | Error _ -> Ok (List.rev acc, input)
197 in
198 loop [x] inp
199 | Error e -> Error e]
200
201 | Optional { p; loc } ->
202 let p_code = compile ~loc env p in
203 [%expr
204 match [%e p_code] with
205 | Ok (x, inp) -> Ok (Some x, inp)
206 | Error _ -> Ok (None, input)]
207
208 | Option { default; p; loc } ->
209 let p_code = compile ~loc env p in
210 [%expr
211 match [%e p_code] with
212 | Ok (x, inp) -> Ok (x, inp)
213 | Error _ -> Ok ([%e default], input)]
214
215 | SepBy { p; sep; loc } ->
216 let sepby1 = compile ~loc env (SepBy1 { p; sep; loc }) in
217 [%expr
218 match [%e sepby1] with
219 | Ok _ as r -> r
220 | Error _ -> Ok ([], input)]
221
222 | SepBy1 { p; sep; loc } ->
223 let p_code = compile ~loc env p in
224 let sep_code = compile ~loc env sep in
225 [%expr
226 match [%e p_code] with
227 | Ok (x, inp) ->
228 let rec loop acc input =
229 match [%e sep_code] with
230 | Ok (_, inp2) ->
231 let input = inp2 in
232 (match [%e p_code] with
233 | Ok (y, inp3) -> loop (y :: acc) inp3
234 | Error e -> Error e)
235 | Error _ -> Ok (List.rev acc, input)
236 in
237 loop [x] inp
238 | Error e -> Error e]
239
240 | EndBy { p; sep; loc } ->
241 let endby1 = compile ~loc env (EndBy1 { p; sep; loc }) in
242 [%expr
243 match [%e endby1] with
244 | Ok _ as r -> r
245 | Error _ -> Ok ([], input)]
246
247 | EndBy1 { p; sep; loc } ->
248 let p_code = compile ~loc env p in
249 let sep_code = compile ~loc env sep in
250 [%expr
251 match [%e p_code] with
252 | Ok (x, inp) ->
253 let input = inp in
254 (match [%e sep_code] with
255 | Ok (_, inp2) ->
256 let rec loop acc input =
257 match [%e p_code] with
258 | Ok (y, inp3) ->
259 let input = inp3 in
260 (match [%e sep_code] with
261 | Ok (_, inp4) -> loop (y :: acc) inp4
262 | Error e -> Error e)
263 | Error _ -> Ok (List.rev acc, input)
264 in
265 loop [x] inp2
266 | Error e -> Error e)
267 | Error e -> Error e]
268
269 | ManyTill { p; end_; loc } ->
270 let p_code = compile ~loc env p in
271 let end_code = compile ~loc env end_ in
272 [%expr
273 let rec loop acc input =
274 match [%e end_code] with
275 | Ok (_, inp) -> Ok (List.rev acc, inp)
276 | Error _ ->
277 match [%e p_code] with
278 | Ok (x, inp) -> loop (x :: acc) inp
279 | Error e -> Error e
280 in
281 loop [] input]
282
283 | Count { n; p; loc } ->
284 let p_code = compile ~loc env p in
285 [%expr
286 let rec loop n acc input =
287 if n <= 0 then Ok (List.rev acc, input)
288 else
289 match [%e p_code] with
290 | Ok (x, inp) -> loop (n - 1) (x :: acc) inp
291 | Error e -> Error e
292 in
293 loop [%e n] [] input]
294
295 | Between { open_; close; p; loc } ->
296 compile ~loc env (SeqRight { loc; p = open_; q = SeqLeft { loc; p; q = close } })
297
298 | ChainL { p; op; loc } ->
299 let chainl1 = compile ~loc env (ChainL1 { p; op; loc }) in
300 [%expr
301 match [%e chainl1] with
302 | Ok _ as r -> r
303 | Error _ -> Ok ([], input)]
304
305 | ChainL1 { p; op; loc } ->
306 let p_code = compile ~loc env p in
307 let op_code = compile ~loc env op in
308 [%expr
309 match [%e p_code] with
310 | Ok (x, inp) ->
311 let rec loop acc input =
312 match [%e op_code] with
313 | Ok (f, inp2) ->
314 let input = inp2 in
315 (match [%e p_code] with
316 | Ok (y, inp3) -> loop (f acc y) inp3
317 | Error e -> Error e)
318 | Error _ -> Ok (acc, input)
319 in
320 loop x inp
321 | Error e -> Error e]
322
323 | ChainR { p; op; loc } ->
324 let chainr1 = compile ~loc env (ChainR1 { p; op; loc }) in
325 [%expr
326 match [%e chainr1] with
327 | Ok _ as r -> r
328 | Error _ -> Ok ([], input)]
329
330 | ChainR1 { p; op; loc } ->
331 let p_code = compile ~loc env p in
332 let op_code = compile ~loc env op in
333 [%expr
334 match [%e p_code] with
335 | Ok (x, inp) ->
336 let rec loop stack input =
337 match [%e op_code] with
338 | Ok (f, inp2) ->
339 let input = inp2 in
340 (match [%e p_code] with
341 | Ok (y, inp3) -> loop ((f, y) :: stack) inp3
342 | Error e -> Error e)
343 | Error _ ->
344 let rec fold v = function
345 | [] -> v
346 | (f, y) :: rest -> fold (f v y) rest
347 in
348 Ok (fold x (List.rev stack), input)
349 in
350 loop [] inp
351 | Error e -> Error e]
352
353 | Choice { ps; label; loc } ->
354 let rec build_choice = function
355 | [] -> error_expr ~loc (match label with Some l -> elist ~loc [estring ~loc l] | None -> elist ~loc [estring ~loc "<choice>"])
356 | [p] -> compile ~loc env p
357 | p :: rest ->
358 let p_code = compile ~loc env p in
359 let rest_code = build_choice rest in
360 [%expr
361 let saved = input in
362 match [%e p_code] with
363 | Ok _ as r -> r
364 | Error e1 ->
365 let input = saved in
366 match [%e rest_code] with
367 | Ok _ as r -> r
368 | Error e2 -> Error (Combin.merge_errors e1 e2)]
369 in
370 build_choice ps
371
372 | Label { p; label; loc } ->
373 let p_code = compile ~loc env p in
374 [%expr
375 match [%e p_code] with
376 | Ok _ as r -> r
377 | Error e -> Error { e with Combin.expected = [[%e estring ~loc label]] }]
378
379 | Fix { body; _ } ->
380 [%expr
381 let rec parser_fix = [%e body] in
382 parser_fix input]
383
384 | Var { name; loc } ->
385 [%expr [%e evar ~loc name] (module I) input]
386
387and compile_committed_alt ~loc env p q p_first q_first =
388 let p_code = compile ~loc env p in
389 let q_code = compile ~loc env q in
390 let build_guard first =
391 match first.First_set.firsts with
392 | [First_set.Token tok] ->
393 [%expr match I.peek input with Some t when t = [%e tok] -> true | _ -> false]
394 | [First_set.OneOf toks] ->
395 [%expr match I.peek input with Some t when List.mem t [%e toks] -> true | _ -> false]
396 | _ -> [%expr true]
397 in
398 let p_guard = build_guard p_first in
399 let q_guard = build_guard q_first in
400 [%expr
401 if [%e p_guard] then [%e p_code]
402 else if [%e q_guard] then [%e q_code]
403 else [%e error_expr ~loc (elist ~loc [estring ~loc "<alt>"])]]
404
405and compile_backtrack_alt ~loc env p q =
406 let p_code = compile ~loc env p in
407 let q_code = compile ~loc env q in
408 [%expr
409 let saved = input in
410 match [%e p_code] with
411 | Ok _ as r -> r
412 | Error e1 ->
413 let input = saved in
414 match [%e q_code] with
415 | Ok _ as r -> r
416 | Error e2 -> Error (Combin.merge_errors e1 e2)]
417
418let compile_def env { name; expr; loc } =
419 let body = compile ~loc env expr in
420 let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
421 value_binding ~loc ~pat:(pvar ~loc name) ~expr:func
422
423let compile_mutual_def env { names; expr; loc } =
424 let body = compile ~loc env expr in
425 let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
426 let pat = ppat_tuple ~loc (List.map (pvar ~loc) names) in
427 value_binding ~loc ~pat ~expr:func