From bca9e656b61f7d2b827016b7fd9b1a682c690a7b Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <me@rgrinberg.com>
Date: Sun, 8 Dec 2024 18:11:56 +0000
Subject: [PATCH] feature: add --prefix to configure script (#11172)

In symmetry with --prefix in the install command.

Fix #10229

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
---
 boot/configure.ml                |  5 ++++-
 doc/changes/11172.md             |  3 +++
 src/dune_rules/context.ml        | 15 ++++++++++++++-
 src/dune_rules/setup.defaults.ml |  1 +
 src/dune_rules/setup.mli         |  1 +
 src/install/roots.mli            |  1 +
 6 files changed, 24 insertions(+), 2 deletions(-)
 create mode 100644 doc/changes/11172.md

diff --git a/boot/configure.ml b/boot/configure.ml
index 2423ebf9274..42e25d29564 100644
--- a/boot/configure.ml
+++ b/boot/configure.ml
@@ -35,6 +35,7 @@ let toggle =
 
 let () =
   let bad fmt = ksprintf (fun s -> raise (Arg.Bad s)) fmt in
+  let prefix = ref None in
   let library_path = ref [] in
   let library_destdir = ref None in
   let mandir = ref None in
@@ -58,7 +59,8 @@ let () =
     v := Some dir
   in
   let args =
-    [ ( "--libdir"
+    [ "--prefix", Arg.String (set_dir prefix), "DIR where files are copied"
+    ; ( "--libdir"
       , Arg.String set_libdir
       , "DIR where public libraries are looked up in the default build context. Can be \
          specified multiple times new one taking precedence. The last is used as default \
@@ -120,6 +122,7 @@ let () =
   pr "  ; libexec_root = %s" (option string !libexecdir);
   pr "  }";
   pr "";
+  pr "let prefix : string option = %s" (option string !prefix);
   List.iter !toggles ~f:(fun (name, value) ->
     pr
       "let %s = `%s"
diff --git a/doc/changes/11172.md b/doc/changes/11172.md
new file mode 100644
index 00000000000..7fea425fca1
--- /dev/null
+++ b/doc/changes/11172.md
@@ -0,0 +1,3 @@
+- Allow the `--prefix` flag when configuring dune with `ocaml configure.ml`.
+  This allows to set the prefix just like `$ dune install --prefix`. (#1172,
+  @rgrinberg)
diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml
index 70f924355a1..943a568c9d0 100644
--- a/src/dune_rules/context.ml
+++ b/src/dune_rules/context.ml
@@ -743,6 +743,19 @@ let map_exe (context : t) =
        | _ -> exe)
 ;;
 
+let roots =
+  lazy
+    (let open Setup in
+     match prefix with
+     | None -> roots
+     | Some prefix ->
+       let prefix = Install.Roots.make prefix ~relative:Filename.concat in
+       Install.Roots.map2 roots prefix ~f:(fun root prefix ->
+         match root with
+         | None -> Some prefix
+         | Some _ -> root))
+;;
+
 let roots t =
   let module Roots = Install.Roots in
   let+ prefix_roots =
@@ -756,7 +769,7 @@ let roots t =
   in
   match t.kind with
   | Lock _ | Default ->
-    let setup_roots = Roots.map ~f:(Option.map ~f:Path.of_string) Setup.roots in
+    let setup_roots = Roots.map ~f:(Option.map ~f:Path.of_string) (Lazy.force roots) in
     Roots.first_has_priority setup_roots prefix_roots
   | Opam _ -> prefix_roots
 ;;
diff --git a/src/dune_rules/setup.defaults.ml b/src/dune_rules/setup.defaults.ml
index 03add9eae36..d96e454774b 100644
--- a/src/dune_rules/setup.defaults.ml
+++ b/src/dune_rules/setup.defaults.ml
@@ -14,3 +14,4 @@ let roots : string option Install.Roots.t =
 let toolchains = `Enabled
 let pkg_build_progress = `Disabled
 let lock_dev_tool = `Disabled
+let prefix = None
diff --git a/src/dune_rules/setup.mli b/src/dune_rules/setup.mli
index 6863d42ca4b..4666b18ec25 100644
--- a/src/dune_rules/setup.mli
+++ b/src/dune_rules/setup.mli
@@ -13,3 +13,4 @@ val roots : string option Install.Roots.t
 val toolchains : Dune_config.Config.Toggle.t
 val pkg_build_progress : Dune_config.Config.Toggle.t
 val lock_dev_tool : Dune_config.Config.Toggle.t
+val prefix : string option
diff --git a/src/install/roots.mli b/src/install/roots.mli
index f75aa5bb9bd..433c7ad52e5 100644
--- a/src/install/roots.mli
+++ b/src/install/roots.mli
@@ -20,6 +20,7 @@ val opam_from_prefix : 'a -> relative:('a -> string -> 'a) -> 'a t
 val complete : 'a option t -> 'a option t
 
 val map : f:('a -> 'b) -> 'a t -> 'b t
+val map2 : f:('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
 
 (** return the roots of the first argument if present *)
 val first_has_priority : 'a option t -> 'a option t -> 'a option t