-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathgeneric_ppx.ml
280 lines (250 loc) · 7.27 KB
/
generic_ppx.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
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
open Asttypes
open! Location
open Parsetree
module StringSet = Set.Make(String)
module StringMap = Map.Make(String)
module CharSet = Set.Make(Char)
let s c = String.make 1 c
exception Not_known of char
let ident_of_char c = match c with
| 'a' .. 'z' ->
s (Char.uppercase c)
| 'A' .. 'Z' ->
"U" ^ (s c)
| '0' .. '9' ->
"N" ^ (s c)
| '%' ->
"Percent"
| '(' ->
"Lparen"
| ')' ->
"Rparen"
| '[' ->
"Lbracket"
| ']' ->
"Rbracket"
| '{' ->
"Lbrace"
| '}' ->
"Rbrace"
| ' ' ->
"Space"
| '\n' ->
"Newline"
| '_' ->
"Underscore"
| '!' ->
"Bang"
| '"' ->
"Doublequote"
| '#' ->
"Sharp"
| '$' ->
"Dollar"
| '&' ->
"Ampersand"
| '\\' ->
"Backslash"
| '\'' ->
"Quote"
| '*' ->
"Star"
| '+' ->
"Plus"
| ',' ->
"Comma"
| '-' ->
"Minus"
| '.' ->
"Dot"
| '/' ->
"Slash"
| ':' ->
"Colon"
| c ->
raise (Not_known c)
(* Misc.fatal_error (Printf.sprintf "character %c" c) *)
let chars =
let rec aux i set =
if i >= 256
then set
else aux (i+1) (CharSet.add (Char.chr i) set)
in
aux 0 CharSet.empty
let strmap =
let rec aux i map =
if i >= 256
then map
else
let c = Char.chr i in
let map = try
let s = ident_of_char c in
StringMap.add s c map
with _ -> map in
aux (i+1) map
in
aux 0 StringMap.empty
let is_special_case = function
| ({ txt = "OTHERS" }, _, _, _) -> true
| _ -> false
exception Missing of string
type ('a,'b) lr =
| Left of 'a
| Right of 'b
let remaining_cases strset =
try
let set = StringSet.fold (fun s acc ->
match s with
| "OTHERS" -> acc
| "Start" -> acc
| "End" -> acc
| _ ->
try CharSet.add (StringMap.find s strmap) acc
with Not_found -> raise (Missing s))
strset CharSet.empty in
let set = CharSet.diff chars set in
let aux c set =
try StringSet.add (ident_of_char c) set
with _ -> set in
Left (CharSet.fold aux set StringSet.empty)
with Missing s -> Right s
let char_of_ident id =
try StringMap.find id strmap
with Not_found -> assert false
let loc_char i loc =
let loc_start =
{ loc.loc_start with
pos_cnum = loc.loc_start.Lexing.pos_cnum + i + 1 } in
let loc_end =
{ loc.loc_start with
pos_cnum = loc.loc_start.Lexing.pos_cnum + i + 2 } in
{ loc with
loc_start;
loc_end }
let list_of_string loc s =
let l = ref [] in
String.iteri (fun i c -> l := (c,loc_char i loc) :: !l) s;
List.rev !l
let to_constructors loc s =
let l = list_of_string loc s in
let constr loc str expr =
let lident = mkloc (Longident.Lident str) loc in
Ast_mapper.E.construct lident (Some expr) false
in
let aux (c,loc) expr = constr loc (ident_of_char c) expr in
let end_constr =
Ast_mapper.E.construct (mkloc (Longident.Lident "End") loc) None false in
constr loc "Start" (List.fold_right aux l end_constr)
module Main : sig end = struct
let is_special_operator s =
String.length s > 1 && s.[0] = '!'
let rec replace_last_ident s = function
| Longident.Lident _ -> Longident.Lident s
| Ldot(t,_) -> Ldot(t,s)
| Lapply(t1,t2) -> Lapply(t1,replace_last_ident s t2)
class char_mapper c = object
inherit Ast_mapper.mapper as parent
method! expr expr =
match expr.pexp_desc with
| Pexp_construct ({ txt = Lident "CHAR" }, None, _) ->
let pexp_desc = Pexp_constant (Const_char c) in
{ expr with pexp_desc }
| _ -> parent#expr expr
end
let map_char c expr =
match expr.pexp_desc with
| Pexp_construct ({ txt = Lident "CHAR" }, None, _) ->
let pexp_desc = Pexp_constant (Const_char c) in
{ expr with pexp_desc }
| _ -> Ast_mapper.E.map (new char_mapper c) expr
let map_pattern expr pats f =
let aux (p,e) = function
| None -> None (* some pattern with the wrong shape *)
| Some (r,l,set) -> match p.ppat_desc with
| Ppat_construct ({ txt = lident }, _, _) ->
begin match Longident.last lident with
| "OTHERS" ->
Some (Some (p, e), l, set)
| s ->
let set = StringSet.add s set in
match e.pexp_desc with
| Pexp_construct ({ txt = Lident "DROP" }, None, _) ->
Some (r,l,set)
| _ ->
Some (r,(p,e)::l,set)
end
| _ -> None
in
begin match List.fold_right aux pats (Some (None,[],StringSet.empty)) with
| None -> expr
| Some (special_pattern, rest, used_cases) ->
match remaining_cases used_cases with
| Right s ->
expr
| Left remainings ->
match special_pattern with
| None -> expr
| Some (p,e) ->
let make_case s =
match p.ppat_desc with
| Ppat_construct ({ txt = lident } as li, subpat, b) ->
let ppat_desc =
Ppat_construct ({ li with txt = replace_last_ident s lident },
subpat, b) in
let e = map_char (char_of_ident s) e in
{ p with ppat_desc }, e
| _ -> assert false
in
let cases = StringSet.fold (fun s l -> make_case s :: l) remainings rest in
{ expr with pexp_desc = f cases }
end
class mapper = object
inherit Ast_mapper.mapper as parent
method! expr expr =
let expr = parent#expr expr in
match expr.pexp_desc with
| Pexp_apply
( { pexp_desc =
Pexp_ident { txt = Lident op_ident } } as
fun_exp,
[label,{ pexp_loc; pexp_desc = Pexp_constant (Const_string s) }] )
when is_special_operator op_ident ->
{ expr with
pexp_desc =
Pexp_apply (fun_exp, [label, to_constructors pexp_loc s])}
| Pexp_match ( cond, pats ) ->
map_pattern expr pats
(fun pats -> Pexp_match ( cond, pats ))
| Pexp_function (label, lab_def, pats) ->
map_pattern expr pats
(fun pats -> Pexp_function (label, lab_def, pats))
| _ -> expr
method! type_declaration typedecl = match typedecl.ptype_kind with
| Ptype_abstract | Ptype_record _ -> typedecl
| Ptype_variant cases ->
let special_case =
try Some (List.find is_special_case cases)
with Not_found -> None in
match special_case with
| None -> typedecl
| Some special_case ->
let strset = List.fold_left (fun set ({ txt = str }, _, _, _) ->
StringSet.add str set) StringSet.empty cases in
match remaining_cases strset with
| Right s ->
Misc.fatal_error (Printf.sprintf "case %s is not recognized" s)
| Left remainings ->
let (strloc, lst, opt, loc) = special_case in
let res = List.map (fun case ->
if is_special_case case
then
StringSet.fold (fun str acc ->
({ strloc with txt = str }, lst, opt, loc)::acc)
remainings []
else [case])
cases in
{ typedecl with ptype_kind = Ptype_variant (List.flatten res) }
end
let mapper = new mapper
let () = Ast_mapper.main mapper
end