comparison vext.sml @ 314:d741e2c90eab

Update Vext and subrepos

     Particular Programs Ltd shall not be used in advertising or
     otherwise to promote the sale, use or other dealings in this
     Software without prior written authorization.
 *)
 
-val vext_version = "0.9.4"
+val vext_version = "0.9.6"
 
 
 datatype vcs =
          HG |
          GIT

              service : string,
              owner : string option,
              repo : string option
          }
 
+type id_or_tag = string
+
 datatype pin =
          UNPINNED |
-         PINNED of string
+         PINNED of id_or_tag
 
 datatype libstate =
          ABSENT |
          CORRECT |
          SUPERSEDED |
          WRONG
 
 datatype localstate =
          MODIFIED |
-         UNMODIFIED
+         LOCK_MISMATCHED |
+         CLEAN
 
 datatype branch =
          BRANCH of string |
          DEFAULT_BRANCH
              

          OK of 'a |
          ERROR of string
 
 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
 }
 

 
 signature LIB_CONTROL = sig
     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
     val extpath : context -> string
     val libpath : context -> libname -> string

        - WRONG: We are at any revision other than the pinned one.
 
        - 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
                                     else V.is_newest_locally
                 in

             fun check_pinned target =
                 case V.is_at context (libname, target) of
                     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
                   | OK true => V.id_of context libname
                   | OK false => V.update context (libname, branch)

                 case V.is_at context (libname, target) of
                     ERROR e => ERROR e
                   | 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
               | OK true => update' ()
               | OK false =>
                 case V.checkout context (libname, source, branch) of
                     ERROR e => ERROR e
                   | OK () => update' ()
         end
+
+    fun id_of context ({ libname, ... } : libspec) =
+        V.id_of context libname
+                
 end
 
 (* Simple Standard ML JSON parser
    ==============================
 

     fun status context (spec as { vcs, ... } : libspec) =
         (fn HG => H.status | GIT => G.status) vcs context spec
 
     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"
                                              
 fun load_libspec spec_json lock_json libname : libspec =

         val service  = retrieve ["service"]
         val owner    = retrieve ["owner"]
         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,
           vcs = case vcs of
                     "hg" => HG

                        (SOME u, NONE, _, _) => URL_SOURCE u
                      | (NONE, SOME ss, owner, repo) =>
                        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
         }
     end  

 fun hline_to 0 = ""
   | hline_to n = "-" ^ hline_to (n-1)
 
 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 ^
            "Notes" ^ "\n " ^
            hline_to libname_width ^ "-+-" ^
            hline_to libstate_width ^ "-+-" ^
            hline_to localstate_width ^ "-+-" ^
            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 " ^
            hline_to libname_width ^ "-+-" ^
            hline_to libstate_width ^ "-+-" ^

               | OK (WRONG, _) => "Wrong"
               | ERROR _ => "Error"
         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
               | _ => ""
     in

         then save_lock_file (#rootpath context) locks
         else ();
         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 ()
     in
         load_project userconfig rootpath pintype

         val _ = print "\n";
     in
         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 () =
     (print ("v" ^ vext_version ^ "\n");
      OS.Process.success)

             ^ "where <command> is one of:\n\n"
             ^ "  status   print quick report on local status only, without using network\n"
             ^ "  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)
 
 fun vext args =
     let val return_code = 
             case args of
                 ["review"] => review ()
               | ["status"] => status ()
               | ["install"] => install ()
               | ["update"] => update ()
+              | ["lock"] => lock ()
               | ["version"] => version ()
               | _ => usage ()
     in
         OS.Process.exit return_code;
         ()