vm.fail
OCaml parser combinator that compiles to direct recursive descent
11 kB
216 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
67 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "option"; _ }; _ }, [(Nolabel, default); (Nolabel, p)]) ->
68 Ir.Option { loc; default; p = expr_to_ir ~loc p }
69 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "sep_by"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
70 Ir.SepBy { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
71 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "sep_by1"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
72 Ir.SepBy1 { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
73 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "end_by"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
74 Ir.EndBy { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
75 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "end_by1"; _ }; _ }, [(Nolabel, p); (Nolabel, sep)]) ->
76 Ir.EndBy1 { loc; p = expr_to_ir ~loc p; sep = expr_to_ir ~loc sep }
77 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "many_till"; _ }; _ }, [(Nolabel, p); (Nolabel, e)]) ->
78 Ir.ManyTill { loc; p = expr_to_ir ~loc p; end_ = expr_to_ir ~loc e }
79 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "count"; _ }; _ }, [(Nolabel, n); (Nolabel, p)]) ->
80 Ir.Count { loc; n; p = expr_to_ir ~loc p }
81 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "between"; _ }; _ }, [(Nolabel, o); (Nolabel, c); (Nolabel, p)]) ->
82 Ir.Between { loc; open_ = expr_to_ir ~loc o; close = expr_to_ir ~loc c; p = expr_to_ir ~loc p }
83 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainl"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
84 Ir.ChainL { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
85 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainl1"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
86 Ir.ChainL1 { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
87 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainr"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
88 Ir.ChainR { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
89 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "chainr1"; _ }; _ }, [(Nolabel, p); (Nolabel, op)]) ->
90 Ir.ChainR1 { loc; p = expr_to_ir ~loc p; op = expr_to_ir ~loc op }
91 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "choice"; _ }; _ }, [(Nolabel, list_expr)]) ->
92 let ps = match list_expr.pexp_desc with
93 | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> []
94 | Pexp_construct ({ txt = Lident "::"; _ }, _) ->
95 let rec extract_list e = match e.pexp_desc with
96 | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> []
97 | Pexp_construct ({ txt = Lident "::"; _ }, Some { pexp_desc = Pexp_tuple [h; t]; _ }) ->
98 expr_to_ir ~loc h :: extract_list t
99 | _ -> Location.raise_errorf ~loc "choice expects a list"
100 in
101 extract_list list_expr
102 | _ -> Location.raise_errorf ~loc "choice expects a list"
103 in
104 Ir.Choice { loc; ps; label = None }
105
106 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident ">>="; _ }; _ }, [(Nolabel, p); (Nolabel, f)]) ->
107 Ir.Bind { loc; p = expr_to_ir ~loc p; f }
108 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<|>"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
109 Ir.Alt { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
110 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<*>"; _ }; _ }, [(Nolabel, pf); (Nolabel, px)]) ->
111 Ir.Apply { loc; pf = expr_to_ir ~loc pf; px = expr_to_ir ~loc px }
112 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "*>"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
113 Ir.SeqRight { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
114 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<*"; _ }; _ }, [(Nolabel, p); (Nolabel, q)]) ->
115 Ir.SeqLeft { loc; p = expr_to_ir ~loc p; q = expr_to_ir ~loc q }
116 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<$>"; _ }; _ }, [(Nolabel, f); (Nolabel, p)]) ->
117 Ir.Map { loc; f; p = expr_to_ir ~loc p }
118 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "<?>"; _ }; _ }, [(Nolabel, p); (Nolabel, { pexp_desc = Pexp_constant (Pconst_string (label, _, _)); _ })]) ->
119 Ir.Label { loc; p = expr_to_ir ~loc p; label }
120 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "memo"; _ }; _ }, [(Nolabel, { pexp_desc = Pexp_constant (Pconst_string (name, _, _)); _ }); (Nolabel, p)]) ->
121 Ir.Memo { loc; name; p = expr_to_ir ~loc p }
122
123 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "fix"; _ }; _ }, [(Nolabel, fn)]) ->
124 let (pats, body) = extract_fun_params fn in
125 (match pats with
126 | [pat] ->
127 let names = extract_pattern_names pat in
128 Ir.Fix { loc; arity = List.length names; names; body }
129 | _ -> Location.raise_errorf ~loc "fix requires a single function argument")
130
131 | Pexp_apply (_, _) when is_infix_chain e ->
132 parse_infix_chain ~loc e
133
134 | _ ->
135 Location.raise_errorf ~loc "unsupported parser expression"
136
137and is_infix_chain e =
138 match e.pexp_desc with
139 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident op; _ }; _ }, [(Nolabel, _); (Nolabel, _)])
140 when is_operator op -> true
141 | _ -> false
142
143and parse_infix_chain ~loc e =
144 expr_to_ir ~loc e
145
146and extract_pattern_names pat =
147 match pat.ppat_desc with
148 | Ppat_var { txt; _ } -> [txt]
149 | Ppat_tuple pats -> List.concat_map extract_pattern_names pats
150 | _ -> Location.raise_errorf ~loc:pat.ppat_loc "fix pattern must be variable or tuple of variables"
151
152let expand_parser_expr ~ctxt expr =
153 let loc = Expansion_context.Extension.extension_point_loc ctxt in
154 let ir = expr_to_ir ~loc expr in
155 let ir = Optimise.optimise ir in
156 let errors = Check.check_expr [] ir in
157 List.iter (fun e ->
158 let err_loc = Check.error_loc e in
159 let msg = Check.format_error e in
160 Location.raise_errorf ~loc:err_loc "%s" msg
161 ) errors;
162 let body = Codegen.compile ~loc [] ir in
163 [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) ->
164 let _memo = Combin.Memo.create () in
165 [%e body]]
166
167let parser_extension =
168 Extension.V3.declare
169 "parser"
170 Extension.Context.expression
171 Ast_pattern.(single_expr_payload __)
172 expand_parser_expr
173
174let parser_rule = Context_free.Rule.extension parser_extension
175
176let extract_let_bindings str_items =
177 List.filter_map (fun item ->
178 match item.pstr_desc with
179 | Pstr_value (Nonrecursive, [vb]) ->
180 (match vb.pvb_pat.ppat_desc with
181 | Ppat_var { txt = name; _ } -> Some (name, vb.pvb_expr, vb.pvb_loc)
182 | _ -> None)
183 | _ -> None
184 ) str_items
185
186let expand_parser_stri ~ctxt str_items =
187 let loc = Expansion_context.Extension.extension_point_loc ctxt in
188 let bindings = extract_let_bindings str_items in
189 let compiled = List.map (fun (name, expr, binding_loc) ->
190 let ir = expr_to_ir ~loc:binding_loc expr in
191 let ir = Optimise.optimise ir in
192 let memoized_ir = Ir.Memo { loc = binding_loc; name; p = ir } in
193 let errors = Check.check_expr [] memoized_ir in
194 List.iter (fun e ->
195 let err_loc = Check.error_loc e in
196 let msg = Check.format_error e in
197 Location.raise_errorf ~loc:err_loc "%s" msg
198 ) errors;
199 let body = Codegen.compile ~loc:binding_loc [] memoized_ir in
200 let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) _memo (input : inp) -> [%e body]] in
201 Ast_builder.Default.value_binding ~loc:binding_loc
202 ~pat:(Ast_builder.Default.pvar ~loc:binding_loc name)
203 ~expr:func
204 ) bindings in
205 Ast_builder.Default.pstr_value ~loc Nonrecursive compiled
206
207let parser_stri_extension =
208 Extension.V3.declare
209 "parser"
210 Extension.Context.structure_item
211 Ast_pattern.(pstr __)
212 expand_parser_stri
213
214let parser_stri_rule = Context_free.Rule.extension parser_stri_extension
215
216let () = Driver.register_transformation ~rules:[parser_rule; parser_stri_rule] "ppx_combin"