@@ 38,7 38,7 @@
authorization.
*)
-val repoint_version = "1.3"
+val repoint_version = "1.5"
datatype vcs =
@@ 72,7 72,7 @@ datatype localstate =
CLEAN
datatype branch =
- BRANCH of string |
+ BRANCH of string | (* Non-empty *)
DEFAULT_BRANCH
(* If we can recover from an error, for example by reporting failure
@@ 191,8 191,9 @@ signature VCS_CONTROL = sig
local copy of the library already exists *)
val update : context -> libname * source * branch -> unit result
- (** Update the library to the given specific id or tag *)
- val update_to : context -> libname * source * id_or_tag -> unit result
+ (** Update the library to the given specific id or tag,
+ understanding that we are expected to be on the given branch *)
+ val update_to : context -> libname * source * branch * id_or_tag -> unit result
(** Return a URL from which the library can be cloned, given that
the local copy already exists. For a DVCS this can be the
@@ 633,7 634,7 @@ functor LibControlFn (V: VCS_CONTROL) :>
case V.is_at context (libname, target) of
ERROR e => ERROR e
| OK true => OK ()
- | OK false => V.update_to context (libname, source, target)
+ | OK false => V.update_to context (libname, source, branch, target)
fun update' () =
case lock_pin of
PINNED target => update_pinned target
@@ 1285,12 1286,14 @@ structure HgControl :> VCS_CONTROL = str
fun remote_for context (libname, source) =
Provider.remote_url context HG source libname
+ val default_branch_name = "default"
+
fun current_state (context : context) libname : vcsstate result =
let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
and extract_branch b =
if is_branch b (* need to remove enclosing parens *)
then (implode o rev o tl o rev o tl o explode) b
- else "default"
+ else default_branch_name
and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
and extract_id id =
if is_modified id (* need to remove trailing "+" *)
@@ 1327,8 1330,7 @@ structure HgControl :> VCS_CONTROL = str
end
fun branch_name branch = case branch of
- DEFAULT_BRANCH => "default"
- | BRANCH "" => "default"
+ DEFAULT_BRANCH => default_branch_name
| BRANCH b => b
fun id_of context libname =
@@ 1420,9 1422,9 @@ structure HgControl :> VCS_CONTROL = str
end
end
- fun update_to context (libname, _, "") =
+ fun update_to context (libname, _, _, "") =
ERROR "Non-empty id (tag or revision id) required for update_to"
- | update_to context (libname, source, id) =
+ | update_to context (libname, source, _, id) =
let (* pull invalidates the cache, as we must here *)
val pull_result = pull context (libname, source)
in
@@ 1441,12 1443,13 @@ end
structure GitControl :> VCS_CONTROL = struct
- (* With Git repos we always operate in detached HEAD state. Even
- the master branch is checked out using a remote reference
- (repoint/master). The remote we use is always named repoint, and we
- update it to the expected URL each time we fetch, in order to
- ensure we update properly if the location given in the project
- file changes. The origin remote is unused. *)
+ (* With Git repos we are intentionally careless about the state of
+ the local branch whose name we are given - we work by checking
+ out either a specific commit (perhaps in detached HEAD state)
+ or resetting our local branch based on the remote. The remote
+ we use is always named repoint, and we update it to the
+ expected URL each time we fetch, in order to ensure we update
+ properly if the location given in the project file changes. *)
val git_program = "git"
@@ 1469,35 1472,46 @@ structure GitControl :> VCS_CONTROL = st
fun remote_for context (libname, source) =
Provider.remote_url context GIT source libname
- fun branch_name branch = case branch of
- DEFAULT_BRANCH => "master"
- | BRANCH "" => "master"
- | BRANCH b => b
-
val our_remote = "repoint"
-
- fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
-
- fun checkout context (libname, source, branch) =
- let val url = remote_for context (libname, source)
+ val fallback_default_branch = "master" (* only if it can't be determined *)
+
+ fun default_branch_name context libname =
+ let fun return_fallback msg =
+ (if FileBits.verbose ()
+ then print ("\n" ^ msg ^ "\n")
+ else ();
+ fallback_default_branch)
in
- (* make the lib dir rather than just the ext dir, since
- the lib dir might be nested and git will happily check
- out into an existing empty dir anyway *)
- case FileBits.mkpath (FileBits.libpath context libname) of
- OK () =>
- git_command context ""
- (case branch of
- DEFAULT_BRANCH =>
- ["clone", "--origin", our_remote,
- url, libname]
- | _ =>
- ["clone", "--origin", our_remote,
- "--branch", branch_name branch,
- url, libname])
- | ERROR e => ERROR e
+ let val headfile = FileBits.subpath
+ context libname
+ (".git/refs/remotes/" ^ our_remote ^ "/HEAD")
+ val headspec = FileBits.file_contents headfile
+ in
+ case String.tokens (fn c => c = #" ") headspec of
+ ["ref:", refpath] =>
+ (case String.fields (fn c => c = #"/") refpath of
+ "refs" :: "remotes" :: _ :: rest =>
+ String.concatWith "/" rest
+ | _ =>
+ return_fallback
+ ("Unable to extract default branch from "
+ ^ "HEAD ref \"" ^ refpath ^ "\""))
+ | _ =>
+ return_fallback ("Unable to extract HEAD ref from \""
+ ^ headspec ^ "\"")
+ end
+ handle IO.Io _ =>
+ return_fallback "Unable to read HEAD ref file"
end
+ fun local_branch_name context (libname, branch) =
+ case branch of
+ BRANCH b => b
+ | DEFAULT_BRANCH => default_branch_name context libname
+
+ fun remote_branch_for branch_name =
+ our_remote ^ "/" ^ branch_name
+
fun add_our_remote context (libname, source) =
(* When we do the checkout ourselves (above), we add the
remote at the same time. But if the repo was cloned by
@@ 1518,17 1532,11 @@ structure GitControl :> VCS_CONTROL = st
fun id_of context libname =
git_command_output context libname ["rev-parse", "HEAD"]
-
- fun is_at context (libname, id_or_tag) =
- case id_of context libname of
- ERROR e => OK false (* HEAD nonexistent, expected in empty repo *)
- | OK id =>
- if String.isPrefix id_or_tag id orelse
- String.isPrefix id id_or_tag
- then OK true
- else is_at_tag context (libname, id, id_or_tag)
- and is_at_tag context (libname, id, tag) =
+ fun symbolic_id_of context libname =
+ git_command_output context libname ["rev-parse", "--abbrev-ref", "HEAD"]
+
+ fun is_at_tag context (libname, id, tag) =
(* For annotated tags (with message) show-ref returns the tag
object ref rather than that of the revision being tagged;
we need the subsequent rev-list to chase that up. In fact
@@ 1548,8 1556,22 @@ structure GitControl :> VCS_CONTROL = st
OK tagged => OK (id = tagged)
| ERROR _ => OK false
end
+
+ fun ids_match id1 id2 =
+ String.isPrefix id1 id2 orelse
+ String.isPrefix id2 id1
+
+ fun is_commit_at context (libname, id_or_tag) id =
+ if ids_match id_or_tag id
+ then OK true
+ else is_at_tag context (libname, id, id_or_tag)
+
+ fun is_at context (libname, id_or_tag) =
+ case id_of context libname of
+ ERROR e => OK false (* HEAD nonexistent, expected in empty repo *)
+ | OK id => is_commit_at context (libname, id_or_tag) id
- fun branch_tip context (libname, branch) =
+ fun branch_tip context (libname, branch_name) =
(* We don't have access to the source info or the network
here, as this is used by status (e.g. via is_on_branch) as
well as review. It's possible the remote branch won't exist,
@@ 1559,43 1581,78 @@ structure GitControl :> VCS_CONTROL = st
instead could produce the wrong result. *)
git_command_output context libname
["rev-list", "-1",
- remote_branch_name branch, "--"]
-
- fun is_newest_locally context (libname, branch) =
- case branch_tip context (libname, branch) of
- ERROR e => OK false
- | OK rev => is_at context (libname, rev)
+ remote_branch_for branch_name,
+ "--"]
- fun is_on_branch context (libname, branch) =
- case branch_tip context (libname, branch) of
+ fun is_branch_ancestor context (libname, branch_name) commit =
+ case git_command context libname
+ ["merge-base", "--is-ancestor",
+ commit,
+ remote_branch_for branch_name
+ ] of
+ ERROR e => OK false (* cmd returns non-zero for no *)
+ | _ => OK true
+
+ fun is_tip_or_ancestor_by_name context (libname, branch_name) =
+ case branch_tip context (libname, branch_name) of
ERROR e => OK false
| OK rev =>
case is_at context (libname, rev) of
ERROR e => ERROR e
| OK true => OK true
| OK false =>
- case git_command context libname
- ["merge-base", "--is-ancestor",
- "HEAD", remote_branch_name branch] of
- ERROR e => OK false (* cmd returns non-zero for no *)
- | _ => OK true
+ is_branch_ancestor context (libname, branch_name) "HEAD"
+
+ fun is_commit_tip_or_ancestor_by_name context (libname, branch_name) id =
+ case branch_tip context (libname, branch_name) of
+ ERROR e => OK false
+ | OK rev =>
+ case is_commit_at context (libname, rev) id of
+ ERROR e => ERROR e
+ | OK true => OK true
+ | OK false =>
+ is_branch_ancestor context (libname, branch_name) id
+
+ fun is_on_branch context (libname, branch) =
+ let val branch_name = local_branch_name context (libname, branch)
+ in
+ is_tip_or_ancestor_by_name context (libname, branch_name)
+ end
+
+ fun is_newest_locally_by_name context (libname, branch_name) =
+ case branch_tip context (libname, branch_name) of
+ ERROR e => OK false
+ | OK rev => is_at context (libname, rev)
+
+ fun is_newest_locally context (libname, branch) =
+ let val branch_name = local_branch_name context (libname, branch)
+ in
+ is_newest_locally_by_name context (libname, branch_name)
+ end
fun fetch context (libname, source) =
case add_our_remote context (libname, source) of
ERROR e => ERROR e
| _ => git_command context libname ["fetch", our_remote]
- fun is_newest context (libname, source, branch) =
+ fun is_newest_by_name context (libname, source, branch_name) =
case add_our_remote context (libname, source) of
ERROR e => ERROR e
| OK () =>
- case is_newest_locally context (libname, branch) of
+ case is_newest_locally_by_name context (libname, branch_name) of
ERROR e => ERROR e
| OK false => OK false
| OK true =>
case fetch context (libname, source) of
ERROR e => ERROR e
- | _ => is_newest_locally context (libname, branch)
+ | _ =>
+ is_newest_locally_by_name context (libname, branch_name)
+
+ fun is_newest context (libname, source, branch) =
+ let val branch_name = local_branch_name context (libname, branch)
+ in
+ is_newest_by_name context (libname, source, branch_name)
+ end
fun is_modified_locally context libname =
case git_command_output context libname
@@ 1605,37 1662,106 @@ structure GitControl :> VCS_CONTROL = st
| OK "" => OK false
| OK _ => OK true
+ fun checkout context (libname, source, branch) =
+ let val url = remote_for context (libname, source)
+ in
+ (* make the lib dir rather than just the ext dir, since
+ the lib dir might be nested and git will happily check
+ out into an existing empty dir anyway *)
+ case FileBits.mkpath (FileBits.libpath context libname) of
+ ERROR e => ERROR e
+ | OK () =>
+ git_command context ""
+ (case branch of
+ DEFAULT_BRANCH =>
+ ["clone", "--origin", our_remote,
+ url, libname]
+ | BRANCH b =>
+ ["clone", "--origin", our_remote,
+ "--branch", b,
+ url, libname])
+ end
+
+ (* Generally speaking, when updating to a new commit from a remote
+ branch, we can reset the local branch to that commit only if it
+ was previously pointing at an ancestor of it. Otherwise it's
+ possible the user has made some unpushed commits locally that
+ we would lose, and we should avoid moving the local branch. *)
+
+ fun can_reset_for context (libname, branch_name) =
+ case git_command_output context libname ["rev-parse", branch_name] of
+ ERROR _ => true
+ | OK id =>
+ case is_commit_tip_or_ancestor_by_name
+ context (libname, branch_name) id of
+ ERROR _ => true
+ | OK result => result
+
(* This function updates to the latest revision on a branch rather
than to a specific id or tag. We can't just checkout the given
- branch, as that will succeed even if the branch isn't up to
- date. We could checkout the branch and then fetch and merge,
- but it's perhaps cleaner not to maintain a local branch at all,
- but instead checkout the remote branch as a detached head. *)
+ local branch, as that will succeed even if it isn't up to
+ date. Instead fetch and check out the commit identified by the
+ remote branch, resetting the local branch if can_reset_for says
+ we can. *)
fun update context (libname, source, branch) =
- case fetch context (libname, source) of
- ERROR e => ERROR e
- | _ =>
- case git_command context libname ["checkout", "--detach",
- remote_branch_name branch] of
+ let val branch_name = local_branch_name context (libname, branch)
+ val remote_branch_name = remote_branch_for branch_name
+ val fetch_result = fetch context (libname, source)
+ (* NB it matters that we do the fetch before can_reset_for *)
+ val should_reset = can_reset_for context (libname, branch_name)
+ in
+ case fetch_result of
ERROR e => ERROR e
- | _ => OK ()
+ | _ =>
+ case git_command context libname
+ (if should_reset
+ then ["checkout",
+ "-B", branch_name, "--track",
+ remote_branch_name]
+ else ["checkout",
+ "--detach",
+ remote_branch_name]
+ ) of
+ ERROR e => ERROR e
+ | _ => OK ()
+ end
(* This function is dealing with a specific id or tag, so if we
- can successfully check it out (detached) then that's all we
- need to do, regardless of whether fetch succeeded or not. We do
- attempt the fetch first, though, purely in order to avoid ugly
- error messages in the common case where we're being asked to
- update to a new pin (from the lock file) that hasn't been
- fetched yet. *)
+ can successfully check it out then that's all we strictly need
+ to do. As with update, we reset the local branch if
+ can_reset_for says we can, but with the extra condition that
+ the commit we're resetting to is also on the given branch. *)
- fun update_to context (libname, _, "") =
+ fun update_to context (libname, _, _, "") =
ERROR "Non-empty id (tag or revision id) required for update_to"
- | update_to context (libname, source, id) =
- let val fetch_result = fetch context (libname, source)
+ | update_to context (libname, source, branch, id) =
+ let val branch_name = local_branch_name context (libname, branch)
+ val fetch_result = fetch context (libname, source)
+ (* NB it matters that we do the fetch before can_reset_for *)
+ val should_reset =
+ if can_reset_for context (libname, branch_name)
+ then case branch_tip context (libname, branch_name) of
+ ERROR _ => true
+ | OK tip_id =>
+ if ids_match tip_id id
+ then true
+ else case is_branch_ancestor
+ context (libname, branch_name) id of
+ ERROR _ => true
+ | OK result => result
+ else false
in
- case git_command context libname ["checkout", "--detach", id] of
- OK _ => OK ()
+ case git_command context libname
+ (if should_reset
+ then ["checkout",
+ "-B", branch_name,
+ id]
+ else ["checkout",
+ "--detach",
+ id]
+ ) of
+ OK _ => OK()
| ERROR e =>
case fetch_result of
ERROR e' => ERROR e' (* this was the ur-error *)
@@ 2229,9 2355,9 @@ structure SvnControl :> VCS_CONTROL = st
ERROR e => ERROR e
| _ => OK ()
- fun update_to context (libname, _, "") =
+ fun update_to context (libname, _, _, "") =
ERROR "Non-empty id (tag or revision id) required for update_to"
- | update_to context (libname, source, id) =
+ | update_to context (libname, source, _, id) =
case check_remote context (libname, source) of
ERROR e => ERROR e
| OK () =>
@@ 2551,6 2677,7 @@ fun load_libspec spec_json lock_json lib
lock_pin = lock_pin,
branch = case branch of
NONE => DEFAULT_BRANCH
+ | SOME "" => DEFAULT_BRANCH
| SOME b =>
case vcs of
"svn" => raise Fail ("Branches not supported for " ^
@@ 2763,11 2890,15 @@ fun print_problem_summary context lines
foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc
| (_, acc) => acc) [] lines
fun report_nonworking vcs error =
- print ((if error = "" then "" else error ^ "\n\n") ^
- "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^
- " version control system, but its\n" ^
- "executable program (" ^ (#2 (vcs_name vcs)) ^
- ") does not appear to be installed in the program path\n\n")
+ (print ((if error = "" then "" else error ^ "\n\n") ^
+ "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^
+ " version control system, but its\n" ^
+ "executable program (" ^ (#2 (vcs_name vcs)) ^
+ ") does not appear to be installed or cannot be run.\n\n");
+ case (FileBits.verbose (), OS.Process.getEnv "PATH") of
+ (true, SOME path) =>
+ print ("The PATH variable is: " ^ path ^ "\n\n")
+ | _ => ())
fun check_working [] checked = ()
| check_working (vcs::rest) checked =
if List.exists (fn v => vcs = v) checked