--- a/src/ppx/instrument.ml 2022-10-31 16:01:28.486756629 -0600
+++ b/src/ppx/instrument.ml 2022-10-31 17:05:13.572237694 -0600
@@ -1039,24 +1039,24 @@ class instrumenter =
let instrument_cases = Generated_code.instrument_cases points in
object (self)
- inherit Ppxlib.Ast_traverse.map_with_expansion_context as super
+ inherit Ppxlib.Ast_traverse.map_with_expansion_context_and_errors as super
method! class_expr ctxt ce =
let loc = ce.pcl_loc in
let attrs = ce.pcl_attributes in
- let ce = super#class_expr ctxt ce in
+ let ce, locs = super#class_expr ctxt ce in
match ce.pcl_desc with
| Pcl_fun (l, e, p, ce) ->
- Cl.fun_ ~loc ~attrs l (Option.map instrument_expr e) p ce
+ Cl.fun_ ~loc ~attrs l (Option.map instrument_expr e) p ce, locs
| _ ->
- ce
+ ce, locs
method! class_field ctxt cf =
let loc = cf.pcf_loc in
let attrs = cf.pcf_attributes in
- let cf = super#class_field ctxt cf in
+ let cf, locs = super#class_field ctxt cf in
match cf.pcf_desc with
| Pcf_method (name, private_, cf) ->
@@ -1065,13 +1065,13 @@ class instrumenter =
(match cf with
| Cfk_virtual _ -> cf
| Cfk_concrete (o, e) ->
- Cf.concrete o (instrument_expr e))
+ Cf.concrete o (instrument_expr e)), locs
| Pcf_initializer e ->
- Cf.initializer_ ~loc ~attrs (instrument_expr e)
+ Cf.initializer_ ~loc ~attrs (instrument_expr e), locs
| _ ->
- cf
+ cf, locs
method! expression ctxt e =
let is_trivial_function = Parsetree.(function
@@ -1494,17 +1494,19 @@ class instrumenter =
(f, traverse ~is_in_tail_position:false e)))
| Pexp_letmodule (m, e, e') ->
+ let mexpr', _locs = (self#module_expr ctxt e) in
Exp.letmodule ~loc ~attrs
m
- (self#module_expr ctxt e)
+ mexpr'
(traverse ~is_in_tail_position e')
| Pexp_letexception (c, e) ->
Exp.letexception ~loc ~attrs c (traverse ~is_in_tail_position e)
| Pexp_open (m, e) ->
+ let oexpr', _locs = (self#open_declaration ctxt m) in
Exp.open_ ~loc ~attrs
- (self#open_declaration ctxt m)
+ oexpr'
(traverse ~is_in_tail_position e)
| Pexp_newtype (t, e) ->
@@ -1513,10 +1515,12 @@ class instrumenter =
(* Expressions that don't need instrumentation, and where AST
traversal leaves the expression language. *)
| Pexp_object c ->
- Exp.object_ ~loc ~attrs (self#class_structure ctxt c)
+ let cstr, _locs = (self#class_structure ctxt c) in
+ Exp.object_ ~loc ~attrs cstr
| Pexp_pack m ->
- Exp.pack ~loc ~attrs (self#module_expr ctxt m)
+ let mexpr', _locs = (self#module_expr ctxt m) in
+ Exp.pack ~loc ~attrs mexpr'
(* Expressions that are not recursively traversed at all. *)
| Pexp_extension _ | Pexp_unreachable ->
@@ -1536,7 +1540,7 @@ class instrumenter =
in
- traverse ~is_in_tail_position:false e
+ traverse ~is_in_tail_position:false e, []
(* Set to [true] upon encountering [[@@@coverage.off]], and back to
[false] again upon encountering [[@@@coverage.on]]. *)
@@ -1548,7 +1552,7 @@ class instrumenter =
match si.pstr_desc with
| Pstr_value (rec_flag, bindings) ->
if structure_instrumentation_suppressed then
- si
+ si, []
else
let bindings =
@@ -1580,16 +1584,18 @@ class instrumenter =
if do_not_instrument then
binding
else
- {binding with pvb_expr = self#expression ctxt binding.pvb_expr}
+ let expr', _errs = self#expression ctxt binding.pvb_expr in
+ {binding with pvb_expr = expr'}
end
in
- Str.value ~loc rec_flag bindings
+ Str.value ~loc rec_flag bindings, []
| Pstr_eval (e, a) ->
if structure_instrumentation_suppressed then
- si
+ si, []
else
- Str.eval ~loc ~attrs:a (self#expression ctxt e)
+ let expr', errors = self#expression ctxt e in
+ Str.eval ~loc ~attrs:a expr', errors
| Pstr_attribute attribute ->
let kind = Coverage_attributes.recognize attribute in
@@ -1612,17 +1618,17 @@ class instrumenter =
Location.raise_errorf
~loc:attribute.attr_loc "coverage exclude_file is not allowed here."
end;
- si
+ si, []
| _ ->
super#structure_item ctxt si
(* Don't instrument payloads of extensions and attributes. *)
method! extension _ e =
- e
+ e, []
method! attribute _ a =
- a
+ a, []
method! structure ctxt ast =
let saved_structure_instrumentation_suppressed =
@@ -1655,7 +1661,7 @@ class instrumenter =
ast
else begin
- let instrumented_ast = super#structure ctxt ast in
+ let instrumented_ast, _errs = super#structure ctxt ast in
let runtime_initialization =
Generated_code.runtime_initialization points path in
runtime_initialization @ instrumented_ast
--- a/src/ppx/instrument.mli 2022-03-14 01:39:55.000000000 -0600
+++ b/src/ppx/instrument.mli 2022-10-31 15:48:11.733614835 -0600
@@ -5,7 +5,7 @@
class instrumenter : object
- inherit Ppxlib.Ast_traverse.map_with_expansion_context
+ inherit Ppxlib.Ast_traverse.map_with_expansion_context_and_errors
method transform_impl_file:
Ppxlib.Expansion_context.Base.t ->