open! Dune_engine
open! Import
open Result.O

(* Errors *)

(* The current module never raises. It returns all errors as [Result.Error
   (User_error.E _)] values instead. Errors are later inserted into [Build.t]
   values so that they are only raised during the actual build rather than while
   generating the rules. *)

module Error = struct
  (* This sub-module construct the error values generated by functions in this
     module.

     When a location is not available, for instance because the error is
     attached to transitive dependency of a library written by the user in a
     [dune] file, a dependency path should be used to explain how dune came to
     consider the library that triggered the error. *)

  let make ?loc ?hints paragraphs =
    Error (User_error.E (User_error.make ?loc ?hints paragraphs))

  let pp_lib info =
    let name = Lib_info.name info in
    let src_dir = Lib_info.src_dir info in
    Pp.textf "%S in %s" (Lib_name.to_string name)
      (Path.to_string_maybe_quoted src_dir)

  let pp_lib_and_dep_path (info, dp) =
    let info = Pp.box (pp_lib info) in
    match dp with
    | [] -> info
    | _ -> Pp.vbox (Pp.concat ~sep:Pp.cut [ info; Dep_path.Entries.pp dp ])

  let external_lib_deps_hint () =
    match !Clflags.external_lib_deps_hint with
    | [] -> []
    | l ->
      [ l
        |> List.map ~f:String.quote_for_shell
        |> String.concat ~sep:" " |> Utils.pp_command_hint
      ]

  let not_found ~loc ~name =
    make ~loc
      [ Pp.textf "Library %S not found." (Lib_name.to_string name) ]
      ~hints:(external_lib_deps_hint ())

  let hidden ~loc ~name ~dir ~reason =
    make ~loc
      [ Pp.textf "Library %S in %s is hidden (%s)." (Lib_name.to_string name)
          (Path.to_string_maybe_quoted dir)
          reason
      ]
      ~hints:(external_lib_deps_hint ())

  (* diml: it is not very clear what a "default implementation cycle" is *)
  let default_implementation_cycle cycle =
    make
      [ Pp.text
          "Default implementation cycle detected between the following \
           libraries:"
      ; Pp.chain cycle ~f:(fun info ->
            let name = Lib_info.name info in
            Pp.textf "%S" (Lib_name.to_string name))
      ]

  let double_implementation impl1 impl2 ~vlib =
    make
      [ Pp.concat
          [ Pp.text "Conflicting implementations for virtual library "
          ; pp_lib vlib
          ; Pp.char ':'
          ]
      ; Pp.enumerate [ impl1; impl2 ] ~f:pp_lib_and_dep_path
      ; Pp.text "This cannot work."
      ]

  let no_implementation (info, dp) =
    make
      ( Pp.concat
          [ Pp.text "No implementation found for virtual library "
          ; pp_lib info
          ; Pp.char '.'
          ]
      ::
      ( match dp with
      | [] -> []
      | _ -> [ Dep_path.Entries.pp dp ] ) )

  let overlap ~in_workspace ~installed =
    make
      [ Pp.text "Conflict between the following libraries:"
      ; Pp.enumerate [ (in_workspace, []); installed ] ~f:pp_lib_and_dep_path
      ]

  let no_solution_found_for_select ~loc =
    make ~loc [ Pp.text "No solution found for this select form." ]

  let not_an_implementation_of ~vlib ~impl =
    make
      [ Pp.textf "%S is not an implementation of %S."
          (Lib_name.to_string (Lib_info.name impl))
          (Lib_name.to_string (Lib_info.name vlib))
      ]

  let dependency_cycle cycle =
    make
      [ Pp.text "Dependency cycle detected between the following libraries:"
      ; Pp.chain cycle ~f:(fun (dir, name) ->
            Pp.textf "%S in %s" (Lib_name.to_string name)
              (Path.to_string_maybe_quoted dir))
      ]

  let private_deps_not_allowed ~loc private_dep =
    let name = Lib_info.name private_dep in
    make ~loc
      [ Pp.textf
          "Library %S is private, it cannot be a dependency of a public \
           library. You need to give %S a public name."
          (Lib_name.to_string name) (Lib_name.to_string name)
      ]

  let only_ppx_deps_allowed ~loc dep =
    let name = Lib_info.name dep in
    make ~loc
      [ Pp.textf
          "Ppx dependency on a non-ppx library %S. If %S is in fact a ppx \
           rewriter library, it should have (kind ppx_rewriter) in its dune \
           file."
          (Lib_name.to_string name) (Lib_name.to_string name)
      ]

  let not_virtual_lib ~loc ~impl ~not_vlib =
    let impl = Lib_info.name impl in
    let not_vlib = Lib_info.name not_vlib in
    make ~loc
      [ Pp.textf "Library %S is not virtual. It cannot be implemented by %S."
          (Lib_name.to_string not_vlib)
          (Lib_name.to_string impl)
      ]
end

(* Types *)

module Resolved_select = struct
  type t =
    { src_fn : string Or_exn.t
    ; dst_fn : string
    }
end

type sub_system = ..

module Sub_system0 = struct
  module type S = sig
    module Info : Sub_system_info.S

    type t

    type sub_system += T of t

    val public_info : (t -> Info.t Or_exn.t) option
  end

  type 'a s = (module S with type t = 'a)

  module Instance = struct
    type t = T : 'a s * 'a -> t
  end
end

module Id : sig
  type t =
    { unique_id : int
    ; path : Path.t
    ; name : Lib_name.t
    }

  val to_dyn : t -> Dyn.t

  val to_dep_path_lib : t -> Dep_path.Entry.Lib.t

  val hash : t -> int

  val compare : t -> t -> Ordering.t

  include Comparator.OPS with type t := t

  val make : path:Path.t -> name:Lib_name.t -> t

  module Set : Set.S with type elt = t

  module Map : Map.S with type key = t

  module Top_closure :
    Top_closure_intf.S with type key := t and type 'a monad := 'a Monad.Id.t
end = struct
  module T = struct
    type t =
      { unique_id : int
      ; path : Path.t
      ; name : Lib_name.t
      }

    let compare t1 t2 = Int.compare t1.unique_id t2.unique_id

    let to_dyn { unique_id = _; path; name } =
      let open Dyn.Encoder in
      record [ ("path", Path.to_dyn path); ("name", Lib_name.to_dyn name) ]
  end

  include T

  let to_dep_path_lib { path; name; unique_id = _ } =
    { Dep_path.Entry.Lib.path; name }

  include (Comparator.Operators (T) : Comparator.OPS with type t := T.t)

  let gen_unique_id =
    let next = ref 0 in
    fun () ->
      let n = !next in
      next := n + 1;
      n

  let hash t = t.unique_id

  let make ~path ~name = { unique_id = gen_unique_id (); path; name }

  include Comparable.Make (T)
  module Top_closure = Top_closure.Make (Set) (Monad.Id)
end

module T = struct
  type t =
    { info : Lib_info.external_
    ; name : Lib_name.t
    ; unique_id : Id.t
    ; re_exports : t list Or_exn.t
    ; (* [requires] is contains all required libraries, including the ones
         mentioned in [re_exports]. *)
      requires : t list Or_exn.t
    ; ppx_runtime_deps : t list Or_exn.t
    ; pps : t list Or_exn.t
    ; resolved_selects : Resolved_select.t list
    ; user_written_deps : Dune_file.Lib_deps.t
    ; implements : t Or_exn.t option
    ; lib_config : Lib_config.t
    ; project : Dune_project.t option
    ; (* these fields cannot be forced until the library is instantiated *)
      default_implementation : t Or_exn.t Lazy.t option
    ; (* This is mutable to avoid this error:

         {[ This kind of expression is not allowed as right-hand side of `let
         rec' }] *)
      mutable sub_systems : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t
    ; modules : Modules.t Lazy.t option
    ; src_dirs : Path.Set.t Lazy.t
    }

  let compare (x : t) (y : t) = Id.compare x.unique_id y.unique_id

  let to_dyn t = Lib_name.to_dyn t.name
end

include T

type lib = t

include (Comparator.Operators (T) : Comparator.OPS with type t := t)

module Hidden = struct
  type 'lib t =
    { lib : 'lib
    ; path : Path.t
    ; reason : string
    }

  let of_lib lib ~reason =
    let path = Lib_info.src_dir lib.info in
    { lib; path; reason }

  let to_dyn to_dyn { lib; path; reason } =
    let open Dyn.Encoder in
    record
      [ ("lib", to_dyn lib)
      ; ("path", Path.to_dyn path)
      ; ("reason", string reason)
      ]

  let error { path; reason; lib = _ } ~name ~loc =
    Error.hidden ~loc ~name ~dir:path ~reason

  let unsatisfied_exist_if pkg =
    let info = Dune_package.Lib.info pkg in
    let path = Lib_info.src_dir info in
    { lib = info; reason = "unsatisfied 'exist_if'"; path }
end

module Status = struct
  type t =
    | Initializing of Id.t (* To detect cycles *)
    | Found of lib
    | Not_found
    | Hidden of lib Hidden.t
    | Invalid of exn

  let to_dyn t =
    let open Dyn.Encoder in
    match t with
    | Invalid e -> constr "Invalid" [ Exn.to_dyn e ]
    | Initializing i -> constr "Initializing" [ Id.to_dyn i ]
    | Not_found -> constr "Not_found" []
    | Hidden { lib = _; path; reason } ->
      constr "Hidden" [ Path.to_dyn path; string reason ]
    | Found t -> constr "Found" [ to_dyn t ]
end

type db =
  { parent : db option
  ; resolve : Lib_name.t -> resolve_result
  ; table : (Lib_name.t, Status.t) Table.t
  ; all : Lib_name.t list Lazy.t
  ; lib_config : Lib_config.t
  ; instrument_with : Lib_name.t list
  ; modules_of_lib : (dir:Path.Build.t -> name:Lib_name.t -> Modules.t) Fdecl.t
  ; projects_by_package : Dune_project.t Package.Name.Map.t
  }

and resolve_result =
  | Not_found
  | Found of Lib_info.external_
  | Hidden of Lib_info.external_ Hidden.t
  | Invalid of exn
  | (* Redirect (None, lib) looks up lib in the same database *)
      Redirect of
      db option * (Loc.t * Lib_name.t)

let lib_config (t : lib) = t.lib_config

let name t = t.name

let info t = t.info

let implements t = t.implements

let unique_id t = t.unique_id

let is_impl t = Option.is_some t.implements

let requires t = t.requires

let obj_dir t = Lib_info.obj_dir t.info

let is_local t =
  let obj_dir = obj_dir t in
  Path.is_managed (Obj_dir.byte_dir obj_dir)

let main_module_name t =
  let main_module_name = Lib_info.main_module_name t.info in
  match main_module_name with
  | This mmn -> Ok mmn
  | From _ -> (
    let+ vlib = Option.value_exn t.implements in
    let main_module_name = Lib_info.main_module_name vlib.info in
    match main_module_name with
    | This x -> x
    | From _ -> assert false )

let entry_module_names t =
  match Lib_info.entry_modules t.info with
  | External d -> d
  | Local ->
    Ok
      ( Option.value_exn t.modules |> Lazy.force |> Modules.entry_modules
      |> List.map ~f:Module.name )

let src_dirs t = Lazy.force t.src_dirs

let wrapped t =
  let wrapped = Lib_info.wrapped t.info in
  match wrapped with
  | None -> Ok None
  | Some (This wrapped) -> Ok (Some wrapped)
  | Some (From _) -> (
    let+ vlib = Option.value_exn t.implements in
    let wrapped = Lib_info.wrapped vlib.info in
    match wrapped with
    | Some (From _) (* can't inherit this value in virtual libs *)
    | None ->
      assert false (* will always be specified in dune package *)
    | Some (This x) -> Some x )

let to_id t : Id.t = t.unique_id

let equal l1 l2 = Id.equal (to_id l1) (to_id l2)

let hash t = Id.hash (to_id t)

include Comparable.Make (T)

module Link_params = struct
  type t =
    { include_dirs : Path.t list
    ; deps : Path.t list
          (* List of files that will be read by the compiler at link time and
             appear directly on the command line *)
    ; hidden_deps : Path.t list
          (* List of files that will be read by the compiler at link time but do
             not appear on the command line *)
    }

  let get (t : lib) (mode : Link_mode.t) =
    let lib_files = Lib_info.foreign_archives t.info
    and dll_files = Lib_info.foreign_dll_files t.info in
    (* OCaml library archives [*.cma] and [*.cmxa] are directly listed in the
       command line. *)
    let deps = Mode.Dict.get (Lib_info.archives t.info) (Link_mode.mode mode) in
    (* Foreign archives [lib*.a] and [dll*.so] and native archives [lib*.a] are
       declared as hidden dependencies, and appropriate [-I] flags are provided
       separately to help the linker locate them. *)
    let hidden_deps =
      match mode with
      | Byte -> dll_files
      | Byte_with_stubs_statically_linked_in -> lib_files
      | Native ->
        let native_archives =
          let modules = Option.map t.modules ~f:Lazy.force in
          Lib_info.eval_native_archives_exn t.info ~modules
        in
        List.rev_append native_archives lib_files
    in
    let include_dirs =
      let files =
        match mode with
        | Byte -> dll_files
        | Byte_with_stubs_statically_linked_in
        | Native ->
          lib_files
      in
      let files =
        match Lib_info.exit_module t.info with
        | None -> files
        | Some _ ->
          (* The exit module is copied next to the archive, so we add the
             archive here so that its directory ends up in [include_dirs]. *)
          files @ deps
      in
      (* TODO: Remove the below unsafe call to [parent_exn] by separating files
         and directories at the type level. Then any file will have a
         well-defined parent directory, possibly ".". *)
      let dirs = List.map files ~f:Path.parent_exn in
      List.sort_uniq dirs ~compare:Path.compare
    in
    let hidden_deps =
      match Lib_info.exit_module t.info with
      | None -> hidden_deps
      | Some m -> (
        let obj_name =
          Path.relative (Lib_info.src_dir t.info) (Module_name.uncapitalize m)
        in
        match mode with
        | Byte
        | Byte_with_stubs_statically_linked_in ->
          Path.extend_basename obj_name ~suffix:(Cm_kind.ext Cmo) :: hidden_deps
        | Native ->
          Path.extend_basename obj_name ~suffix:(Cm_kind.ext Cmx)
          :: Path.extend_basename obj_name ~suffix:t.lib_config.ext_obj
          :: hidden_deps )
    in
    { deps; hidden_deps; include_dirs }
end

let link_deps t mode =
  let x = Link_params.get t mode in
  List.rev_append x.hidden_deps x.deps

module L = struct
  type nonrec t = t list

  let to_iflags dirs =
    Command.Args.S
      ( Path.Set.fold dirs ~init:[] ~f:(fun dir acc ->
            Command.Args.Path dir :: A "-I" :: acc)
      |> List.rev )

  let include_paths ?project ts mode =
    let visible_cmi =
      match project with
      | None -> fun _ -> true
      | Some project -> (
        let check_project lib =
          match lib.project with
          | None -> false
          | Some project' -> Dune_project.equal project project'
        in
        fun lib ->
          match Lib_info.status lib.info with
          | Private (_, Some _)
          | Installed_private ->
            check_project lib
          | _ -> true )
    in
    let dirs =
      List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t ->
          let obj_dir = Lib_info.obj_dir t.info in
          let acc =
            if visible_cmi t then
              let public_cmi_dir = Obj_dir.public_cmi_dir obj_dir in
              Path.Set.add acc public_cmi_dir
            else
              acc
          in
          match mode with
          | Mode.Byte -> acc
          | Native ->
            let native_dir = Obj_dir.native_dir obj_dir in
            Path.Set.add acc native_dir)
    in
    match ts with
    | [] -> dirs
    | x :: _ -> Path.Set.remove dirs x.lib_config.stdlib_dir

  let include_flags ?project ts mode =
    to_iflags (include_paths ?project ts mode)

  let c_include_paths ts =
    let dirs =
      List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t ->
          let src_dir = Lib_info.src_dir t.info in
          Path.Set.add acc src_dir)
    in
    match ts with
    | [] -> dirs
    | x :: _ -> Path.Set.remove dirs x.lib_config.stdlib_dir

  let c_include_flags ts = to_iflags (c_include_paths ts)

  let toplevel_include_paths ts =
    let with_dlls =
      List.filter ts ~f:(fun t ->
          match Lib_info.foreign_dll_files (info t) with
          | [] -> false
          | _ -> true)
    in
    Path.Set.union (include_paths ts Mode.Byte) (c_include_paths with_dlls)

  let compile_and_link_flags ~compile ~link ~mode =
    let params = List.map link ~f:(fun t -> Link_params.get t mode) in
    let dirs =
      let dirs =
        Path.Set.union
          (include_paths compile (Link_mode.mode mode))
          (c_include_paths link)
      in
      List.fold_left params ~init:dirs ~f:(fun acc (p : Link_params.t) ->
          List.fold_left p.include_dirs ~init:acc ~f:Path.Set.add)
    in
    Command.Args.S
      ( to_iflags dirs
      :: List.map params ~f:(fun (p : Link_params.t) ->
             Command.Args.S
               [ Deps p.deps; Hidden_deps (Dep.Set.of_files p.hidden_deps) ]) )

  let jsoo_runtime_files ts =
    List.concat_map ts ~f:(fun t -> Lib_info.jsoo_runtime t.info)

  let remove_dups l =
    let rec loop acc l seen =
      match l with
      | [] -> acc
      | x :: l ->
        if Id.Set.mem seen x.unique_id then
          loop acc l seen
        else
          loop (x :: acc) l (Id.Set.add seen x.unique_id)
    in
    loop [] l Id.Set.empty

  let top_closure l ~key ~deps =
    Id.Top_closure.top_closure l ~key:(fun t -> unique_id (key t)) ~deps
end

module Lib_and_module = struct
  type t =
    | Lib of lib
    | Module of Path.t Obj_dir.t * Module.t

  module L = struct
    type nonrec t = t list

    let link_flags ts ~(lib_config : Lib_config.t) ~mode =
      Command.Args.S
        (List.map ts ~f:(function
          | Lib t ->
            let p = Link_params.get t mode in
            Command.Args.S
              ( Deps p.deps
              :: Hidden_deps (Dep.Set.of_files p.hidden_deps)
              :: List.map p.include_dirs ~f:(fun dir ->
                     Command.Args.S [ A "-I"; Path dir ]) )
          | Module (obj_dir, m) ->
            Command.Args.S
              ( Dep
                  (Obj_dir.Module.cm_file_exn obj_dir m
                     ~kind:(Mode.cm_kind (Link_mode.mode mode)))
              ::
              ( match mode with
              | Native ->
                [ Command.Args.Hidden_deps
                    (Dep.Set.of_files
                       [ Obj_dir.Module.o_file_exn obj_dir m
                           ~ext_obj:lib_config.ext_obj
                       ])
                ]
              | Byte
              | Byte_with_stubs_statically_linked_in ->
                [] ) )))

    let of_libs l = List.map l ~f:(fun x -> Lib x)
  end
end

(* Sub-systems *)

module Sub_system = struct
  type t = sub_system = ..

  module type S = sig
    module Info : Sub_system_info.S

    type t

    type sub_system += T of t

    val instantiate :
         resolve:(Loc.t * Lib_name.t -> lib Or_exn.t)
      -> get:(loc:Loc.t -> lib -> t option)
      -> lib
      -> Info.t
      -> t

    val public_info : (t -> Info.t Or_exn.t) option
  end

  module type S' = sig
    include S

    val for_instance : t Sub_system0.s

    val get : lib -> t option
  end

  (* This mutable table is safe under the assumption that subsystems are
     registered at the top level, which is currently true. *)
  let all = Sub_system_name.Table.create ~default_value:None

  module Register (M : S) = struct
    let get lib =
      Option.map (Sub_system_name.Map.find lib.sub_systems M.Info.name)
        ~f:(fun (lazy (Sub_system0.Instance.T ((module X), t))) ->
          match X.T t with
          | M.T t -> t
          | _ -> assert false)

    let () =
      let module M = struct
        include M

        let for_instance = (module M : Sub_system0.S with type t = t)

        let get = get
      end in
      Sub_system_name.Table.set all ~key:M.Info.name
        ~data:(Some (module M : S'))
  end

  let instantiate name info lib ~resolve =
    let impl = Option.value_exn (Sub_system_name.Table.get all name) in
    let (module M : S') = impl in
    match info with
    | M.Info.T info ->
      let get ~loc lib' =
        if lib = lib' then
          User_error.raise ~loc
            [ Pp.textf "Library %S depends on itself"
                (Lib_name.to_string lib.name)
            ]
        else
          M.get lib'
      in
      Sub_system0.Instance.T
        (M.for_instance, M.instantiate ~resolve ~get lib info)
    | _ -> assert false

  let public_info lib =
    try
      Ok
        (Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun (lazy inst) ->
             let (Sub_system0.Instance.T ((module M), t)) = inst in
             Option.map M.public_info ~f:(fun f ->
                 M.Info.T (Result.ok_exn (f t)))))
    with User_error.E _ as exn -> Error exn
end

(* Library name resolution and transitive closure *)

(* Dependency stack used while resolving the dependencies of a library that was
   just returned by the [resolve] callback *)
module Dep_stack = struct
  module Implements_via = struct
    type t = Default_for of Id.t

    let to_dep_path_implements_via = function
      | Default_for id ->
        Dep_path.Entry.Implements_via.Default_for (Id.to_dep_path_lib id)
  end

  type t =
    { stack : Id.t list
    ; implements_via : Implements_via.t Id.Map.t
    ; seen : Id.Set.t
    }

  let empty = { stack = []; seen = Id.Set.empty; implements_via = Id.Map.empty }

  let to_required_by t ~stop_at =
    let stop_at = stop_at.stack in
    let rec loop acc l =
      if List.physically_equal l stop_at then
        List.rev acc
      else
        match l with
        | [] -> assert false
        | ({ Id.path; name; _ } as id) :: l ->
          let implements_via =
            let open Option.O in
            let+ via = Id.Map.find t.implements_via id in
            Implements_via.to_dep_path_implements_via via
          in
          loop
            (Dep_path.Entry.Library ({ path; name }, implements_via) :: acc)
            l
    in
    loop [] t.stack

  let dependency_cycle t (last : Id.t) =
    assert (Id.Set.mem t.seen last);
    let rec build_loop acc stack =
      match stack with
      | [] -> assert false
      | (x : Id.t) :: stack ->
        let acc = (x.path, x.name) :: acc in
        if Id.equal x last then
          acc
        else
          build_loop acc stack
    in
    let loop = build_loop [ (last.path, last.name) ] t.stack in
    Error.dependency_cycle loop

  let create_and_push t name path =
    let init = Id.make ~path ~name in
    ( init
    , { stack = init :: t.stack
      ; seen = Id.Set.add t.seen init
      ; implements_via = Id.Map.empty
      } )

  let push (t : t) ~implements_via (x : Id.t) : (_, _) result =
    if Id.Set.mem t.seen x then
      dependency_cycle t x
    else
      let implements_via =
        match implements_via with
        | None -> t.implements_via
        | Some via -> Id.Map.add_exn t.implements_via x via
      in
      Ok { stack = x :: t.stack; seen = Id.Set.add t.seen x; implements_via }
end

type private_deps =
  | From_same_project
  | Allow_all

let check_private_deps lib ~loc ~(private_deps : private_deps) =
  match private_deps with
  | Allow_all -> Ok lib
  | From_same_project -> (
    match Lib_info.status lib.info with
    | Private (_, Some _) -> Ok lib
    | Private (_, None) -> Error.private_deps_not_allowed ~loc lib.info
    | _ -> Ok lib )

let already_in_table info name x =
  let to_dyn = Dyn.Encoder.(pair Path.to_dyn Lib_name.to_dyn) in
  let src_dir = Lib_info.src_dir info in
  Code_error.raise
    "Lib_db.DB: resolver returned name that's already in the table"
    [ ("name", Lib_name.to_dyn name)
    ; ("returned_lib", to_dyn (src_dir, name))
    ; ("conflicting_with", Status.to_dyn x)
    ]

module Vlib : sig
  (** Make sure that for every virtual library in the list there is at most one
      corresponding implementation.

      Additionally, if linking is [true], ensures that every virtual library as
      an implementation and re-arrange the list so that implementations replaces
      virtual libraries. *)
  val associate :
       (t * Dep_stack.t) list
    -> orig_stack:Dep_stack.t
    -> linking:bool
    -> t list Or_exn.t

  module Unimplemented : sig
    (** set of unimplemented libraries*)
    type t

    val empty : t

    val add : t -> lib -> t Or_exn.t

    val with_default_implementations : t -> lib list
  end

  module Visit : sig
    type t

    val create : unit -> t

    val visit :
         t
      -> lib
      -> stack:Lib_info.external_ list
      -> f:(lib -> unit Or_exn.t)
      -> unit Or_exn.t
  end
end = struct
  module Unimplemented = struct
    type t =
      { implemented : Set.t
      ; unimplemented : Set.t
      }

    let empty = { implemented = Set.empty; unimplemented = Set.empty }

    let add t lib =
      let virtual_ = Lib_info.virtual_ lib.info in
      match (lib.implements, virtual_) with
      | None, None -> Ok t
      | Some _, Some _ -> assert false (* can't be virtual and implement *)
      | None, Some _ ->
        Ok
          ( if Set.mem t.implemented lib then
            t
          else
            { t with unimplemented = Set.add t.unimplemented lib } )
      | Some vlib, None ->
        let+ vlib = vlib in
        { implemented = Set.add t.implemented vlib
        ; unimplemented = Set.remove t.unimplemented vlib
        }

    let with_default_implementations t =
      Set.fold t.unimplemented ~init:[] ~f:(fun lib acc ->
          match lib.default_implementation with
          | None -> acc
          | Some _ -> lib :: acc)
  end

  module Table = struct
    module Partial = struct
      type vlib_status =
        | No_impl of Dep_stack.t
        | Impl of lib * Dep_stack.t

      type t = vlib_status Map.t

      let is_empty = Map.is_empty

      let make closure ~orig_stack : t Or_exn.t =
        let rec loop acc = function
          | [] -> Ok acc
          | (lib, stack) :: libs -> (
            let virtual_ = Lib_info.virtual_ lib.info in
            match (lib.implements, virtual_) with
            | None, None -> loop acc libs
            | Some _, Some _ ->
              assert false (* can't be virtual and implement *)
            | None, Some _ -> loop (Map.set acc lib (No_impl stack)) libs
            | Some vlib, None -> (
              let* vlib = vlib in
              match Map.find acc vlib with
              | None ->
                (* we've already traversed the virtual library because it must
                   have occurred earlier in the closure *)
                assert false
              | Some (No_impl _) ->
                loop (Map.set acc vlib (Impl (lib, stack))) libs
              | Some (Impl (lib', stack')) ->
                let req_by' =
                  Dep_stack.to_required_by stack' ~stop_at:orig_stack
                in
                let req_by =
                  Dep_stack.to_required_by stack ~stop_at:orig_stack
                in
                Error.double_implementation (lib'.info, req_by')
                  (lib.info, req_by) ~vlib:vlib.info ) )
        in
        loop Map.empty closure
    end

    type t = lib Map.t

    let make impls ~orig_stack : t Or_exn.t =
      let rec loop acc = function
        | [] -> Ok acc
        | (vlib, Partial.No_impl stack) :: _ ->
          let rb = Dep_stack.to_required_by stack ~stop_at:orig_stack in
          Error.no_implementation (vlib.info, rb)
        | (vlib, Impl (impl, _stack)) :: libs ->
          loop (Map.set acc vlib impl) libs
      in
      loop Map.empty (Map.to_list impls)
  end

  let second_step_closure ts impls =
    let visited = ref Id.Set.empty in
    let res = ref [] in
    let rec loop t =
      let t = Option.value ~default:t (Map.find impls t) in
      if Id.Set.mem !visited t.unique_id then
        Ok ()
      else (
        visited := Id.Set.add !visited t.unique_id;
        let* deps = t.requires in
        let+ () = Result.List.iter deps ~f:loop in
        res := t :: !res
      )
    in
    let+ () = Result.List.iter ts ~f:loop in
    List.rev !res

  let associate closure ~orig_stack ~linking =
    let* impls = Table.Partial.make closure ~orig_stack in
    let closure = List.map closure ~f:fst in
    if linking && not (Table.Partial.is_empty impls) then
      let* impls = Table.make impls ~orig_stack in
      second_step_closure closure impls
    else
      Ok closure

  module Visit = struct
    module Status = struct
      type t =
        | Visiting
        | Visited
    end

    type t = Status.t Map.t ref

    let create () = ref Map.empty

    let visit t lib ~stack ~f =
      match Map.find !t lib with
      | Some Status.Visited -> Ok ()
      | Some Visiting -> Error.default_implementation_cycle (lib.info :: stack)
      | None ->
        t := Map.set !t lib Visiting;
        let res = f lib in
        t := Map.set !t lib Visited;
        res
  end
end

let instrumentation_backend ?(do_not_fail = false) instrument_with resolve
    libname =
  if not (List.mem ~set:instrument_with (snd libname)) then
    None
  else
    match
      resolve libname |> Result.ok_exn |> info
      |> Lib_info.instrumentation_backend
    with
    | Some _ as ppx -> ppx
    | None ->
      if do_not_fail then
        Some libname
      else
        User_error.raise ~loc:(fst libname)
          [ Pp.textf
              "Library %S is not declared to have an instrumentation backend."
              (Lib_name.to_string (snd libname))
          ]

module rec Resolve : sig
  val find_internal : db -> Lib_name.t -> stack:Dep_stack.t -> Status.t

  val resolve_dep :
       db
    -> Loc.t * Lib_name.t
    -> private_deps:private_deps
    -> stack:Dep_stack.t
    -> lib Or_exn.t

  val resolve_name : db -> Lib_name.t -> stack:Dep_stack.t -> Status.t

  val available_internal : db -> Lib_name.t -> stack:Dep_stack.t -> bool

  val resolve_simple_deps :
       db
    -> (Loc.t * Lib_name.t) list
    -> private_deps:private_deps
    -> stack:Dep_stack.t
    -> (t list, exn) Result.t

  type resolved =
    { requires : lib list Or_exn.t
    ; pps : lib list Or_exn.t
    ; selects : Resolved_select.t list
    ; re_exports : lib list Or_exn.t
    }

  val resolve_deps_and_add_runtime_deps :
       db
    -> Lib_dep.t list
    -> private_deps:private_deps
    -> pps:(Loc.t * Lib_name.t) list
    -> dune_version:Dune_lang.Syntax.Version.t option
    -> stack:Dep_stack.t
    -> resolved

  val compile_closure_with_overlap_checks :
       db option
    -> lib list
    -> stack:Dep_stack.t
    -> forbidden_libraries:Loc.t Map.t
    -> lib list Or_exn.t

  val linking_closure_with_overlap_checks :
       db option
    -> lib list
    -> stack:Dep_stack.t
    -> forbidden_libraries:Loc.t Map.t
    -> lib list Or_exn.t
end = struct
  open Resolve

  let instantiate db name info ~stack ~hidden =
    let unique_id, stack =
      let src_dir = Lib_info.src_dir info in
      Dep_stack.create_and_push stack name src_dir
    in
    Option.iter (Table.find db.table name) ~f:(fun x ->
        already_in_table info name x);
    (* Add [id] to the table, to detect loops *)
    Table.add_exn db.table name (Status.Initializing unique_id);
    let status = Lib_info.status info in
    let private_deps =
      match status with
      (* [Allow_all] is used for libraries that are installed because we don't
         have to check it again. It has been checked when compiling the
         libraries before their installation *)
      | Installed_private
      | Private _
      | Installed ->
        Allow_all
      | Public (_, _) -> From_same_project
    in
    let resolve name = resolve_dep db name ~private_deps ~stack in
    let implements =
      let open Option.O in
      let+ ((loc, _) as name) = Lib_info.implements info in
      let open Result.O in
      let* vlib = resolve name in
      let virtual_ = Lib_info.virtual_ vlib.info in
      match virtual_ with
      | None -> Error.not_virtual_lib ~loc ~impl:info ~not_vlib:vlib.info
      | Some _ -> Ok vlib
    in
    let resolve_impl impl_name =
      let* impl = resolve impl_name in
      let* vlib =
        match impl.implements with
        | Some vlib -> vlib
        | None -> Error.not_an_implementation_of ~vlib:info ~impl:impl.info
      in
      if Id.equal vlib.unique_id unique_id then
        Ok impl
      else
        Error.not_an_implementation_of ~vlib:info ~impl:impl.info
    in
    let default_implementation =
      Lib_info.default_implementation info
      |> Option.map ~f:(fun l ->
             lazy
               (let* impl = resolve_impl l in
                match Lib_info.package impl.info with
                | None -> Ok impl
                | Some p -> (
                  let loc = fst l in
                  match Lib_info.package info with
                  | None ->
                    (* We don't need to verify that impl is private if this
                       virtual library is private. Every implementation already
                       depends on the virtual library, so the check will be done
                       there. *)
                    Ok impl
                  | Some p' ->
                    (* It's not good to rely on package names for equality like
                       this, but we piggy back on the fact that package names
                       are globally unique *)
                    if Package.Name.equal p p' then
                      Ok impl
                    else
                      Error.make ~loc
                        [ Pp.textf
                            "default implementation belongs to package %s \
                             while virtual libarary belongs to package %s. \
                             This is impossible\n"
                            (Package.Name.to_string p)
                            (Package.Name.to_string p')
                        ] )))
    in
    let { requires; pps; selects = resolved_selects; re_exports } =
      let pps =
        Preprocess.Per_module.pps
          (Preprocess.Per_module.with_instrumentation (Lib_info.preprocess info)
             ~instrumentation_backend:
               (instrumentation_backend db.instrument_with resolve))
      in
      let dune_version = Lib_info.dune_version info in
      Lib_info.requires info
      |> resolve_deps_and_add_runtime_deps db ~private_deps ~dune_version ~pps
           ~stack
    in
    let requires =
      match implements with
      | None -> requires
      | Some impl ->
        let* impl = impl in
        let+ requires = requires in
        impl :: requires
    in
    let ppx_runtime_deps =
      Lib_info.ppx_runtime_deps info
      |> resolve_simple_deps db ~private_deps ~stack
    in
    let src_dir = Lib_info.src_dir info in
    let map_error x =
      Result.map_error x ~f:(fun e ->
          let lib = { Dep_path.Entry.Lib.path = src_dir; name } in
          Dep_path.prepend_exn e (Library (lib, None)))
    in
    let requires = map_error requires in
    let ppx_runtime_deps = map_error ppx_runtime_deps in
    let project =
      let status = Lib_info.status info in
      match Lib_info.Status.project status with
      | Some _ as project -> project
      | None ->
        let open Option.O in
        let* package = Lib_info.package info in
        Package.Name.Map.find db.projects_by_package package
    in
    let modules =
      match Path.as_in_build_dir (Lib_info.src_dir info) with
      | None -> None
      | Some dir -> Some (lazy (Fdecl.get db.modules_of_lib ~dir ~name))
    in
    let src_dirs =
      lazy
        (let obj_dir = Lib_info.obj_dir info in
         match Path.is_managed (Obj_dir.byte_dir obj_dir) with
         | false -> Path.Set.singleton src_dir
         | true ->
           let (lazy modules) = Option.value_exn modules in
           Path.Set.map ~f:Path.drop_optional_build_context
             (Modules.source_dirs modules))
    in
    let t =
      { info
      ; name
      ; unique_id
      ; requires
      ; ppx_runtime_deps
      ; pps
      ; resolved_selects
      ; user_written_deps = Lib_info.user_written_deps info
      ; sub_systems = Sub_system_name.Map.empty
      ; implements
      ; default_implementation
      ; lib_config = db.lib_config
      ; re_exports
      ; project
      ; modules
      ; src_dirs
      }
    in
    t.sub_systems <-
      Lib_info.sub_systems info
      |> Sub_system_name.Map.mapi ~f:(fun name info ->
             lazy (Sub_system.instantiate name info t ~resolve));
    let res =
      let hidden =
        match hidden with
        | Some _ -> hidden
        | None -> (
          let enabled = Lib_info.enabled info in
          match enabled with
          | Normal -> None
          | Optional ->
            Option.some_if
              (not (Result.is_ok t.requires && Result.is_ok t.ppx_runtime_deps))
              "optional with unavailable dependencies"
          | Disabled_because_of_enabled_if -> Some "unsatisfied 'enabled_if'" )
      in
      match hidden with
      | None -> Status.Found t
      | Some reason -> Hidden (Hidden.of_lib t ~reason)
    in
    ( match Table.find db.table name with
    | Some (Status.Initializing u) -> assert (Id.equal u unique_id)
    | _ -> assert false );
    Table.set db.table name res;
    res

  let find_internal db (name : Lib_name.t) ~stack : Status.t =
    match Table.find db.table name with
    | Some x -> x
    | None -> resolve_name db name ~stack

  let resolve_dep db (loc, name) ~private_deps ~stack : t Or_exn.t =
    match find_internal db name ~stack with
    | Initializing id -> Dep_stack.dependency_cycle stack id
    | Found lib -> check_private_deps lib ~loc ~private_deps
    | Not_found -> Error.not_found ~loc ~name
    | Invalid why -> Error why
    | Hidden h -> Hidden.error h ~loc ~name

  let resolve_name db name ~stack =
    match db.resolve name with
    | Redirect (db', (_, name')) -> (
      let db' = Option.value db' ~default:db in
      match find_internal db' name' ~stack with
      | Status.Initializing _ as x -> x
      | x ->
        Table.add_exn db.table name x;
        x )
    | Found info -> instantiate db name info ~stack ~hidden:None
    | Invalid e -> Status.Invalid e
    | Not_found ->
      let res =
        match db.parent with
        | None -> Status.Not_found
        | Some db -> find_internal db name ~stack
      in
      Table.add_exn db.table name res;
      res
    | Hidden { lib = info; reason = hidden; path = _ } -> (
      match
        match db.parent with
        | None -> Status.Not_found
        | Some db -> find_internal db name ~stack
      with
      | Status.Found _ as x ->
        Table.add_exn db.table name x;
        x
      | _ -> instantiate db name info ~stack ~hidden:(Some hidden) )

  let available_internal db (name : Lib_name.t) ~stack =
    resolve_dep db (Loc.none, name) ~private_deps:Allow_all ~stack
    |> Result.is_ok

  let resolve_simple_deps db names ~private_deps ~stack =
    Result.List.map names ~f:(resolve_dep db ~private_deps ~stack)

  let re_exports_closure ts =
    let visited = ref Set.empty in
    let res = ref [] in
    let rec one (t : lib) =
      if Set.mem !visited t then
        Ok ()
      else (
        visited := Set.add !visited t;
        let* re_exports = t.re_exports in
        let+ () = many re_exports in
        res := t :: !res
      )
    and many l = Result.List.iter l ~f:one in
    let+ () = many ts in
    List.rev !res

  type resolved_deps =
    { resolved : t list Or_exn.t
    ; selects : Resolved_select.t list
    ; re_exports : t list Or_exn.t
    }

  type resolved =
    { requires : lib list Or_exn.t
    ; pps : lib list Or_exn.t
    ; selects : Resolved_select.t list
    ; re_exports : lib list Or_exn.t
    }

  let resolve_complex_deps db deps ~private_deps ~stack : resolved_deps =
    let resolve_select { Lib_dep.Select.result_fn; choices; loc } =
      let res, src_fn =
        match
          List.find_map choices ~f:(fun { required; forbidden; file } ->
              if Lib_name.Set.exists forbidden ~f:(available_internal db ~stack)
              then
                None
              else
                match
                  let deps =
                    Lib_name.Set.fold required ~init:[] ~f:(fun x acc ->
                        (loc, x) :: acc)
                  in
                  resolve_simple_deps ~private_deps db deps ~stack
                with
                | Ok ts -> Some (ts, file)
                | Error _ -> None)
        with
        | Some (ts, file) -> (Ok ts, Ok file)
        | None ->
          let e () = Error.no_solution_found_for_select ~loc in
          (e (), e ())
      in
      (res, { Resolved_select.src_fn; dst_fn = result_fn })
    in
    let res, resolved_selects, re_exports =
      List.fold_left deps ~init:(Ok [], [], Ok [])
        ~f:(fun (acc_res, acc_selects, acc_re_exports) dep ->
          match (dep : Lib_dep.t) with
          | Re_export (loc, name) ->
            let lib = resolve_dep db (loc, name) ~private_deps ~stack in
            let acc_re_exports =
              let+ lib = lib
              and+ acc_re_exports = acc_re_exports in
              lib :: acc_re_exports
            in
            let acc_res =
              let+ lib = lib
              and+ acc_res = acc_res in
              lib :: acc_res
            in
            (acc_res, acc_selects, acc_re_exports)
          | Direct (loc, name) ->
            let acc_res =
              let+ lib = resolve_dep db (loc, name) ~private_deps ~stack
              and+ acc_res = acc_res in
              lib :: acc_res
            in
            (acc_res, acc_selects, acc_re_exports)
          | Select select ->
            let res, resolved_select = resolve_select select in
            let acc_res =
              let+ res = res
              and+ acc_res = acc_res in
              List.rev_append res acc_res
            in
            (acc_res, resolved_select :: acc_selects, acc_re_exports))
    in
    let res = Result.map ~f:List.rev res in
    let re_exports = Result.map ~f:List.rev re_exports in
    { resolved = res; selects = resolved_selects; re_exports }

  type pp_deps =
    { pps : t list Or_exn.t
    ; runtime_deps : t list Or_exn.t
    }

  let pp_deps db pps ~stack ~dune_version ~private_deps =
    let allow_only_ppx_deps =
      match dune_version with
      | Some version -> Dune_lang.Syntax.Version.Infix.(version >= (2, 2))
      | None ->
        if List.is_non_empty pps then
          (* See note {!Lib_info_invariants}. *)
          Code_error.raise
            "Lib.resolve_user_deps: non-empty set of preprocessors but the \
             Dune language version not set. This should be impossible."
            [];
        true
    in
    match pps with
    | [] -> { runtime_deps = Ok []; pps = Ok [] }
    | first :: others ->
      (* Location of the list of ppx rewriters *)
      let loc : Loc.t =
        let (last, _) : Loc.t * _ =
          Option.value (List.last others) ~default:first
        in
        Loc.span (fst first) last
      in
      let pps =
        let* pps =
          Result.List.map pps ~f:(fun (loc, name) ->
              let* lib =
                resolve_dep db (loc, name) ~private_deps:Allow_all ~stack
              in
              match (allow_only_ppx_deps, Lib_info.kind lib.info) with
              | true, Normal -> Error.only_ppx_deps_allowed ~loc lib.info
              | _ -> Ok lib)
        in
        linking_closure_with_overlap_checks None pps ~stack
          ~forbidden_libraries:Map.empty
      in
      let deps =
        let* pps = pps in
        let+ pps_deps =
          Result.List.concat_map pps ~f:(fun pp ->
              let* ppx_runtime_deps = pp.ppx_runtime_deps in
              Result.List.map ppx_runtime_deps
                ~f:(check_private_deps ~loc ~private_deps))
        in
        pps_deps
      in
      { runtime_deps = deps; pps }

  let add_pp_runtime_deps db resolved ~private_deps ~pps ~dune_version ~stack :
      resolved =
    let { runtime_deps; pps } =
      pp_deps db pps ~stack ~dune_version ~private_deps
    in
    let deps =
      let* runtime_deps = runtime_deps in
      let* deps = resolved.resolved in
      re_exports_closure (deps @ runtime_deps)
    in
    { requires = deps
    ; pps
    ; selects = resolved.selects
    ; re_exports = resolved.re_exports
    }

  let resolve_deps_and_add_runtime_deps db deps ~private_deps ~pps ~dune_version
      ~stack =
    resolve_complex_deps db ~private_deps ~stack deps
    |> add_pp_runtime_deps db ~private_deps ~dune_version ~pps ~stack

  (* Compute transitive closure of libraries to figure which ones will trigger
     their default implementation.

     Assertion: libraries is a list of virtual libraries with no implementation.
     The goal is to find which libraries can safely be defaulted. *)
  let resolve_default_libraries libraries =
    (* Map from a vlib to vlibs that are implemented in the transitive closure
       of its default impl. *)
    let vlib_status = Vlib.Visit.create () in
    (* Reverse map *)
    let vlib_default_parent = ref Map.empty in
    let avoid_direct_parent vlib (impl : lib) =
      match impl.implements with
      | None -> Ok true
      | Some x ->
        let+ x = x in
        x <> vlib
    in
    (* Either by variants or by default. *)
    let impl_for vlib =
      match vlib.default_implementation with
      | None -> Ok None
      | Some d -> Result.map ~f:Option.some (Lazy.force d)
    in
    let impl_different_from_vlib_default vlib (impl : lib) =
      impl_for vlib >>| function
      | None -> true
      | Some lib -> lib <> impl
    in
    let library_is_default lib =
      match Map.find !vlib_default_parent lib with
      | Some (_ :: _) -> None
      | None
      | Some [] ->
        Option.bind lib.default_implementation ~f:(fun (lazy default) ->
            match default with
            | Error _ -> None
            | Ok default ->
              let implements_via =
                Dep_stack.Implements_via.Default_for lib.unique_id
              in
              Some (implements_via, default))
    in
    (* Gather vlibs that are transitively implemented by another vlib's default
       implementation. *)
    let rec visit ~stack ancestor_vlib =
      Vlib.Visit.visit vlib_status ~stack ~f:(fun lib ->
          (* Visit direct dependencies *)
          let* deps = lib.requires in
          let* () =
            List.filter deps ~f:(fun x ->
                match avoid_direct_parent x lib with
                | Ok x -> x
                | Error _ -> false)
            |> Result.List.iter
                 ~f:(visit ~stack:(lib.info :: stack) ancestor_vlib)
          in
          (* If the library is an implementation of some virtual library that
             overrides default, add a link in the graph. *)
          let* () =
            Result.Option.iter lib.implements ~f:(fun vlib ->
                let* res = impl_different_from_vlib_default vlib lib in
                match (res, ancestor_vlib) with
                | true, None ->
                  (* Recursion: no ancestor, vlib is explored *)
                  visit ~stack:(lib.info :: stack) None vlib
                | true, Some ancestor ->
                  vlib_default_parent :=
                    Map.Multi.cons !vlib_default_parent lib ancestor;
                  visit ~stack:(lib.info :: stack) None vlib
                | false, _ ->
                  (* If lib is the default implementation, we'll manage it when
                     handling virtual lib. *)
                  Ok ())
          in
          (* If the library has an implementation according to variants or
             default impl. *)
          let virtual_ = Lib_info.virtual_ lib.info in
          if Option.is_none virtual_ then
            Ok ()
          else
            let* impl = impl_for lib in
            match impl with
            | None -> Ok ()
            | Some impl -> visit ~stack:(lib.info :: stack) (Some lib) impl)
    in
    (* For each virtual library we know which vlibs will be implemented when
       enabling its default implementation. *)
    let+ () = Result.List.iter ~f:(visit ~stack:[] None) libraries in
    List.filter_map ~f:library_is_default libraries

  module Closure = struct
    type nonrec t =
      { mutable result : (t * Dep_stack.t) list
      ; mutable visited : Set.t
      ; mutable unimplemented : Vlib.Unimplemented.t
      ; db : db option
      ; forbidden_libraries : Loc.t Map.t
      ; orig_stack : Dep_stack.t
      }

    let result t ~linking =
      Vlib.associate (List.rev t.result) ~linking ~orig_stack:t.orig_stack

    let make ~db ~forbidden_libraries ~orig_stack =
      { result = []
      ; visited = Set.empty
      ; unimplemented = Vlib.Unimplemented.empty
      ; db
      ; forbidden_libraries
      ; orig_stack
      }

    let rec visit (t : t) ~stack (implements_via, lib) =
      if Set.mem t.visited lib then
        Ok ()
      else
        match Map.find t.forbidden_libraries lib with
        | Some loc ->
          let req_by = Dep_stack.to_required_by stack ~stop_at:t.orig_stack in
          Error.make ~loc
            [ Pp.textf "Library %S was pulled in." (Lib_name.to_string lib.name)
            ; Dep_path.Entries.pp req_by
            ]
        | None ->
          t.visited <- Set.add t.visited lib;
          let* () =
            match t.db with
            | None -> Ok ()
            | Some db -> (
              match Lib_info.status lib.info with
              | Private (_, Some _) -> Ok ()
              | _ -> (
                match find_internal db lib.name ~stack with
                | Status.Found lib' ->
                  if lib = lib' then
                    Ok ()
                  else
                    let req_by =
                      Dep_stack.to_required_by stack ~stop_at:t.orig_stack
                    in
                    Error.overlap ~in_workspace:lib'.info
                      ~installed:(lib.info, req_by)
                | found ->
                  Code_error.raise "Unexpected find result"
                    [ ("found", Status.to_dyn found)
                    ; ("lib.name", Lib_name.to_dyn lib.name)
                    ] ) )
          in
          let* new_stack = Dep_stack.push stack ~implements_via (to_id lib) in
          let* deps = lib.requires in
          let* unimplemented' = Vlib.Unimplemented.add t.unimplemented lib in
          t.unimplemented <- unimplemented';
          let+ () =
            Result.List.iter deps ~f:(fun l ->
                visit t (None, l) ~stack:new_stack)
          in
          t.result <- (lib, stack) :: t.result
  end

  let step1_closure db ts ~stack:orig_stack ~forbidden_libraries =
    let state = Closure.make ~db ~forbidden_libraries ~orig_stack in
    let+ () =
      Result.List.iter ts ~f:(fun lib ->
          Closure.visit state ~stack:orig_stack (None, lib))
    in
    state

  let compile_closure_with_overlap_checks db ts ~stack ~forbidden_libraries =
    let* state = step1_closure db ts ~stack ~forbidden_libraries in
    Closure.result state ~linking:false

  let linking_closure_with_overlap_checks db ts ~stack ~forbidden_libraries =
    let* state = step1_closure db ts ~stack ~forbidden_libraries in
    let rec impls_via_defaults () =
      let* defaults =
        Vlib.Unimplemented.with_default_implementations state.unimplemented
        |> resolve_default_libraries
      in
      match defaults with
      | _ :: _ -> fill_impls defaults
      | [] -> Ok ()
    and fill_impls libs =
      let* () =
        Result.List.iter libs ~f:(fun (via, lib) ->
            Closure.visit state (Some via, lib) ~stack)
      in
      impls_via_defaults ()
    in
    let* () = impls_via_defaults () in
    Closure.result state ~linking:true
end

let closure l ~linking =
  let stack = Dep_stack.empty in
  let forbidden_libraries = Map.empty in
  if linking then
    Resolve.linking_closure_with_overlap_checks None l ~stack
      ~forbidden_libraries
  else
    Resolve.compile_closure_with_overlap_checks None l ~forbidden_libraries
      ~stack

let closure_exn l ~linking = Result.ok_exn (closure l ~linking)

module Compile = struct
  module Resolved_select = Resolved_select

  type nonrec t =
    { direct_requires : t list Or_exn.t
    ; requires_link : t list Or_exn.t Lazy.t
    ; pps : t list Or_exn.t
    ; resolved_selects : Resolved_select.t list
    ; lib_deps_info : Lib_deps_info.t
    ; sub_systems : Sub_system0.Instance.t Lazy.t Sub_system_name.Map.t
    ; merlin_ident : Merlin_ident.t
    }

  let make_lib_deps_info ~user_written_deps ~pps ~kind =
    Lib_deps_info.merge
      (Dune_file.Lib_deps.info user_written_deps ~kind)
      ( List.map pps ~f:(fun (_, pp) -> (pp, kind))
      |> Lib_name.Map.of_list_reduce ~f:Lib_deps_info.Kind.merge )

  let for_lib resolve ~allow_overlaps db (t : lib) =
    let requires =
      (* This makes sure that the default implementation belongs to the same
         package before we build the virtual library *)
      let* () =
        match t.default_implementation with
        | None -> Result.ok ()
        | Some i ->
          let+ (_ : lib) = Lazy.force i in
          ()
      in
      t.requires
    in
    let lib_deps_info =
      let pps =
        let resolve = resolve db in
        Preprocess.Per_module.pps
          (Preprocess.Per_module.with_instrumentation
             (Lib_info.preprocess t.info)
             ~instrumentation_backend:
               (instrumentation_backend ~do_not_fail:true db.instrument_with
                  resolve))
      in
      let user_written_deps = Lib_info.user_written_deps t.info in
      let kind : Lib_deps_info.Kind.t =
        let enabled = Lib_info.enabled t.info in
        match enabled with
        | Normal -> Required
        | _ -> Optional
      in
      make_lib_deps_info ~user_written_deps ~pps ~kind
    in
    let requires_link =
      let db = Option.some_if (not allow_overlaps) db in
      lazy
        ( requires
        >>= Resolve.compile_closure_with_overlap_checks db
              ~stack:Dep_stack.empty ~forbidden_libraries:Map.empty )
    in
    let merlin_ident = Merlin_ident.for_lib t.name in
    { direct_requires = requires
    ; requires_link
    ; resolved_selects = t.resolved_selects
    ; pps = t.pps
    ; lib_deps_info
    ; sub_systems = t.sub_systems
    ; merlin_ident
    }

  let direct_requires t = t.direct_requires

  let requires_link t = t.requires_link

  let resolved_selects t = t.resolved_selects

  let pps t = t.pps

  let lib_deps_info t = t.lib_deps_info

  let merlin_ident t = t.merlin_ident

  let sub_systems t =
    Sub_system_name.Map.values t.sub_systems
    |> List.map ~f:(fun (lazy (Sub_system0.Instance.T ((module M), t))) ->
           M.T t)
end

(* Databases *)

module DB = struct
  module Resolve_result = struct
    type t = resolve_result =
      | Not_found
      | Found of Lib_info.external_
      | Hidden of Lib_info.external_ Hidden.t
      | Invalid of exn
      | Redirect of db option * (Loc.t * Lib_name.t)

    let found f = Found f

    let not_found = Not_found

    let redirect db lib = Redirect (db, lib)

    let to_dyn x =
      let open Dyn.Encoder in
      match x with
      | Not_found -> constr "Not_found" []
      | Invalid e -> constr "Invalid" [ Exn.to_dyn e ]
      | Found lib -> constr "Found" [ Lib_info.to_dyn Path.to_dyn lib ]
      | Hidden h ->
        constr "Hidden" [ Hidden.to_dyn (Lib_info.to_dyn Path.to_dyn) h ]
      | Redirect (_, (_, name)) -> constr "Redirect" [ Lib_name.to_dyn name ]
  end

  type t = db

  (* CR-someday amokhov: this whole module should be rewritten using the
     memoization framework instead of using mutable state. *)
  let create ~parent ~resolve ~projects_by_package ~all ~modules_of_lib
      ~lib_config () =
    { parent
    ; resolve
    ; table = Table.create (module Lib_name) 1024
    ; all = Lazy.from_fun all
    ; lib_config
    ; instrument_with = lib_config.Lib_config.instrument_with
    ; projects_by_package
    ; modules_of_lib
    }

  let create_from_findlib ~lib_config ~projects_by_package findlib =
    create () ~parent:None ~lib_config ~projects_by_package
      ~modules_of_lib:
        (let t = Fdecl.create Dyn.Encoder.opaque in
         Fdecl.set t (fun ~dir ~name ->
             Code_error.raise "external libraries need no modules"
               [ ("dir", Path.Build.to_dyn dir)
               ; ("name", Lib_name.to_dyn name)
               ]);
         t)
      ~resolve:(fun name ->
        match Findlib.find findlib name with
        | Ok (Library pkg) -> Found (Dune_package.Lib.info pkg)
        | Ok (Deprecated_library_name d) ->
          Redirect (None, (d.loc, d.new_public_name))
        | Ok (Hidden_library pkg) -> Hidden (Hidden.unsatisfied_exist_if pkg)
        | Error e -> (
          match e with
          | Invalid_dune_package why -> Invalid why
          | Not_found ->
            if !Clflags.external_lib_deps_mode then
              let pkg = Findlib.dummy_lib findlib ~name in
              Found (Dune_package.Lib.info pkg)
            else
              Not_found ))
      ~all:(fun () ->
        Findlib.all_packages findlib |> List.map ~f:Dune_package.Entry.name)

  let find t name =
    match Resolve.find_internal t name ~stack:Dep_stack.empty with
    | Status.Initializing _ -> assert false
    | Found t -> Some t
    | Not_found
    | Invalid _
    | Hidden _ ->
      None

  let find_even_when_hidden t name =
    match Resolve.find_internal t name ~stack:Dep_stack.empty with
    | Initializing _ -> assert false
    | Found t
    | Hidden { lib = t; reason = _; path = _ } ->
      Some t
    | Invalid _
    | Not_found ->
      None

  let resolve_when_exists t (loc, name) =
    match Resolve.find_internal t name ~stack:Dep_stack.empty with
    | Status.Initializing _ -> assert false
    | Found t -> Some (Ok t)
    | Invalid w -> Some (Error w)
    | Not_found -> None
    | Hidden h -> Some (Hidden.error h ~loc ~name)

  let resolve t (loc, name) =
    match resolve_when_exists t (loc, name) with
    | None -> Error.not_found ~loc ~name
    | Some k -> k

  let available t name =
    Resolve.available_internal t name ~stack:Dep_stack.empty

  let get_compile_info t ?(allow_overlaps = false) name =
    match find_even_when_hidden t name with
    | None ->
      Code_error.raise "Lib.DB.get_compile_info got library that doesn't exist"
        [ ("name", Lib_name.to_dyn name) ]
    | Some lib -> Compile.for_lib resolve ~allow_overlaps t lib

  let resolve_user_written_deps_for_exes t exes ?(allow_overlaps = false)
      ?(forbidden_libraries = []) deps ~pps ~dune_version ~optional =
    let lib_deps_info =
      Compile.make_lib_deps_info ~user_written_deps:deps ~pps
        ~kind:
          ( if optional then
            Optional
          else
            Required )
    in
    let { Resolve.requires = res
        ; pps
        ; selects = resolved_selects
        ; re_exports = _
        } =
      Resolve.resolve_deps_and_add_runtime_deps t deps ~pps
        ~private_deps:Allow_all ~stack:Dep_stack.empty
        ~dune_version:(Some dune_version)
    in
    let requires_link =
      lazy
        (let* forbidden_libraries =
           let* l =
             Result.List.map forbidden_libraries ~f:(fun (loc, name) ->
                 let+ lib = resolve t (loc, name) in
                 (lib, loc))
           in
           match Map.of_list l with
           | Ok _ as res -> res
           | Error (lib, _, loc) ->
             Error.make ~loc
               [ Pp.textf "Library %S appears for the second time"
                   (Lib_name.to_string lib.name)
               ]
         and+ res = res in
         Resolve.linking_closure_with_overlap_checks ~stack:Dep_stack.empty
           (Option.some_if (not allow_overlaps) t)
           ~forbidden_libraries res
         |> Result.map_error ~f:(fun e ->
                Dep_path.prepend_exn e (Executables exes)))
    in
    let merlin_ident = Merlin_ident.for_exes ~names:(List.map ~f:snd exes) in
    { Compile.direct_requires = res
    ; requires_link
    ; pps
    ; resolved_selects
    ; lib_deps_info
    ; sub_systems = Sub_system_name.Map.empty
    ; merlin_ident
    }

  (* Here we omit the [only_ppx_deps_allowed] check because by the time we reach
     this point, all preprocess dependencies should have been checked already. *)
  let resolve_pps t pps =
    Resolve.resolve_simple_deps t ~private_deps:Allow_all pps
      ~stack:Dep_stack.empty

  let rec all ?(recursive = false) t =
    let l =
      List.fold_left (Lazy.force t.all)
        ~f:(fun libs name ->
          match find t name with
          | Some x -> Set.add libs x
          | None -> libs)
        ~init:Set.empty
    in
    match (recursive, t.parent) with
    | true, Some t -> Set.union (all ~recursive t) l
    | _ -> l

  let instrumentation_backend t libname =
    instrumentation_backend t.instrument_with (resolve t) libname
end

(* META files *)

module Meta = struct
  let to_names = Lib_name.Set.of_list_map ~f:(fun t -> t.name)

  (* For the deprecated method, we need to put all the runtime dependencies of
     the transitive closure.

     We need to do this because [ocamlfind ocamlc -package ppx_foo] will not
     look for the transitive dependencies of [foo], and the runtime dependencies
     might be attached to a dependency of [foo] rather than [foo] itself.

     Sigh... *)
  let ppx_runtime_deps_for_deprecated_method t =
    closure_exn [ t ] ~linking:false
    |> List.concat_map ~f:(fun lib -> Result.ok_exn lib.ppx_runtime_deps)
    |> to_names

  let requires t = to_names (Result.ok_exn t.requires)

  let ppx_runtime_deps t = to_names (Result.ok_exn t.ppx_runtime_deps)
end

let to_dune_lib ({ info; _ } as lib) ~modules ~foreign_objects ~dir =
  let loc = Lib_info.loc info in
  let mangled_name lib =
    match Lib_info.status lib.info with
    | Private (_, Some pkg) ->
      Lib_name.mangled (Package.name pkg) (Lib_name.to_local_exn lib.name)
    | _ -> lib.name
  in
  let add_loc = List.map ~f:(fun x -> (loc, mangled_name x)) in
  let obj_dir =
    match Obj_dir.to_local (obj_dir lib) with
    | None -> assert false
    | Some obj_dir -> Obj_dir.convert_to_external ~dir obj_dir
  in
  let modules =
    let install_dir = Obj_dir.dir obj_dir in
    Modules.version_installed modules ~install_dir
  in
  let use_public_name ~lib_field ~info_field =
    match (info_field, lib_field) with
    | Some _, None
    | None, Some _ ->
      assert false
    | None, None -> Ok None
    | Some (loc, _), Some field ->
      let open Result.O in
      let+ field = field in
      Some (loc, mangled_name field)
  in
  let open Result.O in
  let+ implements =
    use_public_name ~info_field:(Lib_info.implements info)
      ~lib_field:(implements lib)
  and+ default_implementation =
    use_public_name
      ~info_field:(Lib_info.default_implementation info)
      ~lib_field:(Option.map ~f:Lazy.force lib.default_implementation)
  and+ ppx_runtime_deps = lib.ppx_runtime_deps
  and+ main_module_name = main_module_name lib
  and+ requires = lib.requires
  and+ re_exports = lib.re_exports
  and+ sub_systems = Sub_system.public_info lib in
  let ppx_runtime_deps = add_loc ppx_runtime_deps in
  let requires =
    List.map requires ~f:(fun lib ->
        if List.exists re_exports ~f:(fun r -> r = lib) then
          Lib_dep.Re_export (loc, mangled_name lib)
        else
          Direct (loc, mangled_name lib))
  in
  let name = mangled_name lib in
  let info =
    Lib_info.for_dune_package info ~name ~ppx_runtime_deps ~requires
      ~foreign_objects ~obj_dir ~implements ~default_implementation ~sub_systems
      ~modules
  in
  Dune_package.Lib.of_dune_lib ~info ~modules ~main_module_name

module Local : sig
  type t = private lib

  val of_lib : lib -> t option

  val of_lib_exn : lib -> t

  val to_lib : t -> lib

  val obj_dir : t -> Path.Build.t Obj_dir.t

  val info : t -> Path.Build.t Lib_info.t

  val to_dyn : t -> Dyn.t

  val equal : t -> t -> bool

  val hash : t -> int

  module Set : Stdune.Set.S with type elt = t

  module Map : Stdune.Map.S with type key = t
end = struct
  type nonrec t = t

  let to_lib t = t

  let of_lib (t : lib) = Option.some_if (is_local t) t

  let of_lib_exn t =
    match of_lib t with
    | Some l -> l
    | None -> Code_error.raise "Lib.Local.of_lib_exn" [ ("l", to_dyn t) ]

  let obj_dir t = Obj_dir.as_local_exn (Lib_info.obj_dir t.info)

  let info t = Lib_info.as_local_exn t.info

  module Set = Set
  module Map = Map

  let to_dyn = to_dyn

  let equal = equal

  let hash = hash
end
