Source file load_path.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*                   Jeremie Dimino, Jane Street Europe                   *)
(*                                                                        *)
(*   Copyright 2018 Jane Street Group LLC                                 *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Local_store

exception Parse_error of string

(** Splits input line into tokens, with spaces acting as separators.
    Leading/trailing whitespace is removed to avoid empty tokens. Backslashing
    works inside tokens, namely '\n', '\r', ' ' and '\' itself should be
    escaped with '\'. *)
let split_and_unescape ~buffer line =
  let len = String.length line in
  let[@inline] end_current_token current_token tokens =
    let token = Buffer.contents current_token in
    Buffer.clear current_token;
    if String.equal token "" then tokens else token :: tokens
  in
  let rec loop i current_token tokens =
    if i >= len
    then (List.rev (end_current_token current_token tokens))
    else (
      match String.unsafe_get line i with
      | '\\' when i + 1 < len ->
        (match String.unsafe_get line (i + 1) with
          | '\\' ->
            Buffer.add_char current_token '\\';
            loop (i + 2) current_token tokens
          | ' ' ->
            Buffer.add_char current_token ' ';
            loop (i + 2) current_token tokens
          | 'n' ->
            Buffer.add_char current_token '\n';
            loop (i + 2) current_token tokens
          | 'r' ->
            Buffer.add_char current_token '\r';
            loop (i + 2) current_token tokens
          | c -> raise (
            Parse_error (Printf.sprintf "Invalid escape sequence: \\%c" c)))
      | '\\' -> raise (Parse_error "Trailing backslash")
      | ' ' ->
        let tokens = end_current_token current_token tokens in
        loop (i + 1) current_token tokens
      | c ->
        Buffer.add_char current_token c;
        loop (i + 1) current_token tokens)
  in
  loop 0 buffer []
;;

module Dune_manifests_reader : sig
  (* Internal ticket 5767 *)
  [@@@warning "-32"]
  module Path : sig
    module For_testing : sig
      val root_override : string option ref
    end

    module Load_root_relative : sig
      type t

      val of_string : string -> t
    end

    module Cwd_relative : sig
      type t

      val to_string : t -> string
    end
  end

  type t

  val create : unit -> t

  val iter_manifest
    :  t
    -> f:(filename:string -> location:Path.Cwd_relative.t ->
          cmx_guaranteed:bool -> unit)
    -> manifest_path:Path.Load_root_relative.t
    -> unit
end = struct
  module Path : sig
    module For_testing : sig
      val root_override : string option ref
    end

    module Cwd_relative : sig
      type t

      val to_string : t -> string
    end

    module Load_root_relative : sig
      type t

      val of_string : string -> t
      val to_cwd_relative : t -> Cwd_relative.t

      module Hash_set : sig
        type elem := t
        type t

        val create : unit -> t
        val mem : t -> elem -> bool
        val add : t -> elem -> unit
      end
    end
  end = struct
    module For_testing = struct
      let root_override = ref None
    end

    let root =
      let from_env_var = lazy (
        let var_name = "MANIFEST_FILES_ROOT" in
        match Sys.getenv_opt var_name with
        | None -> failwith (var_name ^ " not set")
        | Some path -> path)
      in
      fun () ->
        match !For_testing.root_override with
        | None -> Lazy.force from_env_var
        | Some root -> root

    module Cwd_relative = struct
      type t = string

      let to_string path = path
    end

    module Load_root_relative = struct
      type t = string

      let of_string path = path

      let to_cwd_relative path =
        Filename.concat (root ()) path
      ;;

      module Hash_set = struct
        type t = unit Misc.Stdlib.String.Tbl.t

        let create () = Misc.Stdlib.String.Tbl.create 42
        let mem t path =
          Misc.Stdlib.String.Tbl.mem t path
        let add t path =
          Misc.Stdlib.String.Tbl.add t path ()
      end
    end
  end

  type t = { visited : Path.Load_root_relative.Hash_set.t }

  let create () = { visited = Path.Load_root_relative.Hash_set.create () }

  let visit { visited } ~f path =
    if Path.Load_root_relative.Hash_set.mem visited path
    then ()
    else (
      Path.Load_root_relative.Hash_set.add visited path;
      f (Path.Load_root_relative.to_cwd_relative path))
  ;;

  let iter_lines ~f path =
    In_channel.with_open_text
      (Path.Cwd_relative.to_string path)
      (fun ic ->
        let rec loop () =
          try
            let line = String.trim (input_line ic) in
            f line;
            loop ()
          with
          | End_of_file -> ()
        in
        loop ())
  ;;

  module Entry = struct
    type t =
      | File of
          { filename : string
          ; location : Path.Load_root_relative.t
          ; cmx_guaranteed : bool
          }
      | Manifest of Path.Load_root_relative.t
  end

  let parse_line ~buffer line =
    match split_and_unescape ~buffer line with
    | [ "file"; filename; location ] ->
      let location = Path.Load_root_relative.of_string location in
      Some (Entry.File { filename; location; cmx_guaranteed = false })
    | [ "file_x"; filename; location ] ->
      let location = Path.Load_root_relative.of_string location in
      Some (Entry.File { filename; location; cmx_guaranteed = true })
    | [ "manifest"; _; location ] ->
      (* [filename] is included in "manifest" entry only for human
         readability, so we discard them here. *)
      let location = Path.Load_root_relative.of_string location in
      Some (Entry.Manifest location)
    | [] -> None
    | _ -> raise (Parse_error ("Cannot parse manifest file line: " ^ line))
  ;;

  let rec iter_manifest t ~f ~manifest_path =
    let buffer = Buffer.create 16 in
    visit t manifest_path ~f:(fun manifest_path ->
      iter_lines manifest_path ~f:(fun line ->
        match parse_line ~buffer line with
        | None -> ()
        | Some (Entry.File { filename; location; cmx_guaranteed }) ->
          visit t location ~f:(fun location ->
            f ~filename ~location ~cmx_guaranteed)
        | Some (Manifest manifest_path) -> iter_manifest t ~f ~manifest_path))
  ;;
end

module For_testing = struct
  exception Parse_error = Parse_error

  let split_and_unescape = split_and_unescape

  let set_manifest_files_root path =
    Dune_manifests_reader.Path.For_testing.root_override := path
end

type visibility = Visible of { cmx_guaranteed : bool } | Hidden

let visibility_eq a b =
  match a, b with
  | ( Visible { cmx_guaranteed = cmx_guaranteed_a },
      Visible { cmx_guaranteed = cmx_guaranteed_b } ) ->
    Bool.equal cmx_guaranteed_a cmx_guaranteed_b
  | Hidden, Hidden -> true
  | Visible _, Hidden | Hidden, Visible _ -> false

module Dir : sig
  type entry = {
    basename : string;
    path : string
  }

  type t

  val path : t -> string
  val files : t -> entry list
  val basenames : t -> string list
  val visibility : t -> visibility

  val create : visibility -> string -> t

  val find : t -> string -> string option
  val find_normalized : t -> string -> string option

  val check : visibility -> t -> bool
end = struct
  type entry = {
    basename : string;
    path : string
  }

  type t = {
    path : string;
    files : entry list;
    visibility : visibility;
  }

  let path t = t.path
  let files t = t.files
  let basenames t = List.map (fun { basename; _ } -> basename) t.files
  let visibility t = t.visibility

  let find t fn =
    List.find_map (fun { basename; path } ->
      if String.equal basename fn then
        Some path
      else
        None) t.files

  let find_normalized t fn =
    let fn = Misc.normalized_unit_filename fn in
    let search { basename; path } =
      if Misc.normalized_unit_filename basename = fn then
        Some path
      else
        None
    in
    List.find_map search t.files

  let check visibility t =
    visibility_eq visibility t.visibility && Directory_content_cache.check t.path

  let create visibility path =
    let files = Array.to_list (Directory_content_cache.read path)
      |> List.map (
        fun basename -> { basename; path = Filename.concat path basename }) in
    { path; files; visibility }
end

(** Stores cached paths to files *)
module Path_cache : sig
  (* Clear cache *)
  val reset : unit -> unit

  (* Same as [add] below, but will replace existing entries.

     [prepend_add] is faster than [add] and intended for use in [init] and [remove_dir]:
     since we are starting from an empty cache, we can avoid checking whether a unit name
     already exists in the cache simply by adding entries in reverse order. *)
  val prepend_add : Dir.t -> unit

  (* Add path to cache. If path with same basename is already in cache, skip adding. *)
  val add : Dir.t -> unit

  (* Like [prepent_add], but only adds a single file to the cache. *)
  val prepend_add_single : hidden:bool -> cmx_guaranteed:bool ->
    string -> string -> unit

  (* Search for a basename in cache. Ignore case if [uncap] is true *)
  val find : uncap:bool -> string -> string * visibility
end = struct
  module STbl = Misc.Stdlib.String.Tbl

  (* Mappings from basenames to full filenames *)
  type visible_registry = Clflags.visible_include STbl.t
  type hidden_registry = string STbl.t

  let visible_files : visible_registry ref = s_table STbl.create 42
  let visible_files_uncap : visible_registry ref = s_table STbl.create 42

  let hidden_files : hidden_registry ref = s_table STbl.create 42
  let hidden_files_uncap : hidden_registry ref = s_table STbl.create 42

  let reset () =
    STbl.clear !hidden_files;
    STbl.clear !hidden_files_uncap;
    STbl.clear !visible_files;
    STbl.clear !visible_files_uncap

  let prepend_add_single ~hidden ~cmx_guaranteed base fn =
    if hidden then begin
      STbl.replace !hidden_files base fn;
      STbl.replace !hidden_files_uncap (Misc.normalized_unit_filename base) fn
    end else begin
      STbl.replace !visible_files base { Clflags.path = fn; cmx_guaranteed };
      STbl.replace !visible_files_uncap (String.uncapitalize_ascii base)
        { Clflags.path = fn; cmx_guaranteed }
    end

  let prepend_add dir =
    let hidden, cmx_guaranteed =
      match Dir.visibility dir with
      | Hidden -> true, false
      | Visible { cmx_guaranteed } -> false, cmx_guaranteed
    in
    List.iter
      (fun ({ basename; path } : Dir.entry) ->
        prepend_add_single ~hidden ~cmx_guaranteed basename path)
      (Dir.files dir)

  let add dir =
    let update base fn visible_files hidden_files =
      match Dir.visibility dir with
      | Hidden ->
        if not (STbl.mem !hidden_files base) then
          STbl.replace !hidden_files base fn
      | Visible { cmx_guaranteed } ->
        if not (STbl.mem !visible_files base) then
          STbl.replace !visible_files base { Clflags.path = fn; cmx_guaranteed }
    in
    List.iter
      (fun ({ basename = base; path = fn } : Dir.entry) ->
         update base fn visible_files hidden_files;
         let ubase = Misc.normalized_unit_filename base in
         update ubase fn visible_files_uncap hidden_files_uncap)
      (Dir.files dir)

  let find fn visible_files hidden_files =
    try
      let { Clflags.path; cmx_guaranteed } = STbl.find !visible_files fn in
      (path, Visible { cmx_guaranteed })
    with
    | Not_found -> (STbl.find !hidden_files fn, Hidden)

  let find ~uncap fn =
    if uncap then
      find (String.uncapitalize_ascii fn) visible_files_uncap hidden_files_uncap
    else
      find fn visible_files hidden_files
end

type auto_include_callback =
  (Dir.t -> string -> string option) -> string -> string

let visible_dirs = s_ref []
let visible_basenames = s_ref []
let hidden_dirs = s_ref []
let hidden_basenames = s_ref []
let no_auto_include _ _ = raise Not_found
let auto_include_callback = ref no_auto_include


let reset () =
  assert (not Config.merlin || Local_store.is_bound ());
  Path_cache.reset ();
  hidden_dirs := [];
  hidden_basenames := [];
  visible_dirs := [];
  visible_basenames := [];
  auto_include_callback := no_auto_include
;;

type dirs_and_files =
  { dirs : Dir.t list
  ; basenames : string list
  }

let get_visible () =
  { dirs = List.rev !visible_dirs; basenames = !visible_basenames }

let get_path_list () =
  Misc.rev_map_end Dir.path !visible_dirs (List.rev_map Dir.path !hidden_dirs)

type paths =
  { visible : Clflags.visible_include list;
    hidden : string list }

let get_paths () =
  let visible_dir_to_include dir : Clflags.visible_include =
    let cmx_guaranteed =
      match Dir.visibility dir with
      | Hidden -> Misc.fatal_error "Load_path.get_paths"
      | Visible { cmx_guaranteed } -> cmx_guaranteed
    in
    { path = Dir.path dir; cmx_guaranteed }
  in
  { visible = List.rev_map visible_dir_to_include !visible_dirs;
    hidden = List.rev_map Dir.path !hidden_dirs }

(* CR-someday: init_manifests is not currently relevant because Merlin can safely ignore
   the -I-manifest and -H-manifest flags due to current build rules. But at some point,
   this will change, and manifest files will need to be handled properly. This will also
   likely involve updating .merlin files to be able to accept directives equivalent to
   -I-manifest and -H-manifest. Internal ticket 5767 *)
let () = ignore Path_cache.prepend_add_single;;
(*
let init_manifests () =
  let manifests_reader = Dune_manifests_reader.create () in
  let load_manifest ~hidden ~basenames manifest_path =
    let manifest_path =
      Dune_manifests_reader.Path.Load_root_relative.of_string manifest_path in
    Dune_manifests_reader.iter_manifest
      manifests_reader
      ~manifest_path
      ~f:(fun ~filename ~location ~cmx_guaranteed ->
          let basename = Filename.basename filename in
          basenames := basename :: !basenames;
          Path_cache.prepend_add_single
            ~hidden
            ~cmx_guaranteed
            basename
            (Dune_manifests_reader.Path.Cwd_relative.to_string location))
  in
  List.iter
    (load_manifest ~hidden:false ~basenames:visible_basenames)
    !Clflags.include_manifests;
  List.iter
    (load_manifest ~hidden:true ~basenames:hidden_basenames)
    !Clflags.hidden_include_manifests
*)

let init ~auto_include ~visible ~hidden =
  assert (not Config.merlin || Local_store.is_bound ());
  let get_new_dirs ~get_visibility ~get_path new_entries old_dirs =
    let create_dir entry = Dir.create (get_visibility entry) (get_path entry) in
    let rec create_dirs ~acc = function
      | [] -> Some acc
      | new_entry :: new_rest -> create_dirs ~acc:(create_dir new_entry :: acc) new_rest
    in
    let rec process_entries ~acc new_entries old_dirs =
      match new_entries, old_dirs with
      | [], [] -> None
      | new_entry :: new_rest, [] -> create_dirs ~acc (new_entry :: new_rest)
      | [], _ :: _ -> Some acc
      | new_entry :: new_rest, old_dir :: old_rest ->
        let visibility = get_visibility new_entry in
        if String.equal (get_path new_entry) (Dir.path old_dir)
           && Dir.check visibility old_dir
        then process_entries ~acc:(old_dir :: acc) new_rest old_rest
        else create_dirs ~acc (new_entry :: new_rest)
    in
    process_entries ~acc:[] new_entries old_dirs
  in
  let new_visible =
    get_new_dirs visible (List.rev !visible_dirs)
      ~get_visibility:(fun ({ path = _; cmx_guaranteed } : Clflags.visible_include) ->
        Visible { cmx_guaranteed })
      ~get_path:(fun ({ path; cmx_guaranteed = _ } : Clflags.visible_include) -> path)
  in
  let new_hidden =
    get_new_dirs hidden (List.rev !hidden_dirs)
      ~get_visibility:(Fun.const Hidden) ~get_path:Fun.id
  in
  let update =
    match new_visible, new_hidden with
    | None, None -> None
    | Some v, None -> Some (v, !hidden_dirs)
    | None, Some h -> Some (!visible_dirs, h)
    | Some v, Some h -> Some (v, h)
  in
  match update with
  | None -> ()
  | Some (new_visible, new_hidden) ->
    reset ();
    visible_dirs := new_visible;
    hidden_dirs := new_hidden;
    List.iter Path_cache.prepend_add new_hidden;
    List.iter Path_cache.prepend_add new_visible;
    (*= init_manifests (); *)
    auto_include_callback := auto_include

let remove_dir dir =
  assert (not Config.merlin || Local_store.is_bound ());
  let visible = List.filter (fun d -> Dir.path d <> dir) !visible_dirs in
  let hidden = List.filter (fun d -> Dir.path d <> dir) !hidden_dirs in
  if    List.compare_lengths visible !visible_dirs <> 0
     || List.compare_lengths hidden !hidden_dirs <> 0 then begin
    reset ();
    visible_dirs := visible;
    hidden_dirs := hidden;
    List.iter Path_cache.prepend_add hidden;
    List.iter Path_cache.prepend_add visible
  end

(* General purpose version of function to add a new entry to load path: We only
   add a basename to the cache if it is not already present, in order to enforce
   left-to-right precedence. *)
let add (dir : Dir.t) =
  assert (not Config.merlin || Local_store.is_bound ());
  Path_cache.add dir;
  match Dir.visibility dir with
  | Hidden -> hidden_dirs := dir :: !hidden_dirs
  | Visible _ -> visible_dirs := dir :: !visible_dirs

let append_dir = add

let add_dir visibility dir = add (Dir.create visibility dir)

(* Add the directory at the start of load path - so basenames are
   unconditionally added. *)
let prepend_dir (dir : Dir.t) =
  assert (not Config.merlin || Local_store.is_bound ());
  Path_cache.prepend_add dir;
  match Dir.visibility dir with
  | Hidden -> hidden_dirs := !hidden_dirs @ [dir]
  | Visible _ -> visible_dirs := !visible_dirs @ [dir]

let is_basename fn = Filename.basename fn = fn

(* let auto_include_libs libs alert find_in_dir fn =
  let scan (lib, lazy dir) =
    let file = find_in_dir dir fn in
    let alert_and_add_dir _ =
      alert lib;
      append_dir dir
    in
    Option.iter alert_and_add_dir file;
    file
  in
  match List.find_map scan libs with
  | Some base -> base
  | None -> raise Not_found *)

(* let auto_include_otherlibs =
  (* Ensure directories are only ever scanned once *)
  let expand = Misc.expand_directory Config.standard_library in
  let otherlibs =
    let read_lib lib =
      lazy (Dir.create (Visible { cmx_guaranteed = true }) (expand ("+" ^ lib)))
    in
    List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in
  auto_include_libs otherlibs *)

let find fn =
  assert (not Config.merlin || Local_store.is_bound ());
  try
    if is_basename fn && not !Sys.interactive then
      fst (Path_cache.find ~uncap:false fn)
    else
      Misc.find_in_path (get_path_list ()) fn
  with Not_found ->
    !auto_include_callback Dir.find fn

let search_dirs dirs fn =
  List.find_map
    (fun dir ->
      Option.map
        (fun path -> (path, Dir.visibility dir))
        (Dir.find_normalized dir fn))
    dirs

let find_normalized_with_visibility fn =
  assert (not Config.merlin || Local_store.is_bound ());
  try
    if is_basename fn && not !Sys.interactive then
      Path_cache.find ~uncap:true fn
    else
      match search_dirs (List.rev !visible_dirs) fn with
      | Some result -> result
      | None ->
        match search_dirs (List.rev !hidden_dirs) fn with
        | Some result -> result
        | None -> raise Not_found
  with Not_found ->
    let fn_uncap = String.uncapitalize_ascii fn in
    (!auto_include_callback Dir.find_normalized fn_uncap,
     Visible { cmx_guaranteed = false })

let find_normalized fn = fst (find_normalized_with_visibility fn)

(* Merlin: expose standard reset function *)
let reset () = reset ()