Source file ppx_expand.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
type ppx_kind =
| Expr of Parsetree.expression
| Sig_item of Parsetree.signature_item
| Str_item of Parsetree.structure_item
let check_at_pos pos loc = Location_aux.compare_pos pos loc = 0
let check_extension_node pos (expression : Parsetree.expression) =
match expression.pexp_desc with
| Pexp_extension (loc, _) ->
if check_at_pos pos loc.loc then Some expression.pexp_loc else None
| _ -> None
let check_deriving_attr pos (attrs : Parsetree.attributes) =
let found_attr =
List.find_opt
(fun (attribute : Parsetree.attribute) ->
attribute.attr_name.txt = "deriving"
&& check_at_pos pos attribute.attr_loc)
attrs
in
match found_attr with
| Some attribute -> Some attribute.attr_loc
| None -> None
let check_structures pos (item : Parsetree.structure_item_desc) =
match item with
| Pstr_type (_, ty) ->
List.find_map
(fun (t : Parsetree.type_declaration) ->
check_deriving_attr pos t.ptype_attributes)
ty
| Pstr_exception tc -> check_deriving_attr pos tc.ptyexn_attributes
| Pstr_modtype mt -> check_deriving_attr pos mt.pmtd_attributes
| Pstr_typext tex -> check_deriving_attr pos tex.ptyext_attributes
| _ -> None
let check_signatures pos (item : Parsetree.signature_item_desc) =
match item with
| Psig_type (_, ty) ->
List.find_map
(fun (t : Parsetree.type_declaration) ->
check_deriving_attr pos t.ptype_attributes)
ty
| Psig_exception tc -> check_deriving_attr pos tc.ptyexn_attributes
| Psig_modtype mt -> check_deriving_attr pos mt.pmtd_attributes
| Psig_typext tex -> check_deriving_attr pos tex.ptyext_attributes
| _ -> None
let check_extension ~parsetree ~pos =
let kind = ref None in
let expr (self : Ast_iterator.iterator) (expr : Parsetree.expression) =
match check_extension_node pos expr with
| Some ext_loc -> kind := Some (Expr expr, ext_loc)
| None -> Ast_iterator.default_iterator.expr self expr
in
let signature_item (self : Ast_iterator.iterator)
(original_sg : Parsetree.signature_item) =
match check_signatures pos original_sg.psig_desc with
| Some attr_loc -> kind := Some (Sig_item original_sg, attr_loc)
| None -> Ast_iterator.default_iterator.signature_item self original_sg
in
let structure_item (self : Ast_iterator.iterator)
(original_str : Parsetree.structure_item) =
match check_structures pos original_str.pstr_desc with
| Some attr_loc -> kind := Some (Str_item original_str, attr_loc)
| None -> Ast_iterator.default_iterator.structure_item self original_str
in
let iterator =
{ Ast_iterator.default_iterator with signature_item; structure_item; expr }
in
let () =
match parsetree with
| `Interface si -> iterator.signature iterator si
| `Implementation str -> iterator.structure iterator str
in
!kind
let get_ppxed_source ~ppxed_parsetree ~pos ppx_kind_with_attr :
Query_protocol.ppxed_source =
let expression = ref None in
let signature = ref [] in
let structure = ref [] in
let () =
match ppx_kind_with_attr with
| Expr original_expr, _ -> (
let expr (self : Ast_iterator.iterator) (new_expr : Parsetree.expression)
=
match
Location_aux.included ~into:original_expr.pexp_loc new_expr.pexp_loc
with
| true -> expression := Some new_expr
| false -> Ast_iterator.default_iterator.expr self new_expr
in
let iterator = { Ast_iterator.default_iterator with expr } in
match ppxed_parsetree with
| `Interface si -> iterator.signature iterator si
| `Implementation str -> iterator.structure iterator str)
| Sig_item original_sg, _ -> (
let signature_item (self : Ast_iterator.iterator)
(new_sg : Parsetree.signature_item) =
let included =
Location_aux.included new_sg.psig_loc ~into:original_sg.psig_loc
in
match
(included && original_sg <> new_sg, new_sg.psig_loc.loc_ghost)
with
| true, _ -> signature := new_sg :: !signature
| false, false ->
Ast_iterator.default_iterator.signature_item self new_sg
| false, true -> ()
in
let iterator = { Ast_iterator.default_iterator with signature_item } in
match ppxed_parsetree with
| `Interface si -> iterator.signature iterator si
| `Implementation str -> iterator.structure iterator str)
| Str_item original_str, _ -> (
let structure_item (self : Ast_iterator.iterator)
(new_str : Parsetree.structure_item) =
let included =
Location_aux.included new_str.pstr_loc ~into:original_str.pstr_loc
in
match (included, new_str.pstr_loc.loc_ghost) with
| true, _ -> (
match check_structures pos new_str.pstr_desc with
| None -> structure := new_str :: !structure
| Some _ -> ())
| false, false ->
Ast_iterator.default_iterator.structure_item self new_str
| false, true -> ()
in
let iterator = { Ast_iterator.default_iterator with structure_item } in
match ppxed_parsetree with
| `Interface si -> iterator.signature iterator si
| `Implementation str -> iterator.structure iterator str)
in
match (ppx_kind_with_attr : ppx_kind * Warnings.loc) with
| Expr _, ext_loc ->
{ code = Pprintast.string_of_expression (Option.get !expression);
attr_start = ext_loc.loc_start;
attr_end = ext_loc.loc_end
}
| Sig_item _, attr_loc ->
let exp =
Pprintast.signature Format.str_formatter (List.rev !signature);
Format.flush_str_formatter ()
in
{ code = exp; attr_start = attr_loc.loc_start; attr_end = attr_loc.loc_end }
| Str_item _, attr_loc ->
let exp =
Pprintast.structure Format.str_formatter (List.rev !structure);
Format.flush_str_formatter ()
in
{ code = exp; attr_start = attr_loc.loc_start; attr_end = attr_loc.loc_end }