install_uninstall.ml

open Import
module Artifact_substitution = Dune_rules.Artifact_substitution

let synopsis =
  [ `P "The installation directories used are defined by priority:"
  ; `Noblank
  ; `P
      "- directories set on the command line of $(i,dune install), or corresponding \
       environment variables"
  ; `Noblank
  ; `P
      "- directories set in dune binary. They are setup before the compilation of dune \
       with $(i,./configure)"
  ; `Noblank
  ; `P "- inferred from the environment variable $(i,OPAM_SWITCH_PREFIX) if present"
  ]
;;

let print_line ~(verbosity : Dune_engine.Display.t) fmt =
  Printf.ksprintf
    (fun s ->
      match verbosity with
      | Quiet -> ()
      | _ -> Console.print [ Pp.verbatim s ])
    fmt
;;

let interpret_destdir ~destdir path =
  match destdir with
  | None -> path
  | Some destdir -> Path.append_local destdir (Path.local_part path)
;;

let get_dirs context ~prefix_from_command_line ~from_command_line =
  let open Fiber.O in
  let module Roots = Install.Roots in
  let prefix_from_command_line = Option.map ~f:Path.of_string prefix_from_command_line in
  let+ roots =
    match prefix_from_command_line with
    | None -> Memo.run (Context.roots context)
    | Some prefix ->
      Roots.opam_from_prefix prefix ~relative:Path.relative
      |> Roots.map ~f:(fun s -> Some s)
      |> Fiber.return
  in
  let roots = Roots.first_has_priority from_command_line roots in
  let must_be_defined name v =
    match v with
    | Some v -> v
    | None ->
      (* We suggest that the user sets --prefix first rather than the specific
         missing option, since this is the most common case. *)
      User_error.raise
        [ Pp.textf "The %s installation directory is unknown." name ]
        ~hints:
          [ Pp.concat
              ~sep:Pp.space
              [ Pp.text "It can be specified with"
              ; User_message.command "--prefix"
              ; Pp.textf "or by setting"
              ; User_message.command (sprintf "--%s" name)
              ]
            |> Pp.hovbox
          ]
  in
  { Roots.lib_root = must_be_defined "libdir" roots.lib_root
  ; libexec_root = must_be_defined "libexecdir" roots.libexec_root
  ; bin = must_be_defined "bindir" roots.bin
  ; sbin = must_be_defined "sbindir" roots.sbin
  ; etc_root = must_be_defined "etcdir" roots.etc_root
  ; doc_root = must_be_defined "docdir" roots.doc_root
  ; share_root = must_be_defined "datadir" roots.share_root
  ; man = must_be_defined "mandir" roots.man
  }
;;

module Workspace = struct
  type t =
    { packages : Package.t Package.Name.Map.t
    ; contexts : Context.t list
    }

  let get () =
    let open Memo.O in
    Memo.run
      (let+ packages = Dune_rules.Dune_load.packages ()
       and+ contexts = Context.DB.all () in
       { packages; contexts })
  ;;

  let package_install_file t ~findlib_toolchain pkg =
    match Package.Name.Map.find t.packages pkg with
    | None -> Error ()
    | Some p ->
      let name = Package.name p in
      let dir = Package.dir p in
      Ok
        (Path.Source.relative
           dir
           (Dune_rules.Install_rules.install_file ~package:name ~findlib_toolchain))
  ;;
end

let resolve_package_install workspace ~findlib_toolchain pkg =
  match Workspace.package_install_file workspace ~findlib_toolchain pkg with
  | Ok path -> path
  | Error () ->
    let pkg = Package.Name.to_string pkg in
    User_error.raise
      [ Pp.textf "Unknown package %s!" pkg ]
      ~hints:
        (User_message.did_you_mean
           pkg
           ~candidates:
             (Package.Name.Map.keys workspace.packages
              |> List.map ~f:Package.Name.to_string))
;;

let print_unix_error f =
  try f () with
  | Unix.Unix_error (error, syscall, arg) ->
    let error = Unix_error.Detailed.create error ~syscall ~arg in
    User_message.prerr (User_error.make [ Unix_error.Detailed.pp error ])
;;

module Special_file = struct
  type t =
    | META
    | Dune_package

  let of_entry (e : _ Install.Entry.t) =
    match e.section with
    | Lib ->
      let dst = Install.Entry.Dst.to_string e.dst in
      if dst = Dune_findlib.Findlib.Package.meta_fn
      then Some META
      else if dst = Dune_package.fn
      then Some Dune_package
      else None
    | _ -> None
  ;;
end

type rmdir_mode =
  | Fail
  | Warn

(** Operations that act on real files or just pretend to (for --dry-run) *)
module type File_operations = sig
  val copy_file
    :  src:Path.t
    -> dst:Path.t
    -> executable:bool
    -> special_file:Special_file.t option
    -> package:Package.Name.t
    -> conf:Artifact_substitution.Conf.t
    -> unit Fiber.t

  val mkdir_p : Path.t -> unit
  val remove_file_if_exists : Path.t -> unit
  val remove_dir_if_exists : if_non_empty:rmdir_mode -> Path.t -> unit
end

module File_ops_dry_run (Verbosity : sig
    val verbosity : Dune_engine.Display.t
  end) : File_operations = struct
  open Verbosity

  let print_line fmt = print_line ~verbosity fmt

  let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ ~conf:_ =
    print_line
      "Copying %s to %s (executable: %b)"
      (Path.to_string_maybe_quoted src)
      (Path.to_string_maybe_quoted dst)
      executable;
    Fiber.return ()
  ;;

  let mkdir_p path = print_line "Creating directory %s" (Path.to_string_maybe_quoted path)

  let remove_file_if_exists path =
    print_line "Removing (if it exists) %s" (Path.to_string_maybe_quoted path)
  ;;

  let remove_dir_if_exists ~if_non_empty path =
    print_line
      "Removing directory (%s if not empty) %s"
      (match if_non_empty with
       | Fail -> "fail"
       | Warn -> "warn")
      (Path.to_string_maybe_quoted path)
  ;;
end

module File_ops_real (W : sig
    val verbosity : Dune_engine.Display.t
    val workspace : Workspace.t
  end) : File_operations = struct
  open W

  let print_line = print_line ~verbosity
  let get_vcs p = Dune_rules.Vcs_db.nearest_vcs p

  type load_special_file_result =
    { need_version : bool
    ; callback : ?version:string -> Format.formatter -> unit
    }

  let copy_special_file ~src ~package ~ic ~oc ~f =
    let open Fiber.O in
    let plain_copy () =
      (* CR-rgrinberg: we have fast paths for copying that we aren't making use
         of here *)
      seek_in ic 0;
      Io.copy_channels ic oc;
      Fiber.return ()
    in
    match f ic with
    | None -> plain_copy ()
    (* XXX should we really be catching everything here? *)
    | exception _ ->
      User_warning.emit
        ~loc:(Loc.in_file src)
        [ Pp.text "Failed to parse file, not adding version and locations information." ];
      plain_copy ()
    | Some { need_version; callback } ->
      let* version =
        if need_version
        then
          let* packages =
            match Package.Name.Map.find workspace.packages package with
            | None -> Fiber.return None
            | Some package -> Memo.run (get_vcs (Package.dir package))
          in
          match packages with
          | None -> Fiber.return None
          | Some vcs -> Memo.run (Vcs.describe vcs)
        else Fiber.return None
      in
      let ppf = Format.formatter_of_out_channel oc in
      callback ppf ?version;
      Format.pp_print_flush ppf ();
      Fiber.return ()
  ;;

  let process_meta ic =
    let module Meta = Dune_findlib.Findlib.Meta in
    let lb = Lexing.from_channel ic in
    let meta : Meta.t = { name = None; entries = Meta.parse_entries lb } in
    let need_more_versions =
      try
        let (_ : Meta.t) =
          Meta.add_versions meta ~get_version:(fun _ -> raise_notrace Exit)
        in
        false
      with
      | Exit -> true
    in
    if not need_more_versions
    then None
    else (
      let callback ?version ppf =
        let meta = Meta.add_versions meta ~get_version:(fun _ -> version) in
        Pp.to_fmt ppf (Meta.pp meta.entries)
      in
      Some { need_version = true; callback })
  ;;

  let replace_sites ~(get_location : Section.t -> Package.Name.t -> Stdune.Path.t) dp =
    match
      List.find_map dp ~f:(function
        | Dune_lang.List [ Atom (A "name"); Atom (A name) ] -> Some name
        | _ -> None)
    with
    | None -> dp
    | Some name ->
      List.map dp ~f:(function
        | Dune_lang.List ((Atom (A "sections") as sexp_sections) :: sections) ->
          let sections =
            List.map sections ~f:(function
              | Dune_lang.List [ (Atom (A section) as section_sexp); _ ] ->
                let path =
                  get_location
                    (Option.value_exn (Section.of_string section))
                    (Package.Name.of_string name)
                in
                let open Dune_lang.Encoder in
                pair sexp string (section_sexp, Path.to_absolute_filename path)
              | _ -> assert false)
          in
          Dune_lang.List (sexp_sections :: sections)
        | x -> x)
  ;;

  let process_dune_package ~get_location ic =
    let lb = Lexing.from_channel ic in
    let dp =
      Dune_lang.Parser.parse ~mode:Many lb |> List.map ~f:Dune_lang.Ast.remove_locs
    in
    (* replace sites with external path in the file *)
    let dp = replace_sites ~get_location dp in
    (* replace version if needed in the file *)
    let need_version =
      not
        (List.exists dp ~f:(function
          | Dune_lang.List (Atom (A "version") :: _)
          | Dune_lang.List [ Atom (A "use_meta"); Atom (A "true") ]
          | Dune_lang.List [ Atom (A "use_meta") ] -> true
          | _ -> false))
    in
    let callback ?version ppf =
      let dp =
        match version with
        | Some version ->
          let version =
            Dune_lang.List
              [ Dune_lang.atom "version"; Dune_lang.atom_or_quoted_string version ]
          in
          (match dp with
           | lang :: name :: rest -> lang :: name :: version :: rest
           | [ lang ] -> [ lang; version ]
           | [] -> [ version ])
        | _ -> dp
      in
      Format.pp_open_vbox ppf 0;
      List.iter dp ~f:(fun x ->
        Dune_lang.Deprecated.pp ppf x;
        Format.pp_print_cut ppf ());
      Format.pp_close_box ppf ()
    in
    Some { need_version; callback }
  ;;

  let copy_file
    ~src
    ~dst
    ~executable
    ~special_file
    ~package
    ~(conf : Artifact_substitution.Conf.t)
    =
    let chmod = if executable then fun _ -> 0o755 else fun _ -> 0o644 in
    match (special_file : Special_file.t option) with
    | None -> Artifact_substitution.copy_file ~conf ~executable ~src ~dst ~chmod ()
    | Some sf ->
      (* CR-rgrinberg: slow copying *)
      let ic, oc = Io.setup_copy ~chmod ~src ~dst () in
      Fiber.finalize
        ~finally:(fun () ->
          Io.close_both (ic, oc);
          Fiber.return ())
        (fun () ->
          let f =
            match sf with
            | META -> process_meta
            | Dune_package ->
              process_dune_package
                ~get_location:(Artifact_substitution.Conf.get_location conf)
          in
          copy_special_file ~src ~package ~ic ~oc ~f)
  ;;

  let remove_file_if_exists dst =
    if Path.exists dst
    then (
      print_line "Deleting %s" (Path.to_string_maybe_quoted dst);
      print_unix_error (fun () -> Path.unlink_exn dst))
  ;;

  let remove_dir_if_exists ~if_non_empty dir =
    match Path.readdir_unsorted dir with
    | Error (Unix.ENOENT, _, _) -> ()
    | Ok [] ->
      print_line "Deleting empty directory %s" (Path.to_string_maybe_quoted dir);
      print_unix_error (fun () -> Path.rmdir dir)
    | Error (e, _, _) ->
      User_message.prerr (User_error.make [ Pp.text (Unix.error_message e) ])
    | _ ->
      let dir = Path.to_string_maybe_quoted dir in
      (match if_non_empty with
       | Warn ->
         User_message.prerr
           (User_error.make
              [ Pp.textf "Directory %s is not empty, cannot delete (ignoring)." dir ])
       | Fail ->
         User_error.raise
           [ Pp.textf "Please delete non-empty directory %s manually." dir ])
  ;;

  let mkdir_p p =
    (* CR-someday amokhov: We should really change [Path.mkdir_p dir] to fail if
       it turns out that [dir] exists and is not a directory. Even better, make
       [Path.mkdir_p] return an explicit variant to deal with. *)
    match Fpath.mkdir_p (Path.to_string p) with
    | Created -> ()
    | Already_exists ->
      (match Path.is_directory p with
       | true -> ()
       | false ->
         User_error.raise
           [ Pp.textf "Please delete file %s manually." (Path.to_string_maybe_quoted p) ])
  ;;
end

module Sections = struct
  type t =
    | All
    | Only of Section.Set.t

  let sections_conv =
    let all =
      Section.all
      |> Section.Set.to_list
      |> List.map ~f:(fun section -> Section.to_string section, section)
    in
    Arg.list ~sep:',' (Arg.enum all)
  ;;

  let term =
    let doc = "sections that should be installed" in
    let open Cmdliner.Arg in
    let+ sections = value & opt (some sections_conv) None & info [ "sections" ] ~doc in
    match sections with
    | None -> All
    | Some sections -> Only (Section.Set.of_list sections)
  ;;

  let should_install t section =
    match t with
    | All -> true
    | Only set -> Section.Set.mem set section
  ;;
end

let file_operations ~verbosity ~dry_run ~workspace : (module File_operations) =
  if dry_run
  then
    (module File_ops_dry_run (struct
        let verbosity = verbosity
      end))
  else
    (module File_ops_real (struct
        let workspace = workspace
        let verbosity = verbosity
      end))
;;

let package_is_vendored (pkg : Package.t) =
  let dir = Package.dir pkg in
  Memo.run (Source_tree.is_vendored dir)
;;

type what =
  | Install
  | Uninstall

let pp_what fmt = function
  | Install -> Format.pp_print_string fmt "Install"
  | Uninstall -> Format.pp_print_string fmt "Uninstall"
;;

let cmd_what = function
  | Install -> "install"
  | Uninstall -> "uninstall"
;;

let install_entry
  ~ops
  ~conf
  ~package
  ~dir
  ~create_install_files
  (entry : Path.t Install.Entry.t)
  ~dst
  ~verbosity
  =
  let module Ops = (val ops : File_operations) in
  let open Fiber.O in
  let special_file = Special_file.of_entry entry in
  (match special_file with
   | _ when not create_install_files -> Fiber.return true
   | Some Special_file.META | Some Special_file.Dune_package -> Fiber.return true
   | None ->
     Artifact_substitution.test_file ~src:entry.src ()
     >>| (function
      | Some_substitution -> true
      | No_substitution -> false))
  >>= function
  | false -> Fiber.return entry
  | true ->
    let+ () =
      (match Path.is_directory dst with
       | true -> Ops.remove_dir_if_exists ~if_non_empty:Fail dst
       | false -> Ops.remove_file_if_exists dst);
      print_line
        ~verbosity
        "%s %s"
        (if create_install_files then "Copying to" else "Installing")
        (Path.to_string_maybe_quoted dst);
      Ops.mkdir_p dir;
      let executable = Section.should_set_executable_bit entry.section in
      Ops.copy_file ~src:entry.src ~dst ~executable ~special_file ~package ~conf
    in
    Install.Entry.set_src entry dst
;;

let run
  what
  context
  common
  pkgs
  sections
  (config : Dune_config.t)
  ~dry_run
  ~destdir
  ~relocatable
  ~create_install_files
  ~prefix_from_command_line
  ~(from_command_line : _ Install.Roots.t)
  =
  let open Fiber.O in
  let* workspace = Workspace.get () in
  let contexts =
    match context with
    | None ->
      (match Common.x common with
       | Some findlib_toolchain ->
         let contexts =
           List.filter workspace.contexts ~f:(fun (ctx : Context.t) ->
             match Context.findlib_toolchain ctx with
             | None -> false
             | Some ctx_findlib_toolchain ->
               Dune_engine.Context_name.equal ctx_findlib_toolchain findlib_toolchain)
         in
         contexts
       | None -> workspace.contexts)
    | Some name ->
      (match
         List.find workspace.contexts ~f:(fun c ->
           Dune_engine.Context_name.equal (Context.name c) name)
       with
       | Some ctx -> [ ctx ]
       | None ->
         User_error.raise
           [ Pp.textf "Context %S not found!" (Dune_engine.Context_name.to_string name) ])
  in
  let* pkgs =
    match pkgs with
    | _ :: _ -> Fiber.return pkgs
    | [] ->
      Package.Name.Map.values workspace.packages
      |> Fiber.parallel_map ~f:(fun pkg ->
        package_is_vendored pkg
        >>| function
        | true -> None
        | false -> Some (Package.name pkg))
      >>| List.filter_opt
  in
  let install_files, missing_install_files =
    List.concat_map pkgs ~f:(fun pkg ->
      List.map contexts ~f:(fun (ctx : Context.t) ->
        let fn =
          let fn =
            resolve_package_install
              workspace
              ~findlib_toolchain:(Context.findlib_toolchain ctx)
              pkg
          in
          Path.append_source (Path.build (Context.build_dir ctx)) fn
        in
        if Path.exists fn then Left (ctx, (pkg, fn)) else Right fn))
    |> List.partition_map ~f:Fun.id
  in
  if missing_install_files <> []
  then
    User_error.raise
      [ Pp.textf "The following <package>.install are missing:"
      ; Pp.enumerate missing_install_files ~f:(fun p -> Pp.text (Path.to_string p))
      ]
      ~hints:
        [ Pp.concat
            ~sep:Pp.space
            [ Pp.text "try running"
            ; User_message.command "dune build [-p <pkg>] @install"
            ]
          |> Pp.hovbox
        ];
  (match contexts, prefix_from_command_line, from_command_line.lib_root with
   | _ :: _ :: _, Some _, _ | _ :: _ :: _, _, Some _ ->
     User_error.raise
       [ Pp.concat
           ~sep:Pp.space
           [ Pp.text "Cannot specify"
           ; User_message.command "--prefix"
           ; Pp.text "or"
           ; User_message.command "--libdir"
           ; Pp.text "when installing into multiple contexts!"
           ]
       ]
   | _ -> ());
  let install_files_by_context =
    let module CMap = Map.Make (Context) in
    CMap.of_list_multi install_files
    |> CMap.to_list_map ~f:(fun context install_files ->
      let entries_per_package =
        List.map install_files ~f:(fun (package, install_file) ->
          let entries =
            Install.Entry.load_install_file install_file (fun local ->
              Path.append_local (Path.source Path.Source.root) local)
            |> List.filter ~f:(fun (entry : Path.t Install.Entry.t) ->
              Sections.should_install sections entry.section)
          in
          match
            List.filter_map entries ~f:(fun entry ->
              (* CR rgrinberg: this is ignoring optional entries *)
              Option.some_if (not (Path.exists entry.src)) entry.src)
          with
          | [] -> package, entries
          | missing_files ->
            User_error.raise
              [ Pp.textf
                  "The following files which are listed in %s cannot be installed \
                   because they do not exist:"
                  (Path.to_string_maybe_quoted install_file)
              ; Pp.enumerate missing_files ~f:(fun p ->
                  Pp.verbatim (Path.to_string_maybe_quoted p))
              ])
      in
      context, entries_per_package)
  in
  let destdir =
    Option.map
      ~f:Path.of_string
      (if create_install_files
       then
         (* CR-rgrinberg: why are we silently ignoring an argument instead
            of erroring given that they mutually exclusive? *)
         Some (Option.value ~default:"_destdir" destdir)
       else destdir)
  in
  let relocatable =
    if relocatable
    then (
      match prefix_from_command_line with
      | Some dir -> Some (Path.of_string dir)
      | None ->
        User_error.raise
          [ Pp.concat
              ~sep:Pp.space
              [ Pp.text "Option"
              ; User_message.command "--prefix"
              ; Pp.text "is needed with"
              ; User_message.command "--relocation"
              ]
            |> Pp.hovbox
          ])
    else None
  in
  let verbosity =
    match config.display with
    | Simple display -> display.verbosity
    | Tui -> Quiet
  in
  let open Fiber.O in
  let (module Ops) = file_operations ~verbosity ~dry_run ~workspace in
  let files_deleted_in = ref Path.Set.empty in
  let+ () =
    Fiber.sequential_iter
      install_files_by_context
      ~f:(fun (context, entries_per_package) ->
        let* roots = get_dirs context ~prefix_from_command_line ~from_command_line in
        let conf = Artifact_substitution.Conf.of_install ~relocatable ~roots ~context in
        Fiber.sequential_iter entries_per_package ~f:(fun (package, entries) ->
          let+ entries =
            (* CR rgrinberg: why don't we install things concurrently? *)
            Fiber.sequential_map entries ~f:(fun entry ->
              let dst =
                let paths = Install.Paths.make ~relative:Path.relative ~package ~roots in
                Install.Entry.relative_installed_path entry ~paths
                |> interpret_destdir ~destdir
              in
              let dir = Path.parent_exn dst in
              match what with
              | Uninstall ->
                Ops.remove_file_if_exists dst;
                files_deleted_in := Path.Set.add !files_deleted_in dir;
                Fiber.return entry
              | Install ->
                install_entry
                  ~ops:(module Ops)
                  ~conf
                  ~package
                  ~dir
                  ~create_install_files
                  ~dst
                  ~verbosity
                  entry)
          in
          if create_install_files
          then (
            let fn =
              resolve_package_install
                workspace
                ~findlib_toolchain:(Context.findlib_toolchain context)
                package
            in
            Install.Entry.gen_install_file entries |> Io.write_file (Path.source fn))))
  in
  Path.Set.to_list !files_deleted_in
  (* This [List.rev] is to ensure we process children directories before
     their parents *)
  |> List.rev
  |> List.iter ~f:(Ops.remove_dir_if_exists ~if_non_empty:Warn)
;;

let make ~what =
  let doc = Format.asprintf "%a packages defined in the workspace." pp_what what in
  let name_ = Arg.info [] ~docv:"PACKAGE" in
  let absolute_path =
    Arg.conv'
      ( (fun path ->
          if Filename.is_relative path
          then Error "the path must be absolute to avoid ambiguity"
          else Ok path)
      , Arg.conv_printer Arg.string )
  in
  let term =
    let+ builder = Common.Builder.term
    and+ prefix_from_command_line =
      Arg.(
        value
        & opt (some string) None
        & info
            [ "prefix" ]
            ~env:(Cmd.Env.info "DUNE_INSTALL_PREFIX")
            ~docv:"PREFIX"
            ~doc:
              "Directory where files are copied. For instance binaries are copied into \
               $(i,\\$prefix/bin), library files into $(i,\\$prefix/lib), etc...")
    and+ destdir =
      Arg.(
        value
        & opt (some string) None
        & info
            [ "destdir" ]
            ~env:(Cmd.Env.info "DESTDIR")
            ~docv:"PATH"
            ~doc:"This directory is prepended to all installed paths.")
    and+ libdir_from_command_line =
      Arg.(
        value
        & opt (some absolute_path) None
        & info
            [ "libdir" ]
            ~docv:"PATH"
            ~doc:
              "Directory where library files are copied, relative to $(b,prefix) or \
               absolute. If $(b,--prefix) is specified the default is \
               $(i,\\$prefix/lib). Only absolute path accepted.")
    and+ mandir_from_command_line =
      let doc =
        "Manually override the directory to install man pages. Only absolute path \
         accepted."
      in
      Arg.(value & opt (some absolute_path) None & info [ "mandir" ] ~docv:"PATH" ~doc)
    and+ docdir_from_command_line =
      let doc =
        "Manually override the directory to install documentation files. Only absolute \
         path accepted."
      in
      Arg.(value & opt (some absolute_path) None & info [ "docdir" ] ~docv:"PATH" ~doc)
    and+ etcdir_from_command_line =
      let doc =
        "Manually override the directory to install configuration files. Only absolute \
         path accepted."
      in
      Arg.(value & opt (some absolute_path) None & info [ "etcdir" ] ~docv:"PATH" ~doc)
    and+ bindir_from_command_line =
      let doc =
        "Manually override the directory to install public binaries. Only absolute path \
         accepted."
      in
      Arg.(value & opt (some absolute_path) None & info [ "bindir" ] ~docv:"PATH" ~doc)
    and+ sbindir_from_command_line =
      let doc =
        "Manually override the directory to install files from sbin section. Only \
         absolute path accepted."
      in
      Arg.(value & opt (some absolute_path) None & info [ "sbindir" ] ~docv:"PATH" ~doc)
    and+ datadir_from_command_line =
      let doc =
        "Manually override the directory to install files from share section. Only \
         absolute path accepted."
      in
      Arg.(value & opt (some absolute_path) None & info [ "datadir" ] ~docv:"PATH" ~doc)
    and+ libexecdir_from_command_line =
      let doc =
        "Manually override the directory to install executable library files. Only \
         absolute path accepted."
      in
      Arg.(
        value & opt (some absolute_path) None & info [ "libexecdir" ] ~docv:"PATH" ~doc)
    and+ dry_run =
      Arg.(
        value
        & flag
        & info
            [ "dry-run" ]
            ~doc:"Only display the file operations that would be performed.")
    and+ relocatable =
      Arg.(
        value
        & flag
        & info
            [ "relocatable" ]
            ~doc:
              "Make the binaries relocatable (the installation directory can be moved). \
               The installation directory must be specified with --prefix")
    and+ create_install_files =
      Arg.(
        value
        & flag
        & info
            [ "create-install-files" ]
            ~doc:
              "Do not directly install, but create install files in the root directory \
               and create substituted files if needed in destdir (_destdir by default).")
    and+ pkgs = Arg.(value & pos_all package_name [] name_)
    and+ context =
      Arg.(
        value
        & opt (some Arg.context_name) None
        & info
            [ "context" ]
            ~docv:"CONTEXT"
            ~doc:
              "Select context to install from. By default, install files from all \
               defined contexts.")
    and+ sections = Sections.term in
    let builder = Common.Builder.forbid_builds builder in
    let builder = Common.Builder.disable_log_file builder in
    let common, config = Common.init builder in
    Scheduler.go ~common ~config (fun () ->
      let from_command_line =
        { Install.Roots.lib_root = libdir_from_command_line
        ; etc_root = etcdir_from_command_line
        ; doc_root = docdir_from_command_line
        ; man = mandir_from_command_line
        ; bin = bindir_from_command_line
        ; sbin = sbindir_from_command_line
        ; libexec_root = libexecdir_from_command_line
        ; share_root = datadir_from_command_line
        }
        |> Install.Roots.map ~f:(Option.map ~f:Path.of_string)
        |> Install.Roots.complete
      in
      run
        what
        context
        common
        pkgs
        sections
        config
        ~dry_run
        ~destdir
        ~relocatable
        ~create_install_files
        ~prefix_from_command_line
        ~from_command_line)
  in
  Cmd.v
    (Cmd.info
       (cmd_what what)
       ~doc
       ~man:Manpage.(`S s_synopsis :: (synopsis @ Common.help_secs)))
    term
;;

let install = make ~what:Install
let uninstall = make ~what:Uninstall