From 188f0748f75051cb7c9e9f41cea315b3e52090ef Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 9 May 2019 11:20:22 +0100 Subject: [PATCH] Use the VCS module in watermarks.ml As a side effect, this adds support for hg Signed-off-by: Jeremie Dimino --- CHANGES.md | 2 + src/vcs.ml | 186 ++++++++++++++++++++++++++++++---------------- src/vcs.mli | 8 +- src/watermarks.ml | 53 ++++++------- 4 files changed, 154 insertions(+), 95 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 2c30fd348e2..c6713617115 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -51,6 +51,8 @@ unreleased create duplicates of the default context with different settings. (#2098, @TheLortex, review by @diml, @rgrinberg and @aalekseyev) +- Add support for hg in `dune subst` (#2135, @diml) + 1.9.3 (06/05/2019) ------------------ diff --git a/src/vcs.ml b/src/vcs.ml index f28cc546254..62aa7e35072 100644 --- a/src/vcs.ml +++ b/src/vcs.ml @@ -17,18 +17,46 @@ module Kind = struct | Git -> "Git" | Hg -> "Hg"), []) + + let equal = (=) + + let decode = + Stanza.Decoder.enum + [ "git", Git + ; "hg", Hg + ] end -type t = - { root : Path.t - ; kind : Kind.t - } +module T = struct + type t = + { root : Path.t + ; kind : Kind.t + } + + let to_dyn { root; kind } = + Dyn.Encoder.record + [ "root", Path.to_dyn root + ; "kind", Kind.to_dyn kind + ] + + let to_sexp t = Dyn.to_sexp (to_dyn t) -let to_dyn { root; kind } = - Dyn.Encoder.record - [ "root", Path.to_dyn root - ; "kind", Kind.to_dyn kind - ] + let equal { root = ra; kind = ka } { root = rb; kind = kb } = + Path.equal ra rb && Kind.equal ka kb + + (* No need to hash the kind as there is only only kind per directory *) + let hash t = Path.hash t.root + + let decode = + let open Stanza.Decoder in + record + (let+ root = field "root" Path_dune_lang.decode + and+ kind = field "kind" Kind.decode + in + { root; kind }) +end + +include T let git, hg = let get prog = lazy ( @@ -38,61 +66,93 @@ let git, hg = in (get "git", get "hg") -let git_describe = - Memo.create - "git-describe" - ~doc:"Run [git describe] in the following directory" - ~input:(module Path) +let select git hg t = + match t.kind with + | Git -> git t + | Hg -> hg t + +let prog t = + Lazy.force ( + match t.kind with + | Git -> git + | Hg -> hg) + +let run t args = + let open Fiber.O in + let+ s = + Process.run_capture Strict (prog t) args ~dir:t.root ~env:Env.initial + in + String.trim s + +let run_lines t args = + Process.run_capture_lines Strict (prog t) args ~dir:t.root ~env:Env.initial + +let hg_describe t = + let open Fiber.O in + let* s = + run t [ "log"; "--rev"; "."; "-T"; "{latesttag} {latesttagdistance}" ] + in + let+ id = + run t [ "id"; "-i" ] + in + let id, dirty_suffix = + match String.drop_suffix id ~suffix:"+" with + | Some id -> id, "-dirty" + | None -> id, "" + in + let s = + let s, dist = Option.value_exn (String.rsplit2 s ~on:' ') in + match s with + | "null" -> id + | _ -> + match int_of_string dist with + | 1 -> s + | n -> sprintf "%s-%d-%s" s (n - 1) id + | exception _ -> sprintf "%s-%s-%s" s dist id + in + s ^ dirty_suffix + +let make_fun name ~output ~doc ~git ~hg = + let memo = + Memo.create + name + ~doc + ~input:(module T) + ~output + ~visibility:(Public decode) + Async + (Some (select git hg)) + in + Staged.stage (Memo.exec memo) + +let describe = + Staged.unstage @@ + make_fun "vcs-describe" + ~doc:"Obtain a nice description of the tip from the vcs" ~output:(Simple (module String)) - ~visibility:(Public Path_dune_lang.decode) - Async - (Some (fun dir -> - let open Fiber.O in - let+ s = - Process.run_capture Strict (Lazy.force git) - ["describe"; "--always"; "--dirty"] ~env:Env.initial ~dir - in - String.trim s)) + ~git:(fun t -> run t ["describe"; "--always"; "--dirty"]) + ~hg:hg_describe -let hg_describe = - let f dir = +let commit_id = + Staged.unstage @@ + make_fun "vcs-commit-id" + ~doc:"The hash of the head commit" + ~output:(Simple (module String)) + ~git:(fun t -> run t ["rev-parse"; "HEAD"]) + ~hg:(fun t -> run t ["id"; "-i"]) + +let files = + let f args t = let open Fiber.O in - let hg = Lazy.force hg in - let hg args = Process.run_capture Strict hg ~env:Env.initial ~dir args in - let* s = - hg [ "log"; "--rev"; "."; "-T"; "{latesttag} {latesttagdistance}" ] - in - let+ id = - hg [ "id"; "-i" ] - in - let s = String.trim s and id = String.trim id in - let id, dirty_suffix = - match String.drop_suffix id ~suffix:"+" with - | Some id -> id, "-dirty" - | None -> id, "" - in - let s = - let s, dist = Option.value_exn (String.rsplit2 s ~on:' ') in - match s with - | "null" -> id - | _ -> - match int_of_string dist with - | 1 -> s - | n -> sprintf "%s-%d-%s" s (n - 1) id - | exception _ -> sprintf "%s-%s-%s" s dist id - in - s ^ dirty_suffix + let+ l = run_lines t args in + List.map l ~f:Path.in_source in - Memo.create - "hg-describe" - ~doc:"Do something similar to [git describe] with hg" - ~input:(module Path) - ~output:(Simple (module String)) - ~visibility:(Public Path_dune_lang.decode) - Async - (Some f) - -let describe { root; kind } = - match kind with - | Git -> Memo.exec git_describe root - | Hg -> Memo.exec hg_describe root + Staged.unstage @@ + make_fun "vcs-files" + ~doc:"Return the files committed in the repo" + ~output:(Simple (module struct + type t = Path.t list + let to_sexp = Sexp.Encoder.list Path.to_sexp + end)) + ~git:(f ["ls-tree"; "-r"; "--name-only"; "HEAD"]) + ~hg:(f ["files"]) diff --git a/src/vcs.mli b/src/vcs.mli index e6e18492fe0..e95503f2d0b 100644 --- a/src/vcs.mli +++ b/src/vcs.mli @@ -15,9 +15,15 @@ type t = val to_dyn : t -> Dyn.t -(** Output of [git describe --dirty --always] or hg equivalent *) +(** Nice description of the current tip *) val describe : t -> string Fiber.t +(** String uniquely identifying the current head commit *) +val commit_id : t -> string Fiber.t + +(** List of files committed in the repo *) +val files : t -> Path.t list Fiber.t + (** VCS commands *) val git : Path.t Lazy.t val hg : Path.t Lazy.t diff --git a/src/watermarks.ml b/src/watermarks.ml index 81903ffd6f2..70f38af9d81 100644 --- a/src/watermarks.ml +++ b/src/watermarks.ml @@ -169,20 +169,23 @@ let read_project_name () = let get_name ~files ?name () = let package_names = List.filter_map files ~f:(fun fn -> - if Filename.dirname fn = "." then + match Path.parent fn with + | Some p when Path.is_root p -> begin + let fn = Path.basename fn in match Filename.split_extension fn with | s, ".opam" -> Some s | _ -> None - else - None) + end + | _ -> None) in + let dune_project_file = Path.in_source Dune_project.filename in if package_names = [] then die "@{Error@}: no .opam files found."; let (loc, name) = match Wp.t with | Dune -> begin assert (Option.is_none name); - if not (List.mem ~set:files Dune_project.filename) then + if not (List.mem ~set:files dune_project_file) then die "@{Error@}: There is no dune-project file in the current \ directory, please add one with a (name ) field in it.\n\ Hint: dune subst must be executed from the root of the project."; @@ -197,7 +200,7 @@ let get_name ~files ?name () = | Some name -> (Loc.none, name) | None -> match - if List.mem ~set:files Dune_project.filename then + if List.mem ~set:files dune_project_file then read_project_name () else None @@ -234,39 +237,27 @@ let get_name ~files ?name () = end; name -let subst_git ?name () = - let rev = "HEAD" in - let git = - match Bin.which ~path:(Env.path Env.initial) "git" with - | Some x -> x - | None -> Utils.program_not_found "git" ~loc:None - in - let env = Env.initial in +let subst ?name vcs = let+ ((version, commit), files) = Fiber.fork_and_join (fun () -> - Fiber.fork_and_join - (fun () -> - Process.run_capture Strict git ["describe"; "--always"; "--dirty"] - ~env) - (fun () -> - Process.run_capture Strict git ["rev-parse"; rev] - ~env)) - (fun () -> - Process.run_capture_lines Strict git - ["ls-tree"; "-r"; "--name-only"; rev] ~env) + Fiber.fork_and_join + (fun () -> Vcs.describe vcs) + (fun () -> Vcs.commit_id vcs)) + (fun () -> Vcs.files vcs) in - let version = String.trim version in - let commit = String.trim commit in let name = get_name ~files ?name () in let watermarks = make_watermark_map ~name ~version ~commit in - List.iter files ~f:(fun fn -> - let path = Path.in_source fn in + List.iter files ~f:(fun path -> if is_a_source_file path then subst_file path ~map:watermarks) let subst ?name () = - if Sys.file_exists ".git" then - subst_git ?name () - else - Fiber.return () + match + Sys.readdir "." + |> Array.to_list + |> String.Set.of_list + |> Vcs.Kind.of_dir_contents + with + | None -> Fiber.return () + | Some kind -> subst ?name { kind; root = Path.root }