comparison vext.sml @ 1772:128c4544036d

Update Vext

     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.95"
+val vext_version = "0.9.97"
 
 
 datatype vcs =
          HG |
          GIT |

     val archive_dir = ".vext-archive"
 end
                    
 signature VCS_CONTROL = sig
 
+    (** Check whether the given VCS is installed and working *)
+    val is_working : context -> bool result
+    
     (** Test whether the library is present locally at all *)
     val exists : context -> libname -> bool result
                                             
     (** Return the id (hash) of the current revision for the library *)
     val id_of : context -> libname -> id_or_tag result

 signature LIB_CONTROL = sig
     val review : context -> libspec -> (libstate * localstate) result
     val status : context -> libspec -> (libstate * localstate) result
     val update : context -> libspec -> unit result
     val id_of : context -> libspec -> id_or_tag result
+    val is_working : context -> vcs -> bool result
 end
 
 structure FileBits :> sig
     val extpath : context -> string
     val libpath : context -> libname -> string

                   | OK () => update' ()
         end
 
     fun id_of context ({ libname, ... } : libspec) =
         V.id_of context libname
+
+    fun is_working context vcs =
+        V.is_working context
                 
 end
 
 (* Simple Standard ML JSON parser
    https://bitbucket.org/cannam/sml-simplejson

        given in the project file changes. *)
 
     type vcsstate = { id: string, modified: bool,
                       branch: string, tags: string list }
 
+    val hg_program = "hg"
+                        
     val hg_args = [ "--config", "ui.interactive=true",
                     "--config", "ui.merge=:merge" ]
                         
     fun hg_command context libname args =
-        FileBits.command context libname ("hg" :: hg_args @ args)
+        FileBits.command context libname (hg_program :: hg_args @ args)
 
     fun hg_command_output context libname args =
-        FileBits.command_output context libname ("hg" :: hg_args @ args)
-                        
+        FileBits.command_output context libname (hg_program :: hg_args @ args)
+
+    fun is_working context =
+        case hg_command_output context "" ["--version"] of
+            OK "" => OK false
+          | OK _ => OK true
+          | ERROR e => ERROR e
+
     fun exists context libname =
         OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
         handle _ => OK false
 
     fun remote_for context (libname, source) =

        (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. *)
 
+    val git_program = "git"
+                      
     fun git_command context libname args =
-        FileBits.command context libname ("git" :: args)
+        FileBits.command context libname (git_program :: args)
 
     fun git_command_output context libname args =
-        FileBits.command_output context libname ("git" :: args)
+        FileBits.command_output context libname (git_program :: args)
+
+    fun is_working context =
+        case git_command_output context "" ["--version"] of
+            OK "" => OK false
+          | OK _ => OK true
+          | ERROR e => ERROR e
                             
     fun exists context libname =
         OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
         handle _ => OK false
 

         OK (FileBits.file_url (FileBits.libpath context libname))
             
 end
 
 (* SubXml - A parser for a subset of XML
-   https://bitbucket.org/cannam/sml-simplexml
+   https://bitbucket.org/cannam/sml-subxml
    Copyright 2018 Chris Cannam. BSD licence.
 *)
 
 signature SUBXML = sig
 

 end
 
 
 structure SvnControl :> VCS_CONTROL = struct
 
+    val svn_program = "svn"
+
     fun svn_command context libname args =
-        FileBits.command context libname ("svn" :: args)
+        FileBits.command context libname (svn_program :: args)
 
     fun svn_command_output context libname args =
-        FileBits.command_output context libname ("svn" :: args)
+        FileBits.command_output context libname (svn_program :: args)
 
     fun svn_command_lines context libname args =
         case svn_command_output context libname args of
             ERROR e => ERROR e
           | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s)

             case String.tokens (fn c => c = #":") line of
                 [] => ("", "")
               | first::rest =>
                 (first, strip_leading_ws (String.concatWith ":" rest))
         end
+
+    fun is_working context =
+        case svn_command_output context "" ["--version"] of
+            OK "" => OK false
+          | OK _ => OK true
+          | ERROR e => ERROR e
 
     structure X = SubXml
                       
     fun svn_info context libname route =
         (* SVN 1.9 has info --show-item which is just what we need,

     fun update context (spec as { vcs, ... } : libspec) =
         (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec
 
     fun id_of context (spec as { vcs, ... } : libspec) =
         (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec
+
+    fun is_working context vcs =
+        (fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working)
+            vcs context vcs
 
 end
 
 
 type exclusions = string list

            "Notes" ^ "\n " ^
            hline_to libname_width ^ "-+-" ^
            hline_to libstate_width ^ "-+-" ^
            hline_to notes_width ^ "\n")
                         
-fun print_status with_network (libname, status) =
+fun print_status with_network (lib : libspec, status) =
     let val libstate_str =
             case status of
                 OK (ABSENT, _) => "Absent"
               | OK (CORRECT, _) => if with_network then "Correct" else "Present"
               | OK (SUPERSEDED, _) => "Superseded"

             case status of
                 ERROR e => e
               | _ => ""
     in
         print (" " ^
-               pad_to libname_width libname ^ divider ^
+               pad_to libname_width (#libname lib) ^ divider ^
                pad_to libstate_width libstate_str ^ divider ^
                pad_to localstate_width localstate_str ^ divider ^
                error_str ^ "\n")
     end
 
-fun print_update_outcome (libname, outcome) =
+fun print_update_outcome (lib : libspec, outcome) =
     let val outcome_str =
             case outcome of
                 OK id => "Ok"
               | ERROR e => "Failed"
         val error_str =
             case outcome of
                 ERROR e => e
               | _ => ""
     in
         print (" " ^
-               pad_to libname_width libname ^ divider ^
+               pad_to libname_width (#libname lib) ^ divider ^
                pad_to libstate_width outcome_str ^ divider ^
                error_str ^ "\n")
     end
 
-fun act_and_print action print_header print_line (libs : libspec list) =
-    let val lines = map (fn lib => (#libname lib, action lib)) libs
+fun vcs_name HG = ("Mercurial", "hg")
+  | vcs_name GIT = ("Git", "git")
+  | vcs_name SVN = ("Subversion", "svn")
+        
+fun print_problem_summary context lines =
+    let val failed_vcs =
+            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")
+        fun check_working [] checked = ()
+          | check_working (vcs::rest) checked =
+            if List.exists (fn v => vcs = v) checked
+            then check_working rest checked
+            else
+                case AnyLibControl.is_working context vcs of
+                    OK true => check_working rest checked
+                  | OK false => (report_nonworking vcs "";
+                                 check_working rest (vcs::checked))
+                  | ERROR e => (report_nonworking vcs e;
+                                check_working rest (vcs::checked))
+    in
+        print "\nError: Some operations failed\n\n";
+        check_working failed_vcs []
+    end
+        
+fun act_and_print action print_header print_line context (libs : libspec list) =
+    let val lines = map (fn lib => (lib, action lib)) libs
+        val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines
         val _ = print_header ()
     in
         app print_line lines;
+        if imperfect then print_problem_summary context lines else ();
         lines
     end
 
 fun return_code_for outcomes =
     foldl (fn ((_, result), acc) =>

           outcomes
         
 fun status_of_project ({ context, libs } : project) =
     return_code_for (act_and_print (AnyLibControl.status context)
                                    print_status_header (print_status false)
-                                   libs)
+                                   context libs)
                                              
 fun review_project ({ context, libs } : project) =
     return_code_for (act_and_print (AnyLibControl.review context)
                                    print_status_header (print_status true)
-                                   libs)
+                                   context libs)
 
 fun lock_project ({ context, libs } : project) =
     let val _ = if FileBits.verbose ()
                 then print ("Scanning IDs for lock file...\n")
                 else ()
-        val outcomes = map (fn lib =>
-                               (#libname lib, AnyLibControl.id_of context lib))
+        val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib))
                            libs
         val locks =
             List.concat
-                (map (fn (libname, result) =>
+                (map (fn (lib : libspec, result) =>
                          case result of
                              ERROR _ => []
-                           | OK id => [{ libname = libname, id_or_tag = id }])
+                           | OK id => [{ libname = #libname lib,
+                                         id_or_tag = id }])
                      outcomes)
         val return_code = return_code_for outcomes
         val _ = print clear_line
     in
         if OS.Process.isSuccess return_code

     end
 
 fun update_project (project as { context, libs }) =
     let val outcomes = act_and_print
                            (AnyLibControl.update context)
-                           print_outcome_header print_update_outcome libs
+                           print_outcome_header print_update_outcome
+                           context libs
         val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
                 then lock_project project
                 else OS.Process.success
     in
         return_code_for outcomes

         load_project userconfig rootpath pintype
     end    
 
 fun with_local_project pintype f =
     let val return_code = f (load_local_project pintype)
+                          handle Fail msg => (print ("Error: " ^ msg);
+                                              OS.Process.failure)
                           handle e => (print ("Error: " ^ exnMessage e);
                                        OS.Process.failure)
         val _ = print "\n";
     in
         return_code

               | ["install"] => install ()
               | ["update"] => update ()
               | ["lock"] => lock ()
               | ["version"] => version ()
               | "archive"::target::args => archive target args
+              | arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n");
+                           usage ())
               | _ => usage ()
     in
         OS.Process.exit return_code;
         ()
     end