Distinguish identical files (#130)

* Create test

* Fix bug

* Disable test on windows

* Fix uncaught exception

* Remove `.t` extension from cram config

* Disable test

---------

Co-authored-by: Ulysse Gérard <thevoodoos@gmail.com>

Author: liam923

src/analysis/locate.ml

@@ -584,12 +584,13 @@ let find_source ~config loc =
     | Some s -> s
   in
   log ~title:"find_source" "initial path: %S" initial_path;
-  let dir = Filename.dirname initial_path in
-  let dir =
+  let canonical_dir_for_file file =
+    let raw_dir = Filename.dirname file in
     match config.Mconfig.query.directory with
-    | "" -> dir
-    | cwd -> Misc.canonicalize_filename ~cwd dir
+    | "" -> raw_dir
+    | cwd -> Misc.canonicalize_filename ~cwd raw_dir
   in
+  let dir = canonical_dir_for_file initial_path in
   match Utils.find_all_matches ~config ~with_fallback file with
   | [] ->
     log ~title:"find_source" "failed to find %S in source path (fallback = %b)"
@@ -608,22 +609,28 @@ let find_source ~config loc =
       ~title:(sprintf "find_source(%s)" filename)
       "multiple matches in the source path : %s"
       (String.concat ~sep:" , " files);
-    try
+    let files_matching_digest =
       match File_switching.source_digest () with
       | None ->
         log ~title:"find_source"
           "... no source digest available to select the right one";
-        raise Not_found
+        []
       | Some digest ->
         log ~title:"find_source"
           "... trying to use source digest to find the right one";
         log ~title:"find_source" "Source digest: %s" (Digest.to_hex digest);
-        Found
-          (List.find files ~f:(fun f ->
-               let fdigest = Digest.file f in
-               log ~title:"find_source" "  %s (%s)" f (Digest.to_hex fdigest);
-               fdigest = digest))
-    with Not_found -> (
+
+        List.filter files ~f:(fun f ->
+            let fdigest = Digest.file f in
+            log ~title:"find_source" "  %s (%s)" f (Digest.to_hex fdigest);
+            fdigest = digest)
+    in
+    match files_matching_digest with
+    | [ file ] ->
+      log ~title:"find_source" "... found exactly one file with matching digest";
+      Found file
+    | [] -> (
+      log ~title:"find_source" "... found no files with matching digest";
       log ~title:"find_source" "... using heuristic to select the right one";
       log ~title:"find_source" "we are looking for a file named %s in %s" fname
         dir;
@@ -660,7 +667,66 @@ let find_source ~config loc =
       match lst with
       | (i1, _) :: (i2, _) :: _ when i1 = i2 -> Multiple_matches files
       | (_, s) :: _ -> Found s
-      | _ -> assert false))
+      | _ -> assert false)
+    | files_matching_digest ->
+      log ~title:"find_source" "... found multiple files with matching digest";
+      log ~title:"find_source"
+        "... using directory heuristic to choose the best one";
+      (* Give each source file a score that represents how close its path is to the
+           target path (the path of the build artifact) and then choose the source file
+           with the highest score.
+
+           The score of a source file is the longest tail of the path of the its
+           directory that is a subpath of the target path. This is premised on build
+           systems liking to put artifacts in paths that are similar to the source path.
+           i.e., dune may put the cmt for foo/bar/baz.ml in
+           _build/default/foo/bar/.bar.objs/byte/bar__Baz.cmt, so we want to use that
+           shared foo/bar in the path to disambiguate.
+
+           ex:
+             source file: /a/b/c/d/e/f.ml
+             target path: /a/b/c/_build/default/d/e/artifacts/f.cmi
+             score: 2, because /a/b/c/d/e is the source file's directory, and d/e is
+                    the longest tail of it that is a subpath of the target path. *)
+      let score_file source_file =
+        (* This is technically quadratic, but
+             a) most file paths are short
+             b) in the common case, this is linear because common_prefix_len
+                will usually fail on the first loop
+             c) this isn't a hot path - this is only for the uncommon case where there are
+                two identical files
+             So the stars would need to align for this to cause performance problems *)
+        let target_dir = dir in
+        let source_dir = canonical_dir_for_file source_file in
+        let target_dir_rev = target_dir |> Misc.split_path |> List.rev in
+        let source_dir_rev = source_dir |> Misc.split_path |> List.rev in
+        let rec common_prefix_len a b =
+          match (a, b) with
+          | [], _ | _, [] -> 0
+          | a_hd :: a_tl, b_hd :: b_tl ->
+            if String.equal a_hd b_hd then 1 + common_prefix_len a_tl b_tl
+            else 0
+        in
+        let rec candidates = function
+          | [] -> []
+          | _ :: tl as curr -> curr :: candidates tl
+        in
+        candidates target_dir_rev
+        |> List.map ~f:(common_prefix_len source_dir_rev)
+        |> List.max_elt ~cmp:Int.compare
+        |> Option.value ~default:0
+      in
+      let files_matching_digest_with_scores =
+        List.map files_matching_digest ~f:(fun file -> (file, score_file file))
+      in
+      (* get the max *)
+      let best_file, _best_score =
+        List.max_elt files_matching_digest_with_scores
+          ~cmp:(fun (_, a) (_, b) -> Int.compare a b)
+        |> Option.get
+        (* theres at least one element, so this is never None *)
+      in
+      Found best_file)
 
 (* Well, that's just another hack.
    [find_source] doesn't like the "-o" option of the compiler. This hack handles

src/utils/misc.ml

@@ -125,7 +125,7 @@ let remove_file filename =
     then Sys.remove filename
   with Sys_error _msg -> ()
 
-let rec split_path path acc =
+let rec split_path_and_prepend path acc =
   match Filename.dirname path with
   | dir when dir = path ->
     let is_letter c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') in
@@ -142,7 +142,9 @@ let rec split_path path acc =
       else dir
     in
     dir :: acc
-  | dir -> split_path dir (Filename.basename path :: acc)
+  | dir -> split_path_and_prepend dir (Filename.basename path :: acc)
+
+let split_path path = split_path_and_prepend path []
 
 (* Deal with case insensitive FS *)
 
@@ -181,9 +183,9 @@ let exact_file_exists ~dirname ~basename =
 
 let canonicalize_filename ?cwd path =
   let parts =
-    match split_path path [] with
+    match split_path path with
     | dot :: rest when dot = Filename.current_dir_name ->
-      split_path (match cwd with None -> Sys.getcwd () | Some c -> c) rest
+      split_path_and_prepend (match cwd with None -> Sys.getcwd () | Some c -> c) rest
     | parts -> parts
   in
   let goup path = function
@@ -230,7 +232,7 @@ let rec expand_glob ~filter acc root = function
     Array.fold_left process acc items
 
 let expand_glob ?(filter=fun _ -> true) path acc =
-  match split_path path [] with
+  match split_path path with
   | [] -> acc
   | root :: subs ->
     let patterns = List.map ~f:Glob.compile_pattern subs in

src/utils/misc.mli

@@ -128,11 +128,16 @@ val canonicalize_filename : ?cwd:string -> string -> string
 val expand_glob : ?filter:(string -> bool) -> string -> string list -> string list
         (* [expand_glob ~filter pattern acc] adds all filenames matching
            [pattern] and satistfying the [filter] predicate to [acc]*)
-val split_path : string -> string list -> string list
-        (* [split_path path tail] prepends all components of [path] to [tail],
+val split_path : string -> string list
+        (* [split_path path] returns the components of [path],
+           including implicit "." if path is not absolute.
+           [split_path "a/b/c"] = ["."; "a"; "b"; "c"]
+           [split_path "/a/b/c"] = ["/"; "a"; "b"; "c"]
+        FIXME: explain windows behavior
+        *)
+val split_path_and_prepend : string -> string list -> string list
+        (* [split_path_and_prepend path tail] prepends all components of [path] to [tail],
            including implicit "." if path is not absolute.
-           [split_path "a/b/c" []] = ["."; "a"; "b"; "c"]
-           [split_path "/a/b/c" []] = ["/"; "a"; "b"; "c"]
         FIXME: explain windows behavior
         *)
 

src/utils/std.ml

@@ -290,6 +290,18 @@ module List = struct
   let sort_uniq ~cmp l = dedup_adjacent ~cmp (sort ~cmp l)
 
   let print f () l = "[ " ^ String.concat "; " (List.map (f ()) l) ^ " ]"
+
+  let max_elt list ~cmp =
+    fold_left list ~init:None ~f:(fun acc elt ->
+        match acc with
+        | None -> Some elt
+        | Some max -> if cmp max elt < 0 then Some elt else acc)
+
+  let min_elt list ~cmp =
+    fold_left list ~init:None ~f:(fun acc elt ->
+        match acc with
+        | None -> Some elt
+        | Some min -> if cmp min elt > 0 then Some elt else acc)
 end
 
 module Option = struct

tests/test-dirs/locate/distinguish-files.t/bin/dune

@@ -0,0 +1,3 @@
+(executable
+ (name main)
+ (libraries lib_a lib_b))

tests/test-dirs/locate/distinguish-files.t/bin/main.ml

@@ -0,0 +1,5 @@
+let _ = Lib_a.Same.foo
+let _ = Lib_b.Same.foo
+
+let _ = Lib_a.Different.foo
+let _ = Lib_b.Different.foo

tests/test-dirs/locate/distinguish-files.t/dune-project

@@ -0,0 +1 @@
+(lang dune 2.0)

tests/test-dirs/locate/distinguish-files.t/lib_a/different.ml

@@ -0,0 +1,2 @@
+(* AAAAA *)
+let foo = 10

tests/test-dirs/locate/distinguish-files.t/lib_a/dune

@@ -0,0 +1,2 @@
+(library
+ (name lib_a))

tests/test-dirs/locate/distinguish-files.t/lib_a/same.ml

@@ -0,0 +1 @@
+let foo = 10