diff vext.sml @ 1740:669bd699082d

Update vext

--- a/vext.sml	Thu Jul 13 15:33:43 2017 +0100
+++ b/vext.sml	Thu Jul 13 15:34:33 2017 +0100
@@ -33,7 +33,7 @@
     Software without prior written authorization.
 *)
 
-val vext_version = "0.9.4"
+val vext_version = "0.9.6"
 
 
 datatype vcs =
@@ -48,9 +48,11 @@
              repo : string option
          }
 
+type id_or_tag = string
+
 datatype pin =
          UNPINNED |
-         PINNED of string
+         PINNED of id_or_tag
 
 datatype libstate =
          ABSENT |
@@ -60,7 +62,8 @@
 
 datatype localstate =
          MODIFIED |
-         UNMODIFIED
+         LOCK_MISMATCHED |
+         CLEAN
 
 datatype branch =
          BRANCH of string |
@@ -77,21 +80,20 @@
 
 type libname = string
 
-type id_or_tag = string
-
 type libspec = {
     libname : libname,
     vcs : vcs,
     source : source,
     branch : branch,
-    pin : pin
+    project_pin : pin,
+    lock_pin : pin
 }
 
 type lock = {
     libname : libname,
     id_or_tag : id_or_tag
 }
-                   
+
 type remote_spec = {
     anon : string option,
     auth : string option
@@ -177,6 +179,7 @@
     val review : context -> libspec -> (libstate * localstate) result
     val status : context -> libspec -> (libstate * localstate) result
     val update : context -> libspec -> id_or_tag result
+    val id_of : context -> libspec -> id_or_tag result
 end
 
 structure FileBits :> sig
@@ -402,7 +405,8 @@
        - ABSENT: Repo doesn't exist here at all.
     *)
 
-    fun check with_network context ({ libname, branch, pin, ... } : libspec) =
+    fun check with_network context
+              ({ libname, branch, project_pin, lock_pin, ... } : libspec) =
         let fun check_unpinned () =
                 let val is_newest = if with_network
                                     then V.is_newest
@@ -422,26 +426,39 @@
                     ERROR e => ERROR e
                   | OK true => OK CORRECT
                   | OK false => OK WRONG
-            fun check' () =
-                case pin of
+            fun check_remote () =
+                case project_pin of
                     UNPINNED => check_unpinned ()
                   | PINNED target => check_pinned target
+            fun check_local () =
+                case V.is_modified_locally context libname of
+                    ERROR e => ERROR e
+                  | OK true  => OK MODIFIED
+                  | OK false => 
+                    case lock_pin of
+                        UNPINNED => OK CLEAN
+                      | PINNED target =>
+                        case V.is_at context (libname, target) of
+                            ERROR e => ERROR e
+                          | OK true => OK CLEAN
+                          | OK false => OK LOCK_MISMATCHED
         in
             case V.exists context libname of
                 ERROR e => ERROR e
-              | OK false => OK (ABSENT, UNMODIFIED)
+              | OK false => OK (ABSENT, CLEAN)
               | OK true =>
-                case (check' (), V.is_modified_locally context libname) of
+                case (check_remote (), check_local ()) of
                     (ERROR e, _) => ERROR e
                   | (_, ERROR e) => ERROR e
-                  | (OK state, OK true) => OK (state, MODIFIED)
-                  | (OK state, OK false) => OK (state, UNMODIFIED)
+                  | (OK r, OK l) => OK (r, l)
         end
 
     val review = check true
     val status = check false
-                         
-    fun update context ({ libname, source, branch, pin, ... } : libspec) =
+
+    fun update context
+               ({ libname, source, branch,
+                  project_pin, lock_pin, ... } : libspec) =
         let fun update_unpinned () =
                 case V.is_newest context (libname, branch) of
                     ERROR e => ERROR e
@@ -453,9 +470,12 @@
                   | OK true => OK target
                   | OK false => V.update_to context (libname, target)
             fun update' () =
-                case pin of
-                    UNPINNED => update_unpinned ()
-                  | PINNED target => update_pinned target
+                case lock_pin of
+                    PINNED target => update_pinned target
+                  | UNPINNED =>
+                    case project_pin of
+                        PINNED target => update_pinned target
+                      | UNPINNED => update_unpinned ()
         in
             case V.exists context libname of
                 ERROR e => ERROR e
@@ -465,6 +485,10 @@
                     ERROR e => ERROR e
                   | OK () => update' ()
         end
+
+    fun id_of context ({ libname, ... } : libspec) =
+        V.id_of context libname
+                
 end
 
 (* Simple Standard ML JSON parser
@@ -1369,6 +1393,9 @@
 
     fun update context (spec as { vcs, ... } : libspec) =
         (fn HG => H.update | GIT => G.update) vcs context spec
+
+    fun id_of context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.id_of | GIT => G.id_of) vcs context spec
 end
 
 val libobjname = "libraries"
@@ -1383,10 +1410,14 @@
         val repo     = retrieve ["repository"]
         val url      = retrieve ["url"]
         val branch   = retrieve ["branch"]
-        val user_pin = retrieve ["pin"]
+        val project_pin = case retrieve ["pin"] of
+                              NONE => UNPINNED
+                            | SOME p => PINNED p
         val lock_pin = case lookup_optional lock_json [libobjname, libname] of
-                           SOME ll => lookup_optional_string ll ["pin"]
-                         | NONE => NONE
+                           NONE => UNPINNED
+                         | SOME ll => case lookup_optional_string ll ["pin"] of
+                                          SOME p => PINNED p
+                                        | NONE => UNPINNED
     in
         {
           libname = libname,
@@ -1401,12 +1432,8 @@
                        SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
                      | _ => raise Fail ("Must have exactly one of service " ^
                                         "or url string"),
-          pin = case lock_pin of
-                    SOME p => PINNED p
-                  | NONE =>
-                    case user_pin of
-                        SOME p => PINNED p
-                      | NONE => UNPINNED,
+          project_pin = project_pin,
+          lock_pin = lock_pin,
           branch = case branch of
                        SOME b => BRANCH b
                      | NONE => DEFAULT_BRANCH
@@ -1502,12 +1529,13 @@
 
 val libname_width = 25
 val libstate_width = 11
-val localstate_width = 9
+val localstate_width = 17
 val notes_width = 5
 val divider = " | "
+val clear_line = "\r" ^ pad_to 80 "";
 
 fun print_status_header () =
-    print ("\r" ^ pad_to 80 "" ^ "\n " ^
+    print (clear_line ^ "\n " ^
            pad_to libname_width "Library" ^ divider ^
            pad_to libstate_width "State" ^ divider ^
            pad_to localstate_width "Local" ^ divider ^
@@ -1518,7 +1546,7 @@
            hline_to notes_width ^ "\n")
 
 fun print_outcome_header () =
-    print ("\r" ^ pad_to 80 "" ^ "\n " ^
+    print (clear_line ^ "\n " ^
            pad_to libname_width "Library" ^ divider ^
            pad_to libstate_width "Outcome" ^ divider ^
            "Notes" ^ "\n " ^
@@ -1537,8 +1565,9 @@
         val localstate_str =
             case status of
                 OK (_, MODIFIED) => "Modified"
-              | OK (_, UNMODIFIED) => "Clean"
-              | _ => ""
+              | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
+              | OK (_, CLEAN) => "Clean"
+              | ERROR _ => ""
         val error_str =
             case status of
                 ERROR e => e
@@ -1612,6 +1641,26 @@
         return_code
     end
 
+fun lock_project ({ context, libs } : project) =
+    let val outcomes = map (fn lib =>
+                               (#libname lib, AnyLibControl.id_of context lib))
+                           libs
+        val locks =
+            List.concat
+                (map (fn (libname, result) =>
+                         case result of
+                             ERROR _ => []
+                           | OK id => [{ libname = libname, id_or_tag = id }])
+                     outcomes)
+        val return_code = return_code_for outcomes
+        val _ = print clear_line
+    in
+        if OS.Process.isSuccess return_code
+        then save_lock_file (#rootpath context) locks
+        else ();
+        return_code
+    end
+        
 fun load_local_project pintype =
     let val userconfig = load_userconfig ()
         val rootpath = OS.FileSys.getDir ()
@@ -1630,9 +1679,10 @@
         return_code
     end
         
-fun review () = with_local_project NO_LOCKFILE review_project
-fun status () = with_local_project NO_LOCKFILE status_of_project
+fun review () = with_local_project USE_LOCKFILE review_project
+fun status () = with_local_project USE_LOCKFILE status_of_project
 fun update () = with_local_project NO_LOCKFILE update_project
+fun lock () = with_local_project NO_LOCKFILE lock_project
 fun install () = with_local_project USE_LOCKFILE update_project
 
 fun version () =
@@ -1650,6 +1700,7 @@
             ^ "  review   check configured libraries against their providers, and report\n"
             ^ "  install  update configured libraries according to project specs and lock file\n"
             ^ "  update   update configured libraries and lock file according to project specs\n"
+            ^ "  lock     update lock file to match local library status\n"
             ^ "  version  print the Vext version number and exit\n\n");
     OS.Process.failure)
 
@@ -1660,6 +1711,7 @@
               | ["status"] => status ()
               | ["install"] => install ()
               | ["update"] => update ()
+              | ["lock"] => lock ()
               | ["version"] => version ()
               | _ => usage ()
     in