Avoid false-positives reporting from the generated code (#62)

* Avoid false-positives reporting from the generated code

Previously we were reporting lints (usually about eta-expansion)
in the code generated by PPX extensions like deriving.
Now we have a special lint, that collects type declarations
and if buggy expression location points to type declaration
we decide that it was not written by user and don't report it.

Signed-off-by: Kakadu <Kakadu@pm.me>

* Cleanup collecting types' locations.

Signed-off-by: Kakadu <Kakadu@pm.me>

* fixup! Cleanup collecting types' locations.

Signed-off-by: Kakadu <kakadu@pm.me>

---------

Signed-off-by: Kakadu <Kakadu@pm.me>
Signed-off-by: Kakadu <kakadu@pm.me>

src/Collected_lints.ml

@@ -76,3 +76,8 @@ let report () =
       in
       List.iter f all_files)
 ;;
+
+let tdecls : (Location.t, unit) Hashtbl.t = Hashtbl.create 123
+let clear_tdecls () = Hashtbl.clear tdecls
+let add_tdecl key = Hashtbl.add tdecls key ()
+let has_tdecl_at key = Hashtbl.mem tdecls key

src/Collected_lints.mli

@@ -10,6 +10,8 @@
 
 [@@@ocaml.text "/*"]
 
+(** {1 Collecting found lints} *)
+
 val clear : unit -> unit
 val add : loc:Warnings.loc -> (module LINT.REPORTER) -> unit
 
@@ -18,3 +20,12 @@ val add : loc:Warnings.loc -> (module LINT.REPORTER) -> unit
     - In RdJSONl format. Change {!Config.out_rdjsonl} to modify output file name
     - As plain text to stdout *)
 val report : unit -> unit
+
+(** {1 Collecting type declarations}
+
+    We use information about type declarations to skip reporting lints in
+    the code generated from a type declaration via `deriving`. *)
+
+val add_tdecl : Warnings.loc -> unit
+val has_tdecl_at : Warnings.loc -> bool
+val clear_tdecls : unit -> unit

src/Config.ml

@@ -108,10 +108,13 @@ let recover_filepath filepath =
 let is_enabled () =
   let hash = enabled_lints () in
   fun (module M : LINT.GENERAL) ->
-    (* Format.printf "is_enabled of %s\n%!" M.lint_id; *)
-    match M.level with
-    | LINT.Allow when opts.skip_level_allow -> false
-    | _ -> Hash_set.mem hash M.lint_id
+    let ans =
+      match M.level with
+      | LINT.Allow when opts.skip_level_allow -> false
+      | _ -> Hash_set.mem hash M.lint_id
+    in
+    (* Format.printf "is_enabled of %s = %b\n%!" M.lint_id ans; *)
+    ans
 ;;
 
 let parse_args () =

src/Load_dune.ml

@@ -142,6 +142,7 @@ let analyze_dir ~untyped:analyze_untyped ~cmt:analyze_cmt ~cmti:analyze_cmti pat
     (* Now analyze Typedtree extracted from cmt[i] *)
     let on_cmti source_file (_cmi_info, cmt_info) =
       Option.iter cmt_info ~f:(fun cmt ->
+        Collected_lints.clear_tdecls ();
         match cmt.Cmt_format.cmt_annots with
         | Cmt_format.Implementation stru -> analyze_cmt is_wrapped source_file stru
         | Interface sign -> analyze_cmti is_wrapped source_file sign

src/main.ml

@@ -29,7 +29,8 @@ let untyped_linters =
 let typed_linters =
   let open TypedLints in
   [ (* *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** *)
-    (module Ambiguous_constructors : LINT.TYPED)
+    (module Aggregate_defs : LINT.TYPED)
+  ; (module Ambiguous_constructors : LINT.TYPED)
   ; (module Exc_try_with_wildcard : LINT.TYPED)
   ; (module Failwith : LINT.TYPED)
   ; (module Equality : LINT.TYPED)
@@ -66,6 +67,7 @@ let () =
     if not (String.equal L.lint_id UntypedLints.Toplevel_eval.lint_id)
     then Hash_set.add enabled L.lint_id);
   List.iter typed_linters ~f:(fun (module L : LINT.TYPED) ->
+    (* Format.printf "   ENABLE %s\n%!" L.lint_id; *)
     Hash_set.add all L.lint_id;
     Hash_set.add enabled L.lint_id);
   List.iter per_file_linters ~f:(fun (module L : LINT.TYPED) ->
@@ -125,7 +127,11 @@ let run_typed_lints entry info =
   build_iterator
     ~f:entry
     ~compose:(fun ((module L : LINT.TYPED) as lint) acc ->
-      if is_enabled (lint :> (module LINT.GENERAL)) then L.run info acc else acc)
+      if is_enabled (lint :> (module LINT.GENERAL))
+      then L.run info acc
+      else (
+        let __ () = Format.printf "%s is disabled\n%!" L.lint_id in
+        acc))
     ~init:Tast_iterator.default_iterator
     typed_linters
 ;;

src/typed/Aggregate_defs.ml

@@ -0,0 +1,71 @@
+(** Aggregate all types defined in a file.
+    Not really a lint but a preparation for skipping false-positives *)
+
+[@@@ocaml.text "/*"]
+
+(** Copyright 2021-2024, Kakadu *)
+
+(** SPDX-License-Identifier: LGPL-3.0-or-later *)
+
+[@@@ocaml.text "/*"]
+
+open Zanuda_core
+open Zanuda_core.Utils
+open Tast_pattern
+
+type input = Tast_iterator.iterator
+
+let lint_id = "misc_aggregate_defs"
+let level = LINT.Warn
+let lint_source = LINT.FPCourse
+
+let documentation =
+  {|
+It is not really a lint. It collects locations in the file where types are declared and saves them.
+If PPX-expanded expressions have issues and locations corresponding type declarations,
+we don't report these false-positive lints (at the moment, only about possible eta-conversion)
+
+|}
+  |> Stdlib.String.trim
+;;
+
+let describe_as_json () =
+  describe_as_clippy_json lint_id ~group:LINT.Style ~level ~docs:documentation
+;;
+
+let has_deriving_attribute (attrs : Typedtree.attributes) =
+  try
+    let open Parsetree in
+    let _ : attribute =
+      List.find
+        (function
+          | { attr_name = { txt = "deriving" }; _ } -> true
+          | _ -> false)
+        attrs
+    in
+    true
+  with
+  | Not_found -> false
+;;
+
+let run _ fallback =
+  let open Tast_iterator in
+  { fallback with
+    typ =
+      (fun self typ ->
+        Collected_lints.add_tdecl typ.ctyp_loc;
+        fallback.typ self typ)
+  ; type_declaration =
+      (fun self tdecl ->
+        (match tdecl.typ_kind, tdecl.Typedtree.typ_manifest with
+         | Ttype_variant cds, _ when has_deriving_attribute tdecl.typ_attributes ->
+           (* Adding locations of constructor definitions is kind of misuse of
+              [Collected_lints.add_tdecl] but is required for ppx_deriving.eq *)
+           List.iter (fun cd -> Collected_lints.add_tdecl cd.Typedtree.cd_loc) cds
+         | Ttype_abstract, Some t when has_deriving_attribute tdecl.typ_attributes ->
+           Collected_lints.add_tdecl t.ctyp_loc
+         | (Ttype_variant _ | Ttype_open | Ttype_record _), _ | Ttype_abstract, None | _
+           -> ());
+        fallback.type_declaration self tdecl)
+  }
+;;

src/typed/Eta.ml

@@ -105,43 +105,44 @@ let run _ fallback =
   in
   let pat = of_func pat_func in
   let open Tast_iterator in
+  let check expr (ids, new_expr, args) () =
+    let open Typedtree in
+    let loc = expr.exp_loc in
+    let extract_ident = function
+      | Path.Pident id -> Some id
+      | _ -> None
+    in
+    (*              Format.printf "Expr: `%s`\nInner=`%s`\nFormal args=`%s`\nReal args=`%s`\nLengths: %d %d\n"
+                    (expr2string expr)
+                    (expr2string func)
+                    (String.concat ~sep:", " ids)
+                    (String.concat ~sep:", " (List.map ~f:ident2string args))
+                    (List.length ids)
+                    (List.length args); *)
+    let idents = List.filter_map extract_ident args in
+    let args_len = List.length args in
+    if args_len > 0
+       && args_len = List.length idents
+       && List.equal String.equal ids (List.map Ident.name idents)
+       && (not (Base.List.contains_dup ~compare:String.compare ids))
+       && List.for_all (no_ident new_expr) idents
+    then
+      if not (Collected_lints.has_tdecl_at loc)
+      then
+        Collected_lints.add
+          ~loc
+          (report loc.Location.loc_start.Lexing.pos_fname ~loc ~old_expr:expr new_expr)
+  in
   { fallback with
     expr =
       (fun self expr ->
         let open Typedtree in
-        let loc = expr.exp_loc in
-        let extract_ident = function
-          | Path.Pident id -> Some id
-          | _ -> None
-        in
         Tast_pattern.parse
           pat
-          loc
+          expr.exp_loc
           ~on_error:(fun _desc () -> ())
           expr
-          (fun (ids, new_expr, args) () ->
-            (*              Format.printf "Expr: `%s`\nInner=`%s`\nFormal args=`%s`\nReal args=`%s`\nLengths: %d %d\n"
-                            (expr2string expr)
-                            (expr2string func)
-                            (String.concat ~sep:", " ids)
-                            (String.concat ~sep:", " (List.map ~f:ident2string args))
-                            (List.length ids)
-                            (List.length args); *)
-            let idents = List.filter_map extract_ident args in
-            let args_len = List.length args in
-            if args_len > 0
-               && args_len = List.length idents
-               && List.equal String.equal ids (List.map Ident.name idents)
-               && (not (Base.List.contains_dup ~compare:String.compare ids))
-               && List.for_all (no_ident new_expr) idents
-            then
-              Collected_lints.add
-                ~loc
-                (report
-                   loc.Location.loc_start.Lexing.pos_fname
-                   ~loc
-                   ~old_expr:expr
-                   new_expr))
+          (check expr)
           ();
         fallback.expr self expr)
   }

src/typed/dune

@@ -2,6 +2,7 @@
  (name TypedLints)
  (libraries zanuda_core Tast_pattern Refactoring)
  (modules
+  Aggregate_defs
   Ambiguous_constructors
   Exc_try_with_wildcard
   Equality

tests/typed/Eta.t/deriv.ml

@@ -5,4 +5,10 @@ type ty = A of typ
 and typ = ty lvls  [@@deriving show { with_path = false }]
 
 
-type hack = int list
+type hack = int list
+
+(** In the below definition eta conversion is possible because of deriving.eq 
+The reported located is a constructor, not the type definition
+*)
+type expr = FuncCall of expr list [@@deriving eq ]
+

tests/typed/Eta.t/dune

@@ -6,4 +6,4 @@
  ; (flags
  ;  (:standard -dsource))
  (preprocess
-  (pps ppx_deriving.show)))
+  (pps ppx_deriving.show ppx_deriving.eq)))