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