vm.fail
OCaml parser combinator that compiles to direct recursive descent
14 kB
442 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 let p_code = compile ~loc env p in
183 [%expr
184 let rec loop acc input =
185 match [%e p_code] with
186 | Ok (x, inp) -> loop (x :: acc) inp
187 | Error _ -> Ok (List.rev acc, input)
188 in
189 loop [] input]
190
191 | Some_ { p; loc } ->
192 let p_code = compile ~loc env p in
193 [%expr
194 match [%e p_code] with
195 | Ok (x, inp) ->
196 let rec loop acc input =
197 match [%e p_code] with
198 | Ok (y, inp2) -> loop (y :: acc) inp2
199 | Error _ -> Ok (List.rev acc, input)
200 in
201 loop [x] inp
202 | Error e -> Error e]
203
204 | Optional { p; loc } ->
205 let p_code = compile ~loc env p in
206 [%expr
207 match [%e p_code] with
208 | Ok (x, inp) -> Ok (Some x, inp)
209 | Error _ -> Ok (None, input)]
210
211 | Option { default; p; loc } ->
212 let p_code = compile ~loc env p in
213 [%expr
214 match [%e p_code] with
215 | Ok (x, inp) -> Ok (x, inp)
216 | Error _ -> Ok ([%e default], input)]
217
218 | SepBy { p; sep; loc } ->
219 let sepby1 = compile ~loc env (SepBy1 { p; sep; loc }) in
220 [%expr
221 match [%e sepby1] with
222 | Ok _ as r -> r
223 | Error _ -> Ok ([], input)]
224
225 | SepBy1 { p; sep; loc } ->
226 let p_code = compile ~loc env p in
227 let sep_code = compile ~loc env sep in
228 [%expr
229 match [%e p_code] with
230 | Ok (x, inp) ->
231 let rec loop acc input =
232 match [%e sep_code] with
233 | Ok (_, inp2) ->
234 let input = inp2 in
235 (match [%e p_code] with
236 | Ok (y, inp3) -> loop (y :: acc) inp3
237 | Error e -> Error e)
238 | Error _ -> Ok (List.rev acc, input)
239 in
240 loop [x] inp
241 | Error e -> Error e]
242
243 | EndBy { p; sep; loc } ->
244 let endby1 = compile ~loc env (EndBy1 { p; sep; loc }) in
245 [%expr
246 match [%e endby1] with
247 | Ok _ as r -> r
248 | Error _ -> Ok ([], input)]
249
250 | EndBy1 { p; sep; loc } ->
251 let p_code = compile ~loc env p in
252 let sep_code = compile ~loc env sep in
253 [%expr
254 match [%e p_code] with
255 | Ok (x, inp) ->
256 let input = inp in
257 (match [%e sep_code] with
258 | Ok (_, inp2) ->
259 let rec loop acc input =
260 match [%e p_code] with
261 | Ok (y, inp3) ->
262 let input = inp3 in
263 (match [%e sep_code] with
264 | Ok (_, inp4) -> loop (y :: acc) inp4
265 | Error e -> Error e)
266 | Error _ -> Ok (List.rev acc, input)
267 in
268 loop [x] inp2
269 | Error e -> Error e)
270 | Error e -> Error e]
271
272 | ManyTill { p; end_; loc } ->
273 let p_code = compile ~loc env p in
274 let end_code = compile ~loc env end_ in
275 [%expr
276 let rec loop acc input =
277 match [%e end_code] with
278 | Ok (_, inp) -> Ok (List.rev acc, inp)
279 | Error _ ->
280 match [%e p_code] with
281 | Ok (x, inp) -> loop (x :: acc) inp
282 | Error e -> Error e
283 in
284 loop [] input]
285
286 | Count { n; p; loc } ->
287 let p_code = compile ~loc env p in
288 [%expr
289 let rec loop n acc input =
290 if n <= 0 then Ok (List.rev acc, input)
291 else
292 match [%e p_code] with
293 | Ok (x, inp) -> loop (n - 1) (x :: acc) inp
294 | Error e -> Error e
295 in
296 loop [%e n] [] input]
297
298 | Between { open_; close; p; loc } ->
299 compile ~loc env (SeqRight { loc; p = open_; q = SeqLeft { loc; p; q = close } })
300
301 | ChainL { p; op; loc } ->
302 let chainl1 = compile ~loc env (ChainL1 { p; op; loc }) in
303 [%expr
304 match [%e chainl1] with
305 | Ok _ as r -> r
306 | Error _ -> Ok ([], input)]
307
308 | ChainL1 { p; op; loc } ->
309 let p_code = compile ~loc env p in
310 let op_code = compile ~loc env op in
311 [%expr
312 match [%e p_code] with
313 | Ok (x, inp) ->
314 let rec loop acc input =
315 match [%e op_code] with
316 | Ok (f, inp2) ->
317 let input = inp2 in
318 (match [%e p_code] with
319 | Ok (y, inp3) -> loop (f acc y) inp3
320 | Error e -> Error e)
321 | Error _ -> Ok (acc, input)
322 in
323 loop x inp
324 | Error e -> Error e]
325
326 | ChainR { p; op; loc } ->
327 let chainr1 = compile ~loc env (ChainR1 { p; op; loc }) in
328 [%expr
329 match [%e chainr1] with
330 | Ok _ as r -> r
331 | Error _ -> Ok ([], input)]
332
333 | ChainR1 { p; op; loc } ->
334 let p_code = compile ~loc env p in
335 let op_code = compile ~loc env op in
336 [%expr
337 match [%e p_code] with
338 | Ok (x, inp) ->
339 let rec loop stack input =
340 match [%e op_code] with
341 | Ok (f, inp2) ->
342 let input = inp2 in
343 (match [%e p_code] with
344 | Ok (y, inp3) -> loop ((f, y) :: stack) inp3
345 | Error e -> Error e)
346 | Error _ ->
347 let rec fold v = function
348 | [] -> v
349 | (f, y) :: rest -> fold (f v y) rest
350 in
351 Ok (fold x (List.rev stack), input)
352 in
353 loop [] inp
354 | Error e -> Error e]
355
356 | Choice { ps; label; loc } ->
357 let rec build_choice = function
358 | [] -> error_expr ~loc (match label with Some l -> elist ~loc [estring ~loc l] | None -> elist ~loc [estring ~loc "<choice>"])
359 | [p] -> compile ~loc env p
360 | p :: rest ->
361 let p_code = compile ~loc env p in
362 let rest_code = build_choice rest in
363 [%expr
364 let saved = input in
365 match [%e p_code] with
366 | Ok _ as r -> r
367 | Error e1 ->
368 let input = saved in
369 match [%e rest_code] with
370 | Ok _ as r -> r
371 | Error e2 -> Error (Combin.merge_errors e1 e2)]
372 in
373 build_choice ps
374
375 | Label { p; label; loc } ->
376 let p_code = compile ~loc env p in
377 [%expr
378 match [%e p_code] with
379 | Ok _ as r -> r
380 | Error e -> Error { e with Combin.expected = [[%e estring ~loc label]] }]
381
382 | Memo { name; p; loc } ->
383 let p_code = compile ~loc env p in
384 let name_expr = estring ~loc name in
385 [%expr
386 let pos = I.position input in
387 match Combin.Memo.find _memo [%e name_expr] pos with
388 | Some r -> r
389 | None ->
390 let r = [%e p_code] in
391 Combin.Memo.add _memo [%e name_expr] pos r;
392 r]
393
394 | Fix { body; _ } ->
395 [%expr
396 let rec parser_fix = [%e body] in
397 parser_fix input]
398
399 | Var { name; loc } ->
400 [%expr [%e evar ~loc name] (module I) _memo input]
401
402and compile_committed_alt ~loc env p q p_first q_first =
403 let p_code = compile ~loc env p in
404 let q_code = compile ~loc env q in
405 let build_guard first =
406 match first.First_set.firsts with
407 | [First_set.Token tok] ->
408 [%expr match I.peek input with Some t when t = [%e tok] -> true | _ -> false]
409 | [First_set.OneOf toks] ->
410 [%expr match I.peek input with Some t when List.mem t [%e toks] -> true | _ -> false]
411 | _ -> [%expr true]
412 in
413 let p_guard = build_guard p_first in
414 let q_guard = build_guard q_first in
415 [%expr
416 if [%e p_guard] then [%e p_code]
417 else if [%e q_guard] then [%e q_code]
418 else [%e error_expr ~loc (elist ~loc [estring ~loc "<alt>"])]]
419
420and compile_backtrack_alt ~loc env p q =
421 let p_code = compile ~loc env p in
422 let q_code = compile ~loc env q in
423 [%expr
424 let saved = input in
425 match [%e p_code] with
426 | Ok _ as r -> r
427 | Error e1 ->
428 let input = saved in
429 match [%e q_code] with
430 | Ok _ as r -> r
431 | Error e2 -> Error (Combin.merge_errors e1 e2)]
432
433let compile_def env { name; expr; loc } =
434 let body = compile ~loc env expr in
435 let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
436 value_binding ~loc ~pat:(pvar ~loc name) ~expr:func
437
438let compile_mutual_def env { names; expr; loc } =
439 let body = compile ~loc env expr in
440 let func = [%expr fun (type inp tok) (module I : Combin.INPUT with type t = inp and type token = tok) input -> [%e body]] in
441 let pat = ppat_tuple ~loc (List.map (pvar ~loc) names) in
442 value_binding ~loc ~pat ~expr:func