work harder at matching changed files when a workspace is involved

Summary:
Detect when changed files paths are trying to escape the project root
and try to guess their relative project root (which has to be a parent
of the current one).

This is perhaps a bit too hacky but it works for the case we need it to.

Reviewed By: martintrojer

Differential Revision: D24425427

fbshipit-source-id: 018651740

infer/src/base/SourceFile.ml

@@ -191,7 +191,8 @@ let create ?(warn_on_error = true) path =
     | None ->
         RelativeProjectRoot path
     | Some workspace_rel_root ->
-        RelativeProjectRootAndWorkspace {workspace_rel_root; rel_path= path}
+        let rel_path, new_root = Utils.normalize_path_from ~root:workspace_rel_root path in
+        RelativeProjectRootAndWorkspace {workspace_rel_root= new_root; rel_path}
   else from_abs_path ~warn_on_error path
 
 

infer/src/base/Utils.ml

@@ -90,25 +90,55 @@ let create_outfile fname =
 (** close an outfile *)
 let close_outf outf = Out_channel.close outf.out_c
 
-(** Convert a filename to an absolute one if it is relative, and normalize "." and ".." *)
-let filename_to_absolute ~root fname =
-  let add_entry rev_done entry =
-    match (entry, rev_done) with
-    | ".", [] ->
-        entry :: rev_done (* id on . *)
-    | ".", _ ->
-        rev_done (* path/. --> path *)
-    | "..", ("." | "..") :: _ ->
-        entry :: rev_done (* id on {.,..}/.. *)
-    | "..", ["/"] ->
-        rev_done (* /.. -> / *)
-    | "..", _ :: rev_done_parent ->
-        rev_done_parent (* path/dir/.. --> path *)
+let normalize_path_from ~root fname =
+  let add_entry (rev_done, rev_root) entry =
+    match (entry, rev_done, rev_root) with
+    | ".", _, _ ->
+        (* path/. --> path *)
+        (rev_done, rev_root)
+    | "..", [], ["/"] | "..", ["/"], _ ->
+        (* /.. -> / *)
+        (rev_done, rev_root)
+    | "..", [], ("." | "..") :: _ | "..", ("." | "..") :: _, _ ->
+        (* id on {.,..}/.. *)
+        (entry :: rev_done, rev_root)
+    | "..", [], _ :: rev_root_parent ->
+        (* eat from the root part if it's not / *)
+        ([], rev_root_parent)
+    | "..", _ :: rev_done_parent, _ ->
+        (* path/dir/.. --> path *)
+        (rev_done_parent, rev_root)
     | _ ->
-        entry :: rev_done
+        (entry :: rev_done, rev_root)
+  in
+  let rev_root =
+    (* Remove the leading "." inserted by [Filename.parts] on relative paths. We don't need to do
+       that for [Filename.parts fname] because the "." will go away during normalization in
+       [add_entry]. *)
+    let root_without_leading_dot =
+      match Filename.parts root with "." :: (_ :: _ as rest) -> rest | parts -> parts
+    in
+    List.rev root_without_leading_dot
+  in
+  let rev_result, rev_root = Filename.parts fname |> List.fold ~init:([], rev_root) ~f:add_entry in
+  (* don't use [Filename.of_parts] because it doesn't like empty lists and produces relative paths
+     "./like/this" instead of "like/this" *)
+  let filename_of_rev_parts = function
+    | [] ->
+        "."
+    | _ :: _ as rev_parts ->
+        let parts = List.rev rev_parts in
+        if String.equal (List.hd_exn parts) "/" then
+          "/" ^ String.concat ~sep:Filename.dir_sep (List.tl_exn parts)
+        else String.concat ~sep:Filename.dir_sep parts
   in
+  (filename_of_rev_parts rev_result, filename_of_rev_parts rev_root)
+
+
+(** Convert a filename to an absolute one if it is relative, and normalize "." and ".." *)
+let filename_to_absolute ~root fname =
   let abs_fname = if Filename.is_absolute fname then fname else root ^/ fname in
-  Filename.of_parts (List.rev (List.fold ~f:add_entry ~init:[] (Filename.parts abs_fname)))
+  normalize_path_from ~root:"/" abs_fname |> fst
 
 
 (** Convert an absolute filename to one relative to the given directory. *)

infer/src/base/Utils.mli

@@ -20,6 +20,12 @@ val string_crc_hex32 : string -> string
 val read_file : string -> (string list, string) Result.t
 (** read a source file and return a list of lines *)
 
+val normalize_path_from : root:string -> string -> string * string
+(** [normalize_path_from ~root path] removes ".." and "." parts of [root/path] when possible and
+    returns the new [root] and [path], eg if [root = "r"] and [path = "a/../../../foo/./bar"] then
+    the result is [("../foo/bar", ".")] (in particular "r/a/../../../foo/./bar" and "./../foo/bar"
+    represent the same file) *)
+
 val filename_to_absolute : root:string -> string -> string
 (** Convert a filename to an absolute one if it is relative, and normalize "." and ".." *)