diff vext.sml @ 1752:716e13004b19

Update Vext and subrepos

--- a/vext.sml	Tue Oct 10 11:18:47 2017 +0100
+++ b/vext.sml	Thu Nov 09 15:59:18 2017 +0000
@@ -38,7 +38,7 @@
     authorization.
 *)
 
-val vext_version = "0.9.9"
+val vext_version = "0.9.91"
 
 
 datatype vcs =
@@ -158,7 +158,7 @@
         given branch. False may indicate that the branch has advanced
         or that the library is not on the branch at all. This function
         may use the network to check for new revisions *)
-    val is_newest : context -> libname * branch -> bool result
+    val is_newest : context -> libname * source * branch -> bool result
 
     (** Test whether the library is at the newest revision available
         locally for the given branch. False may indicate that the
@@ -175,10 +175,10 @@
     val checkout : context -> libname * source * branch -> unit result
 
     (** Update the library to the given branch tip *)
-    val update : context -> libname * branch -> id_or_tag result
+    val update : context -> libname * source * branch -> id_or_tag result
 
     (** Update the library to the given specific id or tag *)
-    val update_to : context -> libname * id_or_tag -> id_or_tag result
+    val update_to : context -> libname * source * id_or_tag -> id_or_tag result
 end
 
 signature LIB_CONTROL = sig
@@ -210,23 +210,31 @@
           | SOME _ => true
           | NONE => false
 
+    fun split_relative path desc =
+        case OS.Path.fromString path of
+            { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
+          | { arcs, ... } => arcs
+                        
     fun extpath ({ rootpath, extdir, ... } : context) =
         let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
         in OS.Path.toString {
                 isAbs = isAbs,
                 vol = vol,
-                arcs = arcs @ [ extdir ]
+                arcs = arcs @
+                       split_relative extdir "extdir"
             }
         end
     
     fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
         (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
         let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
-            val split = String.fields (fn c => c = #"/")
         in OS.Path.toString {
                 isAbs = isAbs,
                 vol = vol,
-                arcs = arcs @ [ extdir ] @ split libname @ split remainder
+                arcs = arcs @
+                       split_relative extdir "extdir" @
+                       split_relative libname "library path" @
+                       split_relative remainder "subpath"
             }
         end
 
@@ -385,12 +393,9 @@
                                       ERROR ("Directory creation failed: " ^ e))
 
     fun mkpath path =
-        (* strip any trailing '/', something isDir doesn't always handle *)
-        case rev (explode path) of
-            #"/"::rest => mkpath (implode (rev rest))
-          | _ => mkpath' path
+        mkpath' (OS.Path.mkCanonical path)
 
-    fun rmpath path =
+    fun rmpath' path =
         let open OS
             fun files_from dirstream =
                 case FileSys.readDir dirstream of
@@ -419,6 +424,10 @@
             (remove path; OK ())
             handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
         end
+
+    fun rmpath path =
+        rmpath' (OS.Path.mkCanonical path)
+
 end
                                          
 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
@@ -449,13 +458,15 @@
     *)
 
     fun check with_network context
-              ({ libname, branch, project_pin, lock_pin, ... } : libspec) =
+              ({ libname, source, branch,
+                 project_pin, lock_pin, ... } : libspec) =
         let fun check_unpinned () =
-                let val is_newest = if with_network
-                                    then V.is_newest
-                                    else V.is_newest_locally
+                let val newest =
+                        if with_network
+                        then V.is_newest context (libname, source, branch)
+                        else V.is_newest_locally context (libname, branch)
                 in
-                    case is_newest context (libname, branch) of
+                    case newest of
                          ERROR e => ERROR e
                        | OK true => OK CORRECT
                        | OK false =>
@@ -503,15 +514,15 @@
                ({ libname, source, branch,
                   project_pin, lock_pin, ... } : libspec) =
         let fun update_unpinned () =
-                case V.is_newest context (libname, branch) of
+                case V.is_newest context (libname, source, branch) of
                     ERROR e => ERROR e
                   | OK true => V.id_of context libname
-                  | OK false => V.update context (libname, branch)
+                  | OK false => V.update context (libname, source, branch)
             fun update_pinned target =
                 case V.is_at context (libname, target) of
                     ERROR e => ERROR e
                   | OK true => OK target
-                  | OK false => V.update_to context (libname, target)
+                  | OK false => V.update_to context (libname, source, target)
             fun update' () =
                 case lock_pin of
                     PINNED target => update_pinned target
@@ -1156,7 +1167,11 @@
 end
 
 structure HgControl :> VCS_CONTROL = struct
-                            
+
+    (* Pulls always use an explicit URL, never just the default
+       remote, in order to ensure we update properly if the location
+       given in the project file changes. *)
+
     type vcsstate = { id: string, modified: bool,
                       branch: string, tags: string list }
 
@@ -1233,21 +1248,24 @@
                                ["log", "-l1",
                                 "-b", branch_name branch,
                                 "--template", "{node}"] of
-            ERROR e => ERROR e
+            ERROR e => OK false (* desired branch does not exist *)
           | OK newest_in_repo => is_at context (libname, newest_in_repo)
 
-    fun pull context libname =
-        hg_command context libname
-                   (if FileBits.verbose ()
-                    then ["pull"]
-                    else ["pull", "-q"])
+    fun pull context (libname, source) =
+        let val url = remote_for context (libname, source)
+        in
+            hg_command context libname
+                       (if FileBits.verbose ()
+                        then ["pull", url]
+                        else ["pull", "-q", url])
+        end
 
-    fun is_newest context (libname, branch) =
+    fun is_newest context (libname, source, branch) =
         case is_newest_locally context (libname, branch) of
             ERROR e => ERROR e
           | OK false => OK false
           | OK true =>
-            case pull context libname of
+            case pull context (libname, source) of
                 ERROR e => ERROR e
               | _ => is_newest_locally context (libname, branch)
 
@@ -1269,8 +1287,8 @@
                                  url, libname]
         end
                                                     
-    fun update context (libname, branch) =
-        let val pull_result = pull context libname
+    fun update context (libname, source, branch) =
+        let val pull_result = pull context (libname, source)
         in
             case hg_command context libname ["update", branch_name branch] of
                 ERROR e => ERROR e
@@ -1280,10 +1298,10 @@
                   | _ => id_of context libname
         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, id) = 
-        let val pull_result = pull context libname
+      | update_to context (libname, source, id) = 
+        let val pull_result = pull context (libname, source)
         in
             case hg_command context libname ["update", "-r", id] of
                 OK _ => id_of context libname
@@ -1298,8 +1316,11 @@
 structure GitControl :> VCS_CONTROL = struct
 
     (* With Git repos we always operate in detached HEAD state. Even
-       the master branch is checked out using the remote reference,
-       origin/master. *)
+       the master branch is checked out using a remote reference
+       (vext/master). The remote we use is always named vext, 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. *)
 
     fun git_command context libname args =
         FileBits.command context libname ("git" :: args)
@@ -1319,7 +1340,9 @@
                                | BRANCH "" => "master"
                                | BRANCH b => b
 
-    fun remote_branch_name branch = "origin/" ^ branch_name branch
+    val our_remote = "vext"
+                                                 
+    fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
 
     fun checkout context (libname, source, branch) =
         let val url = remote_for context (libname, source)
@@ -1329,12 +1352,27 @@
                out into an existing empty dir anyway *)
             case FileBits.mkpath (FileBits.libpath context libname) of
                 OK () => git_command context ""
-                                     ["clone", "-b",
-                                      branch_name branch,
+                                     ["clone", "--origin", our_remote,
+                                      "--branch", branch_name branch,
                                       url, libname]
               | ERROR e => ERROR e
         end
 
+    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
+           someone else, we'll need to do it after the fact. Git
+           doesn't seem to have a means to add a remote or change its
+           url if it already exists; seems we have to do this: *)
+        let val url = remote_for context (libname, source)
+        in
+            case git_command context libname
+                             ["remote", "set-url", our_remote, url] of
+                OK () => OK ()
+              | ERROR e => git_command context libname
+                                       ["remote", "add", "-f", our_remote, url]
+        end
+
     (* NB git rev-parse HEAD shows revision id of current checkout;
        git rev-list -1 <tag> shows revision id of revision with that tag *)
 
@@ -1343,7 +1381,7 @@
             
     fun is_at context (libname, id_or_tag) =
         case id_of context libname of
-            ERROR e => ERROR e
+            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
@@ -1351,24 +1389,32 @@
             else 
                 case git_command_output context libname
                                         ["show-ref",
-                                         "refs/tags/" ^ id_or_tag] of
+                                         "refs/tags/" ^ id_or_tag,
+                                         "--"] of
                     OK "" => OK false
                   | ERROR _ => OK false
                   | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s))
 
     fun branch_tip context (libname, branch) =
+        (* 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,
+           e.g. if the repo was checked out by something other than
+           Vext, and if that's the case, we can't add it here; we'll
+           just have to fail, since checking against local branches
+           instead could produce the wrong result. *)
         git_command_output context libname
                            ["rev-list", "-1",
-                            remote_branch_name branch]
+                            remote_branch_name branch, "--"]
                        
     fun is_newest_locally context (libname, branch) =
         case branch_tip context (libname, branch) of
-            ERROR e => ERROR e
+            ERROR e => OK false
           | OK rev => is_at context (libname, rev)
 
     fun is_on_branch context (libname, branch) =
         case branch_tip context (libname, branch) of
-            ERROR e => ERROR e
+            ERROR e => OK false
           | OK rev =>
             case is_at context (libname, rev) of
                 ERROR e => ERROR e
@@ -1380,14 +1426,22 @@
                     ERROR e => OK false  (* cmd returns non-zero for no *)
                   | _ => OK true
 
-    fun is_newest context (libname, branch) =
-        case is_newest_locally context (libname, branch) of
+    fun fetch context (libname, source) =
+        case add_our_remote context (libname, source) of
             ERROR e => ERROR e
-          | OK false => OK false
-          | OK true =>
-            case git_command context libname ["fetch"] of
+          | _ => git_command context libname ["fetch", our_remote]
+                            
+    fun is_newest context (libname, source, branch) =
+        case add_our_remote context (libname, source) of
+            ERROR e => ERROR e
+          | OK () => 
+            case is_newest_locally context (libname, branch) of
                 ERROR e => ERROR e
-              | _ => is_newest_locally context (libname, branch)
+              | OK false => OK false
+              | OK true =>
+                case fetch context (libname, source) of
+                    ERROR e => ERROR e
+                  | _ => is_newest_locally context (libname, branch)
 
     fun is_modified_locally context libname =
         case git_command_output context libname ["status", "--porcelain"] of
@@ -1402,8 +1456,8 @@
        but it's perhaps cleaner not to maintain a local branch at all,
        but instead checkout the remote branch as a detached head. *)
 
-    fun update context (libname, branch) =
-        case git_command context libname ["fetch"] of
+    fun update context (libname, source, branch) =
+        case fetch context (libname, source) of
             ERROR e => ERROR e
           | _ =>
             case git_command context libname ["checkout", "--detach",
@@ -1419,10 +1473,10 @@
        update to a new pin (from the lock file) that hasn't been
        fetched yet. *)
 
-    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, id) =
-        let val fetch_result = git_command context libname ["fetch"]
+      | update_to context (libname, source, id) =
+        let val fetch_result = fetch context (libname, source)
         in
             case git_command context libname ["checkout", "--detach", id] of
                 OK _ => id_of context libname