Mercurial > hg > sonic-visualiser
changeset 1772:128c4544036d
Update Vext
| author | Chris Cannam |
|---|---|
| date | Fri, 09 Mar 2018 09:00:48 +0000 |
| parents | bd14a0f69b60 |
| children | 436156b8a448 |
| files | .hgignore vext vext.ps1 vext.sml |
| diffstat | 4 files changed, 126 insertions(+), 31 deletions(-) [+] |
line wrap: on
line diff
--- 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
--- 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
--- 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"
--- 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;