Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Use the VCS module in watermarks.ml #2135

Merged
2 commits merged into from May 13, 2019
Merged

Use the VCS module in watermarks.ml #2135

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
188f074
Use the VCS module in watermarks.ml
jeremiedimino May 9, 2019
1a89cdf
Merge branch 'master' into use-vcs-in-watermarks
jeremiedimino May 13, 2019
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions CHANGES.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -55,6 +55,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)
------------------

Expand Down
186 changes: 123 additions & 63 deletions src/vcs.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 (
Expand All @@ -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"])
8 changes: 7 additions & 1 deletion src/vcs.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
53 changes: 22 additions & 31 deletions src/watermarks.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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>Error@}: no <package>.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>Error@}: There is no dune-project file in the current \
directory, please add one with a (name <name>) field in it.\n\
Hint: dune subst must be executed from the root of the project.";
Expand All @@ -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
Expand Down Expand Up @@ -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 "."
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

How about using Path.readdir_unsorted here? It's probably overkill, but it will make the error a bit nicer if the user messed up permissions somehow.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hmm, I'm not sure is completely necessary here. In the case of the file_tree, it seems important as we are reporting an error for a directory somewhere far from where the user ran dune, so it's not obvious why dune is not happy. In this case, we are reporting an error for the current directory and it's going to be no surprise that dune complains if the current dir is not readable.

That said, we should probably have a special case for Sys_error in report_error.ml, so that we don't print exception Sys_error(...) which is indeed ugly.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Okay, that would be acceptable as well.

|> Array.to_list
|> String.Set.of_list
|> Vcs.Kind.of_dir_contents
with
| None -> Fiber.return ()
| Some kind -> subst ?name { kind; root = Path.root }