infer_clone/infer/src/base/SourceFile.ml

(*
 * Copyright (c) 2016 - present Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD style license found in the
 * LICENSE file in the root directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *)

open! IStd
open! PVariant

let count_newlines (path: string): int =
  let f file = In_channel.fold_lines file ~init:0 ~f:(fun i _ -> i + 1) in
  In_channel.with_file path ~f

type t =
  | Absolute of string
  | RelativeProjectRoot of string (* relative to project root *)
  | RelativeInferModel of string (* relative to infer models *)
[@@deriving compare]

let equal = [%compare.equal : t]

module OrderedSourceFile =
struct
  (* Don't use nonrec due to https://github.com/janestreet/ppx_compare/issues/2 *)
  type _t = t [@@deriving compare]
  type t = _t [@@deriving compare]
end

module Map = Caml.Map.Make (OrderedSourceFile)

module Set = Caml.Set.Make (OrderedSourceFile)

let from_abs_path fname =
  if Filename.is_relative fname then
    (failwithf
       "ERROR: Path %s is relative, when absolute path was expected .@."
       fname);
  (* try to get realpath of source file. Use original if it fails *)
  let fname_real = try Utils.realpath fname with Unix.Unix_error _ -> fname in
  let project_root_real = Utils.realpath Config.project_root in
  let models_dir_real = Config.models_src_dir in
  match Utils.filename_to_relative ~root:project_root_real fname_real with
  | Some path -> RelativeProjectRoot path
  | None -> (
      match Utils.filename_to_relative ~root:models_dir_real fname_real with
      | Some path -> RelativeInferModel path
      | None -> Absolute fname_real (* fname_real is absolute already *)
    )

let curr_encoding = `Enc_crc

let to_string fname =
  match fname with
  | RelativeInferModel path -> "INFER_MODEL/" ^ path
  | RelativeProjectRoot path
  | Absolute path -> path

let pp fmt fname =
  Format.fprintf fmt "%s" (to_string fname)

(* Checking if the path exists may be needed only in some cases, hence the flag check_exists *)
let to_abs_path fname =
  match fname with
  | RelativeProjectRoot path -> Filename.concat Config.project_root path
  | RelativeInferModel path -> Filename.concat Config.models_src_dir path
  | Absolute path -> path

let line_count source_file =
  let abs_path = to_abs_path source_file in
  count_newlines abs_path

let to_rel_path fname =
  match fname with
  | RelativeProjectRoot path -> path
  | _ -> to_abs_path fname

let cutoff_length = 100
let crc_token = '.'

let append_crc_cutoff ?(key="") name =
  let name_up_to_cutoff =
    if String.length name <= cutoff_length
    then name
    else String.sub name ~pos:0 ~len:cutoff_length in
  let crc_str =
    let name_for_crc = name ^ key in
    Utils.string_crc_hex32 name_for_crc in
  name_up_to_cutoff ^ Char.to_string crc_token ^ crc_str

let strip_crc str =
  (* Strip 32 characters of digest, plus 1 character of crc_token *)
  String.sub ~pos:0 ~len:(String.length str - 33) str

(** string encoding of a source file (including path) as a single filename *)
let encoding source_file =
  let prefix = match source_file with
    | RelativeProjectRoot _ -> "P"
    | RelativeInferModel _ -> "MOD"
    | Absolute _ -> "ABS" in
  let source_file_s = to_string source_file in
  match curr_encoding with
  | `Enc_base ->
      Filename.basename source_file_s
  | `Enc_path_with_underscores ->
      prefix ^ Escape.escape_path source_file_s
  | `Enc_crc ->
      let base = Filename.basename source_file_s in
      let dir = prefix ^ Filename.dirname source_file_s in
      append_crc_cutoff ~key:dir base

let empty = Absolute ""

let is_infer_model source_file = match source_file with
  | RelativeProjectRoot _ | Absolute _ -> false
  | RelativeInferModel _ -> true

(** Returns true if the file is a C++ model *)
let is_cpp_model file =
  match file with
  | RelativeInferModel path ->
      String.is_prefix ~prefix:Config.relative_cpp_models_dir path
  | _ -> false

let is_under_project_root = function
  | RelativeProjectRoot _ -> true
  | Absolute _ | RelativeInferModel _ -> false

let exists_cache = String.Table.create ~size:256 ()

let path_exists abs_path =
  try String.Table.find_exn exists_cache abs_path
  with Not_found ->
    let result = Sys.file_exists abs_path = `Yes in
    String.Table.set exists_cache ~key:abs_path ~data:result;
    result

let of_header header_file =
  let abs_path = to_abs_path header_file in
  let source_exts = ["c"; "cc"; "cpp"; "cxx"; "m"; "mm"] in
  let header_exts = ["h"; "hh"; "hpp"; "hxx"] in
  let file_no_ext, ext_opt = Filename.split_extension abs_path in
  let file_opt = match ext_opt with
    | Some ext when List.mem ~equal:String.equal header_exts ext -> (
        let possible_files = List.map ~f:(fun ext -> file_no_ext ^ "." ^ ext) source_exts in
        List.find ~f:path_exists possible_files
      )
    | _ -> None in
  Option.map ~f:from_abs_path file_opt

let changed_files_set =
  let create_source_file path =
    if Filename.is_relative path then
      (* sources in changed-files-index may be specified relative to project root *)
      RelativeProjectRoot path
    else
      from_abs_path path in
  Option.bind Config.changed_files_index Utils.read_file |>
  Option.map ~f:(
    List.fold
      ~f:(fun changed_files line ->
          let source_file = create_source_file line in
          let changed_files' = Set.add source_file changed_files in
          (* Add source corresponding to changed header if it exists *)
          match of_header source_file with
          | Some src -> Set.add src changed_files'
          | None -> changed_files'
        )
      ~init:Set.empty
  )

module UNSAFE = struct
  let from_string str =
    if Filename.is_relative str then
      RelativeProjectRoot str
    else
      Absolute str
end