vm.fail
OCaml parser combinator that compiles to direct recursive descent
20 kB
612 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 c when [%e pred] c -> Ok (c, I.advance input)
51 | _ -> [%e error_expr ~loc expected]]
52
53 | Any { loc } ->
54 [%expr
55 match I.peek input with
56 | Some c -> Ok (c, 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 | SkipMany { p; loc } ->
270 (match p with
271 | Token { tok; _ } ->
272 [%expr
273 let rec loop input =
274 match I.peek input with
275 | Some t when t = [%e tok] -> loop (I.advance input)
276 | _ -> Ok ((), input)
277 in
278 loop input]
279 | Satisfy { pred; _ } ->
280 [%expr
281 let rec loop input =
282 match I.peek input with
283 | Some t when [%e pred] t -> loop (I.advance input)
284 | _ -> Ok ((), input)
285 in
286 loop input]
287 | Any _ ->
288 [%expr
289 let rec loop input =
290 match I.peek input with
291 | Some _ -> loop (I.advance input)
292 | None -> Ok ((), input)
293 in
294 loop input]
295 | _ ->
296 let p_code = compile ~loc env p in
297 [%expr
298 let rec loop input =
299 match [%e p_code] with
300 | Ok (_, inp) -> loop inp
301 | Error _ -> Ok ((), input)
302 in
303 loop input])
304
305 | SkipSome { p; loc } ->
306 (match p with
307 | Token { tok; _ } ->
308 [%expr
309 match I.peek input with
310 | Some t when t = [%e tok] ->
311 let rec loop input =
312 match I.peek input with
313 | Some t when t = [%e tok] -> loop (I.advance input)
314 | _ -> Ok ((), input)
315 in
316 loop (I.advance input)
317 | _ -> [%e error_expr ~loc [%expr [I.show_token [%e tok]]]]]
318 | Satisfy { pred; label; _ } ->
319 let expected = match label with
320 | Some l -> elist ~loc [estring ~loc l]
321 | None -> [%expr ["<satisfy>"]]
322 in
323 [%expr
324 match I.peek input with
325 | Some t when [%e pred] t ->
326 let rec loop input =
327 match I.peek input with
328 | Some t when [%e pred] t -> loop (I.advance input)
329 | _ -> Ok ((), input)
330 in
331 loop (I.advance input)
332 | _ -> [%e error_expr ~loc expected]]
333 | _ ->
334 let p_code = compile ~loc env p in
335 [%expr
336 match [%e p_code] with
337 | Ok (_, inp) ->
338 let rec loop input =
339 match [%e p_code] with
340 | Ok (_, inp2) -> loop inp2
341 | Error _ -> Ok ((), input)
342 in
343 loop inp
344 | Error e -> Error e])
345
346 | TakeWhile { pred; at_least_one; loc } ->
347 if at_least_one then
348 [%expr
349 match I.peek input with
350 | Some t when [%e pred] t ->
351 let buf = Buffer.create 16 in
352 let rec loop input =
353 match I.peek input with
354 | Some t when [%e pred] t ->
355 Buffer.add_char buf t;
356 loop (I.advance input)
357 | _ -> Ok (Buffer.contents buf, input)
358 in
359 Buffer.add_char buf t;
360 loop (I.advance input)
361 | _ -> [%e error_expr ~loc [%expr ["<take_while1>"]]]]
362 else
363 [%expr
364 let buf = Buffer.create 16 in
365 let rec loop input =
366 match I.peek input with
367 | Some t when [%e pred] t ->
368 Buffer.add_char buf t;
369 loop (I.advance input)
370 | _ -> Ok (Buffer.contents buf, input)
371 in
372 loop input]
373
374 | Optional { p; loc } ->
375 let p_code = compile ~loc env p in
376 [%expr
377 match [%e p_code] with
378 | Ok (x, inp) -> Ok (Some x, inp)
379 | Error _ -> Ok (None, input)]
380
381 | Option { default; p; loc } ->
382 let p_code = compile ~loc env p in
383 [%expr
384 match [%e p_code] with
385 | Ok (x, inp) -> Ok (x, inp)
386 | Error _ -> Ok ([%e default], input)]
387
388 | SepBy { p; sep; loc } ->
389 let sepby1 = compile ~loc env (SepBy1 { p; sep; loc }) in
390 [%expr
391 match [%e sepby1] with
392 | Ok _ as r -> r
393 | Error _ -> Ok ([], input)]
394
395 | SepBy1 { p; sep; loc } ->
396 let p_code = compile ~loc env p in
397 let sep_code = compile ~loc env sep in
398 [%expr
399 match [%e p_code] with
400 | Ok (x, inp) ->
401 let rec loop acc input =
402 match [%e sep_code] with
403 | Ok (_, inp2) ->
404 let input = inp2 in
405 (match [%e p_code] with
406 | Ok (y, inp3) -> loop (y :: acc) inp3
407 | Error e -> Error e)
408 | Error _ -> Ok (List.rev acc, input)
409 in
410 loop [x] inp
411 | Error e -> Error e]
412
413 | EndBy { p; sep; loc } ->
414 let endby1 = compile ~loc env (EndBy1 { p; sep; loc }) in
415 [%expr
416 match [%e endby1] with
417 | Ok _ as r -> r
418 | Error _ -> Ok ([], input)]
419
420 | EndBy1 { p; sep; loc } ->
421 let p_code = compile ~loc env p in
422 let sep_code = compile ~loc env sep in
423 [%expr
424 match [%e p_code] with
425 | Ok (x, inp) ->
426 let input = inp in
427 (match [%e sep_code] with
428 | Ok (_, inp2) ->
429 let rec loop acc input =
430 match [%e p_code] with
431 | Ok (y, inp3) ->
432 let input = inp3 in
433 (match [%e sep_code] with
434 | Ok (_, inp4) -> loop (y :: acc) inp4
435 | Error e -> Error e)
436 | Error _ -> Ok (List.rev acc, input)
437 in
438 loop [x] inp2
439 | Error e -> Error e)
440 | Error e -> Error e]
441
442 | ManyTill { p; end_; loc } ->
443 let p_code = compile ~loc env p in
444 let end_code = compile ~loc env end_ in
445 [%expr
446 let rec loop acc input =
447 match [%e end_code] with
448 | Ok (_, inp) -> Ok (List.rev acc, inp)
449 | Error _ ->
450 match [%e p_code] with
451 | Ok (x, inp) -> loop (x :: acc) inp
452 | Error e -> Error e
453 in
454 loop [] input]
455
456 | Count { n; p; loc } ->
457 let p_code = compile ~loc env p in
458 [%expr
459 let rec loop n acc input =
460 if n <= 0 then Ok (List.rev acc, input)
461 else
462 match [%e p_code] with
463 | Ok (x, inp) -> loop (n - 1) (x :: acc) inp
464 | Error e -> Error e
465 in
466 loop [%e n] [] input]
467
468 | Between { open_; close; p; loc } ->
469 compile ~loc env (SeqRight { loc; p = open_; q = SeqLeft { loc; p; q = close } })
470
471 | ChainL { p; op; loc } ->
472 let chainl1 = compile ~loc env (ChainL1 { p; op; loc }) in
473 [%expr
474 match [%e chainl1] with
475 | Ok _ as r -> r
476 | Error _ -> Ok ([], input)]
477
478 | ChainL1 { p; op; loc } ->
479 let p_code = compile ~loc env p in
480 let op_code = compile ~loc env op in
481 [%expr
482 match [%e p_code] with
483 | Ok (x, inp) ->
484 let rec loop acc input =
485 match [%e op_code] with
486 | Ok (f, inp2) ->
487 let input = inp2 in
488 (match [%e p_code] with
489 | Ok (y, inp3) -> loop (f acc y) inp3
490 | Error e -> Error e)
491 | Error _ -> Ok (acc, input)
492 in
493 loop x inp
494 | Error e -> Error e]
495
496 | ChainR { p; op; loc } ->
497 let chainr1 = compile ~loc env (ChainR1 { p; op; loc }) in
498 [%expr
499 match [%e chainr1] with
500 | Ok _ as r -> r
501 | Error _ -> Ok ([], input)]
502
503 | ChainR1 { p; op; loc } ->
504 let p_code = compile ~loc env p in
505 let op_code = compile ~loc env op in
506 [%expr
507 match [%e p_code] with
508 | Ok (x, inp) ->
509 let rec loop stack input =
510 match [%e op_code] with
511 | Ok (f, inp2) ->
512 let input = inp2 in
513 (match [%e p_code] with
514 | Ok (y, inp3) -> loop ((f, y) :: stack) inp3
515 | Error e -> Error e)
516 | Error _ ->
517 let rec fold v = function
518 | [] -> v
519 | (f, y) :: rest -> fold (f v y) rest
520 in
521 Ok (fold x (List.rev stack), input)
522 in
523 loop [] inp
524 | Error e -> Error e]
525
526 | Choice { ps; label; loc } ->
527 let rec build_choice = function
528 | [] -> error_expr ~loc (match label with Some l -> elist ~loc [estring ~loc l] | None -> elist ~loc [estring ~loc "<choice>"])
529 | [p] -> compile ~loc env p
530 | p :: rest ->
531 let p_code = compile ~loc env p in
532 let rest_code = build_choice rest in
533 [%expr
534 let saved = input in
535 match [%e p_code] with
536 | Ok _ as r -> r
537 | Error e1 ->
538 let input = saved in
539 match [%e rest_code] with
540 | Ok _ as r -> r
541 | Error e2 -> Error (Combin.merge_errors e1 e2)]
542 in
543 build_choice ps
544
545 | Label { p; label; loc } ->
546 let p_code = compile ~loc env p in
547 [%expr
548 match [%e p_code] with
549 | Ok _ as r -> r
550 | Error e -> Error { e with Combin.expected = [[%e estring ~loc label]] }]
551
552 | Memo { name; p; loc } ->
553 let p_code = compile ~loc env p in
554 let name_expr = estring ~loc name in
555 [%expr
556 let pos = I.position input in
557 match Combin.Memo.find _memo [%e name_expr] pos with
558 | Some r -> r
559 | None ->
560 let r = [%e p_code] in
561 Combin.Memo.add _memo [%e name_expr] pos r;
562 r]
563
564 | Fix { body; _ } ->
565 [%expr
566 let rec parser_fix = [%e body] in
567 parser_fix input]
568
569 | Var { name; loc } ->
570 [%expr [%e evar ~loc name] (module I) _memo input]
571
572and compile_committed_alt ~loc env p q p_first q_first =
573 let p_code = compile ~loc env p in
574 let q_code = compile ~loc env q in
575 let build_guard first =
576 match first.First_set.firsts with
577 | [First_set.Token tok] ->
578 [%expr match I.peek input with Some t when t = [%e tok] -> true | _ -> false]
579 | [First_set.OneOf toks] ->
580 [%expr match I.peek input with Some t when List.mem t [%e toks] -> true | _ -> false]
581 | _ -> [%expr true]
582 in
583 let p_guard = build_guard p_first in
584 let q_guard = build_guard q_first in
585 [%expr
586 if [%e p_guard] then [%e p_code]
587 else if [%e q_guard] then [%e q_code]
588 else [%e error_expr ~loc (elist ~loc [estring ~loc "<alt>"])]]
589
590and compile_backtrack_alt ~loc env p q =
591 let p_code = compile ~loc env p in
592 let q_code = compile ~loc env q in
593 [%expr
594 let saved = input in
595 match [%e p_code] with
596 | Ok _ as r -> r
597 | Error e1 ->
598 let input = saved in
599 match [%e q_code] with
600 | Ok _ as r -> r
601 | Error e2 -> Error (Combin.merge_errors e1 e2)]
602
603let compile_def env { name; expr; loc } =
604 let body = compile ~loc env expr in
605 let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) input -> [%e body]] in
606 value_binding ~loc ~pat:(pvar ~loc name) ~expr:func
607
608let compile_mutual_def env { names; expr; loc } =
609 let body = compile ~loc env expr in
610 let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) input -> [%e body]] in
611 let pat = ppat_tuple ~loc (List.map (pvar ~loc) names) in
612 value_binding ~loc ~pat ~expr:func