Source file ppx_mikmatch.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
open Ppxlib
open Ast_builder.Default
let make_alias_binding ~loc ~var_name =
let warning_attr =
attribute ~loc ~name:{ txt = "warning"; loc } ~payload:(PStr [ { pstr_desc = Pstr_eval (estring ~loc "-32", []); pstr_loc = loc } ])
in
{
pvb_pat = ppat_var ~loc { txt = var_name; loc };
pvb_expr = pexp_ident ~loc { txt = Lident var_name; loc };
pvb_constraint = None;
pvb_attributes = [ warning_attr ];
pvb_loc = loc;
}
let transformation =
object (self)
inherit [value_binding list] Ast_traverse.fold_map as super
method! structure_item item acc =
match item.pstr_desc with
| Pstr_type (rec_flag, type_decls) ->
let needs_transformation =
List.exists
(fun td ->
match td.ptype_manifest with Some { ptyp_desc = Ptyp_extension ({ txt = "mikmatch"; _ }, _); _ } -> true | _ -> false)
type_decls
in
if not needs_transformation then super#structure_item item acc
else (
let all_items, all_bindings =
List.fold_left
(fun (items_acc, bindings_acc) td ->
match td.ptype_manifest with
| Some
{
ptyp_desc =
Ptyp_extension
( { txt = "mikmatch"; _ },
PStr
[ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (pattern_str, loc, _)); _ }, _); _ } ]
);
_;
} ->
let type_name = td.ptype_name.txt in
let items, binding = Transformations.transform_type ~loc rec_flag type_name pattern_str td in
let alias = pstr_value ~loc Nonrecursive [ make_alias_binding ~loc ~var_name:type_name ] in
(alias :: items_acc) @ items, binding :: bindings_acc
| _ -> items_acc, bindings_acc)
([], acc) type_decls
in
let wrapped = pstr_include ~loc:item.pstr_loc (include_infos ~loc:item.pstr_loc (pmod_structure ~loc:item.pstr_loc all_items)) in
wrapped, all_bindings)
| Pstr_extension (({ txt = "mikmatch"; _ }, PStr [ { pstr_desc = Pstr_value (rec_flag, vbs); _ } ]), _) ->
let processed_vbs, collected_bindings =
List.fold_left
begin
fun (vbs_acc, bindings_acc) vb ->
match vb.pvb_pat.ppat_desc, vb.pvb_expr.pexp_desc with
| Ppat_var { txt = var_name; _ }, Pexp_constant (Pconst_string (_, loc, _)) ->
let binding = Transformations.transform_let ~loc vb in
let alias = make_alias_binding ~loc ~var_name in
alias :: vbs_acc, binding :: bindings_acc
| Ppat_constant (Pconst_string (pattern_str, _, _)), _ ->
let new_vb, new_bindings = Transformations.transform_destructuring_let ~loc:vb.pvb_loc pattern_str vb.pvb_expr in
new_vb :: vbs_acc, new_bindings @ bindings_acc
| _ -> vbs_acc, bindings_acc
end
([], acc) vbs
in
let new_item = { item with pstr_desc = Pstr_value (rec_flag, List.rev processed_vbs) } in
new_item, collected_bindings
| Pstr_value (rec_flag, vbs) ->
let processed_vbs, collected_bindings =
List.fold_left
(fun (vbs_acc, bindings_acc) vb ->
match vb.pvb_expr.pexp_desc with
| Pexp_extension ({ txt = "mikmatch"; loc }, PStr [ { pstr_desc = Pstr_eval (expr, _); _ } ])
when match expr.pexp_desc with Pexp_constant (Pconst_string _) -> true | _ -> false ->
let new_vb = { vb with pvb_expr = expr } in
let binding = Transformations.transform_let ~loc new_vb in
let alias =
match vb.pvb_pat.ppat_desc with Ppat_var { txt = var_name; loc } -> make_alias_binding ~loc ~var_name | _ -> new_vb
in
alias :: vbs_acc, binding :: bindings_acc
| _ ->
let new_expr, new_bindings = self#expression vb.pvb_expr bindings_acc in
let new_vb = { vb with pvb_expr = new_expr } in
new_vb :: vbs_acc, new_bindings)
([], acc) vbs
in
let new_item = { item with pstr_desc = Pstr_value (rec_flag, List.rev processed_vbs) } in
new_item, collected_bindings
| _ -> super#structure_item item acc
method! expression e_ext acc =
let e_ext, acc = super#expression e_ext acc in
let has_ext_case =
List.exists
begin
fun case -> match case.pc_lhs.ppat_desc with Ppat_extension ({ txt = "mikmatch"; _ }, _) -> true | _ -> false
end
in
match e_ext.pexp_desc with
| Pexp_extension ({ txt = "mikmatch"; _ }, PStr [ { pstr_desc = Pstr_eval (e, _); _ } ]) ->
let loc = e.pexp_loc in
begin
match e.pexp_desc with
| Pexp_function ([], _, Pfunction_cases (cases, _, _)) ->
let cases, binding = Transformations.transform_cases ~loc cases in
[%expr fun _ppx_mikmatch_v -> [%e cases]], binding @ acc
| Pexp_match (e, cases) ->
let cases, binding = Transformations.transform_cases ~loc cases in
( [%expr
let _ppx_mikmatch_v = [%e e] in
[%e cases]],
binding @ acc )
| Pexp_let (rec_flag, vbs, body) ->
let processed_vbs, new_bindings =
List.fold_left
(fun (vbs_acc, bindings_acc) vb ->
match vb.pvb_pat.ppat_desc, vb.pvb_expr.pexp_desc with
| Ppat_constant (Pconst_string (pattern_str, _, _)), _ ->
let new_vb, new_bindings = Transformations.transform_destructuring_let ~loc:vb.pvb_loc pattern_str vb.pvb_expr in
new_vb :: vbs_acc, new_bindings @ bindings_acc
| _ ->
Util.error ~loc
"[%%pcre] and [%%mikmatch] only apply to match, function, global let declarations of strings, and let destructuring.")
([], []) vbs
in
pexp_let ~loc rec_flag (List.rev processed_vbs) body, new_bindings @ acc
| _ ->
Util.error ~loc
"[%%pcre] and [%%mikmatch] only apply to match, function, global let declarations of strings, and let destructuring."
end
| Pexp_match (matched_expr, cases) when has_ext_case cases ->
Transformations.transform_mixed_match ~loc:e_ext.pexp_loc ~matched_expr cases acc
| Pexp_function ([], _, Pfunction_cases (cases, _, _)) when has_ext_case cases -> Transformations.transform_mixed_match ~loc:e_ext.pexp_loc cases acc
| _ -> e_ext, acc
end
let dispatch_function_binding ~loc =
let open Ppxlib in
let open Ast_builder.Default in
value_binding ~loc
~pat:(ppat_var ~loc { txt = "__ppx_mikmatch_dispatch"; loc })
~expr:
[%expr
fun marks handlers _g ->
let rec loop i =
if i >= Array.length marks then None
else if Re.Mark.test _g marks.(i) then (match handlers.(i) _g with Some result -> Some result | None -> loop (i + 1))
else loop (i + 1)
in
loop 0]
let impl str =
let str, rev_bindings = transformation#structure str [] in
match rev_bindings with
| [] -> str
| _ -> begin
let loc = match List.hd (List.rev rev_bindings) with { pvb_loc; _ } -> pvb_loc in
let struct_items =
rev_bindings
|> List.rev
|> List.fold_left
(fun acc binding -> acc @ [%str let[@warning "-32"] [%p binding.pvb_pat] = [%e binding.pvb_expr]])
[%str [%%i pstr_value ~loc Nonrecursive [ dispatch_function_binding ~loc ]]]
in
let mod_expr = pmod_structure ~loc struct_items in
[%str open [%m mod_expr]] @ str
end
let () = Driver.register_transformation ~impl "ppx_mikmatch"