# HG changeset patch
# User Chris Cannam
# Date 1520586048 0
# Node ID 128c4544036d161e5713de23bc334de6472bd636
# Parent  bd14a0f69b60c1155819e66b399df9cce3234b28
Update Vext

diff -r bd14a0f69b60 -r 128c4544036d .hgignore
--- a/.hgignore	Mon Feb 26 14:30:37 2018 +0000
+++ b/.hgignore	Fri Mar 09 09:00:48 2018 +0000
@@ -48,3 +48,4 @@
 piper-vamp-simple-server
 piper-convert
 .vext*
+glob:.vext-*.bin
diff -r bd14a0f69b60 -r 128c4544036d vext
--- a/vext	Mon Feb 26 14:30:37 2018 +0000
+++ b/vext	Fri Mar 09 09:00:48 2018 +0000
@@ -8,6 +8,9 @@
 
 set -eu
 
+# avoid gussying up output
+export HGPLAIN=true
+
 mydir=$(dirname "$0")
 program="$mydir/vext.sml"
 
@@ -40,10 +43,10 @@
     exec "$gen_out" "$@"
 fi
 
-# We need one of Poly/ML, SML/NJ, or MLton. Since we're running a
-# single-file SML program as if it were a script, our order of
-# preference is based on startup speed, except in the local_install
-# case where we retain a persistent binary.
+# We need one of Poly/ML, SML/NJ, MLton, or MLKit. Since we're running
+# a single-file SML program as if it were a script, our order of
+# preference is usually based on startup speed. An exception is the
+# local_install case, where we retain a persistent binary
 
 if [ -z "$sml" ]; then
     if [ -n "$local_install" ] && mlton 2>&1 | grep -q 'MLton'; then
@@ -52,12 +55,16 @@
 	sml="smlnj"
     # We would prefer Poly/ML to SML/NJ, except that Poly v5.7 has a
     # nasty bug that occasionally causes it to deadlock on startup.
-    # That appears to be fixed in their repo, so we could promote it
-    # up the order again at some point in future
+    # That is fixed in v5.7.1, so we could promote it up the order
+    # again at some point in future
     elif echo | poly -v 2>/dev/null | grep -q 'Poly/ML'; then
 	sml="poly"
     elif mlton 2>&1 | grep -q 'MLton'; then
 	sml="mlton"
+    # MLKit is at the bottom because it leaves compiled files around
+    # in an MLB subdir in the current directory
+    elif mlkit 2>&1 | grep -q 'MLKit'; then
+	sml="mlkit"
     else cat 1>&2 <<EOF
 
 ERROR: No supported SML compiler or interpreter found       
@@ -71,17 +78,21 @@
   installed and present in your PATH, and try again.
 
     1. Standard ML of New Jersey
-       - often found in a distribution package called: smlnj
+       - may be found in a distribution package called: smlnj
        - executable name: sml
 
     2. Poly/ML
-       - often found in a distribution package called: polyml
+       - may be found in a distribution package called: polyml
        - executable name: poly
 
     3. MLton
-       - often found in a distribution package called: mlton
+       - may be found in a distribution package called: mlton
        - executable name: mlton
 
+    4. MLKit
+       - may be found in a distribution package called: mlkit
+       - executable name: mlkit
+
 EOF
 	exit 2
     fi
@@ -115,6 +126,13 @@
 	    mlton -output "$gen_out" "$gen_sml"
         fi
 	"$gen_out" "$@" ;;
+    mlkit)
+        if [ ! -x "$gen_out" ]; then
+	    echo "[Precompiling Vext binary...]" 1>&2
+	    echo "val _ = main ()" | cat "$program" - > "$gen_sml"
+	    mlkit -output "$gen_out" "$gen_sml"
+        fi
+	"$gen_out" "$@" ;;
     smlnj)
 	cat "$program" | (
 	    cat <<EOF
diff -r bd14a0f69b60 -r 128c4544036d vext.ps1
--- a/vext.ps1	Mon Feb 26 14:30:37 2018 +0000
+++ b/vext.ps1	Fri Mar 09 09:00:48 2018 +0000
@@ -8,6 +8,7 @@
 
 Set-StrictMode -Version 2.0
 $ErrorActionPreference = "Stop"
+$env:HGPLAIN = "true"
 
 $sml = $env:VEXT_SML
 
@@ -16,6 +17,9 @@
 
 # We need either Poly/ML or SML/NJ. No great preference as to which.
 
+# Typical locations
+$env:PATH = "$env:PATH;C:\Program Files (x86)\SMLNJ\bin;C:\Program Files\Poly ML;C:\Program Files (x86)\Poly ML"
+
 if (!$sml) {
     if (Get-Command "sml" -ErrorAction SilentlyContinue) {
        $sml = "smlnj"
diff -r bd14a0f69b60 -r 128c4544036d vext.sml
--- 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;