From 87b56809838cfc0a4a06410f64b4707796c859a5 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sat, 14 Jul 2018 23:33:18 +0200 Subject: [PATCH] ast_{iter,mapper}: always traverse the attributes right after the location Now that each node that supports attributes also has a location, we want to make the attributed node's location robustly available to AST traversal functions. The best way to do this would be to change the "attributes" traverser to take the node's location as extra parameter. However, doing this changes the type of the traverser interface, with a risk of breaking user code. This may be the right long-term change, but for now we go with something weaker: we ensure that the attributes of a node are always traversed right after the node's location, which lets user track attributed location (if they wish) through a side-effect. --- parsing/ast_iterator.ml | 13 +++++++---- parsing/ast_mapper.ml | 48 ++++++++++++++++++++++++----------------- 2 files changed, 37 insertions(+), 24 deletions(-) diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index 55542f4c8604..a002e53288df 100755 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -153,14 +153,18 @@ module T = struct {ptyext_path; ptyext_params; ptyext_constructors; ptyext_private = _; + ptyext_loc; ptyext_attributes} = iter_loc sub ptyext_path; List.iter (sub.extension_constructor sub) ptyext_constructors; List.iter (iter_fst (sub.typ sub)) ptyext_params; + sub.location sub ptyext_loc; sub.attributes sub ptyext_attributes - let iter_type_exception sub {ptyexn_constructor; ptyexn_attributes} = + let iter_type_exception sub + {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = sub.extension_constructor sub ptyexn_constructor; + sub.location sub ptyexn_loc; sub.attributes sub ptyexn_attributes let iter_extension_constructor_kind sub = function @@ -262,7 +266,8 @@ module MT = struct | Psig_class_type l -> List.iter (sub.class_type_declaration sub) l | Psig_extension (x, attrs) -> - sub.extension sub x; sub.attributes sub attrs + sub.attributes sub attrs; + sub.extension sub x | Psig_attribute x -> sub.attribute sub x end @@ -291,7 +296,7 @@ module M = struct sub.location sub loc; match desc with | Pstr_eval (x, attrs) -> - sub.expr sub x; sub.attributes sub attrs + sub.attributes sub attrs; sub.expr sub x | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs | Pstr_primitive vd -> sub.value_description sub vd | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l @@ -306,7 +311,7 @@ module M = struct List.iter (sub.class_type_declaration sub) l | Pstr_include x -> sub.include_declaration sub x | Pstr_extension (x, attrs) -> - sub.extension sub x; sub.attributes sub attrs + sub.attributes sub attrs; sub.extension sub x | Pstr_attribute x -> sub.attribute sub x end diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 2bdc180e57f5..58c88361cedf 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -90,13 +90,14 @@ module T = struct let row_field sub = function | Rtag (l, attrs, b, tl) -> - Rtag (map_loc sub l, sub.attributes sub attrs, - b, List.map (sub.typ sub) tl) + let attrs = sub.attributes sub attrs in + Rtag (map_loc sub l, attrs, b, List.map (sub.typ sub) tl) | Rinherit t -> Rinherit (sub.typ sub t) let object_field sub = function | Otag (l, attrs, t) -> - Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) + let attrs = sub.attributes sub attrs in + Otag (map_loc sub l, attrs, sub.typ sub t) | Oinherit t -> Oinherit (sub.typ sub t) let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = @@ -132,7 +133,9 @@ module T = struct ptype_manifest; ptype_attributes; ptype_loc} = - Type.mk (map_loc sub ptype_name) + let loc = sub.location sub ptype_loc in + let attrs = sub.attributes sub ptype_attributes in + Type.mk ~loc ~attrs (map_loc sub ptype_name) ~params:(List.map (map_fst (sub.typ sub)) ptype_params) ~priv:ptype_private ~cstrs:(List.map @@ -140,8 +143,6 @@ module T = struct ptype_cstrs) ~kind:(sub.type_kind sub ptype_kind) ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) let map_type_kind sub = function | Ptype_abstract -> Ptype_abstract @@ -159,18 +160,22 @@ module T = struct {ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; + ptyext_loc; ptyext_attributes} = - Te.mk + let loc = sub.location sub ptyext_loc in + let attrs = sub.attributes sub ptyext_attributes in + Te.mk ~loc ~attrs (map_loc sub ptyext_path) (List.map (sub.extension_constructor sub) ptyext_constructors) ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - let map_type_exception sub {ptyexn_constructor; ptyexn_attributes} = - Te.mk_exception + let map_type_exception sub + {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + let loc = sub.location sub ptyexn_loc in + let attrs = sub.attributes sub ptyexn_attributes in + Te.mk_exception ~loc ~attrs (sub.extension_constructor sub ptyexn_constructor) - ~attrs:(sub.attributes sub ptyexn_attributes) let map_extension_constructor_kind sub = function Pext_decl(ctl, cto) -> @@ -183,11 +188,11 @@ module T = struct pext_kind; pext_loc; pext_attributes} = - Te.constructor + let loc = sub.location sub pext_loc in + let attrs = sub.attributes sub pext_attributes in + Te.constructor ~loc ~attrs (map_loc sub pext_name) (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) end @@ -279,7 +284,8 @@ module MT = struct | Psig_class_type l -> class_type ~loc (List.map (sub.class_type_declaration sub) l) | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + let attrs = sub.attributes sub attrs in + extension ~loc ~attrs (sub.extension sub x) | Psig_attribute x -> attribute ~loc (sub.attribute sub x) end @@ -311,7 +317,8 @@ module M = struct let loc = sub.location sub loc in match desc with | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + let attrs = sub.attributes sub attrs in + eval ~loc ~attrs (sub.expr sub x) | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) @@ -326,7 +333,8 @@ module M = struct class_type ~loc (List.map (sub.class_type_declaration sub) l) | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + let attrs = sub.attributes sub attrs in + extension ~loc ~attrs (sub.extension sub x) | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) end @@ -500,13 +508,13 @@ module CE = struct let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; pci_loc; pci_attributes} = - Ci.mk + let loc = sub.location sub pci_loc in + let attrs = sub.attributes sub pci_attributes in + Ci.mk ~loc ~attrs ~virt:pci_virt ~params:(List.map (map_fst (sub.typ sub)) pl) (map_loc sub pci_name) (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) end (* Now, a generic AST mapper, to be extended to cover all kinds and