Mark deriving.end attributes as seen in -no-corrections mode

Signed-off-by: Nathan Rebours <nathan.p.rebours@gmail.com>

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

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

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

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