diff vext.sml @ 1772:128c4544036d

Update Vext
author Chris Cannam
date Fri, 09 Mar 2018 09:00:48 +0000
parents 762ef5d2722a
children 316c4fd7e7bc
line wrap: on
line diff
--- a/vext.sml	Mon Feb 26 14:30:37 2018 +0000
+++ b/vext.sml	Fri Mar 09 09:00:48 2018 +0000
@@ -38,7 +38,7 @@
     authorization.
 *)
 
-val vext_version = "0.9.95"
+val vext_version = "0.9.97"
 
 
 datatype vcs =
@@ -142,6 +142,9 @@
                    
 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
                                             
@@ -194,6 +197,7 @@
     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
@@ -580,6 +584,9 @@
 
     fun id_of context ({ libname, ... } : libspec) =
         V.id_of context libname
+
+    fun is_working context vcs =
+        V.is_working context
                 
 end
 
@@ -1162,15 +1169,23 @@
     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
@@ -1313,11 +1328,19 @@
        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"))
@@ -1497,7 +1520,7 @@
 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.
 *)
 
@@ -1834,11 +1857,13 @@
 
 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
@@ -1856,6 +1881,12 @@
                 (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 =
@@ -2014,6 +2045,10 @@
     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
 
 
@@ -2417,7 +2452,7 @@
            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"
@@ -2437,13 +2472,13 @@
               | _ => ""
     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"
@@ -2454,16 +2489,48 @@
               | _ => ""
     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
 
@@ -2478,26 +2545,26 @@
 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
@@ -2511,7 +2578,8 @@
 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
@@ -2528,6 +2596,8 @@
 
 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";
@@ -2580,6 +2650,8 @@
               | ["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;