vm.fail
OCaml parser combinator that compiles to direct recursive descent
12 kB
224 lines
1open Ppxlib
2
3let is_operator name =
4 String.length name > 0 &&
5 match name.[0] with
6 | '!' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' -> true
7 | _ -> false
8
9let extract_fun_params expr =
10 match expr.pexp_desc with
11 | Pexp_function (params, None, Pfunction_body body) ->
12 let pats = List.filter_map (fun p ->
13 match p.pparam_desc with
14 | Pparam_val (Nolabel, None, pat) -> Some pat
15 | _ -> None
16 ) params in
17 (pats, body)
18 | _ -> ([], expr)
19
20let rec expr_to_ir ~loc (e : expression) : Ir.expr =
21 match e.pexp_desc with
22 | Pexp_ident { txt = Lident "pure"; _ } ->
23 Location.raise_errorf ~loc "pure requires an argument"
24 | Pexp_ident { txt = Lident "fail"; _ } ->
25 Location.raise_errorf ~loc "fail requires an argument"
26 | Pexp_ident { txt = Lident "any"; _ } ->
27 Ir.Any { loc }
28 | Pexp_ident { txt = Lident "eof"; _ } ->
29 Ir.Eof { loc }
30 | Pexp_ident { txt = Lident "cut"; _ } ->
31 Ir.Cut { loc }
32 | Pexp_ident { txt = Lident name; _ } ->
33 Ir.Var { loc; name }
34
35 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "pure"; _ }; _ }, [(Nolabel, arg)]) ->
36 Ir.Pure { loc; value = arg }
37 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "fail"; _ }; _ }, [(Nolabel, { pexp_desc = Pexp_constant (Pconst_string (msg, _, _)); _ })]) ->
38 Ir.Fail { loc; msg }
39 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "satisfy"; _ }; _ }, [(Nolabel, pred)]) ->
40 Ir.Satisfy { loc; pred; label = None }
41 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "token"; _ }; _ }, [(Nolabel, tok)]) ->
42 Ir.Token { loc; tok }
43 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "tokens"; _ }; _ }, [(Nolabel, toks)]) ->
44 Ir.Tokens { loc; toks }
45 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "one_of"; _ }; _ }, [(Nolabel, toks)]) ->
46 Ir.OneOf { loc; toks }
47 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "none_of"; _ }; _ }, [(Nolabel, toks)]) ->
48 Ir.NoneOf { loc; toks }
49 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "char"; _ }; _ }, [(Nolabel, c)]) ->
50 Ir.Token { loc; tok = c }
51 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "string"; _ }; _ }, [(Nolabel, s)]) ->
52 Ir.Tokens { loc; toks = [%expr String.to_seq [%e s] |> List.of_seq] }
53
54 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "attempt"; _ }; _ }, [(Nolabel, p)]) ->
55 Ir.Attempt { loc; p = expr_to_ir ~loc p }
56 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "lookahead"; _ }; _ }, [(Nolabel, p)]) ->
57 Ir.Lookahead { loc; p = expr_to_ir ~loc p }
58 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "not_followed_by"; _ }; _ }, [(Nolabel, p)]) ->
59 Ir.NotFollowedBy { loc; p = expr_to_ir ~loc p }
60 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "many"; _ }; _ }, [(Nolabel, p)]) ->
61 Ir.Many { loc; p = expr_to_ir ~loc p }
62 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "some"; _ }; _ }, [(Nolabel, p)]) ->
63 Ir.Some_ { loc; p = expr_to_ir ~loc p }
64 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "optional"; _ }; _ }, [(Nolabel, p)]) ->
65 Ir.Optional { loc; p = expr_to_ir ~loc p }
66 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "skip_many"; _ }; _ }, [(Nolabel, p)]) ->
67 Ir.SkipMany { loc; p = expr_to_ir ~loc p }
68 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "skip_some"; _ }; _ }, [(Nolabel, p)]) ->
69 Ir.SkipSome { loc; p = expr_to_ir ~loc p }
70 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "take_while"; _ }; _ }, [(Nolabel, pred)]) ->
71 Ir.TakeWhile { loc; pred; at_least_one = false }
72 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "take_while1"; _ }; _ }, [(Nolabel, pred)]) ->
73 Ir.TakeWhile { loc; pred; at_least_one = true }
74
75 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "option"; _ }; _ }, [(Nolabel, default); (Nolabel, p)]) ->
76 Ir.Option { loc; default; p = expr_to_ir ~loc p }
77 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "sep_by"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
78 Ir.SepBy { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
79 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "sep_by1"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
80 Ir.SepBy1 { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
81 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "end_by"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
82 Ir.EndBy { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
83 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "end_by1"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
84 Ir.EndBy1 { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
85 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "many_till"; _ }; _ }, [(Nolabel, p); (Nolabel, e)]) ->
86 Ir.ManyTill { loc; p = expr_to_ir ~loc p; end_ = expr_to_ir ~loc e }
87 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "count"; _ }; _ }, [(Nolabel, n); (Nolabel, p)]) ->
88 Ir.Count { loc; n; p = expr_to_ir ~loc p }
89 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "between"; _ }; _ }, [(Nolabel, o); (Nolabel, c); (Nolabel, p)]) ->
90 Ir.Between { loc; open_ = expr_to_ir ~loc o; close = expr_to_ir ~loc c; p = expr_to_ir ~loc p }
91 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainl"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
92 Ir.ChainL { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
93 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainl1"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
94 Ir.ChainL1 { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
95 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainr"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
96 Ir.ChainR { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
97 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainr1"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
98 Ir.ChainR1 { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
99 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "choice"; _ }; _ }, [(Nolabel, list_expr)]) ->
100 let ps = match list_expr.pexp_desc with
101 | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> []
102 | Pexp_construct ({ txt = Lident "::"; _ }, _) ->
103 let rec extract_list e = match e.pexp_desc with
104 | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> []
105 | Pexp_construct ({ txt = Lident "::"; _ }, Some { pexp_desc = Pexp_tuple [h; t]; _ }) ->
106 expr_to_ir ~loc h :: extract_list t
107 | _ -> Location.raise_errorf ~loc "choice expects a list"
108 in
109 extract_list list_expr
110 | _ -> Location.raise_errorf ~loc "choice expects a list"
111 in
112 Ir.Choice { loc; ps; label = None }
113
114 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident ">>="; _ }; _ }, [(Nolabel, p); (Nolabel, f)]) ->
115 Ir.Bind { loc; p = expr_to_ir ~loc p; f }
116 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<|>"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
117 Ir.Alt { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
118 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<*>"; _ }; _ }, [(Nolabel, pf); (Nolabel, px)]) ->
119 Ir.Apply { loc; pf = expr_to_ir ~loc pf; px = expr_to_ir ~loc px }
120 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "*>"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
121 Ir.SeqRight { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
122 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<*"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
123 Ir.SeqLeft { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
124 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<$>"; _ }; _ }, [(Nolabel, f); (Nolabel, p)]) ->
125 Ir.Map { loc; f; p = expr_to_ir ~loc p }
126 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<?>"; _ }; _ }, [(Nolabel, p); (Nolabel, { pexp_desc = Pexp_constant (Pconst_string (label, _, _)); _ })]) ->
127 Ir.Label { loc; p = expr_to_ir ~loc p; label }
128 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "memo"; _ }; _ }, [(Nolabel, { pexp_desc = Pexp_constant (Pconst_string (name, _, _)); _ }); (Nolabel, p)]) ->
129 Ir.Memo { loc; name; p = expr_to_ir ~loc p }
130
131 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "fix"; _ }; _ }, [(Nolabel, fn)]) ->
132 let (pats, body) = extract_fun_params fn in
133 (match pats with
134 | [pat] ->
135 let names = extract_pattern_names pat in
136 Ir.Fix { loc; arity = List.length names; names; body }
137 | _ -> Location.raise_errorf ~loc "fix requires a single function argument")
138
139 | Pexp_apply (_, _) when is_infix_chain e ->
140 parse_infix_chain ~loc e
141
142 | _ ->
143 Location.raise_errorf ~loc "unsupported parser expression"
144
145and is_infix_chain e =
146 match e.pexp_desc with
147 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident op; _ }; _ }, [(Nolabel, _); (Nolabel, _)])
148 when is_operator op -> true
149 | _ -> false
150
151and parse_infix_chain ~loc e =
152 expr_to_ir ~loc e
153
154and extract_pattern_names pat =
155 match pat.ppat_desc with
156 | Ppat_var { txt; _ } -> [txt]
157 | Ppat_tuple pats -> List.concat_map extract_pattern_names pats
158 | _ -> Location.raise_errorf ~loc:pat.ppat_loc "fix pattern must be variable or tuple of variables"
159
160let expand_parser_expr ~ctxt expr =
161 let loc = Expansion_context.Extension.extension_point_loc ctxt in
162 let ir = expr_to_ir ~loc expr in
163 let ir = Optimise.optimise ir in
164 let errors = Check.check_expr [] ir in
165 List.iter (fun e ->
166 let err_loc = Check.error_loc e in
167 let msg = Check.format_error e in
168 Location.raise_errorf ~loc:err_loc "%s" msg
169 ) errors;
170 let body = Codegen.compile ~loc [] ir in
171 [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) ->
172 let _memo = Combin.Memo.create () in
173 [%e body]]
174
175let parser_extension =
176 Extension.V3.declare
177 "parser"
178 Extension.Context.expression
179 Ast_pattern.(single_expr_payload __)
180 expand_parser_expr
181
182let parser_rule = Context_free.Rule.extension parser_extension
183
184let extract_let_bindings str_items =
185 List.filter_map (fun item ->
186 match item.pstr_desc with
187 | Pstr_value (Nonrecursive, [vb]) ->
188 (match vb.pvb_pat.ppat_desc with
189 | Ppat_var { txt = name; _ } -> Some (name, vb.pvb_expr, vb.pvb_loc)
190 | _ -> None)
191 | _ -> None
192 ) str_items
193
194let expand_parser_stri ~ctxt str_items =
195 let loc = Expansion_context.Extension.extension_point_loc ctxt in
196 let bindings = extract_let_bindings str_items in
197 let compiled = List.map (fun (name, expr, binding_loc) ->
198 let ir = expr_to_ir ~loc:binding_loc expr in
199 let ir = Optimise.optimise ir in
200 let memoized_ir = Ir.Memo { loc = binding_loc; name; p = ir } in
201 let errors = Check.check_expr [] memoized_ir in
202 List.iter (fun e ->
203 let err_loc = Check.error_loc e in
204 let msg = Check.format_error e in
205 Location.raise_errorf ~loc:err_loc "%s" msg
206 ) errors;
207 let body = Codegen.compile ~loc:binding_loc [] memoized_ir in
208 let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) _memo (input : inp) -> [%e body]] in
209 Ast_builder.Default.value_binding ~loc:binding_loc
210 ~pat:(Ast_builder.Default.pvar ~loc:binding_loc name)
211 ~expr:func
212 ) bindings in
213 Ast_builder.Default.pstr_value ~loc Nonrecursive compiled
214
215let parser_stri_extension =
216 Extension.V3.declare
217 "parser"
218 Extension.Context.structure_item
219 Ast_pattern.(pstr __)
220 expand_parser_stri
221
222let parser_stri_rule = Context_free.Rule.extension parser_stri_extension
223
224let () = Driver.register_transformation ~rules:[parser_rule; parser_stri_rule] "ppx_combin"