Merge pull request #15 from cristianoc/type_corresp_impl_intf

Dependencies between types in interface and implementation files.

Author: cristianoc

examples/deadcode/src/DeadTest.bs.js

@@ -170,4 +170,6 @@ let () = Js.log(make);
 
 let theSideEffectIsLogging = Js.log(123);
 
-let stringLengthNoSideEffects = String.length("sdkdl");
+let stringLengthNoSideEffects = String.length("sdkdl");
+
+Trace.infok("", "", ({pf}) => pf("%s", ""));

examples/deadcode/src/DeadTest.re

@@ -0,0 +1,5 @@
+type ('a, 'b) fmt = ('a, Format.formatter, unit, 'b) format4
+type 'a printf = ('a, unit) fmt -> 'a
+type pf = {pf: 'a. 'a printf}
+
+let infok _mod_name _fun_name k = k {pf= Format.eprintf}

examples/deadcode/src/deadcode.txt

@@ -0,0 +1,5 @@
+type ('a, 'b) fmt = ('a, Format.formatter, unit, 'b) format4
+type 'a printf = ('a, unit) fmt -> 'a
+type pf = {pf: 'a. 'a printf}
+
+val infok : string -> string -> (pf -> 'a) -> 'a

examples/deadcode/src/trace.bs.js

@@ -75,7 +75,7 @@ let loadCmtFile = cmtFilePath => {
             (cmtFilePath |> Filename.chop_extension) ++ ".cmti",
           );
         ProcessDeadAnnotations.structure(~doGenType=!cmtiExists, structure);
-        processSignature(~doValues=true, ~doTypes=true, structure.str_type);
+        processSignature(~doValues=true, ~doTypes=false, structure.str_type);
         DeadValue.processStructure(
           ~doTypes=true,
           ~doValues=true,

examples/deadcode/src/trace.ml

@@ -850,7 +850,7 @@ module Decl = {
         ~orderedFiles,
         {
           declKind: kind1,
-          path: path1,
+          path: _path1,
           pos: {
             pos_fname: fname1,
             pos_lnum: lnum1,
@@ -860,7 +860,7 @@ module Decl = {
         },
         {
           declKind: kind2,
-          path: path2,
+          path: _path2,
           pos: {
             pos_fname: fname2,
             pos_lnum: lnum2,
@@ -871,29 +871,15 @@ module Decl = {
       ) => {
     let findPosition = fn => Hashtbl.find(orderedFiles, fn);
 
-    let pathIsImplementationOf = (path1, path2) =>
-      switch (path1, path2) {
-      | ([name1, ...restPath1], [name2, ...restPath2]) =>
-        !Name.isInterface(name1)
-        && Name.isInterface(name2)
-        && List.length(restPath1) > 1
-        && restPath1 == restPath2
-      | ([], _)
-      | (_, []) => false
-      };
-
     /* From the root of the file dependency DAG to the leaves.
        From the bottom of the file to the top. */
     let (position1, position2) = (
       fname1 |> findPosition,
       fname2 |> findPosition,
     );
-    let (p1, p2) =
-      pathIsImplementationOf(path1, path2)
-        ? (1, 0) : pathIsImplementationOf(path2, path1) ? (0, 1) : (0, 0);
     compare(
-      (position1, p1, lnum2, bol2, cnum2, kind1),
-      (position2, p2, lnum1, bol1, cnum1, kind2),
+      (position1, lnum2, bol2, cnum2, kind1),
+      (position2, lnum1, bol1, cnum1, kind2),
     );
   };
 

examples/deadcode/src/trace.mli

@@ -15,19 +15,101 @@ let addTypeReference = (~posFrom, ~posTo) => {
   PosHash.addSet(typeReferences, posTo, posFrom);
 };
 
-let addDeclaration =
-    (
-      ~isInterface,
-      ~path as path_,
-      {type_kind, type_manifest}: Types.type_declaration,
-    ) => {
-  let save = (~declKind, ~loc: Location.t, ~name) => {
-    let name = name |> Name.create(~isInterface);
-    let path = [name, ...path_] |> pathToString;
-    if (type_manifest == None) {
-      addTypeDeclaration(~declKind, ~path=path_, ~loc, name);
+let pathModuleToImplementation = path =>
+  switch (path |> List.rev) {
+  | [moduleName, ...rest] =>
+    [moduleName |> Name.toImplementation, ...rest] |> List.rev
+  | [] => path
+  };
+
+let pathModuleToInterface = path =>
+  switch (path |> List.rev) {
+  | [moduleName, ...rest] =>
+    [moduleName |> Name.toInterface, ...rest] |> List.rev
+  | [] => path
+  };
+
+let pathTypeToInterface = path =>
+  switch (path) {
+  | [typeName, ...rest] => [typeName |> Name.toInterface, ...rest]
+  | [] => path
+  };
+
+let pathTypeToImplementation = path =>
+  switch (path) {
+  | [typeName, ...rest] => [typeName |> Name.toImplementation, ...rest]
+  | [] => path
+  };
+
+let extendTypeDependencies = (loc1: Location.t, loc2: Location.t) =>
+  if (loc1.loc_start != loc2.loc_start) {
+    if (verbose) {
+      Log_.item(
+        "extendTypeDependencies %s --> %s@.",
+        loc1.loc_start |> posToString,
+        loc2.loc_start |> posToString,
+      );
     };
-    Hashtbl.replace(fields, path, loc);
+    typeDependencies := [(loc1, loc2), ...typeDependencies^];
+  };
+
+let addTypeDependenciesImplementationInterface = (~loc, ~name, path_) => {
+  let isInterface = Filename.check_suffix(currentSrc^, "i");
+  if (!isInterface) {
+    let path_1 = path_ |> pathModuleToInterface;
+    let path_2 = path_1 |> pathTypeToInterface;
+    let path1 = [name, ...path_1] |> pathToString;
+    let path2 = [name, ...path_2] |> pathToString;
+
+    switch (Hashtbl.find_opt(fields, path1)) {
+    | None =>
+      switch (Hashtbl.find_opt(fields, path2)) {
+      | None => ()
+      | Some(loc2) =>
+        extendTypeDependencies(loc, loc2);
+        if (!reportTypesDeadOnlyInInterface) {
+          extendTypeDependencies(loc2, loc);
+        };
+      }
+    | Some(loc1) =>
+      extendTypeDependencies(loc, loc1);
+      if (!reportTypesDeadOnlyInInterface) {
+        extendTypeDependencies(loc1, loc);
+      };
+    };
+  } else {
+    let path_1 = path_ |> pathModuleToImplementation;
+    let path_2 = path_1 |> pathTypeToImplementation;
+    let path1 = [name, ...path_1] |> pathToString;
+    let path2 = [name, ...path_2] |> pathToString;
+    switch (Hashtbl.find_opt(fields, path1)) {
+    | None =>
+      switch (Hashtbl.find_opt(fields, path2)) {
+      | None => ()
+      | Some(loc2) =>
+        extendTypeDependencies(loc2, loc);
+        if (!reportTypesDeadOnlyInInterface) {
+          extendTypeDependencies(loc, loc2);
+        };
+      }
+    | Some(loc1) =>
+      extendTypeDependencies(loc1, loc);
+      if (!reportTypesDeadOnlyInInterface) {
+        extendTypeDependencies(loc, loc1);
+      };
+    };
+  };
+};
+
+let addDeclaration = (~path as path_, {type_kind}: Types.type_declaration) => {
+  let save = (~declKind, ~loc: Location.t, ~name) => {
+    let name = name |> Name.create;
+    let path = [name, ...path_];
+    addTypeDeclaration(~declKind, ~path=path_, ~loc, name);
+
+    path_ |> addTypeDependenciesImplementationInterface(~loc, ~name);
+
+    Hashtbl.replace(fields, path |> pathToString, loc);
   };
 
   switch (type_kind) {
@@ -48,18 +130,6 @@ let addDeclaration =
 };
 
 let processTypeDeclaration = (typeDeclaration: Typedtree.type_declaration) => {
-  let extendTypeDependencies = (loc1: Location.t, loc2: Location.t) =>
-    if (loc1.loc_start != loc2.loc_start) {
-      if (verbose) {
-        Log_.item(
-          "extendTypeDependencies %s --> %s@.",
-          loc1.loc_start |> posToString,
-          loc2.loc_start |> posToString,
-        );
-      };
-
-      typeDependencies := [(loc1, loc2), ...typeDependencies^];
-    };
   let updateDependencies = (name, loc) => {
     let path2 =
       [

src/DeadCode.re

@@ -335,7 +335,6 @@ let rec processSignatureItem =
     let (id, t) = si |> Compat.getSigType;
     if (analyzeTypes^) {
       DeadType.addDeclaration(
-        ~isInterface=true,
         ~path=[id |> Ident.name |> Name.create, ...path],
         t,
       );
@@ -443,8 +442,7 @@ let traverseStructure = (~doTypes, ~doValues) => {
                |> Name.create(~isInterface),
                ...currentModulePath^ @ [currentModuleName^],
              ];
-             typeDeclaration.typ_type
-             |> DeadType.addDeclaration(~isInterface, ~path);
+             typeDeclaration.typ_type |> DeadType.addDeclaration(~path);
            });
       }
     | Tstr_include(_) =>