open Import
open Resolve.Memo.O

(* Errors *)

module Dep_path : sig
  module Entry : sig
    module Lib : sig
      type t =
        { path : Path.t
        ; name : Lib_name.t
        }

      val pp : t -> _ Pp.t
    end

    module Implements_via : sig
      type t =
        | Variant of Variant.t
        | Default_for of Lib.t
    end

    type t =
      { lib : Lib.t
      ; implements_via : Implements_via.t option
      }
  end

  type t = Entry.t list

  val pp : t -> _ Pp.t
end = struct
  module Entry = struct
    module Lib = struct
      type t =
        { path : Path.t
        ; name : Lib_name.t
        }

      let pp { path; name } =
        Pp.textf
          "library %S in %s"
          (Lib_name.to_string name)
          (Path.to_string_maybe_quoted path)
      ;;
    end

    module Implements_via = struct
      type t =
        | Variant of Variant.t
        | Default_for of Lib.t

      let pp = function
        | Variant v -> Pp.textf "via variant %S" (Variant.to_string v)
        | Default_for l -> Pp.seq (Pp.text "via default implementation for ") (Lib.pp l)
      ;;
    end

    type t =
      { lib : Lib.t
      ; implements_via : Implements_via.t option
      }

    let pp { lib; implements_via } =
      match implements_via with
      | None -> Lib.pp lib
      | Some via -> Pp.concat ~sep:Pp.space [ Lib.pp lib; Implements_via.pp via ]
    ;;
  end

  type t = Entry.t list

  let pp t =
    Pp.concat_map t ~sep:Pp.cut ~f:(fun x ->
      [ Pp.verbatim "-> "; Pp.text "required by "; Entry.pp x ]
      |> Pp.concat
      |> Pp.box ~indent:3)
    |> Pp.vbox
  ;;
end

(* The current module never raises. It returns all errors as [Result.Error
   (User_error.E _)] values instead. Errors are later inserted into
   [Action_builder.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_resolve ?loc ?hints paragraphs =
    Resolve.fail (User_error.make ?loc ?hints ~needs_stack_trace:true paragraphs)
  ;;

  let make ?loc ?hints paragraphs = Memo.return @@ make_resolve ?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.pp dp ])
  ;;

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

  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
      ]
  ;;

  let duplicated ~loc_a ~loc_b ~name =
    let open Pp.O in
    User_error.make
      ~loc:loc_b
      [ Pp.textf "Library with name %S is already defined in " (Lib_name.to_string name)
        ++ Loc.pp_file_colon_line loc_a
        ++ Pp.text
             ". Either change one of the names, or enable them conditionally using the \
              'enabled_if' field."
      ]
  ;;

  (* 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.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 =
    Resolve.fail
      (User_error.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 ~kind ~loc private_dep =
    let name = Lib_info.name private_dep in
    User_error.make
      ~loc
      [ Pp.textf
          "Library %S is private, it cannot be a dependency of a %s. You need to give %S \
           a public name."
          (Lib_name.to_string name)
          (match kind with
           | `Private_package -> "private library attached to a package"
           | `Public -> "public library")
          (Lib_name.to_string name)
      ]
  ;;

  let only_ppx_deps_allowed ~loc dep =
    let name = Lib_info.name dep in
    make_resolve
      ~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_implementable ~loc ~lib ~not_impl =
    let lib = Lib_info.name lib in
    let not_impl = Lib_info.name not_impl in
    make
      ~loc
      [ Pp.textf
          "Library %S is neither a virtual library nor a library parameter. It cannot be \
           implemented by %S."
          (Lib_name.to_string not_impl)
          (Lib_name.to_string lib)
      ]
  ;;

  let expected_parameter ~loc ~name =
    make
      ~loc
      [ Pp.textf "Expected %S to be a library parameter." (Lib_name.to_string name) ]
  ;;

  let duplicate_parameters ~loc name name' =
    make
      ~loc
      [ Pp.textf
          "Duplicate library parameters: %S and %S."
          (Lib_name.to_string name)
          (Lib_name.to_string name')
      ]
  ;;

  let missing_parameter_inline_tests ~loc p =
    let name = Lib_name.to_string (Lib_info.name p) in
    make_resolve
      ~loc
      [ Pp.textf "To run the inline tests, please provide the missing parameter %S." name
      ]
      ~hints:
        [ Pp.textf
            "Add (arguments ...) to the inline_tests to specify which implementation of \
             the parameter %S to use."
            name
        ]
  ;;

  let missing_parameter_depends ~loc p =
    let name = Lib_name.to_string (Lib_info.name p) in
    make_resolve
      ~loc
      [ Pp.textf "Missing argument for parameter %S." name ]
      ~hints:[ Pp.textf "Pass an argument implementing %S to the dependency." name ]
  ;;

  let missing_parameter ~from ~loc ~loc_param p =
    match from with
    | `depends -> missing_parameter_depends ~loc p
    | `inline_tests -> missing_parameter_inline_tests ~loc:loc_param p
  ;;

  let missing_implements ~loc p =
    let name = Lib_name.to_string (Lib_info.name p) in
    make_resolve
      ~loc
      [ Pp.textf "Library %S does not implement a library parameter." name ]
  ;;
end

(* Types *)

module Resolved_select = struct
  type t =
    { src_fn : Path.Local.t Resolve.t
    ; dst_fn : Path.Local.t
    ; loc : Loc.t
    }
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 Resolve.Memo.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 =
    { path : Path.t
    ; name : Lib_name.t
    }

  val to_dep_path_lib : t -> Dep_path.Entry.Lib.t
  val compare : t -> t -> Ordering.t
  val hash : t -> int

  include Comparator.OPS with type t := t

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

  include Comparable_intf.S with type key := t

  module Top_closure :
    Top_closure with type key := t and type 'a monad := 'a Resolve.Memo.t
end = struct
  module T = struct
    type t =
      { path : Path.t
      ; name : Lib_name.t
      }

    let compare { path; name } t =
      match Lib_name.compare name t.name with
      | Eq -> Path.compare path t.path
      | x -> x
    ;;

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

  include T

  let hash = Poly.hash
  let to_dep_path_lib { path; name } = { Dep_path.Entry.Lib.path; name }

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

  let make ~path ~name = { path; name }

  include Comparable.Make (T)
  module Top_closure = Top_closure.Make (Set) (Resolve.Memo)
end

module T = struct
  type t =
    { info : Lib_info.external_
    ; name : Lib_name.t
    ; unique_id : Id.t
    ; re_exports : t list Resolve.t Compilation_mode.By_mode.t
    ; (* [requires] is contains all required libraries, including the ones
         mentioned in [re_exports]. *)
      requires : t list Resolve.t Compilation_mode.By_mode.t
    ; user_written_requires : (Loc.t * t) list Resolve.Memo.t Compilation_mode.By_mode.t
    ; ppx_runtime_deps : t list Resolve.t Compilation_mode.By_mode.t
    ; pps : t list Resolve.t Compilation_mode.By_mode.t
    ; resolved_selects : Resolved_select.t list Resolve.t Compilation_mode.By_mode.t
    ; allow_unused_libraries : t list Resolve.t
    ; parameters : (Loc.t * t) list Resolve.t
    ; arguments : t option list
    ; implements : t Resolve.t option
    ; project : Dune_project.t option
    ; (* these fields cannot be forced until the library is instantiated *)
      default_implementation : t Resolve.t Memo.Lazy.t option
    ; sub_systems : Sub_system0.Instance.t Memo.Lazy.t Sub_system_name.Map.t
    }

  let rec compare (x : t) (y : t) =
    match Id.compare x.unique_id y.unique_id with
    | (Lt | Gt) as cmp -> cmp
    | Eq -> compare_arguments x y

  and compare_arguments a b =
    List.compare a.arguments b.arguments ~compare:(Option.compare compare)
  ;;

  let to_dyn t =
    Dyn.record
      [ "name", Lib_name.to_dyn t.name; "loc", Loc.to_dyn_hum (Lib_info.loc t.info) ]
  ;;
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 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_exists_if pkg =
    let info = Dune_package.Lib.info pkg in
    let path = Lib_info.src_dir info in
    { lib = info; reason = "unsatisfied 'exists_if'"; path }
  ;;
end

module Status = struct
  type t =
    | Found of lib
    | Not_found
    | Hidden of lib Hidden.t
    | Invalid of User_message.t
    | Ignore

  let to_dyn t =
    let open Dyn in
    match t with
    | Invalid e -> variant "Invalid" [ Dyn.string (User_message.to_string e) ]
    | Not_found -> variant "Not_found" []
    | Hidden { lib = _; path; reason } ->
      variant "Hidden" [ Path.to_dyn path; string reason ]
    | Found t -> variant "Found" [ to_dyn t ]
    | Ignore -> variant "Ignore" []
  ;;
end

type db =
  { parent : db option
  ; resolve : Lib_name.t -> resolve_result list Memo.t
  ; resolve_lib_id : Lib_id.t -> resolve_result Memo.t
  ; instantiate :
      (Lib_name.t -> Path.t Lib_info.t -> hidden:string option -> Status.t Memo.t) Lazy.t
  ; all : Lib_name.t list Memo.Lazy.t
  ; instrument_with : Lib_name.t list
  }

and resolve_result =
  | Not_found
  | Found of Lib_info.external_
  | Hidden of Lib_info.external_ Hidden.t
  | Invalid of User_message.t
  | Ignore
  | Redirect_in_the_same_db of (Loc.t * Lib_name.t)
  | Redirect_by_name of db * (Loc.t * Lib_name.t)
  | Redirect_by_id of db * Lib_id.t

let name t = t.name
let info t = t.info
let project t = t.project
let implements t = Option.map ~f:Memo.return t.implements
let parameters t = Resolve.Memo.lift (Resolve.map ~f:(List.map ~f:snd) t.parameters)
let requires t ~for_ = Memo.return (Compilation_mode.By_mode.get ~for_ t.requires)
let re_exports t ~for_ = Memo.return (Compilation_mode.By_mode.get ~for_ t.re_exports)

let ppx_runtime_deps t ~for_ =
  Memo.return (Compilation_mode.By_mode.get ~for_ t.ppx_runtime_deps)
;;

let pps t ~for_ = Memo.return (Compilation_mode.By_mode.get ~for_ t.pps)

let is_local t =
  match Lib_info.obj_dir t.info |> Obj_dir.byte_dir with
  | External _ -> false
  | In_source_tree _ -> true
  | In_build_dir dir ->
    (match Path.Build.extract_build_context dir with
     | None -> true
     | Some (name, _) ->
       not (Context_name.equal (Context_name.of_string name) Private_context.t.name))
;;

let resolve_main_module_name t =
  let open Resolve.O in
  match Lib_info.main_module_name t.info with
  | This mmn -> Resolve.return mmn
  | From _ ->
    let+ impl = Option.value_exn t.implements in
    (match Lib_info.kind impl.info with
     | Parameter -> Lib_info.local_main_module_name t.info
     | Virtual ->
       (match Lib_info.main_module_name impl.info with
        | This x -> x
        | From _ -> assert false)
     | Dune_file _ -> Code_error.raise "expected implementation" [ "lib", to_dyn t ])
;;

let main_module_name t = Memo.return (resolve_main_module_name t)

module L = struct
  let top_closure l ~key ~deps =
    Id.Top_closure.top_closure l ~key:(fun t -> (key t).unique_id) ~deps
  ;;

  let project_root libs =
    Option.map ~f:Dune_project.root
    @@ List.fold_left libs ~init:None ~f:(fun acc lib ->
      let scope =
        let status = Lib_info.status lib.info in
        match status with
        | Private (scope_name, _) -> Some scope_name
        | Installed_private | Public _ | Installed -> None
      in
      Option.merge acc scope ~f:(fun a b ->
        assert (Dune_project.equal a b);
        a))
  ;;
end

module Parameterised = struct
  type status =
    | Not_parameterised
    | Partial
    | Complete

  let status t =
    match t.arguments with
    | [] -> Not_parameterised
    | _ ->
      let rec check_instantiate lib =
        List.for_all lib.arguments ~f:(function
          | None -> false
          | Some arg -> check_instantiate arg)
      in
      if check_instantiate t then Complete else Partial
  ;;

  let arguments t =
    List.map t.arguments ~f:(function
      | None -> Code_error.raise "expected complete application" [ "lib", to_dyn t ]
      | Some arg -> arg)
  ;;

  let parameterised_arguments t =
    let open Resolve.O in
    let+ parameters = t.parameters in
    List.map2 ~f:(fun (loc, param) arg -> loc, param, arg) parameters t.arguments
  ;;

  let apply_arguments t new_arguments =
    (* The [new_arguments] are expected to be sorted in the same [parameter]
       order as the existing arguments of [t], such that a linear in-order
       traversal allow filling any unset parameter to the new argument. *)
    match t.arguments with
    | [] -> Resolve.return t
    | _ ->
      let open Resolve.O in
      let rec go acc existing' given' =
        match existing', given' with
        | [], _ ->
          (* Ignore remaining arguments *)
          Resolve.return (List.rev acc)
        | (_, _, None) :: existing, [] ->
          (* Keep required parameter which are still unspecifed *)
          go (None :: acc) existing []
        | (_, _, Some arg) :: existing, _ ->
          (* Keep already applied parameter *)
          go (Some arg :: acc) existing given'
        | (_, param_intf, None) :: existing, (param_intf', arg) :: given ->
          (match compare param_intf param_intf' with
           | Eq ->
             (* Apply the argument to the unset parameter *)
             go (Some arg :: acc) existing given
           | Lt ->
             (* Keep the existing parameter as being unknown *)
             go (None :: acc) existing given'
           | Gt ->
             (* Skip unwanted argument *)
             go acc existing' given)
      in
      let* t_arguments = parameterised_arguments t in
      let+ arguments = go [] t_arguments new_arguments in
      { t with arguments }
  ;;

  let make_argument (loc, arg) =
    let open Resolve.O in
    let* arg = arg in
    let+ param =
      match arg.implements with
      | Some param -> param
      | None -> Error.missing_implements ~loc arg.info
    in
    param, arg
  ;;

  let make_arguments arguments =
    let open Resolve.O in
    let+ arguments = Resolve.List.map arguments ~f:make_argument in
    List.sort arguments ~compare:(fun (param, _) (param', _) -> compare param param')
  ;;

  let instantiate ~loc ~from lib args ~parent_parameters =
    let open Resolve.O in
    let* args = make_arguments args in
    let* lib = apply_arguments lib args in
    let+ () =
      let* all_args = parameterised_arguments lib in
      let is_inherited param =
        List.exists parent_parameters ~f:(fun (_, parent_param) ->
          equal param parent_param)
      in
      Resolve.List.iter all_args ~f:(function
        | loc_param, param, None when not (is_inherited param) ->
          Error.missing_parameter ~from ~loc ~loc_param param.info
        | _ -> Resolve.return ())
    in
    lib
  ;;

  let complement_arguments ~parent dep =
    match dep.arguments with
    | [] -> Resolve.return dep
    | _ ->
      let open Resolve.O in
      let* parent_arguments = parameterised_arguments parent in
      let parent_arguments =
        List.filter_map parent_arguments ~f:(fun (_loc, param, opt_arg) ->
          Option.map opt_arg ~f:(fun arg -> param, arg))
      in
      let* arguments =
        Resolve.List.map dep.arguments ~f:(fun opt_arg ->
          match opt_arg with
          | None -> Resolve.return None
          | Some arg ->
            let+ arg = apply_arguments arg parent_arguments in
            Some arg)
      in
      apply_arguments { dep with arguments } parent_arguments
  ;;

  let remove_arguments lib = { lib with parameters = Resolve.return []; arguments = [] }

  let requires (lib : lib) ~for_ =
    let open Resolve.O in
    let+ deps =
      Compilation_mode.By_mode.get lib.requires ~for_
      >>= Resolve.List.map ~f:(complement_arguments ~parent:lib)
    in
    let deps = List.filter_opt lib.arguments @ deps in
    match lib.arguments with
    | [] -> deps
    | _ -> remove_arguments lib :: deps
  ;;

  let scope t =
    let rec all t =
      let args = arguments t |> List.concat_map ~f:all in
      t :: args
    in
    L.project_root (all t) |> Parameterised_name.Scope.encode
  ;;

  let parameterised_name t =
    let rec parameterised_name t =
      let args = arguments t |> List.map ~f:parameterised_name in
      { Parameterised_name.name = name t; args }
    in
    Parameterised_name.to_string (parameterised_name t)
  ;;

  let dir ~build_dir t =
    let parameterised_dir =
      Path.Build.(relative build_dir Dune_lang.Oxcaml.parameterised_dir)
    in
    let scoped_dir = Path.Build.relative parameterised_dir (scope t) in
    Path.Build.relative scoped_dir (Lib_name.to_string (name t))
  ;;

  let info ~build_dir ~ext_lib t =
    match status t with
    | Not_parameterised | Partial -> None
    | Complete ->
      let parameterised_dir = dir ~build_dir t in
      let dir = Path.Build.relative parameterised_dir (parameterised_name t) in
      Some (Lib_info.for_instance ~dir ~ext_lib t.info)
  ;;

  let rec for_instance ~build_dir ~ext_lib t =
    match info ~build_dir ~ext_lib t with
    | None -> remove_arguments t
    | Some info ->
      let arguments =
        List.map t.arguments ~f:(function
          | None -> None
          | Some arg -> Some (for_instance ~build_dir ~ext_lib arg))
      in
      { t with info = Lib_info.of_local info; arguments }
  ;;

  let rec applied_modules t = arguments t |> Resolve.List.map ~f:applied_name

  and applied_name t =
    let open Resolve.O in
    resolve_main_module_name t
    >>= function
    | None -> Code_error.raise "library missing main module name" [ "lib", to_dyn t ]
    | Some name ->
      let+ args = applied_modules t in
      { Parameterised_name.name; args }
  ;;
end

let wrapped t =
  match Lib_info.wrapped t.info with
  | None -> Resolve.Memo.return None
  | Some (This wrapped) -> Resolve.Memo.return (Some wrapped)
  | Some (From _) ->
    let+ impl = Memo.return (Option.value_exn t.implements) in
    (match Lib_info.kind impl.info with
     | Parameter ->
       (* A parameter is an unwrapped Singleton, but its implementation
          should be wrapped. *)
       Some (Wrapped.Simple true)
     | Virtual ->
       (match Lib_info.wrapped impl.info 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)
     | Dune_file _ ->
       Code_error.raise "expected Parameter or Virtual for implements" [ "lib", to_dyn t ])
;;

(* We can't write a structural equality because of all the lazy fields *)
let equal a b = Ordering.is_eq (compare a b)
let hash x = Id.hash x.unique_id

include Comparable.Make (T)

(* 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 Resolve.Memo.t)
      -> get:(loc:Loc.t -> lib -> t option Memo.t)
      -> lib
      -> Info.t
      -> t Memo.t

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

  module type S' = sig
    include S

    val for_instance : t Sub_system0.s
    val get : lib -> t option Memo.t
  end

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

  module Register (M : S) = struct
    let get lib =
      let open Memo.O in
      match Sub_system_name.Map.find lib.sub_systems M.Info.name with
      | None -> Memo.return None
      | Some sub ->
        let+ (Sub_system0.Instance.T ((module X), t)) = Memo.Lazy.force sub in
        (match X.T t with
         | M.T t -> Some 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
      Table.set all M.Info.name (module M : S')
    ;;
  end

  let instantiate name info lib ~resolve =
    let open Memo.O in
    let impl = Table.find_exn 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
      let+ inst = M.instantiate ~resolve ~get lib info in
      Sub_system0.Instance.T (M.for_instance, inst)
    | _ -> assert false
  ;;

  let public_info =
    let open Memo.O in
    (* TODO this should continue using [Resolve]. Not doing so
       will prevent generating the [dune-package] rule if the sub system is
       missing *)
    let module M = Memo.Make_parallel_map (Sub_system_name.Map) in
    fun lib ->
      M.parallel_map lib.sub_systems ~f:(fun _name inst ->
        let* (Sub_system0.Instance.T ((module M), t)) = Memo.Lazy.force inst in
        match M.public_info with
        | None -> Memo.return None
        | Some f ->
          let+ info = Resolve.Memo.read_memo (f t) in
          Some (M.Info.T info))
      >>| Sub_system_name.Map.filter_opt
  ;;
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 : sig
  type t

  val to_required_by : t -> Dep_path.Entry.t list
  val empty : t

  module Implements_via : sig
    type t = Default_for of Id.t
  end

  val push : t -> implements_via:Implements_via.t option -> lib -> t Resolve.Memo.t
end = 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 : Set.t
    }

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

  let to_required_by t =
    List.map t.stack ~f:(fun ({ Id.path; name; _ } as id) ->
      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
      { Dep_path.Entry.lib = { path; name }; implements_via })
  ;;

  let dependency_cycle t (last : lib) =
    assert (Set.mem t.seen last);
    let last = last.unique_id in
    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 push (t : t) ~implements_via (x : lib) =
    if 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.unique_id via
      in
      Resolve.Memo.return
        { stack = x.unique_id :: t.stack; seen = Set.add t.seen x; implements_via })
  ;;
end

type private_deps =
  | From_same_project of [ `Public | `Private_package ]
  | Allow_all

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

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
    -> [ `Compile | `Link | `Partial_link ]
    -> for_:Compilation_mode.t
    -> t list Resolve.Memo.t

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

    val empty : t
    val add : t -> lib -> t Resolve.Memo.t
    val with_default_implementations : t -> lib list
  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 =
      match lib.implements, Lib_info.virtual_ lib.info with
      | None, false -> Resolve.Memo.return t
      | Some _, true -> assert false (* can't be virtual and implement *)
      | None, true ->
        Resolve.Memo.return
          (if Set.mem t.implemented lib
           then t
           else { t with unimplemented = Set.add t.unimplemented lib })
      | Some vlib, false ->
        let+ vlib = Memo.return 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 : t Resolve.Memo.t =
        let rec loop acc = function
          | [] -> Resolve.Memo.return acc
          | (lib, stack) :: libs ->
            (match lib.implements, Lib_info.kind lib.info with
             | None, (Dune_file _ | Parameter) -> loop acc libs
             | None, Virtual -> loop (Map.set acc lib (No_impl stack)) libs
             | Some _, (Parameter | Virtual) ->
               assert false (* can't be virtual and implement *)
             | Some impl, Dune_file _ ->
               let* impl = Memo.return impl in
               (match Lib_info.kind impl.info with
                | Parameter -> loop acc libs
                | Virtual ->
                  (match Map.find acc impl 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 impl (Impl (lib, stack))) libs
                   | Some (Impl (lib', stack')) ->
                     let req_by' = Dep_stack.to_required_by stack' in
                     let req_by = Dep_stack.to_required_by stack in
                     Error.double_implementation
                       (lib'.info, req_by')
                       (lib.info, req_by)
                       ~vlib:impl.info)
                | Dune_file _ ->
                  Code_error.raise
                    "implements expected Virtual or Parameter"
                    [ "lib", to_dyn lib ]))
        in
        loop Map.empty closure
      ;;
    end

    type t = lib Map.t

    let make impls ~allow_partial : t Resolve.Memo.t =
      let rec loop acc = function
        | [] -> Resolve.Memo.return acc
        | (vlib, Partial.No_impl stack) :: libs ->
          let rb = Dep_stack.to_required_by stack in
          if allow_partial then loop acc libs else 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 =
    let module R = struct
      module M =
        State.Make
          (struct
            type t = lib list * Set.t
          end)
          (Resolve.Memo)

      module List = Monad.List (M)
      include M
    end
    in
    let open R.O in
    fun ts impls ~for_ ->
      let rec loop t =
        let t = Option.value ~default:t (Map.find impls t) in
        let* res, visited = R.get in
        if Set.mem visited t
        then R.return ()
        else
          let* () = R.set (res, Set.add visited t) in
          let* deps = R.lift (Resolve.Memo.lift (Parameterised.requires t ~for_)) in
          let* () = many deps in
          R.modify (fun (res, visited) -> t :: res, visited)
      and many deps = R.List.iter deps ~f:loop in
      let open Resolve.Memo.O in
      let+ (res, _visited), () = R.run (many ts) ([], Set.empty) in
      List.rev res
  ;;

  let associate closure kind ~for_ =
    let linking, allow_partial =
      match kind with
      | `Compile -> false, true
      | `Partial_link -> true, true
      | `Link -> true, false
    in
    let* impls = Table.Partial.make closure in
    let closure = List.map closure ~f:fst in
    if linking && not (Table.Partial.is_empty impls)
    then
      let* impls = Table.make impls ~allow_partial in
      second_step_closure closure impls ~for_
    else Resolve.Memo.return closure
  ;;
end

let instrumentation_backend instrument_with resolve libname =
  if not (List.mem ~equal:Lib_name.equal instrument_with (snd libname))
  then Resolve.Memo.return None
  else
    let* lib = resolve libname in
    match lib |> info |> Lib_info.instrumentation_backend with
    | Some _ as ppx -> Resolve.Memo.return ppx
    | None ->
      Resolve.Memo.fail
        (User_error.make
           ~loc:(fst libname)
           [ Pp.textf
               "Library %S is not declared to have an instrumentation backend."
               (Lib_name.to_string (snd libname))
           ])
;;

module Resolve_names : sig
  val find_internal : db -> Lib_name.t -> Status.t Memo.t
  val resolve_lib_id : db -> Lib_id.t -> Status.t Memo.t
  val available_internal : db -> Lib_name.t -> bool Memo.t
  val available_by_lib_id_internal : db -> Lib_id.t -> bool Memo.t

  val resolve_simple_deps
    :  db
    -> (Loc.t * Lib_name.t) list
    -> private_deps:private_deps
    -> t list Resolve.Memo.t

  module Resolved : sig
    type deps =
      { resolved : (Loc.t * t) list Resolve.t
      ; selects : Resolved_select.t list
      ; re_exports : (Loc.t * t) list Resolve.t
      }

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

    val user_written : deps -> (Loc.t * lib) list Resolve.t
  end

  val resolve_complex_deps
    :  db
    -> Lib_dep.t list
    -> private_deps:private_deps
    -> parameters:(Loc.t * lib) list
    -> for_:Compilation_mode.t
    -> Resolved.deps Memo.t

  val resolve_deps_and_add_runtime_deps
    :  db
    -> Lib_dep.t list
    -> private_deps:private_deps
    -> parameters:(Loc.t * t) list
    -> pps:(Loc.t * Lib_name.t) list
    -> dune_version:Dune_lang.Syntax.Version.t option
    -> for_:Compilation_mode.t
    -> Resolved.t Memo.t

  val compile_closure_with_overlap_checks
    :  db option
    -> lib list
    -> forbidden_libraries:Loc.t Map.t
    -> for_:Compilation_mode.t
    -> lib list Resolve.Memo.t

  val linking_closure_with_overlap_checks
    :  db option
    -> lib list
    -> forbidden_libraries:Loc.t Map.t
    -> for_:Compilation_mode.t
    -> lib list Resolve.Memo.t

  val make_instantiate
    :  db Lazy.t
    -> (Lib_name.t -> Path.t Lib_info.t -> hidden:string option -> Status.t Memo.t)
         Staged.t
end = struct
  let projects_by_package =
    Memo.lazy_ (fun () ->
      let open Memo.O in
      Dune_load.projects ()
      >>| List.concat_map ~f:(fun project ->
        Dune_project.including_hidden_packages project
        |> Package.Name.Map.to_list_map ~f:(fun _ (pkg : Package.t) ->
          let name = Package.name pkg in
          name, project))
      >>| Package.Name.Map.of_list_exn)
  ;;

  module Resolved = struct
    type deps =
      { resolved : (Loc.t * t) list Resolve.t
      ; selects : Resolved_select.t list
      ; re_exports : (Loc.t * t) list Resolve.t
      }

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

    let user_written { resolved; selects = _; re_exports } =
      let open Resolve.O in
      let+ resolved = resolved
      and+ re_exports = re_exports in
      resolved @ re_exports
      |> List.map ~f:(fun (loc, lib) -> lib, loc)
      |> Map.of_list_multi
      |> Map.to_list_map ~f:(fun lib locs ->
        let loc = List.hd locs in
        loc, lib)
    ;;
  end

  module Resolved_builder : sig
    type t

    val empty : t
    val add_resolved : t -> Loc.t -> lib Resolve.t -> t
    val add_re_exports : t -> Loc.t -> lib Resolve.t -> t
    val add_select : t -> (Loc.t * lib) list Resolve.t -> Resolved_select.t -> t
    val value : t -> Resolved.deps
  end = struct
    open Resolve.O

    type nonrec t = Resolved.deps

    let empty =
      { Resolved.resolved = Resolve.return []
      ; selects = []
      ; re_exports = Resolve.return []
      }
    ;;

    let add_resolved_list t resolved =
      let resolved =
        let+ resolved = resolved
        and+ tl = t.Resolved.resolved in
        List.rev_append resolved tl
      in
      { t with Resolved.resolved }
    ;;

    let add_select (t : t) resolved select =
      add_resolved_list
        { t with Resolved.selects = select :: t.Resolved.selects }
        resolved
    ;;

    let add_resolved t loc resolved =
      add_resolved_list
        t
        (let+ resolved = resolved in
         [ loc, resolved ])
    ;;

    let add_re_exports (t : t) loc lib =
      let re_exports =
        let+ hd = lib
        and+ tl = t.Resolved.re_exports in
        (loc, hd) :: tl
      in
      add_resolved { t with Resolved.re_exports } loc lib
    ;;

    let value { Resolved.resolved; selects; re_exports } =
      let resolved =
        let+ resolved = resolved in
        List.rev resolved
      in
      let re_exports =
        let+ re_exports = re_exports in
        List.rev re_exports
      in
      { Resolved.resolved; selects; re_exports }
    ;;
  end

  module Input = struct
    type t = Lib_name.t * Path.t Lib_info.t * string option

    let equal (lib_name, info, _) (lib_name', info', _) =
      let lib_id = Lib_info.lib_id info
      and lib_id' = Lib_info.lib_id info' in
      Lib_name.equal lib_name lib_name' && Lib_id.equal lib_id lib_id'
    ;;

    let hash (x, _, _) = Lib_name.hash x
    let to_dyn = Dyn.opaque
  end

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

  module Closure = struct
    type nonrec t =
      { db : db option
      ; forbidden_libraries : Loc.t Map.t
      }

    let make ~db ~forbidden_libraries = { db; forbidden_libraries }

    module R = struct
      type state =
        { result : (lib * Dep_stack.t) list
        ; visited : Set.t
        ; unimplemented : Vlib.Unimplemented.t
        }

      let empty_state =
        { result = []; visited = Set.empty; unimplemented = Vlib.Unimplemented.empty }
      ;;

      module M =
        State.Make
          (struct
            type t = state
          end)
          (Resolve.Memo)

      module List = Monad.List (M)
      include M
    end

    let result computation kind ~for_ =
      let* state, () = R.run computation R.empty_state in
      Vlib.associate (List.rev state.result) kind ~for_
    ;;
  end

  let rec closure_visit (t : Closure.t) ~stack ~for_ (implements_via, (lib : lib)) =
    let open Closure in
    let open R.O in
    let* state = R.get in
    if Set.mem state.visited lib
    then R.return ()
    else (
      match Map.find t.forbidden_libraries lib with
      | Some loc ->
        let req_by = Dep_stack.to_required_by stack in
        R.lift
          (Error.make
             ~loc
             [ Pp.textf "Library %S was pulled in." (Lib_name.to_string lib.name)
             ; Dep_path.pp req_by
             ])
      | None ->
        let* () = R.set { state with visited = Set.add state.visited lib } in
        let* () =
          match t.db with
          | None -> R.return ()
          | Some db ->
            (match Lib_info.status lib.info with
             | Private (_, Some _) -> R.return ()
             | _ ->
               R.lift
                 (let open Memo.O in
                  find_internal db lib.name
                  >>= function
                  | Status.Found lib' ->
                    if Id.equal lib.unique_id lib'.unique_id
                    then Resolve.Memo.return ()
                    else (
                      let req_by = Dep_stack.to_required_by 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 = R.lift (Dep_stack.push stack ~implements_via lib) in
        let* deps = R.lift (Resolve.Memo.lift (Parameterised.requires lib ~for_)) in
        let* unimplemented' = R.lift (Vlib.Unimplemented.add state.unimplemented lib) in
        let* () = R.modify (fun state -> { state with unimplemented = unimplemented' }) in
        let* () =
          R.List.iter deps ~f:(fun l -> closure_visit t (None, l) ~stack:new_stack ~for_)
        in
        (match Parameterised.status lib with
         | Partial -> R.return ()
         | Not_parameterised | Complete ->
           R.modify (fun state -> { state with result = (lib, stack) :: state.result })))

  and resolve_parameters db ~private_deps info =
    let open Resolve.Memo.O in
    let* parameters =
      Resolve.Memo.List.filter_map (Lib_info.parameters info) ~f:(fun (loc, name) ->
        let* lib = Resolve.Memo.lift_memo (resolve_dep db ~private_deps (loc, name)) in
        match lib with
        | None -> Resolve.Memo.return None
        | Some lib ->
          let* lib = Resolve.Memo.lift lib in
          (match Lib_info.kind lib.info with
           | Parameter -> Resolve.Memo.return (Some (loc, name, lib))
           | Virtual | Dune_file _ -> Error.expected_parameter ~loc ~name))
    in
    let parameters =
      List.stable_sort parameters ~compare:(fun (_, _, a) (_, _, b) -> compare a b)
    in
    let rec check_duplicates = function
      | [] | [ _ ] -> Resolve.Memo.return ()
      | (_, name, p) :: (loc, name', p') :: _ when p = p' ->
        Error.duplicate_parameters ~loc name name'
      | _ :: ps -> check_duplicates ps
    in
    let+ () = check_duplicates parameters in
    List.map parameters ~f:(fun (loc, _, param) -> loc, param)

  and instantiate_impl db (name, info, hidden) =
    let db = Lazy.force db in
    let open Memo.O in
    let unique_id = Id.make ~name ~path:(Lib_info.src_dir info) in
    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 (_, None) | Installed -> Allow_all
      | Private (_, Some _) -> From_same_project `Private_package
      | Public (_, _) -> From_same_project `Public
    in
    let resolve name = resolve_dep db name ~private_deps in
    let resolve_forbid_ignore ((loc, _) as name) =
      resolve name
      >>| function
      | Some x -> x
      | None ->
        User_error.raise
          ~loc
          [ Pp.text
              "library does not exist but is automatically provided. It cannot be used \
               in this position."
          ]
    in
    let* parameters = resolve_parameters db ~private_deps info in
    let* resolved =
      let open Resolve.Memo.O in
      let* pps =
        let instrumentation_backend =
          instrumentation_backend db.instrument_with resolve_forbid_ignore
        in
        let modes = Compilation_mode.of_mode_set (Lib_info.modes info) in
        Memo.parallel_map modes.modes ~f:(fun for_ ->
          Lib_info.preprocess info ~for_
          |> Instrumentation.with_instrumentation ~instrumentation_backend
          >>| fun pps -> for_, Preprocess.Per_module.pps pps)
        |> Memo.map ~f:Resolve.all
        >>| Compilation_mode.By_mode.of_list ~init:[]
      in
      let* parameters = Resolve.Memo.lift parameters in
      let dune_version = Lib_info.dune_version info in
      let resolved =
        Compilation_mode.By_mode.map pps ~f:(fun ~for_ pps ->
          let open Memo.O in
          let+ resolved =
            Lib_info.requires info ~for_
            |> resolve_deps_and_add_runtime_deps
                 db
                 ~private_deps
                 ~parameters
                 ~dune_version
                 ~pps
                 ~for_
          in
          resolved)
      in
      let open Memo.O in
      let+ ocaml = resolved.ocaml
      and+ melange = resolved.melange in
      Resolve.return { Compilation_mode.By_mode.ocaml; melange }
    in
    let* implements =
      match Lib_info.implements info with
      | None -> Memo.return None
      | Some ((loc, _) as name) ->
        let res =
          let open Resolve.Memo.O in
          let* implements = resolve_forbid_ignore name in
          match Lib_info.kind implements.info with
          | Dune_file _ ->
            Error.not_implementable ~loc ~lib:info ~not_impl:implements.info
          | Parameter | Virtual -> Resolve.Memo.return implements
        in
        Memo.map res ~f:Option.some
    in
    let resolve_impl impl_name =
      let open Resolve.Memo.O in
      let* impl = resolve_forbid_ignore impl_name in
      let* vlib =
        match impl.implements with
        | Some vlib -> Memo.return vlib
        | None -> Error.not_an_implementation_of ~vlib:info ~impl:impl.info
      in
      if Id.equal vlib.unique_id unique_id
      then Resolve.Memo.return 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 ->
        Memo.lazy_ (fun () ->
          let open Resolve.Memo.O in
          let* impl = resolve_impl l in
          match Lib_info.package impl.info with
          | None -> Resolve.Memo.return 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. *)
               Resolve.Memo.return 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 Resolve.Memo.return impl
               else
                 Error.make
                   ~loc
                   [ Pp.textf
                       "default implementation belongs to package %s while virtual \
                        library belongs to package %s. This is impossible."
                       (Package.Name.to_string p)
                       (Package.Name.to_string p')
                   ])))
    in
    let* requires =
      Compilation_mode.By_mode.Memo.from_fun (fun ~for_ ->
        let open Resolve.Memo.O in
        let* resolved = Memo.return resolved in
        let { Resolved.requires; _ } = Compilation_mode.By_mode.get ~for_ resolved in
        let* requires = Memo.return requires in
        let+ requires_params = Memo.return parameters
        and+ requires_implements =
          match implements with
          | None -> Resolve.Memo.return []
          | Some impl ->
            let* impl = Memo.return impl in
            (match Lib_info.kind impl.info with
             | Parameter -> Resolve.Memo.return [ impl ]
             | Virtual ->
               let requires_for_closure_check =
                 List.filter requires ~f:(fun lib -> not (equal lib impl))
               in
               let+ () =
                 check_forbidden
                   requires_for_closure_check
                   ~forbidden_libraries:(Map.singleton impl Loc.none)
                   ~for_
               in
               [ impl ]
             | Dune_file _ ->
               Code_error.raise
                 "expected Virtual or Parameter"
                 [ "implements", to_dyn impl ])
        in
        let requires_params = List.map ~f:snd requires_params in
        let requires = List.concat [ requires_implements; requires_params; requires ] in
        let (_ : Set.t), requires =
          List.fold_left requires ~init:(Set.empty, []) ~f:(fun (seen, lst) lib ->
            if Set.mem seen lib then seen, lst else Set.add seen lib, lib :: lst)
        in
        List.rev requires)
    in
    let* ppx_runtime_deps =
      let ppx_runtime_deps = Lib_info.ppx_runtime_deps info in
      Compilation_mode.By_mode.Memo.from_fun (fun ~for_ ->
        let deps = Compilation_mode.By_mode.get ppx_runtime_deps ~for_ in
        resolve_simple_deps db ~private_deps deps)
    in
    let user_written_requires =
      Compilation_mode.By_mode.from_fun (fun ~for_ ->
        let open Memo.O in
        let+ complex =
          Lib_info.requires info ~for_
          |> resolve_complex_deps db ~private_deps ~parameters:[] ~for_
        in
        Resolved.user_written complex)
    in
    let* allow_unused_libraries =
      Lib_info.allow_unused_libraries info |> resolve_simple_deps db ~private_deps
    in
    let src_dir = Lib_info.src_dir info in
    let map_error =
      Compilation_mode.By_mode.map ~f:(fun ~for_:_ x ->
        Resolve.push_stack_frame x ~human_readable_description:(fun () ->
          Dep_path.Entry.Lib.pp { name; path = src_dir }))
    in
    let requires = map_error requires in
    let ppx_runtime_deps = map_error ppx_runtime_deps in
    let* project =
      match Lib_info.status info |> Lib_info.Status.project with
      | Some _ as project -> Memo.return project
      | None ->
        let+ projects_by_package = Memo.Lazy.force projects_by_package in
        let open Option.O in
        let* package = Lib_info.package info in
        Package.Name.Map.find projects_by_package package
    in
    let rec t =
      lazy
        (let resolved_selects =
           Compilation_mode.By_mode.from_fun (fun ~for_ ->
             let open Resolve.O in
             resolved >>| Compilation_mode.By_mode.get ~for_ >>| fun r -> r.selects)
         in
         let pps =
           Compilation_mode.By_mode.from_fun (fun ~for_ ->
             let open Resolve.O in
             resolved >>| Compilation_mode.By_mode.get ~for_ >>= fun r -> r.pps)
         in
         let re_exports =
           Compilation_mode.By_mode.from_fun (fun ~for_ ->
             let open Resolve.O in
             resolved >>| Compilation_mode.By_mode.get ~for_ >>= fun r -> r.re_exports)
         in
         { info
         ; name
         ; unique_id
         ; requires
         ; user_written_requires
         ; ppx_runtime_deps
         ; pps
         ; resolved_selects
         ; re_exports
         ; implements
         ; parameters
         ; arguments = List.map ~f:(fun _ -> None) (Lib_info.parameters info)
         ; allow_unused_libraries
         ; default_implementation
         ; project
         ; sub_systems =
             Sub_system_name.Map.mapi (Lib_info.sub_systems info) ~f:(fun name info ->
               Memo.Lazy.create (fun () ->
                 Sub_system.instantiate
                   name
                   info
                   (Lazy.force t)
                   ~resolve:resolve_forbid_ignore))
         })
    in
    let t = Lazy.force t in
    let+ res =
      let+ hidden =
        match hidden with
        | Some _ -> Memo.return hidden
        | None ->
          Lib_info.enabled info
          >>| (function
           | Normal -> None
           | Disabled_because_of_enabled_if -> Some "unsatisfied 'enabled_if'"
           | Optional ->
             (* TODO this could be made lazier *)
             let requires =
               List.for_all [ requires.ocaml; requires.melange ] ~f:Resolve.is_ok
             in
             let ppx_runtime_deps =
               List.for_all
                 [ t.ppx_runtime_deps.ocaml; t.ppx_runtime_deps.melange ]
                 ~f:Resolve.is_ok
             in
             if requires && ppx_runtime_deps
             then None
             else Some "optional with unavailable dependencies")
      in
      match hidden with
      | None -> Status.Found t
      | Some reason -> Hidden (Hidden.of_lib t ~reason)
    in
    res

  and make_instantiate db =
    let memo =
      Memo.create
        "db-instantiate"
        ~input:(module Input)
        (instantiate_impl db)
        ~human_readable_description:(fun (name, info, _hidden) ->
          Dep_path.Entry.Lib.pp { name; path = Lib_info.src_dir info })
    in
    Staged.stage (fun name info ~hidden -> Memo.exec memo (name, info, hidden))

  and instantiate db name info ~hidden = (Lazy.force db.instantiate) name info ~hidden

  and resolve_hidden db ~info hidden =
    let open Memo.O in
    (match db.parent with
     | None -> Memo.return Status.Not_found
     | Some db ->
       let lib_id = Lib_info.lib_id info in
       resolve_lib_id db lib_id)
    >>= function
    | Status.Found _ as x -> Memo.return x
    | _ ->
      let name = Lib_info.name info in
      instantiate db name info ~hidden:(Some hidden)

  and handle_resolve_result db ~super = function
    | Ignore -> Memo.return Status.Ignore
    | Redirect_in_the_same_db (_, name') -> find_internal db name'
    | Redirect_by_name (db', (_, name')) -> find_internal db' name'
    | Redirect_by_id (db', lib_id) -> resolve_lib_id db' lib_id
    | Found info ->
      let name = Lib_info.name info in
      instantiate db name info ~hidden:None
    | Invalid e -> Memo.return (Status.Invalid e)
    | Not_found ->
      (match db.parent with
       | None -> Memo.return Status.Not_found
       | Some db -> super db)
    | Hidden { lib = info; reason = hidden; path = _ } -> resolve_hidden db ~info hidden

  and handle_resolve_result_with_multiple_results db ~super = function
    | [] -> handle_resolve_result ~super db Not_found
    | [ r ] -> handle_resolve_result ~super db r
    | candidates ->
      let open Memo.O in
      Memo.parallel_map candidates ~f:(function
        | Ignore -> Memo.return (Some Status.Ignore)
        | Redirect_in_the_same_db (_, name') -> find_internal db name' >>| Option.some
        | Redirect_by_name (db', (_, name')) -> find_internal db' name' >>| Option.some
        | Redirect_by_id (db', lib_id) -> resolve_lib_id db' lib_id >>| Option.some
        | Found info ->
          Lib_info.enabled info
          >>= (function
           | Disabled_because_of_enabled_if -> Memo.return None
           | Normal | Optional ->
             let name = Lib_info.name info in
             instantiate db name info ~hidden:None >>| Option.some)
        | Invalid e -> Memo.return (Some (Status.Invalid e))
        | Not_found -> handle_resolve_result ~super db Not_found >>| Option.some
        | Hidden { lib = info; reason = hidden; path = _ } ->
          resolve_hidden db ~info hidden >>| Option.some)
      >>| List.filter_opt
      >>| (function
       | [] -> Status.Not_found
       | [ status ] -> status
       | libs ->
         List.fold_left libs ~init:Status.Not_found ~f:(fun acc status ->
           match acc, status with
           | Status.Found a, Status.Found b ->
             let a_id = Lib_info.lib_id a.info in
             let b_id = Lib_info.lib_id b.info in
             (match Lib_id.equal a_id b_id with
              | true -> acc
              | false ->
                let name =
                  if Lib_name.equal a.name b.name then a.name else Lib_id.name a_id
                and loc_a = Lib_info.loc a.info
                and loc_b = Lib_info.loc b.info in
                Status.Invalid (Error.duplicated ~loc_a ~loc_b ~name))
           | (Found _ as lib), _ | _, (Found _ as lib) -> lib
           | _, _ -> acc))

  and find_internal db (name : Lib_name.t) =
    let open Memo.O in
    let super db = find_internal db name in
    db.resolve name >>= handle_resolve_result_with_multiple_results ~super db

  and resolve_dep db (loc, name) ~private_deps : t Resolve.t option Memo.t =
    let open Memo.O in
    find_internal db name
    >>= function
    | Ignore -> Memo.return None
    | Found lib ->
      check_private_deps lib ~loc ~private_deps |> Resolve.Memo.of_result >>| Option.some
    | Not_found -> Error.not_found ~loc ~name >>| Option.some
    | Invalid why -> Resolve.Memo.of_result (Error why) >>| Option.some
    | Hidden h -> Hidden.error h ~loc ~name >>| Option.some

  and resolve_lib_id db lib_id =
    let open Memo.O in
    let super db = resolve_lib_id db lib_id in
    db.resolve_lib_id lib_id >>= handle_resolve_result ~super db

  and available_internal db (name : Lib_name.t) =
    let open Memo.O in
    find_internal db name
    >>| function
    | Ignore | Found _ -> true
    | Not_found | Invalid _ | Hidden _ -> false

  and available_by_lib_id_internal db (lib_id : Lib_id.t) =
    let open Memo.O in
    resolve_lib_id db lib_id
    >>| function
    | Ignore | Found _ -> true
    | Not_found | Invalid _ | Hidden _ -> false

  and resolve_simple_deps db names ~private_deps : t list Resolve.Memo.t =
    Resolve.Memo.List.filter_map names ~f:(fun dep ->
      let open Memo.O in
      resolve_dep db ~private_deps dep
      >>| function
      | None -> Resolve.return None
      | Some r -> Resolve.map r ~f:Option.some)

  and re_exports_closure ts ~for_ =
    let module R = struct
      module M =
        State.Make
          (struct
            type t = lib list * Set.t
          end)
          (Resolve.Memo)

      module List = Monad.List (M)
      include M
    end
    in
    let open R.O in
    let rec one (t : lib) =
      let* res, visited = R.get in
      if Set.mem visited t
      then R.return ()
      else
        let* () = R.set (res, Set.add visited t) in
        let* re_exports = R.lift (re_exports t ~for_) in
        let* () = many re_exports in
        R.modify (fun (res, visited) -> t :: res, visited)
    and many l = R.List.iter l ~f:one in
    let open Resolve.Memo.O in
    let+ (res, _visited), () = R.run (many ts) ([], Set.empty) in
    List.rev res

  and resolve_select db ~private_deps { Lib_dep.Select.result_fn; choices; loc } ~for_ =
    let open Memo.O in
    let resolve_set db ~private_deps libs ~for_ =
      resolve_simple_deps ~private_deps db libs
      |> Resolve.Memo.peek
      >>= function
      | Error () -> Memo.return None
      | Ok ts ->
        linking_closure_with_overlap_checks None ~forbidden_libraries:Map.empty ~for_ ts
        >>| Resolve.peek
        >>| (function
         | Error () -> None
         | Ok _closure -> Some ts)
    in
    let+ res, src_fn =
      let+ select =
        Memo.List.find_map choices ~f:(fun { required; forbidden; file } ->
          Lib_name.Set.to_list forbidden
          |> Memo.List.exists ~f:(fun set ->
            resolve_set db ~private_deps ~for_ [ loc, set ] >>| Option.is_some)
          >>= function
          | true -> Memo.return None
          | false ->
            let add_loc x = loc, x in
            Lib_name.Set.to_list_map required ~f:add_loc
            |> resolve_set db ~private_deps ~for_
            >>| Option.map ~f:(fun ts -> List.map ts ~f:add_loc, file))
      in
      let get which =
        match select |> Option.map ~f:which with
        | Some rs -> Resolve.return rs
        | None -> Error.no_solution_found_for_select ~loc
      in
      get fst, get snd
    in
    res, { Resolved_select.src_fn; dst_fn = result_fn; loc }

  and resolve_complex_deps db deps ~private_deps ~parameters ~for_ =
    let open Memo.O in
    let resolve_parameterised_dep (loc, lib) ~arguments =
      resolve_dep db (loc, lib) ~private_deps
      >>| Option.map ~f:(fun dep ->
        let open Resolve.O in
        let* dep = dep in
        Parameterised.instantiate
          ~loc
          ~from:`depends
          dep
          arguments
          ~parent_parameters:parameters)
    in
    Memo.List.fold_left ~init:Resolved_builder.empty deps ~f:(fun acc (dep : Lib_dep.t) ->
      match dep with
      | Re_export lib ->
        let loc = fst lib in
        resolve_parameterised_dep lib ~arguments:[]
        >>| (function
         | None -> acc
         | Some lib -> Resolved_builder.add_re_exports acc loc lib)
      | Direct lib ->
        let loc = fst lib in
        resolve_parameterised_dep lib ~arguments:[]
        >>| (function
         | None -> acc
         | Some lib -> Resolved_builder.add_resolved acc loc lib)
      | Select select ->
        let+ resolved, select = resolve_select db ~private_deps select ~for_ in
        Resolved_builder.add_select acc resolved select
      | Instantiate { loc; lib; arguments; new_name = _ } ->
        let* arguments =
          Memo.List.filter_map arguments ~f:(fun (loc, dep) ->
            resolve_parameterised_dep (loc, dep) ~arguments:[]
            >>| Option.map ~f:(fun dep -> loc, dep))
        in
        let acc =
          List.fold_left arguments ~init:acc ~f:(fun acc (_loc, dep) ->
            Resolved_builder.add_resolved acc loc dep)
        in
        resolve_parameterised_dep (loc, lib) ~arguments
        >>| (function
         | None -> acc
         | Some lib -> Resolved_builder.add_resolved acc loc lib))
    |> Memo.map ~f:Resolved_builder.value

  and pp_deps db pps ~dune_version ~private_deps ~for_ =
    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 = Resolve.Memo.return []; pps = Resolve.Memo.return [] }
    | 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 =
        Resolve.Memo.List.filter_map pps ~f:(fun (loc, name) ->
          let open Memo.O in
          resolve_dep db (loc, name) ~private_deps:Allow_all
          >>| function
          | None -> Resolve.return None
          | Some lib ->
            let open Resolve.O in
            let* lib = lib in
            (match allow_only_ppx_deps, Lib_info.kind lib.info with
             | true, Dune_file Normal -> Error.only_ppx_deps_allowed ~loc lib.info
             | _ -> Resolve.return (Some lib)))
        >>= linking_closure_with_overlap_checks None ~forbidden_libraries:Map.empty ~for_
      in
      let runtime_deps =
        let* pps = pps in
        Resolve.List.concat_map pps ~f:(fun pp ->
          let open Resolve.O in
          Compilation_mode.By_mode.get pp.ppx_runtime_deps ~for_
          >>= Resolve.List.map ~f:(fun dep ->
            check_private_deps ~loc ~private_deps dep |> Resolve.of_result))
        |> Memo.return
      in
      { runtime_deps; pps }

  and add_pp_runtime_deps
        db
        { Resolved.resolved; selects; re_exports }
        ~private_deps
        ~parameters
        ~pps
        ~dune_version
        ~for_
    : Resolved.t Memo.t
    =
    let { runtime_deps; pps } = pp_deps db pps ~dune_version ~private_deps ~for_ in
    let open Memo.O in
    let resolved = Resolve.map ~f:(List.map ~f:snd) resolved in
    let re_exports = Resolve.map ~f:(List.map ~f:snd) re_exports in
    let+ requires =
      let open Resolve.Memo.O in
      let* resolved = Memo.return resolved in
      let* runtime_deps = runtime_deps in
      let parameters = List.map ~f:snd parameters in
      re_exports_closure (List.concat [ resolved; runtime_deps; parameters ]) ~for_
    and+ pps = pps in
    { Resolved.requires; pps; selects; re_exports }

  and resolve_deps_and_add_runtime_deps
        db
        deps
        ~private_deps
        ~parameters
        ~pps
        ~dune_version
        ~for_
    =
    let open Memo.O in
    resolve_complex_deps db ~private_deps ~parameters deps ~for_
    >>= add_pp_runtime_deps db ~private_deps ~parameters ~dune_version ~pps ~for_

  (* 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. *)

  and resolve_default_libraries libraries ~for_ =
    (* Map from a vlib to vlibs that are implemented in the transitive closure
       of its default impl. *)
    let module R = struct
      type state =
        { vlib_default_parent : lib list Map.t
        ; visited : [ `Visiting | `Visited ] Map.t
        }

      module M =
        State.Make
          (struct
            type t = state
          end)
          (Resolve.Memo)

      module Option = Monad.Option (M)
      module List = Monad.List (M)
      include M

      let visit lib ~stack ~f =
        let open O in
        let* s = get in
        match Map.find s.visited lib with
        | Some `Visited -> return ()
        | Some `Visiting -> lift (Error.default_implementation_cycle (lib.info :: stack))
        | None ->
          let* () = set { s with visited = Map.set s.visited lib `Visiting } in
          let* res = f lib in
          let+ () =
            modify (fun s -> { s with visited = Map.set s.visited lib `Visited })
          in
          res
      ;;
    end
    in
    let avoid_direct_parent vlib (impl : lib) =
      match impl.implements with
      | None -> Resolve.Memo.return true
      | Some x ->
        let+ x = Memo.return x in
        x <> vlib
    in
    (* Either by variants or by default. *)
    let impl_for vlib =
      match vlib.default_implementation with
      | None -> Resolve.Memo.return None
      | Some d -> Resolve.Memo.map ~f:Option.some (Memo.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 vlib_default_parent lib =
      match Map.find vlib_default_parent lib with
      | Some (_ :: _) -> Resolve.Memo.return None
      | None | Some [] ->
        (match lib.default_implementation with
         | None -> Resolve.Memo.return None
         | Some default ->
           let open Memo.O in
           let* default = Memo.Lazy.force default in
           Resolve.Memo.return
             (match Resolve.peek 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 lib ~for_ =
      R.visit lib ~stack ~f:(fun lib ->
        let open R.O in
        (* Visit direct dependencies *)
        let* deps = R.lift (requires lib ~for_) in
        let* () =
          R.lift
            (Resolve.Memo.List.filter deps ~f:(fun x ->
               let open Memo.O in
               let+ peek = Resolve.Memo.peek (avoid_direct_parent x lib) in
               Resolve.return
                 (match peek with
                  | Ok x -> x
                  | Error () -> false)))
          >>= R.List.iter ~f:(visit ~stack:(lib.info :: stack) ancestor_vlib ~for_)
        in
        (* If the library is an implementation of some virtual library that
           overrides default, add a link in the graph. *)
        let* () =
          R.Option.iter lib.implements ~f:(fun vlib ->
            let* vlib = R.lift (Memo.return vlib) in
            let* res = R.lift (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 ~for_
            | true, Some ancestor ->
              let* () =
                R.modify (fun s ->
                  { s with
                    vlib_default_parent =
                      Map.Multi.cons s.vlib_default_parent lib ancestor
                  })
              in
              visit ~stack:(lib.info :: stack) None vlib ~for_
            | false, _ ->
              (* If lib is the default implementation, we'll manage it when
                 handling virtual lib. *)
              R.return ())
        in
        (* If the library has an implementation according to variants or
           default impl. *)
        match Lib_info.kind lib.info with
        | Dune_file _ -> R.return ()
        | Parameter | Virtual ->
          let* impl = R.lift (impl_for lib) in
          (match impl with
           | None -> R.return ()
           | Some impl -> visit ~stack:(lib.info :: stack) (Some lib) impl ~for_))
    in
    (* For each virtual library we know which vlibs will be implemented when
       enabling its default implementation. *)
    let* status, () =
      R.run
        (R.List.iter ~f:(visit ~stack:[] None ~for_) libraries)
        { visited = Map.empty; vlib_default_parent = Map.empty }
    in
    Resolve.Memo.List.filter_map
      libraries
      ~f:(library_is_default status.vlib_default_parent)

  and step1_closure db ts ~forbidden_libraries ~for_ =
    let closure = Closure.make ~db ~forbidden_libraries in
    ( closure
    , Closure.R.List.iter ts ~f:(fun lib ->
        closure_visit closure ~stack:Dep_stack.empty (None, lib) ~for_) )

  and compile_closure_with_overlap_checks db ts ~forbidden_libraries ~for_ =
    let (_ : Closure.t), state = step1_closure db ts ~forbidden_libraries ~for_ in
    Closure.result state `Compile ~for_

  and linking_closure_with_overlap_checks db ts ~forbidden_libraries ~for_ =
    let closure, state = step1_closure db ts ~forbidden_libraries ~for_ in
    let res =
      let open Closure.R.O in
      let rec impls_via_defaults () =
        let* defaults =
          let* state = Closure.R.get in
          Vlib.Unimplemented.with_default_implementations state.unimplemented
          |> resolve_default_libraries ~for_
          |> Closure.R.lift
        in
        match defaults with
        | _ :: _ -> fill_impls defaults
        | [] -> Closure.R.return ()
      and fill_impls libs =
        let* () =
          Closure.R.List.iter libs ~f:(fun (via, lib) ->
            closure_visit closure (Some via, lib) ~stack:Dep_stack.empty ~for_)
        in
        impls_via_defaults ()
      in
      state >>> impls_via_defaults ()
    in
    Closure.result res `Link ~for_

  and check_forbidden ts ~forbidden_libraries ~for_ =
    let (_ : Closure.t), state = step1_closure None ts ~forbidden_libraries ~for_ in
    let+ (_ : lib list) = Closure.result state `Partial_link ~for_ in
    ()
  ;;
end

let closure l ~linking =
  let forbidden_libraries = Map.empty in
  if linking
  then Resolve_names.linking_closure_with_overlap_checks None l ~forbidden_libraries
  else Resolve_names.compile_closure_with_overlap_checks None l ~forbidden_libraries
;;

let descriptive_closure (l : lib list) ~with_pps ~for_ : lib list Memo.t =
  (* [add_work todo l] adds the libraries in [l] to the list [todo],
     that contains the libraries to handle next *)
  let open Memo.O in
  let add_work todo l = if List.is_empty l then todo else l :: todo in
  (* [register_work todo l] reads the list of libraries [l] and adds
     them to the todo list [todo] *)
  let register_work todo l =
    match Resolve.peek l with
    | Error () -> Memo.return todo
    | Ok l -> Memo.return (add_work todo l)
  in
  (* [work todo acc] adds the transitive-reflexive closure of the
     libraries that are contained in the todo list [todo] and are not
     in the set of libraries [acc] to the initial set of libraries
     [acc] *)
  let rec work (todo : lib list list) (acc : Set.t) ~for_ =
    match todo with
    | [] -> Memo.return acc
    | [] :: todo -> work todo acc ~for_
    | (lib :: libs) :: todo ->
      if Set.mem acc lib
      then work (add_work todo libs) acc ~for_
      else (
        let todo = add_work todo libs
        and acc = Set.add acc lib in
        let* todo =
          if with_pps
          then register_work todo (Compilation_mode.By_mode.get ~for_:Ocaml lib.pps)
          else Memo.return todo
        in
        let* todo =
          register_work todo (Compilation_mode.By_mode.get lib.ppx_runtime_deps ~for_)
        in
        let* todo =
          let requires = Compilation_mode.By_mode.get lib.requires ~for_ in
          register_work todo requires
        in
        work todo acc ~for_)
  in
  (* we compute the transitive closure *)
  let+ trans_closure = work [ l ] Set.empty ~for_ in
  (* and then convert it to a list *)
  Set.to_list trans_closure
;;

module Compile = struct
  module Resolved_select = Resolved_select

  type nonrec t =
    { direct_requires : t list Resolve.Memo.t Compilation_mode.By_mode.t
    ; user_written_requires : (Loc.t * t) list Resolve.Memo.t Compilation_mode.By_mode.t
    ; requires_link : t list Resolve.t Memo.Lazy.t Compilation_mode.By_mode.t
    ; pps : t list Resolve.Memo.t Compilation_mode.By_mode.t
    ; resolved_selects : Resolved_select.t list Resolve.Memo.t Compilation_mode.By_mode.t
    ; allow_unused_libraries : t list Resolve.Memo.t
    ; sub_systems : Sub_system0.Instance.t Memo.Lazy.t Sub_system_name.Map.t
    }

  let for_lib ~allow_overlaps db (t : lib) =
    let requires =
      Compilation_mode.By_mode.map t.requires ~f:(fun ~for_:_ 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 -> Resolve.Memo.return ()
          | Some i ->
            let+ (_ : lib) = Memo.Lazy.force i in
            ()
        in
        Memo.return requires)
    in
    let requires_link : lib list Resolve.t Memo.Lazy.t Compilation_mode.By_mode.t =
      let db = Option.some_if (not allow_overlaps) db in
      Compilation_mode.By_mode.map requires ~f:(fun ~for_ requires ->
        Memo.lazy_ (fun () ->
          let open Resolve.Memo.O in
          requires
          >>= Resolve_names.compile_closure_with_overlap_checks
                db
                ~forbidden_libraries:Map.empty
                ~for_))
    in
    { direct_requires = requires
    ; user_written_requires = t.user_written_requires
    ; requires_link
    ; resolved_selects =
        Compilation_mode.By_mode.map t.resolved_selects ~f:(fun ~for_:_ -> Memo.return)
    ; pps = Compilation_mode.By_mode.map t.pps ~f:(fun ~for_:_ -> Memo.return)
    ; allow_unused_libraries = Memo.return t.allow_unused_libraries
    ; sub_systems = t.sub_systems
    }
  ;;

  let direct_requires t ~for_ = Compilation_mode.By_mode.get t.direct_requires ~for_

  let user_written_requires t ~for_ =
    Compilation_mode.By_mode.get t.user_written_requires ~for_
  ;;

  let requires_link t ~for_ = Compilation_mode.By_mode.get t.requires_link ~for_
  let resolved_selects t ~for_ = Compilation_mode.By_mode.get t.resolved_selects ~for_
  let pps t ~for_ = Compilation_mode.By_mode.get t.pps ~for_
  let allow_unused_libraries t = t.allow_unused_libraries

  let sub_systems t =
    Sub_system_name.Map.values t.sub_systems
    |> Memo.parallel_map ~f:(fun sub_system ->
      let open Memo.O in
      let+ (Sub_system0.Instance.T ((module M), t)) = Memo.Lazy.force sub_system in
      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 User_message.t
      | Ignore
      | Redirect_in_the_same_db of (Loc.t * Lib_name.t)
      | Redirect_by_name of db * (Loc.t * Lib_name.t)
      | Redirect_by_id of db * Lib_id.t

    let found f = Found f
    let not_found = Not_found
    let redirect_by_name db lib = Redirect_by_name (db, lib)
    let redirect_by_id db lib_id = Redirect_by_id (db, lib_id)
    let redirect_in_the_same_db lib = Redirect_in_the_same_db lib

    let to_dyn x =
      let open Dyn in
      match x with
      | Not_found -> variant "Not_found" []
      | Invalid e -> variant "Invalid" [ Dyn.string (User_message.to_string e) ]
      | Found lib -> variant "Found" [ Lib_info.to_dyn Path.to_dyn lib ]
      | Hidden h -> variant "Hidden" [ Hidden.to_dyn (Lib_info.to_dyn Path.to_dyn) h ]
      | Ignore -> variant "Ignore" []
      | Redirect_by_name (_, (_, name)) ->
        variant "Redirect_by_name" [ Lib_name.to_dyn name ]
      | Redirect_by_id (_, lib_id) -> variant "Redirect_by_id" [ Lib_id.to_dyn lib_id ]
      | Redirect_in_the_same_db (_, name) ->
        variant "Redirect_in_the_same_db" [ Lib_name.to_dyn name ]
    ;;
  end

  type t = db

  let create ~parent ~resolve ~resolve_lib_id ~all ~instrument_with () =
    let rec t =
      lazy
        { parent
        ; resolve
        ; resolve_lib_id
        ; all = Memo.lazy_ all
        ; instrument_with
        ; instantiate
        }
    and instantiate = lazy (Resolve_names.make_instantiate t |> Staged.unstage) in
    Lazy.force t
  ;;

  let create_from_findlib =
    let bigarray = Lib_name.of_string "bigarray" in
    fun findlib ~has_bigarray_library ->
      let resolve name =
        let open Memo.O in
        Findlib.find findlib name
        >>| function
        | Ok (Library pkg) -> [ Found (Dune_package.Lib.info pkg) ]
        | Ok (Deprecated_library_name d) ->
          [ Redirect_in_the_same_db (d.loc, d.new_public_name) ]
        | Ok (Hidden_library pkg) -> [ Hidden (Hidden.unsatisfied_exists_if pkg) ]
        | Error e ->
          [ (match e with
             | Invalid_dune_package why -> Invalid why
             | Not_found when (not has_bigarray_library) && Lib_name.equal name bigarray
               ->
               (* Recent versions of OCaml already include a [bigrray] library,
                  so we just silently ignore dependencies on it. The more
                  correct thing to do would be to redirect it to the stdlib,
                  but the stdlib isn't first class. *)
               Ignore
             | Not_found -> Not_found)
          ]
      in
      create
        ()
        ~parent:None
        ~resolve
        ~resolve_lib_id:(fun lib_id ->
          let open Memo.O in
          resolve (Lib_id.name lib_id) >>| List.hd)
        ~all:(fun () ->
          let open Memo.O in
          Findlib.all_packages findlib >>| List.map ~f:Dune_package.Entry.name)
  ;;

  let with_parent t ~parent = { t with parent }

  let of_paths context ~paths =
    let open Memo.O in
    let+ ocaml = Context.ocaml context
    and+ findlib = Findlib.create_with_paths (Context.name context) ~paths in
    create_from_findlib
      findlib
      ~has_bigarray_library:(Ocaml.Version.has_bigarray_library ocaml.version)
      ~instrument_with:(Context.instrument_with context)
  ;;

  let installed (context : Context.t) =
    let open Memo.O in
    let+ ocaml = Context.ocaml context
    and+ findlib = Findlib.create (Context.name context) in
    create_from_findlib
      findlib
      ~has_bigarray_library:(Ocaml.Version.has_bigarray_library ocaml.version)
      ~instrument_with:(Context.instrument_with context)
  ;;

  let find t name =
    let open Memo.O in
    Resolve_names.find_internal t name
    >>| function
    | Found t -> Some t
    | Ignore | Not_found | Invalid _ | Hidden _ -> None
  ;;

  let find_lib_id t lib_id =
    let open Memo.O in
    Resolve_names.resolve_lib_id t lib_id
    >>| function
    | Found t -> Some t
    | Ignore | Not_found | Invalid _ | Hidden _ -> None
  ;;

  let find_even_when_hidden t name =
    let open Memo.O in
    Resolve_names.find_internal t name
    >>| function
    | Found t | Hidden { lib = t; reason = _; path = _ } -> Some t
    | Ignore | Invalid _ | Not_found -> None
  ;;

  let find_lib_id_even_when_hidden t lib_id =
    let open Memo.O in
    Resolve_names.resolve_lib_id t lib_id
    >>| function
    | Found t | Hidden { lib = t; reason = _; path = _ } -> Some t
    | Ignore | Invalid _ | Not_found -> None
  ;;

  let resolve_when_exists t (loc, name) =
    let open Memo.O in
    Resolve_names.find_internal t name
    >>= function
    | Found t -> Memo.return @@ Some (Resolve.return t)
    | Invalid w -> Some (Resolve.of_result (Error w)) |> Memo.return
    | Ignore | Not_found -> None |> Memo.return
    | Hidden h ->
      let+ res = Hidden.error h ~loc ~name in
      Some res
  ;;

  let resolve t (loc, name) =
    let open Memo.O in
    resolve_when_exists t (loc, name)
    >>= function
    | None -> Error.not_found ~loc ~name
    | Some k -> Memo.return k
  ;;

  let available t name = Resolve_names.available_internal t name
  let available_by_lib_id t lib_id = Resolve_names.available_by_lib_id_internal t lib_id

  let get_compile_info t ~allow_overlaps lib_id =
    let open Memo.O in
    find_lib_id_even_when_hidden t lib_id
    >>| function
    | Some lib -> lib, Compile.for_lib ~allow_overlaps t lib
    | None ->
      Code_error.raise
        "Lib.DB.get_compile_info got library that doesn't exist"
        [ "lib_id", Lib_id.to_dyn lib_id ]
  ;;

  let resolve_user_written_deps
        t
        targets
        ~allow_overlaps
        ~forbidden_libraries
        deps
        ~allow_unused_libraries
        ~pps
        ~dune_version
    =
    let for_ =
      match targets with
      | `Melange_emit _name -> Compilation_mode.Melange
      | `Exe _ -> Ocaml
    in
    let resolved =
      Memo.lazy_ (fun () ->
        Resolve_names.resolve_deps_and_add_runtime_deps
          t
          deps
          ~pps
          ~parameters:[]
          ~private_deps:Allow_all
          ~dune_version:(Some dune_version)
          ~for_)
    in
    let requires_link : lib list Resolve.t Memo.Lazy.t Compilation_mode.By_mode.t =
      let requires_link =
        Memo.Lazy.create (fun () ->
          let* forbidden_libraries =
            Resolve.Memo.List.map forbidden_libraries ~f:(fun (loc, name) ->
              let+ lib = resolve t (loc, name) in
              lib, loc)
            >>| Map.of_list
            >>= function
            | Ok res -> Resolve.Memo.return res
            | Error (lib, _, loc) ->
              Error.make
                ~loc
                [ Pp.textf
                    "Library %S appears for the second time"
                    (Lib_name.to_string lib.name)
                ]
          and* res =
            let open Memo.O in
            let+ resolved = Memo.Lazy.force resolved in
            resolved.requires
          in
          Resolve.Memo.push_stack_frame
            (fun () ->
               Resolve_names.linking_closure_with_overlap_checks
                 (Option.some_if (not allow_overlaps) t)
                 ~forbidden_libraries
                 ~for_
                 res)
            ~human_readable_description:(fun () ->
              match targets with
              | `Melange_emit name -> Pp.textf "melange target %s" name
              | `Exe Nonempty_list.[ (loc, name) ] ->
                Pp.textf "executable %s in %s" name (Loc.to_file_colon_line loc)
              | `Exe (Nonempty_list.((loc, _) :: _) as names) ->
                Pp.textf
                  "executables %s in %s"
                  (String.enumerate_and
                     (Nonempty_list.map ~f:snd names |> Nonempty_list.to_list))
                  (Loc.to_file_colon_line loc)))
      in
      let init = Memo.lazy_ (fun () -> Resolve.Memo.return []) in
      Compilation_mode.By_mode.of_list ~init [ for_, requires_link ]
    in
    let pps : lib list Resolve.Memo.t Compilation_mode.By_mode.t =
      let pps =
        let open Memo.O in
        let+ resolved = Memo.Lazy.force resolved in
        resolved.pps
      in
      let init = Resolve.Memo.return [] in
      Compilation_mode.By_mode.of_list ~init [ for_, pps ]
    in
    let direct_requires : lib list Resolve.Memo.t Compilation_mode.By_mode.t =
      let direct_requires =
        let open Memo.O in
        let+ resolved = Memo.Lazy.force resolved in
        resolved.requires
      in
      let init = Resolve.Memo.return [] in
      Compilation_mode.By_mode.of_list ~init [ for_, direct_requires ]
    in
    let resolved_selects
      : Resolved_select.t list Resolve.Memo.t Compilation_mode.By_mode.t
      =
      let resolved_selects =
        let open Memo.O in
        let+ resolved = Memo.Lazy.force resolved in
        Resolve.return resolved.selects
      in
      let init = Resolve.Memo.return [] in
      Compilation_mode.By_mode.of_list ~init [ for_, resolved_selects ]
    in
    let allow_unused_libraries =
      Resolve_names.resolve_simple_deps t ~private_deps:Allow_all allow_unused_libraries
    in
    let user_written_requires
      : (Loc.t * lib) list Resolve.Memo.t Compilation_mode.By_mode.t
      =
      let resolved_user_written_requires =
        Memo.lazy_ (fun () ->
          Resolve_names.resolve_complex_deps
            t
            ~private_deps:Allow_all
            deps
            ~parameters:[]
            ~for_
          |> Memo.map ~f:Resolve_names.Resolved.user_written)
        |> Memo.Lazy.force
      in
      let init = Resolve.Memo.return [] in
      Compilation_mode.By_mode.of_list ~init [ for_, resolved_user_written_requires ]
    in
    { Compile.direct_requires
    ; user_written_requires
    ; requires_link
    ; pps
    ; resolved_selects
    ; allow_unused_libraries
    ; sub_systems = Sub_system_name.Map.empty
    }
  ;;

  (* 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_names.resolve_simple_deps t ~private_deps:Allow_all pps

  let rec all ?(recursive = false) t =
    let open Memo.O in
    let* l =
      Memo.Lazy.force t.all
      >>= Memo.parallel_map ~f:(find t)
      >>| List.filter_opt
      >>| Set.of_list
    in
    match recursive, t.parent with
    | true, Some t ->
      let+ parent = all ~recursive t in
      Set.union parent l
    | _ -> Memo.return l
  ;;

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

let to_resolve_memo
  :  lib list Resolve.t Compilation_mode.By_mode.t
  -> lib list Compilation_mode.By_mode.t Resolve.Memo.t
  =
  fun t ->
  let open Resolve.Memo.O in
  let+ ocaml = Resolve.Memo.lift t.ocaml
  and+ melange = Resolve.Memo.lift t.melange in
  { Compilation_mode.By_mode.ocaml; melange }
;;

let to_dune_lib
      ({ info; _ } as lib)
      ~modules
      ~foreign_objects
      ~melange_runtime_deps
      ~public_headers
      ~dir
  : Dune_package.Lib.t Resolve.Memo.t
  =
  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 =
    Compilation_mode.By_mode.map ~f:(fun ~for_:_ ->
      List.map ~f:(fun x -> loc, mangled_name x))
  in
  let obj_dir =
    match Lib_info.obj_dir lib.info |> Obj_dir.to_local with
    | None -> assert false
    | Some obj_dir ->
      let has_private_modules = Obj_dir.need_dedicated_public_dir obj_dir in
      Obj_dir.convert_to_external ~dir ~has_private_modules obj_dir
  in
  let modules =
    let install_dir = Obj_dir.dir obj_dir in
    Compilation_mode.By_mode.map modules ~f:(fun ~for_:_for_ modules ->
      Option.map modules ~f:(fun modules ->
        Modules.With_vlib.version_installed
          modules
          ~src_root:(Lib_info.src_dir lib.info)
          ~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 -> Resolve.Memo.return None
    | Some (loc, _), Some field ->
      let+ field = field in
      Some (loc, mangled_name field)
  in
  let open Memo.O in
  let* sub_systems = Sub_system.public_info lib in
  let open Resolve.Memo.O in
  let* main_module_name = main_module_name lib in
  let+ implements =
    use_public_name
      ~info_field:(Lib_info.implements info)
      ~lib_field:(Option.map ~f:Memo.return lib.implements)
  and+ parameters =
    let+ lib_parameters = Resolve.Memo.lift lib.parameters in
    List.map lib_parameters ~f:(fun (loc, param) -> loc, mangled_name param)
  and+ default_implementation =
    use_public_name
      ~info_field:(Lib_info.default_implementation info)
      ~lib_field:(Option.map ~f:Memo.Lazy.force lib.default_implementation)
  and+ ppx_runtime_deps = to_resolve_memo lib.ppx_runtime_deps
  and+ requires = to_resolve_memo lib.requires
  and+ re_exports = to_resolve_memo lib.re_exports in
  let ppx_runtime_deps = add_loc ppx_runtime_deps in
  let requires =
    Compilation_mode.By_mode.map requires ~f:(fun ~for_ requires ->
      List.map requires ~f:(fun lib ->
        if
          List.exists (Compilation_mode.By_mode.get re_exports ~for_) ~f:(fun r ->
            r = lib)
        then Lib_dep.Re_export (loc, mangled_name lib)
        else (
          match lib.arguments with
          | [] -> Direct (loc, mangled_name lib)
          | args ->
            Instantiate
              { loc
              ; lib = mangled_name lib
              ; arguments =
                  List.filter_map args ~f:(function
                    | None -> None
                    | Some arg -> Some (Loc.none, mangled_name arg))
              ; new_name = None
              })))
  in
  let name = mangled_name lib in
  let remove_public_dep_prefix paths =
    let prefix = Lib_info.src_dir lib.info in
    List.map paths ~f:(fun path -> Path.drop_prefix_exn ~prefix path |> Path.of_local)
  in
  let public_headers = remove_public_dep_prefix public_headers in
  let melange_runtime_deps = remove_public_dep_prefix melange_runtime_deps in
  let info =
    Lib_info.for_dune_package
      info
      ~name
      ~ppx_runtime_deps
      ~requires
      ~foreign_objects
      ~obj_dir
      ~implements
      ~parameters
      ~default_implementation
      ~sub_systems
      ~modules
      ~melange_runtime_deps
      ~public_headers
  in
  Dune_package.Lib.of_dune_lib ~info ~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

  include Comparable_intf.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
