Action for adding @dead annotation.

Author: cristianoc

src/DeadCommon.ml

@@ -486,7 +486,7 @@ let addValueDeclaration ?(isToplevel = true) ~(loc : CL.Location.t) ~moduleLoc
 
 let emitWarning ?(onDeadDecl = fun () -> ()) ~decl ~message name =
   let loc = decl |> declGetLoc in
-  Log_.warning ~loc ~notFinished:true ~name (fun ppf () ->
+  Log_.warning ~loc ~notClosed:true ~name (fun ppf () ->
       Format.fprintf ppf "@{<info>%s@} %s"
         (decl.path |> Path.withoutHead)
         message);
@@ -604,13 +604,15 @@ module WriteDeadAnnotations = struct
           let posAnnotation = decl |> getPosAnnotation in
           let offset = decl.posAdjustment |> offsetOfPosAdjustment in
           EmitJson.emitAnnotate
-            ~line:(posAnnotation.pos_lnum - 1)
-            ~character:(posAnnotation.pos_cnum - posAnnotation.pos_bol + offset)
+            ~pos:
+              ( posAnnotation.pos_lnum - 1,
+                posAnnotation.pos_cnum - posAnnotation.pos_bol + offset )
             ~text:
               (if decl.posAdjustment = FirstVariant then
                (* avoid syntax error *)
                "| @dead "
               else "@dead ")
+            ~action:"Suppress dead code warning"
         else
           Format.fprintf ppf "  <-- line %d@.  %s@." decl.pos.pos_lnum
             (line |> lineToString)

src/EmitJson.ml

@@ -2,25 +2,30 @@ let items = ref 0
 
 let start () = Format.fprintf Format.std_formatter "["
 
-let finish () = Format.fprintf Format.std_formatter "\n]\n"
+let finish () = Format.fprintf Format.std_formatter "\n]@."
 
-let emitClose () =
-  Format.fprintf Format.std_formatter (if !items = 0 then "\n}" else "\n}")
+let emitClose () = Format.fprintf Format.std_formatter "\n}"
 
 let emitItem ~name ~kind ~file ~range ~message =
   let open Format in
   items := !items + 1;
   let ppf = std_formatter in
   let startLine, startCharacter, endLine, endCharacter = range in
   fprintf ppf "%s{\n" (if !items = 1 then "\n" else ",\n");
-  fprintf ppf "  \"name\": \"%s\",@." name;
-  fprintf ppf "  \"kind\": \"%s\",@." kind;
-  fprintf ppf "  \"file\": \"%s\",@." file;
-  fprintf ppf "  \"range\": [%d,%d,%d,%d],@." startLine startCharacter endLine
+  fprintf ppf "  \"name\": \"%s\",\n" name;
+  fprintf ppf "  \"kind\": \"%s\",\n" kind;
+  fprintf ppf "  \"file\": \"%s\",\n" file;
+  fprintf ppf "  \"range\": [%d,%d,%d,%d],\n" startLine startCharacter endLine
     endCharacter;
   fprintf ppf "  \"message\": \"%s\"" message
 
-let emitAnnotate ~line ~character ~text =
+let locToPos (loc : CL.Location.t) =
+  (loc.loc_start.pos_lnum - 1, loc.loc_start.pos_cnum - loc.loc_start.pos_bol)
+
+let emitAnnotate ~pos ~text ~action =
+  let line, character = pos in
   Format.fprintf Format.std_formatter
-    ",@.  \"annotate\": { \"line\": %d, \"character\": %d, \"text\": \"%s\"}@."
-    line character text
+    ",\n\
+    \  \"annotate\": { \"line\": %d, \"character\": %d, \"text\": \"%s\", \
+     \"action\": \"%s\"}"
+    line character text action

src/Exception.ml

@@ -169,6 +169,7 @@ module Checks = struct
   type check = {
     events : Event.t list;
     loc : CL.Location.t;
+    locFull : CL.Location.t;
     moduleName : string;
     name : string;
     exceptions : Exceptions.t;
@@ -178,22 +179,30 @@ module Checks = struct
 
   let checks = (ref [] : t ref)
 
-  let add ~events ~exceptions ~loc ~moduleName ~name =
-    checks := {events; exceptions; loc; moduleName; name} :: !checks
+  let add ~events ~exceptions ~loc ?(locFull = loc) ~moduleName name =
+    checks := {events; exceptions; loc; locFull; moduleName; name} :: !checks
 
-  let doCheck {events; exceptions; loc; moduleName; name} =
+  let doCheck {events; exceptions; loc; locFull; moduleName; name} =
     let raiseSet, exnTable = events |> Event.combine ~moduleName in
     let missingAnnotations = Exceptions.diff raiseSet exceptions in
     let redundantAnnotations = Exceptions.diff exceptions raiseSet in
-    if not (Exceptions.isEmpty missingAnnotations) then
-      Log_.warning ~loc ~name:"Exception Analysis" (fun ppf () ->
+    if not (Exceptions.isEmpty missingAnnotations) then (
+      let raisesTxt =
+        Format.asprintf "%a" (Exceptions.pp ~exnTable:(Some exnTable)) raiseSet
+      in
+      let missingTxt =
+        Format.asprintf "%a" (Exceptions.pp ~exnTable:None) missingAnnotations
+      in
+      Log_.warning ~loc ~name:"Exception Analysis" ~notClosed:true
+        (fun ppf () ->
           Format.fprintf ppf
-            "@{<info>%s@} might raise %a and is not annotated with @raises(%a)"
-            name
-            (Exceptions.pp ~exnTable:(Some exnTable))
-            raiseSet
-            (Exceptions.pp ~exnTable:None)
-            missingAnnotations);
+            "@{<info>%s@} might raise %s and is not annotated with @raises(%s)"
+            name raisesTxt missingTxt);
+      if !Common.Cli.json then (
+        EmitJson.emitAnnotate ~action:"Add @raises annotation"
+          ~pos:(EmitJson.locToPos locFull)
+          ~text:(Format.asprintf "@raises(%s)\\n" missingTxt);
+        EmitJson.emitClose ()));
     if not (Exceptions.isEmpty redundantAnnotations) then
       Log_.warning ~loc ~name:"Exception Analysis" (fun ppf () ->
           let raisesDescription ppf () =
@@ -389,7 +398,7 @@ let traverseAst () =
     self.expr self expr |> ignore;
     Checks.add ~events:!currentEvents
       ~exceptions:(getExceptionsFromAnnotations attributes)
-      ~loc:expr.exp_loc ~moduleName ~name;
+      ~loc:expr.exp_loc ~moduleName name;
     currentId := oldId;
     currentEvents := oldEvents
   in
@@ -445,7 +454,7 @@ let traverseAst () =
         | _ -> Exceptions.empty
       in
       Checks.add ~events:!currentEvents ~exceptions ~loc:vb.vb_pat.pat_loc
-        ~moduleName ~name;
+        ~locFull:vb.vb_loc ~moduleName name;
       currentId := oldId;
       currentEvents := oldEvents;
       res

src/Log_.ml

@@ -142,7 +142,7 @@ type kind = Warning | Error
 
 let first = ref true
 
-let logKind ~count ~kind ~(loc : CL.Location.t) ~name ~notFinished body =
+let logKind ~count ~kind ~(loc : CL.Location.t) ~name ~notClosed body =
   if Suppress.filter loc.loc_start then (
     let open Format in
     first := false;
@@ -159,16 +159,16 @@ let logKind ~count ~kind ~(loc : CL.Location.t) ~name ~notFinished body =
         ~file
         ~range:(startLine, startCharacter, endLine, endCharacter)
         ~message;
-      if notFinished = false then EmitJson.emitClose ())
+      if notClosed = false then EmitJson.emitClose ())
     else
       let color =
         match kind with Warning -> Color.info | Error -> Color.error
       in
       fprintf std_formatter "@[<v 2>@,%a@,%a@,%a@]@." color name Loc.print loc
         body ())
 
-let warning ?(count = true) ?(notFinished = false) ~loc ~name body =
-  body |> logKind ~kind:Warning ~count ~loc ~name ~notFinished
+let warning ?(count = true) ?(notClosed = false) ~loc ~name body =
+  body |> logKind ~kind:Warning ~count ~loc ~name ~notClosed
 
 let error ~loc ~name body =
-  body |> logKind ~kind:Error ~count:true ~loc ~name ~notFinished:false
+  body |> logKind ~kind:Error ~count:true ~loc ~name ~notClosed:false