Merge branch 'main' into dual-libs-names

Signed-off-by: Javier Chávarri <javier.chavarri@gmail.com>

bin/install_uninstall.ml

@@ -141,6 +141,11 @@ module Special_file = struct
   ;;
 end
 
+type copy_kind =
+  | Plain (** Just copy the file. Can use fast paths through [Io.copy_file] *)
+  | Substitute (** Use [Artifact_substitution.copy_file]. Will scan all bytes. *)
+  | Special of Special_file.t (** Hooks to add version numbers, replace sections, etc *)
+
 type rmdir_mode =
   | Fail
   | Warn
@@ -151,7 +156,7 @@ module type File_operations = sig
     :  src:Path.t
     -> dst:Path.t
     -> executable:bool
-    -> special_file:Special_file.t option
+    -> kind:copy_kind
     -> package:Package.Name.t
     -> conf:Artifact_substitution.Conf.t
     -> unit Fiber.t
@@ -168,7 +173,7 @@ module File_ops_dry_run (Verbosity : sig
 
   let print_line fmt = print_line ~verbosity fmt
 
-  let copy_file ~src ~dst ~executable ~special_file:_ ~package:_ ~conf:_ =
+  let copy_file ~src ~dst ~executable ~kind:_ ~package:_ ~conf:_ =
     print_line
       "Copying %s to %s (executable: %b)"
       (Path.to_string_maybe_quoted src)
@@ -207,25 +212,22 @@ module File_ops_real (W : sig
     ; callback : ?version:string -> Format.formatter -> unit
     }
 
+  type copy_special_file_status =
+    | Done
+    | Use_plain_copy
+
   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 ()
+    | None -> Fiber.return Use_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 ()
+      Fiber.return Use_plain_copy
     | Some { need_version; callback } ->
-      let* version =
+      let+ version =
         if need_version
         then
           let* packages =
@@ -241,7 +243,7 @@ module File_ops_real (W : sig
       let ppf = Format.formatter_of_out_channel oc in
       callback ppf ?version;
       Format.pp_print_flush ppf ();
-      Fiber.return ()
+      Done
   ;;
 
   let process_meta ic =
@@ -336,29 +338,39 @@ module File_ops_real (W : sig
     ~src
     ~dst
     ~executable
-    ~special_file
+    ~kind
     ~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 ~src ~dst ~chmod ()
-    | Some sf ->
-      (* CR-rgrinberg: slow copying *)
+    let plain_copy () =
+      Io.copy_file ~chmod ~src ~dst ();
+      Fiber.return ()
+    in
+    match kind with
+    | Plain -> plain_copy ()
+    | Substitute -> Artifact_substitution.copy_file ~conf ~src ~dst ~chmod ()
+    | Special sf ->
+      let open Fiber.O in
       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* status =
+        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)
+      in
+      (match status with
+       | Done -> Fiber.return ()
+       | Use_plain_copy -> plain_copy ())
   ;;
 
   let remove_file_if_exists dst =
@@ -500,7 +512,12 @@ let install_entry
         (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
+      let kind =
+        match special_file with
+        | Some special -> Special special
+        | None -> if executable then Substitute else Plain
+      in
+      Ops.copy_file ~src:entry.src ~dst ~executable ~kind ~package ~conf
     in
     Install.Entry.set_src entry dst
 ;;

doc/changes/10250.md

@@ -0,0 +1,2 @@
+- Remove limitations on percent forms in the `(enabled_if ..)` field of
+  libraries (#10250, @rgrinberg)

doc/changes/10269.md

@@ -0,0 +1,2 @@
+- fix crash when decoding dune-package for libraries with `(include_subdirs
+  qualified)` (#10269, fixes #10264, @emillon)

src/dune_digest/dune_digest.ml

@@ -99,33 +99,17 @@ module Stats_for_digest = struct
   ;;
 end
 
-module Path_digest_result = struct
+module Path_digest_error = struct
   type nonrec t =
-    | Ok of t
     | Unexpected_kind
     | Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t
-
-  let of_result = function
-    | Result.Ok t -> Ok t
-    | Error unix_error -> Unix_error unix_error
-  ;;
-
-  let equal x y =
-    match x, y with
-    | Ok x, Ok y -> D.equal x y
-    | Ok _, _ | _, Ok _ -> false
-    | Unexpected_kind, Unexpected_kind -> true
-    | Unexpected_kind, _ | _, Unexpected_kind -> false
-    | Unix_error x, Unix_error y -> Dune_filesystem_stubs.Unix_error.Detailed.equal x y
-  ;;
 end
 
-exception
-  E of [ `Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t | `Unexpected_kind ]
+exception E of Path_digest_error.t
 
 let directory_digest_version = 2
 
-let path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) : Path_digest_result.t =
+let path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) =
   let rec loop path (stats : Stats_for_digest.t) =
     match stats.st_kind with
     | S_LNK ->
@@ -135,44 +119,42 @@ let path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) : Path_digest_
           let contents = Unix.readlink (Path.to_string path) in
           path_with_executable_bit ~executable ~content_digest:contents)
         path
-      |> Path_digest_result.of_result
+      |> Result.map_error ~f:(fun x -> Path_digest_error.Unix_error x)
     | S_REG ->
       let executable = Path.Permissions.test Path.Permissions.execute stats.st_perm in
       Dune_filesystem_stubs.Unix_error.Detailed.catch
         (file_with_executable_bit ~executable)
         path
-      |> Path_digest_result.of_result
+      |> Result.map_error ~f:(fun x -> Path_digest_error.Unix_error x)
     | S_DIR when allow_dirs ->
       (* CR-someday amokhov: The current digesting scheme has collisions for files
          and directories. It's unclear if this is actually a problem. If it turns
          out to be a problem, we should include [st_kind] into both digests. *)
       (match Path.readdir_unsorted path with
-       | Error e -> Path_digest_result.Unix_error e
+       | Error e -> Error (Path_digest_error.Unix_error e)
        | Ok listing ->
          (match
             List.rev_map listing ~f:(fun name ->
               let path = Path.relative path name in
               let stats =
                 match Path.lstat path with
-                | Error e -> raise_notrace (E (`Unix_error e))
+                | Error e -> raise_notrace (E (Unix_error e))
                 | Ok stat -> Stats_for_digest.of_unix_stats stat
               in
               let digest =
                 match loop path stats with
                 | Ok s -> s
-                | Unix_error e -> raise_notrace (E (`Unix_error e))
-                | Unexpected_kind -> raise_notrace (E `Unexpected_kind)
+                | Error e -> raise_notrace (E e)
               in
               name, digest)
             |> List.sort ~compare:(fun (x, _) (y, _) -> String.compare x y)
           with
-          | exception E (`Unix_error e) -> Path_digest_result.Unix_error e
-          | exception E `Unexpected_kind -> Path_digest_result.Unexpected_kind
+          | exception E e -> Error e
           | contents -> Ok (generic (directory_digest_version, contents, stats.st_perm))))
-    | S_DIR | S_BLK | S_CHR | S_FIFO | S_SOCK -> Unexpected_kind
+    | S_DIR | S_BLK | S_CHR | S_FIFO | S_SOCK -> Error Unexpected_kind
   in
   match stats.st_kind with
-  | S_DIR when not allow_dirs -> Unexpected_kind
-  | S_BLK | S_CHR | S_LNK | S_FIFO | S_SOCK -> Unexpected_kind
+  | S_DIR when not allow_dirs -> Error Path_digest_error.Unexpected_kind
+  | S_BLK | S_CHR | S_LNK | S_FIFO | S_SOCK -> Error Unexpected_kind
   | _ -> loop path stats
 ;;

src/dune_digest/dune_digest.mli

@@ -30,14 +30,11 @@ module Stats_for_digest : sig
   val of_unix_stats : Unix.stats -> t
 end
 
-module Path_digest_result : sig
+module Path_digest_error : sig
   type nonrec t =
-    | Ok of t
     | Unexpected_kind
     | Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t
     (** A Unix error, e.g., [(ENOENT, _, _)] if the path doesn't exist. *)
-
-  val equal : t -> t -> bool
 end
 
 (** Digest a path taking into account its [Stats_for_digest].
@@ -58,7 +55,7 @@ val path_with_stats
   :  allow_dirs:bool
   -> Path.t
   -> Stats_for_digest.t
-  -> Path_digest_result.t
+  -> (t, Path_digest_error.t) result
 
 (** Digest a file taking the [executable] bit into account. Should not be called
     on a directory. *)

src/dune_engine/cached_digest.ml

@@ -235,9 +235,9 @@ let digest_path_with_stats ~allow_dirs path stats =
     Digest.path_with_stats ~allow_dirs path (Digest.Stats_for_digest.of_unix_stats stats)
   with
   | Ok digest -> Ok digest
-  | Unexpected_kind -> Error (Digest_result.Error.Unexpected_kind stats.st_kind)
-  | Unix_error (ENOENT, _, _) -> Error No_such_file
-  | Unix_error other_error -> Error (Unix_error other_error)
+  | Error Unexpected_kind -> Error (Digest_result.Error.Unexpected_kind stats.st_kind)
+  | Error (Unix_error (ENOENT, _, _)) -> Error No_such_file
+  | Error (Unix_error other_error) -> Error (Unix_error other_error)
 ;;
 
 let refresh ~allow_dirs stats path =

src/dune_engine/fs_memo.ml

@@ -224,7 +224,7 @@ end
 let path_stat path =
   let* () = Watcher.watch ~try_to_watch_via_parent:true path in
   match Fs_cache.read Fs_cache.Untracked.path_stat path with
-  | Ok { st_dev = _; st_ino = _; st_kind } as result when st_kind = S_DIR ->
+  | Ok { st_dev = _; st_ino = _; st_kind = S_DIR } as result ->
     (* If [path] is a directory, we conservatively watch it directly too,
        because its stats may change in a way that doesn't trigger an event in
        the parent. We probably don't care about such changes for now because

src/dune_engine/target_promotion.ml

@@ -166,7 +166,7 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo
        Dune will notice its deletion. Furthermore, if we used a tracked version,
        [Path.mkdir_p] below would generate an unnecessary file-system event. *)
     match Fs_cache.(read Untracked.path_stat) (In_source_dir dst_dir) with
-    | Ok { st_kind; _ } when st_kind = S_DIR -> ()
+    | Ok { st_kind = S_DIR; _ } -> ()
     | Error (ENOENT, _, _) -> Path.mkdir_p (Path.source dst_dir)
     | Ok _ | Error _ ->
       (* Try to delete any unexpected stuff out of the way. In future, we might

src/dune_rules/artifact_substitution.ml

@@ -663,7 +663,7 @@ let copy_file_non_atomic ~conf ?chmod ~src ~dst () =
 let replace_if_different ~delete_dst_if_it_is_a_directory ~src ~dst =
   let up_to_date =
     match Path.Untracked.stat dst with
-    | Ok { st_kind; _ } when st_kind = S_DIR ->
+    | Ok { st_kind = S_DIR; _ } ->
       (match delete_dst_if_it_is_a_directory with
        | true ->
          Path.rm_rf dst;

src/dune_rules/artifacts.ml

@@ -36,8 +36,6 @@ let force { local_bins; _ } =
   ()
 ;;
 
-let expand = Fdecl.create Dyn.opaque
-
 let analyze_binary t name =
   match Filename.is_relative name with
   | false -> Memo.return (`Resolved (Path.of_filename_relative_to_initial_cwd name))
@@ -89,7 +87,11 @@ let binary t ?hint ?(where = Install_dir) ~loc name =
        Memo.return @@ Ok (Path.build @@ Path.Build.append_local install_dir dst)
      | Original_path ->
        let+ expanded =
-         File_binding.Unexpanded.expand binding ~dir ~f:(Fdecl.get expand ~dir)
+         let* expander = Expander0.get ~dir in
+         File_binding.Unexpanded.expand
+           binding
+           ~dir
+           ~f:(Expander0.expand_str_and_build_deps expander)
        in
        let src = File_binding.Expanded.src expanded in
        Ok (Path.build src))

src/dune_rules/artifacts.mli

@@ -41,5 +41,3 @@ val create
   :  Context.t
   -> local_bins:origin Appendable_list.t Filename.Map.t Memo.Lazy.t
   -> t
-
-val expand : (dir:Path.Build.t -> String_with_vars.t -> string Memo.t) Fdecl.t

src/dune_rules/artifacts_db.ml

@@ -35,28 +35,28 @@ let available_exes ~dir (exes : Executables.t) =
   Resolve.is_ok available
 ;;
 
-let expander = Fdecl.create Dyn.opaque
-
 let get_installed_binaries ~(context : Context.t) stanzas =
   let merge _ x y = Some (Appendable_list.( @ ) x y) in
   let open Memo.O in
   Memo.List.map stanzas ~f:(fun d ->
     let dir = Path.Build.append_source (Context.build_dir context) (Dune_file.dir d) in
-    let* expander = (Fdecl.get expander) ~dir in
+    let* expander = Expander0.get ~dir in
     let expand_value sw =
-      Expander.expand expander ~mode:Single sw
+      Expander0.expand expander ~mode:Single sw
       |> Action_builder.evaluate_and_collect_facts
       >>| fst
     in
     let expand_str sw =
-      Expander.expand_str expander sw |> Action_builder.evaluate_and_collect_facts >>| fst
+      Expander0.expand_str expander sw
+      |> Action_builder.evaluate_and_collect_facts
+      >>| fst
     in
     let expand_str_partial sw =
-      Expander.expand_str_partial expander sw
+      Expander0.expand_str_partial expander sw
       |> Action_builder.evaluate_and_collect_facts
       >>| fst
     in
-    let eval_blang = Expander.eval_blang expander in
+    let eval_blang = Expander0.eval_blang expander in
     let binaries_from_install ~enabled_if files =
       let* unexpanded_file_bindings =
         Install_entry.File.to_file_bindings_unexpanded files ~expand:expand_value ~dir

src/dune_rules/artifacts_db.mli

@@ -1,6 +1,3 @@
 (* This module is separate from [Artifacts] to avoid cycles *)
 
-open Stdune
-
-val expander : (dir:Path.Build.t -> Expander.t Memo.t) Fdecl.t
 val get : Context.t -> Artifacts.t Memo.t

src/dune_rules/artifacts_obj.ml

@@ -10,12 +10,14 @@ let empty = { libraries = Lib_name.Map.empty; modules = Module_name.Map.empty }
 let lookup_module { modules; libraries = _ } = Module_name.Map.find modules
 let lookup_library { libraries; modules = _ } = Lib_name.Map.find libraries
 
-let make ~dir ~lib_config ~libs ~exes =
+let make ~dir ~expander ~lib_config ~libs ~exes =
   let+ libraries =
     Memo.List.map libs ~f:(fun ((lib : Library.t), _, _) ->
       let+ lib_config = lib_config in
       let name = Lib_name.of_local lib.name in
-      let info = Library.to_lib_info lib ~dir ~lib_config in
+      let info =
+        Library.to_lib_info lib ~expander:(Memo.return expander) ~dir ~lib_config
+      in
       name, info)
     >>| Lib_name.Map.of_list_exn
   in