diff --git a/src/code_matcher.ml b/src/code_matcher.ml index 27cc24c8..52c2ad49 100644 --- a/src/code_matcher.ml +++ b/src/code_matcher.ml @@ -58,6 +58,13 @@ struct in loop [] l + let see_end_marker item = + match Attribute.Floating.convert_res [ M.end_marker ] item with + | Ok None -> Ok () + | Ok (Some ()) -> Ok () + | Error e -> Error e + | exception Failure _ -> Ok () + let remove_loc = object inherit Ast_traverse.map @@ -212,3 +219,6 @@ let match_signature_res = Sig.do_match let match_signature ~pos ~expected ~mismatch_handler l = match_signature_res ~pos ~expected ~mismatch_handler l |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + +let see_end_marker_str = Str.see_end_marker +let see_end_marker_sig = Sig.see_end_marker diff --git a/src/code_matcher.mli b/src/code_matcher.mli index 6f1c9e43..fbd84312 100644 --- a/src/code_matcher.mli +++ b/src/code_matcher.mli @@ -39,3 +39,12 @@ val match_signature : signature -> unit (** Same for signatures *) + +(** The following functions mark [@@@deriving.end] as seen. Useful when + purposefully ignoring correction based transformations. *) + +val see_end_marker_str : + structure_item -> (unit, Location.Error.t NonEmptyList.t) result + +val see_end_marker_sig : + signature_item -> (unit, Location.Error.t NonEmptyList.t) result diff --git a/src/context_free.ml b/src/context_free.ml index 4fbd03b2..4ce1e950 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -581,6 +581,9 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) let handle_attr_inline_expect = handle_attr_inline_expect ~no_corrections ~embed_errors in + let see_end_marker f item = + (if no_corrections then f item else Ok ()) |> of_result ~default:() + in object (self) inherit Ast_traverse.map_with_expansion_context_and_errors as super @@ -783,6 +786,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | [] -> return [] | item :: rest -> ( let loc = item.pstr_loc in + see_end_marker Code_matcher.see_end_marker_str item >>= fun () -> match item.pstr_desc with | Pstr_extension (ext, attrs) -> ( let extension_point_loc = item.pstr_loc in @@ -893,6 +897,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | [] -> return [] | item :: rest -> ( let loc = item.psig_loc in + see_end_marker Code_matcher.see_end_marker_sig item >>= fun () -> match item.psig_desc with | Psig_extension (ext, attrs) -> ( let extension_point_loc = item.psig_loc in diff --git a/test/driver/no-corrections/run.t b/test/driver/no-corrections/run.t index 974dfc5b..573fa111 100644 --- a/test/driver/no-corrections/run.t +++ b/test/driver/no-corrections/run.t @@ -79,9 +79,7 @@ has no knowledge of it but we consider this to be an okay limitation, especially since the unused attributes check is disabled by default. $ ./driver_deriving_x.exe -impl test.ml -check -no-corrections -diff-cmd diff - [%%ocaml.error "Attribute `deriving.end' was not used"] [%%ocaml.error "Attribute `gen_stuff' was not used"] - [%%ocaml.error "Attribute `deriving.end' was not used"] type t[@@deriving x] include struct let _ = fun (_ : t) -> () let x = 2 @@ -117,8 +115,6 @@ no attribute warnings since this time, it knows about the [@@gen_stuff] attribut and explicitly skips it. $ ./driver_all.exe -impl test.ml -check -no-corrections -diff-cmd diff - [%%ocaml.error "Attribute `deriving.end' was not used"] - [%%ocaml.error "Attribute `deriving.end' was not used"] type t[@@deriving x] include struct let _ = fun (_ : t) -> () let x = 2