vm.fail
OCaml parser combinator that compiles to direct recursive descent
11 kB
209 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
121 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident "fix"; _ }; _ }, [(Nolabel, fn)]) ->
122 let (pats, body) = extract_fun_params fn in
123 (match pats with
124 | [pat] ->
125 let names = extract_pattern_names pat in
126 Ir.Fix { loc; arity = List.length names; names; body }
127 | _ -> Location.raise_errorf ~loc "fix requires a single function argument")
128
129 | Pexp_apply (_, _) when is_infix_chain e ->
130 parse_infix_chain ~loc e
131
132 | _ ->
133 Location.raise_errorf ~loc "unsupported parser expression"
134
135and is_infix_chain e =
136 match e.pexp_desc with
137 | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Lident op; _ }; _ }, [(Nolabel, _); (Nolabel, _)])
138 when is_operator op -> true
139 | _ -> false
140
141and parse_infix_chain ~loc e =
142 expr_to_ir ~loc e
143
144and extract_pattern_names pat =
145 match pat.ppat_desc with
146 | Ppat_var { txt; _ } -> [txt]
147 | Ppat_tuple pats -> List.concat_map extract_pattern_names pats
148 | _ -> Location.raise_errorf ~loc:pat.ppat_loc "fix pattern must be variable or tuple of variables"
149
150let expand_parser_expr ~ctxt expr =
151 let loc = Expansion_context.Extension.extension_point_loc ctxt in
152 let ir = expr_to_ir ~loc expr in
153 let errors = Check.check_expr [] ir in
154 List.iter (fun e ->
155 let err_loc = Check.error_loc e in
156 let msg = Check.format_error e in
157 Location.raise_errorf ~loc:err_loc "%s" msg
158 ) errors;
159 let body = Codegen.compile ~loc [] ir in
160 [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) -> [%e body]]
161
162let parser_extension =
163 Extension.V3.declare
164 "parser"
165 Extension.Context.expression
166 Ast_pattern.(single_expr_payload __)
167 expand_parser_expr
168
169let parser_rule = Context_free.Rule.extension parser_extension
170
171let extract_let_bindings str_items =
172 List.filter_map (fun item ->
173 match item.pstr_desc with
174 | Pstr_value (Nonrecursive, [vb]) ->
175 (match vb.pvb_pat.ppat_desc with
176 | Ppat_var { txt = name; _ } -> Some (name, vb.pvb_expr, vb.pvb_loc)
177 | _ -> None)
178 | _ -> None
179 ) str_items
180
181let expand_parser_stri ~ctxt str_items =
182 let loc = Expansion_context.Extension.extension_point_loc ctxt in
183 let bindings = extract_let_bindings str_items in
184 let compiled = List.map (fun (name, expr, binding_loc) ->
185 let ir = expr_to_ir ~loc:binding_loc expr in
186 let errors = Check.check_expr [] ir in
187 List.iter (fun e ->
188 let err_loc = Check.error_loc e in
189 let msg = Check.format_error e in
190 Location.raise_errorf ~loc:err_loc "%s" msg
191 ) errors;
192 let body = Codegen.compile ~loc:binding_loc [] ir in
193 let func = [%expr fun (type inp) (module I : Combin.INPUT with type t = inp and type token = char) (input : inp) -> [%e body]] in
194 Ast_builder.Default.value_binding ~loc:binding_loc
195 ~pat:(Ast_builder.Default.pvar ~loc:binding_loc name)
196 ~expr:func
197 ) bindings in
198 Ast_builder.Default.pstr_value ~loc Nonrecursive compiled
199
200let parser_stri_extension =
201 Extension.V3.declare
202 "parser"
203 Extension.Context.structure_item
204 Ast_pattern.(pstr __)
205 expand_parser_stri
206
207let parser_stri_rule = Context_free.Rule.extension parser_stri_extension
208
209let () = Driver.register_transformation ~rules:[parser_rule; parser_stri_rule] "ppx_combin"