Merge branch 'main' into merlin-add-contxts-cmds

Signed-off-by: Javier Chávarri <[email protected]>

bin/install_uninstall.ml

@@ -206,47 +206,37 @@ module File_ops_real (W : sig
   let print_line = print_line ~verbosity
   let get_vcs p = Dune_rules.Vcs_db.nearest_vcs p
 
-  (* CR-emillon rework this API or at least remove the optional argument *)
-  type load_special_file_result =
-    { need_version : bool
-    ; callback : ?version:string -> Format.formatter -> unit
-    }
-
   type copy_special_file_status =
     | Done
     | Use_plain_copy
 
+  let with_ppf oc ~f =
+    let ppf = Format.formatter_of_out_channel oc in
+    f ppf;
+    Format.pp_print_flush ppf ()
+  ;;
+
   let copy_special_file ~src ~package ~ic ~oc ~f =
     let open Fiber.O in
-    match f ic ~src with
-    | None -> Fiber.return Use_plain_copy
-    (* XXX should we really be catching everything here? *)
-    | exception _ ->
+    let get_version () =
+      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)
+    in
+    try f ~get_version ic ~src oc with
+    | _ (* XXX should we really be catching everything here? *) ->
       User_warning.emit
         ~loc:(Loc.in_file src)
         [ Pp.text "Failed to parse file, not adding version and locations information." ];
       Fiber.return Use_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 ();
-      Done
   ;;
 
-  let process_meta ic ~src:_ =
+  let process_meta ~get_version ic ~src:_ oc =
     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
@@ -260,41 +250,46 @@ module File_ops_real (W : sig
       | Exit -> true
     in
     if not need_more_versions
-    then None
-    else (
-      let callback ?version ppf =
+    then Fiber.return Use_plain_copy
+    else
+      let open Fiber.O in
+      let+ version = get_version () in
+      with_ppf oc ~f:(fun 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 })
+        Pp.to_fmt ppf (Meta.pp meta.entries));
+      Done
   ;;
 
-  let process_dune_package ~get_location ic ~src =
+  let process_dune_package ~get_version ~get_location ic ~src oc =
     let lb = Lexing.from_channel ic in
     let dune_version = Dune_lang.Syntax.greatest_supported_version_exn Stanza.syntax in
     match Dune_package.Or_meta.parse src lb |> User_error.ok_exn with
     | Use_meta ->
-      let callback ?version:_ ppf = Dune_package.Or_meta.pp_use_meta ~dune_version ppf in
-      Some { need_version = false; callback }
+      with_ppf oc ~f:(Dune_package.Or_meta.pp_use_meta ~dune_version);
+      Fiber.return Done
     | Dune_package dp ->
+      let open Fiber.O in
       (* replace sites with external path in the file *)
       let dp, replace_info = Dune_package.replace_site_sections ~get_location dp in
       (* replace version if needed in the file *)
       let need_version = Option.is_none dp.version in
-      let callback ?version ppf =
-        let dp =
-          match version with
+      let+ dp =
+        if need_version
+        then
+          let+ version_opt = get_version () in
+          match version_opt with
           | Some version -> { dp with version = Some (Package_version.of_string version) }
           | None -> dp
-        in
+        else Fiber.return dp
+      in
+      with_ppf oc ~f:(fun ppf ->
         (* CR-emillon: we should write absolute paths only if necessary *)
         Dune_package.Or_meta.pp
           ~dune_version
           ppf
           (Dune_package dp)
-          ~encoding:(Absolute replace_info)
-      in
-      Some { need_version; callback }
+          ~encoding:(Absolute replace_info));
+      Done
   ;;
 
   let copy_file
@@ -306,16 +301,13 @@ module File_ops_real (W : sig
     ~(conf : Artifact_substitution.Conf.t)
     =
     let chmod = if executable then fun _ -> 0o755 else fun _ -> 0o644 in
-    let plain_copy () =
-      Io.copy_file ~chmod ~src ~dst ();
-      Fiber.return ()
-    in
+    let plain_copy () = Io.copy_file ~chmod ~src ~dst () in
     match kind with
     | 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
-      let* status =
+      let+ status =
         Fiber.finalize
           ~finally:(fun () ->
             Io.close_both (ic, oc);
@@ -331,7 +323,7 @@ module File_ops_real (W : sig
             copy_special_file ~src ~package ~ic ~oc ~f)
       in
       (match status with
-       | Done -> Fiber.return ()
+       | Done -> ()
        | Use_plain_copy -> plain_copy ())
   ;;