diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml index d4419b272cbc..e4455e18ee2a 100644 --- a/bin/install_uninstall.ml +++ b/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 ()) ;;