Mercurial > hg > sonic-annotator
changeset 303:523f8f1789b4
Switch to Vext
| author | Chris Cannam |
|---|---|
| date | Mon, 10 Jul 2017 18:57:08 +0100 |
| parents | 1e6cee321cc0 |
| children | 0ea0f36cc576 |
| files | .hgsub .hgsubstate configure configure.ac vext vext-lock.json vext-project.json vext.bat vext.ps1 vext.sml |
| diffstat | 10 files changed, 2010 insertions(+), 25 deletions(-) [+] |
line wrap: on
line diff
--- a/.hgsub Thu May 25 15:01:41 2017 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -vamp-plugin-sdk = https://code.soundsoftware.ac.uk/hg/vamp-plugin-sdk -bqvec = https://bitbucket.org/breakfastquay/bqvec -bqfft = https://bitbucket.org/breakfastquay/bqfft -bqresample = https://bitbucket.org/breakfastquay/bqresample -dataquay = https://bitbucket.org/breakfastquay/dataquay -svcore = https://code.soundsoftware.ac.uk/hg/svcore -sv-dependency-builds = https://code.soundsoftware.ac.uk/hg/sv-dependency-builds -piper-cpp = https://code.soundsoftware.ac.uk/hg/piper-cpp
--- a/.hgsubstate Thu May 25 15:01:41 2017 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,8 +0,0 @@ -fb508f7cdcdc245add2de6811acda46745516716 bqfft -a867fff0963dd91df0fd99c81d690c1155e73645 bqresample -ddbf6d836efb6fc320b652e1a4dff4edeaae9b53 bqvec -3768bdde6fdf866aa63fff5bde8d9fa64a8979ef dataquay -db929669e7d3564ec09cf41bf7ee347fa11233de piper-cpp -eccd51b72864a07c9744d88d0b3c22f557ba43c1 sv-dependency-builds -09751743647e132cec557ef85654fe8436acae54 svcore -5d9af3140f050e99c9ac6c99290dcb55014baf37 vamp-plugin-sdk
--- a/configure Thu May 25 15:01:41 2017 +0100 +++ b/configure Mon Jul 10 18:57:08 2017 +0100 @@ -4381,9 +4381,10 @@ CXXFLAGS_MINIMAL="$AUTOCONF_CXXFLAGS" if test "x$GCC" = "xyes"; then - CXXFLAGS_DEBUG="-Wall -Werror -Wno-error=cpp -Woverloaded-virtual -Wextra -Wformat-nonliteral -Wformat-security -Winit-self -Wswitch-enum -g -pipe" - CXXFLAGS_RELEASE="-g0 -O2 -Wall -pipe" - CXXFLAGS_MINIMAL="-g0 -O0" + CXXFLAGS_ANY="-std=c++11 -fpic -Wall -Wextra -Woverloaded-virtual -Wformat-nonliteral -Wformat-security -Winit-self -Wswitch-enum -Wconversion -pipe" + CXXFLAGS_DEBUG="$CXXFLAGS_ANY -g -Werror" + CXXFLAGS_RELEASE="$CXXFLAGS_ANY -g0 -O3 -ffast-math" + CXXFLAGS_MINIMAL="$CXXFLAGS_ANY -g0 -O0" fi CXXFLAGS_BUILD="$CXXFLAGS_RELEASE" @@ -7608,6 +7609,28 @@ fi +if test -x vext ; then + if test -d .hg -o -d .git ; then + if ! ./vext install; then + as_fn_error $? "Vext failed; please fix any reported errors and try again" "$LINENO" 5 + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: Vext executable found but not in an Hg or Git working-copy: not running it" >&5 +$as_echo "$as_me: Vext executable found but not in an Hg or Git working-copy: not running it" >&6;} + if ! test -d vamp-plugin-sdk ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&5 +$as_echo "$as_me: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&2;} + fi + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: No Vext executable found: assuming external libraries are already here" >&5 +$as_echo "$as_me: No Vext executable found: assuming external libraries are already here" >&6;} + if ! test -d vamp-plugin-sdk ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&5 +$as_echo "$as_me: WARNING: No vamp-plugin-sdk directory present, so external libraries might not have been updated" >&2;} + fi +fi + if ! $QMAKE -r sonic-annotator.pro; then as_fn_error $? "qmake failed: Command was \"$QMAKE -r\"" "$LINENO" 5 fi @@ -7620,7 +7643,7 @@ The file config.pri contains the configuration settings for qmake. If you want to adjust these by hand, edit config.pri -and run \"qmake -r\" again to regenerate the Makefile. +and run \"$QMAKE -r\" again to regenerate the Makefile. " >&5 $as_echo "$as_me: @@ -7630,5 +7653,5 @@ The file config.pri contains the configuration settings for qmake. If you want to adjust these by hand, edit config.pri -and run \"qmake -r\" again to regenerate the Makefile. +and run \"$QMAKE -r\" again to regenerate the Makefile. " >&6;}
--- a/configure.ac Thu May 25 15:01:41 2017 +0100 +++ b/configure.ac Mon Jul 10 18:57:08 2017 +0100 @@ -53,9 +53,10 @@ CXXFLAGS_MINIMAL="$AUTOCONF_CXXFLAGS" if test "x$GCC" = "xyes"; then - CXXFLAGS_DEBUG="-Wall -Werror -Wno-error=cpp -Woverloaded-virtual -Wextra -Wformat-nonliteral -Wformat-security -Winit-self -Wswitch-enum -g -pipe" - CXXFLAGS_RELEASE="-g0 -O2 -Wall -pipe" - CXXFLAGS_MINIMAL="-g0 -O0" + CXXFLAGS_ANY="-std=c++11 -fpic -Wall -Wextra -Woverloaded-virtual -Wformat-nonliteral -Wformat-security -Winit-self -Wswitch-enum -Wconversion -pipe" + CXXFLAGS_DEBUG="$CXXFLAGS_ANY -g -Werror" + CXXFLAGS_RELEASE="$CXXFLAGS_ANY -g0 -O3 -ffast-math" + CXXFLAGS_MINIMAL="$CXXFLAGS_ANY -g0 -O0" fi CXXFLAGS_BUILD="$CXXFLAGS_RELEASE" @@ -114,6 +115,24 @@ AC_OUTPUT +if test -x vext ; then + if test -d .hg -o -d .git ; then + if ! ./vext install; then + AC_MSG_ERROR([Vext failed; please fix any reported errors and try again]) + fi + else + AC_MSG_NOTICE([Vext executable found but not in an Hg or Git working-copy: not running it]) + if ! test -d vamp-plugin-sdk ; then + AC_MSG_WARN([No vamp-plugin-sdk directory present, so external libraries might not have been updated]) + fi + fi +else + AC_MSG_NOTICE([No Vext executable found: assuming external libraries are already here]) + if ! test -d vamp-plugin-sdk ; then + AC_MSG_WARN([No vamp-plugin-sdk directory present, so external libraries might not have been updated]) + fi +fi + if ! $QMAKE -r sonic-annotator.pro; then AC_MSG_ERROR([qmake failed: Command was "$QMAKE -r"]) fi @@ -126,5 +145,5 @@ The file config.pri contains the configuration settings for qmake. If you want to adjust these by hand, edit config.pri -and run "qmake -r" again to regenerate the Makefile. +and run "$QMAKE -r" again to regenerate the Makefile. ])
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vext Mon Jul 10 18:57:08 2017 +0100 @@ -0,0 +1,111 @@ +#!/bin/bash + +# Disable shellcheck warnings for useless-use-of-cat. UUOC is good +# practice, not bad: clearer, safer, less error-prone. +# shellcheck disable=SC2002 + +sml="$VEXT_SML" + +set -eu + +mydir=$(dirname "$0") +program="$mydir/vext.sml" + +# 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. + +if [ -z "$sml" ]; then + if sml -h 2>&1 | grep -q 'Standard ML of New Jersey'; then + 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 + elif echo | poly -v 2>/dev/null | grep -q 'Poly/ML'; then + sml="poly" + elif mlton 2>&1 | grep -q 'MLton'; then + sml="mlton" + else cat 1>&2 <<EOF + +ERROR: No supported SML compiler or interpreter found +EOF + cat <<EOF + + The Vext external source code manager needs a Standard ML (SML) + compiler or interpreter to run. + + Please ensure you have one of the following SML implementations + installed and present in your PATH, and try again. + + 1. Standard ML of New Jersey + - often found in a distribution package called: smlnj + - executable name: sml + + 2. Poly/ML + - often found in a distribution package called: polyml + - executable name: poly + + 3. MLton + - often found in a distribution package called: mlton + - executable name: mlton + +EOF + exit 2 + fi +fi + +tmp_sml=$(mktemp /tmp/vext-XXXXXXXX.sml) +tmp_out=$(mktemp /tmp/vext-XXXXXXXX.bin) + +trap 'rm -f $tmp_sml $tmp_out' 0 + +arglist="" +for arg in "$@"; do + if [ -n "$arglist" ]; then arglist="$arglist,"; fi + if echo "$arg" | grep -q '[^a-z]' ; then + arglist="$arglist\"usage\"" + else + arglist="$arglist\"$arg\"" + fi +done + +case "$sml" in + poly) echo 'use "'"$program"'"; vext ['"$arglist"'];' | + poly -q --error-exit ;; + mlton) + cat "$program" > "$tmp_sml" + echo 'val _ = main ()' >> "$tmp_sml" + mlton -output "$tmp_out" "$tmp_sml" + "$tmp_out" "$@" ;; + smlnj) + cat "$program" | ( + cat <<EOF +val smlrun__cp = + let val x = !Control.Print.out in + Control.Print.out := { say = fn _ => (), flush = fn () => () }; + x + end; +val smlrun__prev = ref ""; +Control.Print.out := { + say = fn s => + (if String.isSubstring " Error" s + then (Control.Print.out := smlrun__cp; + (#say smlrun__cp) (!smlrun__prev); + (#say smlrun__cp) s) + else (smlrun__prev := s; ())), + flush = fn s => () +}; +EOF + cat - + cat <<EOF +val _ = vext [$arglist]; +val _ = OS.Process.exit (OS.Process.success); +EOF + ) > "$tmp_sml" + CM_VERBOSE=false sml "$tmp_sml" ;; + *) + echo "Unknown SML implementation name: $sml"; + exit 2 ;; +esac +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vext-lock.json Mon Jul 10 18:57:08 2017 +0100 @@ -0,0 +1,25 @@ +{ + "libraries": { + "vamp-plugin-sdk": { + "pin": "5d9af3140f05" + }, + "svcore": { + "pin": "a533662c17f4" + }, + "piper-cpp": { + "pin": "b146634c3686168a9d4bb739986d065b5d2d40a2" + }, + "bqvec": { + "pin": "e345a5e32c53" + }, + "bqfft": { + "pin": "81b50ec12d9a" + }, + "bqresample": { + "pin": "39a30cdbb421" + }, + "sv-dependency-builds": { + "pin": "a69c1527268d" + } + } +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vext-project.json Mon Jul 10 18:57:08 2017 +0100 @@ -0,0 +1,48 @@ +{ + "config": { + "extdir": "." + }, + "services": { + "soundsoftware": { + "vcs": ["hg", "git"], + "anonymous": "https://code.soundsoftware.ac.uk/{vcs}/{repository}", + "authenticated": "https://{account}@code.soundsoftware.ac.uk/{vcs}/{repository}" + } + }, + "libraries": { + "vamp-plugin-sdk": { + "vcs": "hg", + "service": "soundsoftware" + }, + "svcore": { + "vcs": "hg", + "service": "soundsoftware" + }, + "piper-cpp": { + "vcs": "git", + "service": "github", + "owner": "piper-audio", + "repository": "piper-vamp-cpp" + }, + "bqvec": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "bqfft": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "bqresample": { + "vcs": "hg", + "service": "bitbucket", + "owner": "breakfastquay" + }, + "sv-dependency-builds": { + "vcs": "hg", + "service": "soundsoftware" + } + } +} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vext.bat Mon Jul 10 18:57:08 2017 +0100 @@ -0,0 +1,3 @@ +@echo off +PowerShell -NoProfile -ExecutionPolicy Bypass -Command "& '%~dpn0.ps1' %*"; +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vext.ps1 Mon Jul 10 18:57:08 2017 +0100 @@ -0,0 +1,101 @@ +<# + +.SYNOPSIS +A simple manager for third-party source code dependencies. +Run "vext help" for more documentation. + +#> + +$sml = $env:VEXT_SML + +$mydir = Split-Path $MyInvocation.MyCommand.Path -Parent +$program = "$mydir/vext.sml" + +# We need either Poly/ML or SML/NJ. No great preference as to which. + +if (!$sml) { + if (Get-Command "polyml" -ErrorAction SilentlyContinue) { + $sml = "poly" + } elseif (Get-Command "sml" -ErrorAction SilentlyContinue) { + $sml = "smlnj" + } else { + echo @" + +ERROR: No supported SML compiler or interpreter found + + The Vext external source code manager needs a Standard ML (SML) + compiler or interpreter to run. + + Please ensure you have one of the following SML implementations + installed and present in your PATH, and try again. + + 1. Poly/ML + - executable name: polyml + + 2. Standard ML of New Jersey + - executable name: sml + +"@ + exit 1 + } +} + +if ($args -match "[^a-z]") { + $arglist = '["usage"]' +} else { + $arglist = '["' + ($args -join '","') + '"]' +} + +if ($sml -eq "poly") { + + $program = $program -replace "\\","\\\\" + echo "use ""$program""; vext $arglist" | polyml -q --error-exit | Out-Host + +} elseif ($sml -eq "smlnj") { + + $lines = @(Get-Content $program) + $lines = $lines -notmatch "val _ = main ()" + + $intro = @" +val smlrun__cp = + let val x = !Control.Print.out in + Control.Print.out := { say = fn _ => (), flush = fn () => () }; + x + end; +val smlrun__prev = ref ""; +Control.Print.out := { + say = fn s => + (if String.isSubstring "Error" s orelse String.isSubstring "Fail" s + then (Control.Print.out := smlrun__cp; + (#say smlrun__cp) (!smlrun__prev); + (#say smlrun__cp) s) + else (smlrun__prev := s; ())), + flush = fn s => () +}; +"@ -split "[\r\n]+" + + $outro = @" +val _ = vext $arglist; +val _ = OS.Process.exit (OS.Process.success); +"@ -split "[\r\n]+" + + $script = @() + $script += $intro + $script += $lines + $script += $outro + + $tmpfile = ([System.IO.Path]::GetTempFileName()) -replace "[.]tmp",".sml" + + $script | Out-File -Encoding "ASCII" $tmpfile + + $env:CM_VERBOSE="false" + + sml $tmpfile $args[1,$args.Length] + + del $tmpfile + +} else { + + "Unknown SML implementation name: $sml" + exit 2 +}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/vext.sml Mon Jul 10 18:57:08 2017 +0100 @@ -0,0 +1,1671 @@ +(* This file is automatically generated from the individual + source files in the Vext repository. *) + +(* + Vext + + A simple manager for third-party source code dependencies + + Copyright 2017 Chris Cannam. + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, copy, + modify, merge, publish, distribute, sublicense, and/or sell copies + of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR + ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + Except as contained in this notice, the names of Chris Cannam and + 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" + + +datatype vcs = + HG | + GIT + +datatype source = + URL_SOURCE of string | + SERVICE_SOURCE of { + service : string, + owner : string option, + repo : string option + } + +datatype pin = + UNPINNED | + PINNED of string + +datatype libstate = + ABSENT | + CORRECT | + SUPERSEDED | + WRONG + +datatype localstate = + MODIFIED | + UNMODIFIED + +datatype branch = + BRANCH of string | + DEFAULT_BRANCH + +(* If we can recover from an error, for example by reporting failure + for this one thing and going on to the next thing, then the error + should usually be returned through a result type rather than an + exception. *) + +datatype 'a result = + 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 +} + +type lock = { + libname : libname, + id_or_tag : id_or_tag +} + +type remote_spec = { + anon : string option, + auth : string option +} + +type provider = { + service : string, + supports : vcs list, + remote_spec : remote_spec +} + +type account = { + service : string, + login : string +} + +type context = { + rootpath : string, + extdir : string, + providers : provider list, + accounts : account list +} + +type userconfig = { + providers : provider list, + accounts : account list +} + +type project = { + context : context, + libs : libspec list +} + +structure VextFilenames = struct + val project_file = "vext-project.json" + val project_lock_file = "vext-lock.json" + val user_config_file = ".vext.json" +end + +signature VCS_CONTROL = sig + + (** 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 + + (** Test whether the library is at the given id *) + val is_at : context -> libname * id_or_tag -> bool result + + (** Test whether the library is on the given branch, i.e. is at + the branch tip or an ancestor of it *) + val is_on_branch : context -> libname * branch -> bool result + + (** Test whether the library is at the newest revision for the + given branch. False may indicate that the branch has advanced + or that the library is not on the branch at all. This function + may use the network to check for new revisions *) + val is_newest : context -> libname * branch -> bool result + + (** Test whether the library is at the newest revision available + locally for the given branch. False may indicate that the + branch has advanced or that the library is not on the branch + at all. This function must not use the network *) + val is_newest_locally : context -> libname * branch -> bool result + + (** Test whether the library has been modified in the local + working copy *) + val is_modified_locally : context -> libname -> bool result + + (** Check out, i.e. clone a fresh copy of, the repo for the given + library on the given branch *) + val checkout : context -> libname * source * branch -> unit result + + (** Update the library to the given branch tip *) + val update : context -> libname * branch -> id_or_tag result + + (** Update the library to the given specific id or tag *) + val update_to : context -> libname * id_or_tag -> id_or_tag result +end + +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 +end + +structure FileBits :> sig + val extpath : context -> string + val libpath : context -> libname -> string + val subpath : context -> libname -> string -> string + val command_output : context -> libname -> string list -> string result + val command : context -> libname -> string list -> unit result + val file_contents : string -> string + val mydir : unit -> string + val homedir : unit -> string + val mkpath : string -> unit result + val project_spec_path : string -> string + val project_lock_path : string -> string + val verbose : unit -> bool +end = struct + + fun verbose () = + case OS.Process.getEnv "VEXT_VERBOSE" of + SOME "0" => false + | SOME _ => true + | NONE => false + + fun extpath ({ rootpath, extdir, ... } : context) = + let val { isAbs, vol, arcs } = OS.Path.fromString rootpath + in OS.Path.toString { + isAbs = isAbs, + vol = vol, + arcs = arcs @ [ extdir ] + } + end + + fun subpath ({ rootpath, extdir, ... } : context) libname remainder = + (* NB libname is allowed to be a path fragment, e.g. foo/bar *) + let val { isAbs, vol, arcs } = OS.Path.fromString rootpath + val split = String.fields (fn c => c = #"/") + in OS.Path.toString { + isAbs = isAbs, + vol = vol, + arcs = arcs @ [ extdir ] @ split libname @ split remainder + } + end + + fun libpath context "" = + extpath context + | libpath context libname = + subpath context libname "" + + fun project_file_path rootpath filename = + let val { isAbs, vol, arcs } = OS.Path.fromString rootpath + in OS.Path.toString { + isAbs = isAbs, + vol = vol, + arcs = arcs @ [ filename ] + } + end + + fun project_spec_path rootpath = + project_file_path rootpath (VextFilenames.project_file) + + fun project_lock_path rootpath = + project_file_path rootpath (VextFilenames.project_lock_file) + + fun trim str = + hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str) + + fun file_contents filename = + let val stream = TextIO.openIn filename + fun read_all str acc = + case TextIO.inputLine str of + SOME line => read_all str (trim line :: acc) + | NONE => rev acc + val contents = read_all stream [] + val _ = TextIO.closeIn stream + in + String.concatWith "\n" contents + end + + fun expand_commandline cmdlist = + (* We are quite [too] strict about what we accept here, except + for the first element in cmdlist which is assumed to be a + known command location rather than arbitrary user input. NB + only ASCII accepted at this point. *) + let open Char + fun quote arg = + if List.all + (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_") + (explode arg) + then arg + else "\"" ^ arg ^ "\"" + fun check arg = + let val valid = explode " /#:;?,._-{}@=" + in + app (fn c => + if isAlphaNum c orelse + List.exists (fn v => v = c) valid + then () + else raise Fail ("Invalid character '" ^ + (Char.toString c) ^ + "' in command list")) + (explode arg); + arg + end + in + String.concatWith " " + (map quote + (hd cmdlist :: map check (tl cmdlist))) + end + + val tick_cycle = ref 0 + val tick_chars = Vector.fromList (map String.str (explode "|/-\\")) + + fun tick libname cmdlist = + let val n = Vector.length tick_chars + fun pad_to n str = + if n <= String.size str then str + else pad_to n (str ^ " ") + val name = if libname <> "" then libname + else if cmdlist = nil then "" + else hd (rev cmdlist) + in + print (" " ^ + Vector.sub(tick_chars, !tick_cycle) ^ " " ^ + pad_to 24 name ^ + "\r"); + tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle) + end + + fun run_command context libname cmdlist redirect = + let open OS + val dir = libpath context libname + val cmd = expand_commandline cmdlist + val _ = if verbose () + then print ("Running: " ^ cmd ^ + " (in dir " ^ dir ^ ")...\n") + else tick libname cmdlist + val _ = FileSys.chDir dir + val status = case redirect of + NONE => Process.system cmd + | SOME file => Process.system (cmd ^ ">" ^ file) + in + if Process.isSuccess status + then OK () + else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")") + end + handle ex => ERROR ("Unable to run command: " ^ exnMessage ex) + + fun command context libname cmdlist = + run_command context libname cmdlist NONE + + fun command_output context libname cmdlist = + let open OS + val tmpFile = FileSys.tmpName () + val result = run_command context libname cmdlist (SOME tmpFile) + val contents = file_contents tmpFile + in + FileSys.remove tmpFile handle _ => (); + case result of + OK () => OK contents + | ERROR e => ERROR e + end + + fun mydir () = + let open OS + val { dir, file } = Path.splitDirFile (CommandLine.name ()) + in + FileSys.realPath + (if Path.isAbsolute dir + then dir + else Path.concat (FileSys.getDir (), dir)) + end + + fun homedir () = + (* Failure is not routine, so we use an exception here *) + case (OS.Process.getEnv "HOME", + OS.Process.getEnv "HOMEPATH") of + (SOME home, _) => home + | (NONE, SOME home) => home + | (NONE, NONE) => + raise Fail "Failed to look up home directory from environment" + + fun mkpath path = + if OS.FileSys.isDir path handle _ => false + then OK () + else case OS.Path.fromString path of + { arcs = nil, ... } => OK () + | { isAbs = false, ... } => ERROR "mkpath requires absolute path" + | { isAbs, vol, arcs } => + case mkpath (OS.Path.toString { (* parent *) + isAbs = isAbs, + vol = vol, + arcs = rev (tl (rev arcs)) }) of + ERROR e => ERROR e + | OK () => ((OS.FileSys.mkDir path; OK ()) + handle OS.SysErr (e, _) => + ERROR ("Directory creation failed: " ^ e)) +end + +functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct + + (* Valid states for unpinned libraries: + + - CORRECT: We are on the right branch and are up-to-date with + it as far as we can tell. (If not using the network, this + should be reported to user as "Present" rather than "Correct" + as the remote repo may have advanced without us knowing.) + + - SUPERSEDED: We are on the right branch but we can see that + there is a newer revision either locally or on the remote (in + Git terms, we are at an ancestor of the desired branch tip). + + - WRONG: We are on the wrong branch (in Git terms, we are not + at the desired branch tip or any ancestor of it). + + - ABSENT: Repo doesn't exist here at all. + + Valid states for pinned libraries: + + - CORRECT: We are at the pinned revision. + + - 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) = + let fun check_unpinned () = + let val is_newest = if with_network + then V.is_newest + else V.is_newest_locally + in + case is_newest context (libname, branch) of + ERROR e => ERROR e + | OK true => OK CORRECT + | OK false => + case V.is_on_branch context (libname, branch) of + ERROR e => ERROR e + | OK true => OK SUPERSEDED + | OK false => OK WRONG + end + 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 + UNPINNED => check_unpinned () + | PINNED target => check_pinned target + in + case V.exists context libname of + ERROR e => ERROR e + | OK false => OK (ABSENT, UNMODIFIED) + | OK true => + case (check' (), V.is_modified_locally context libname) of + (ERROR e, _) => ERROR e + | (_, ERROR e) => ERROR e + | (OK state, OK true) => OK (state, MODIFIED) + | (OK state, OK false) => OK (state, UNMODIFIED) + end + + val review = check true + val status = check false + + fun update context ({ libname, source, branch, 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) + fun update_pinned target = + 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 + 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 +end + +(* Simple Standard ML JSON parser + ============================== + + https://bitbucket.org/cannam/sml-simplejson + + An RFC-compliant JSON parser in one SML file with no dependency + on anything outside the Basis library. Also includes a simple + serialiser. + + Tested with MLton, Poly/ML, and SML/NJ compilers. + + Parser notes: + + * Complies with RFC 7159, The JavaScript Object Notation (JSON) + Data Interchange Format + + * Passes all of the JSONTestSuite parser accept/reject tests that + exist at the time of writing, as listed in "Parsing JSON is a + Minefield" (http://seriot.ch/parsing_json.php) + + * Two-pass parser using naive exploded strings, therefore not + particularly fast and not suitable for large input files + + * Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check + that JSON strings are valid UTF-8 -- the caller must do that -- + but does handle \u escapes + + * Converts all numbers to type "real". If that is a 64-bit IEEE + float type (common but not guaranteed in SML) then we're pretty + standard for a JSON parser + + Copyright 2017 Chris Cannam. + Parts based on the JSON parser in the Ponyo library by Phil Eaton. + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, copy, + modify, merge, publish, distribute, sublicense, and/or sell copies + of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR + ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF + CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION + WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + Except as contained in this notice, the names of Chris Cannam and + 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. +*) + +signature JSON = sig + + datatype json = OBJECT of (string * json) list + | ARRAY of json list + | NUMBER of real + | STRING of string + | BOOL of bool + | NULL + + datatype 'a result = OK of 'a + | ERROR of string + + val parse : string -> json result + val serialise : json -> string + val serialiseIndented : json -> string + +end + +structure Json :> JSON = struct + + datatype json = OBJECT of (string * json) list + | ARRAY of json list + | NUMBER of real + | STRING of string + | BOOL of bool + | NULL + + datatype 'a result = OK of 'a + | ERROR of string + + structure T = struct + datatype token = NUMBER of char list + | STRING of string + | BOOL of bool + | NULL + | CURLY_L + | CURLY_R + | SQUARE_L + | SQUARE_R + | COLON + | COMMA + + fun toString t = + case t of NUMBER digits => implode digits + | STRING s => s + | BOOL b => Bool.toString b + | NULL => "null" + | CURLY_L => "{" + | CURLY_R => "}" + | SQUARE_L => "[" + | SQUARE_R => "]" + | COLON => ":" + | COMMA => "," + end + + fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *) + let open Word + infix 6 orb andb >> + in + map (Char.chr o toInt) + (if cp < 0wx80 then + [cp] + else if cp < 0wx800 then + [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)] + else if cp < 0wx10000 then + [0wxe0 orb (cp >> 0w12), + 0wx80 orb ((cp >> 0w6) andb 0wx3f), + 0wx80 orb (cp andb 0wx3f)] + else raise Fail ("Invalid BMP point " ^ (Word.toString cp))) + end + + fun error pos text = ERROR (text ^ " at character position " ^ + Int.toString (pos - 1)) + fun token_error pos = error pos ("Unexpected token") + + fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) = + lex (pos + 3) (T.NULL :: acc) xs + | lexNull pos acc _ = token_error pos + + and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) = + lex (pos + 3) (T.BOOL true :: acc) xs + | lexTrue pos acc _ = token_error pos + + and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) = + lex (pos + 4) (T.BOOL false :: acc) xs + | lexFalse pos acc _ = token_error pos + + and lexChar tok pos acc xs = + lex pos (tok :: acc) xs + + and lexString pos acc cc = + let datatype escaped = ESCAPED | NORMAL + fun lexString' pos text ESCAPED [] = + error pos "End of input during escape sequence" + | lexString' pos text NORMAL [] = + error pos "End of input during string" + | lexString' pos text ESCAPED (x :: xs) = + let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs + in case x of + #"\"" => esc x + | #"\\" => esc x + | #"/" => esc x + | #"b" => esc #"\b" + | #"f" => esc #"\f" + | #"n" => esc #"\n" + | #"r" => esc #"\r" + | #"t" => esc #"\t" + | _ => error pos ("Invalid escape \\" ^ + Char.toString x) + end + | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) = + if List.all Char.isHexDigit [a,b,c,d] + then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of + SOME w => (let val utf = rev (bmpToUtf8 w) in + lexString' (pos + 6) (utf @ text) + NORMAL xs + end + handle Fail err => error pos err) + | NONE => error pos "Invalid Unicode BMP escape sequence" + else error pos "Invalid Unicode BMP escape sequence" + | lexString' pos text NORMAL (x :: xs) = + if Char.ord x < 0x20 + then error pos "Invalid unescaped control character" + else + case x of + #"\"" => OK (rev text, xs, pos + 1) + | #"\\" => lexString' (pos + 1) text ESCAPED xs + | _ => lexString' (pos + 1) (x :: text) NORMAL xs + in + case lexString' pos [] NORMAL cc of + OK (text, rest, newpos) => + lex newpos (T.STRING (implode text) :: acc) rest + | ERROR e => ERROR e + end + + and lexNumber firstChar pos acc cc = + let val valid = explode ".+-e" + fun lexNumber' pos digits [] = (rev digits, [], pos) + | lexNumber' pos digits (x :: xs) = + if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs + else if Char.isDigit x orelse List.exists (fn c => x = c) valid + then lexNumber' (pos + 1) (x :: digits) xs + else (rev digits, x :: xs, pos) + val (digits, rest, newpos) = + lexNumber' (pos - 1) [] (firstChar :: cc) + in + case digits of + [] => token_error pos + | _ => lex newpos (T.NUMBER digits :: acc) rest + end + + and lex pos acc [] = OK (rev acc) + | lex pos acc (x::xs) = + (case x of + #" " => lex + | #"\t" => lex + | #"\n" => lex + | #"\r" => lex + | #"{" => lexChar T.CURLY_L + | #"}" => lexChar T.CURLY_R + | #"[" => lexChar T.SQUARE_L + | #"]" => lexChar T.SQUARE_R + | #":" => lexChar T.COLON + | #"," => lexChar T.COMMA + | #"\"" => lexString + | #"t" => lexTrue + | #"f" => lexFalse + | #"n" => lexNull + | x => lexNumber x) (pos + 1) acc xs + + fun show [] = "end of input" + | show (tok :: _) = T.toString tok + + fun parseNumber digits = + (* Note lexNumber already case-insensitised the E for us *) + let open Char + + fun okExpDigits [] = false + | okExpDigits (c :: []) = isDigit c + | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs + + fun okExponent [] = false + | okExponent (#"+" :: cs) = okExpDigits cs + | okExponent (#"-" :: cs) = okExpDigits cs + | okExponent cc = okExpDigits cc + + fun okFracTrailing [] = true + | okFracTrailing (c :: cs) = + (isDigit c andalso okFracTrailing cs) orelse + (c = #"e" andalso okExponent cs) + + fun okFraction [] = false + | okFraction (c :: cs) = + isDigit c andalso okFracTrailing cs + + fun okPosTrailing [] = true + | okPosTrailing (#"." :: cs) = okFraction cs + | okPosTrailing (#"e" :: cs) = okExponent cs + | okPosTrailing (c :: cs) = + isDigit c andalso okPosTrailing cs + + fun okPositive [] = false + | okPositive (#"0" :: []) = true + | okPositive (#"0" :: #"." :: cs) = okFraction cs + | okPositive (#"0" :: #"e" :: cs) = okExponent cs + | okPositive (#"0" :: cs) = false + | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs + + fun okNumber (#"-" :: cs) = okPositive cs + | okNumber cc = okPositive cc + in + if okNumber digits + then case Real.fromString (implode digits) of + NONE => ERROR "Number out of range" + | SOME r => OK r + else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"") + end + + fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs) + | parseObject tokens = + let fun parsePair (T.STRING key :: T.COLON :: xs) = + (case parseTokens xs of + ERROR e => ERROR e + | OK (j, xs) => OK ((key, j), xs)) + | parsePair other = + ERROR ("Object key/value pair expected around \"" ^ + show other ^ "\"") + fun parseObject' acc [] = ERROR "End of input during object" + | parseObject' acc tokens = + case parsePair tokens of + ERROR e => ERROR e + | OK (pair, T.COMMA :: xs) => + parseObject' (pair :: acc) xs + | OK (pair, T.CURLY_R :: xs) => + OK (OBJECT (rev (pair :: acc)), xs) + | OK (_, _) => ERROR "Expected , or } after object element" + in + parseObject' [] tokens + end + + and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs) + | parseArray tokens = + let fun parseArray' acc [] = ERROR "End of input during array" + | parseArray' acc tokens = + case parseTokens tokens of + ERROR e => ERROR e + | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs + | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs) + | OK (_, _) => ERROR "Expected , or ] after array element" + in + parseArray' [] tokens + end + + and parseTokens [] = ERROR "Value expected" + | parseTokens (tok :: xs) = + (case tok of + T.NUMBER d => (case parseNumber d of + OK r => OK (NUMBER r, xs) + | ERROR e => ERROR e) + | T.STRING s => OK (STRING s, xs) + | T.BOOL b => OK (BOOL b, xs) + | T.NULL => OK (NULL, xs) + | T.CURLY_L => parseObject xs + | T.SQUARE_L => parseArray xs + | _ => ERROR ("Unexpected token " ^ T.toString tok ^ + " before " ^ show xs)) + + fun parse str = + case lex 1 [] (explode str) of + ERROR e => ERROR e + | OK tokens => case parseTokens tokens of + OK (value, []) => OK value + | OK (_, _) => ERROR "Extra data after input" + | ERROR e => ERROR e + + fun stringEscape s = + let fun esc x = [x, #"\\"] + fun escape' acc [] = rev acc + | escape' acc (x :: xs) = + escape' (case x of + #"\"" => esc x @ acc + | #"\\" => esc x @ acc + | #"\b" => esc #"b" @ acc + | #"\f" => esc #"f" @ acc + | #"\n" => esc #"n" @ acc + | #"\r" => esc #"r" @ acc + | #"\t" => esc #"t" @ acc + | _ => + let val c = Char.ord x + in + if c < 0x20 + then let val hex = Word.toString (Word.fromInt c) + in (rev o explode) (if c < 0x10 + then ("\\u000" ^ hex) + else ("\\u00" ^ hex)) + end @ acc + else + x :: acc + end) + xs + in + implode (escape' [] (explode s)) + end + + fun serialise json = + case json of + OBJECT pp => "{" ^ String.concatWith + "," (map (fn (key, value) => + serialise (STRING key) ^ ":" ^ + serialise value) pp) ^ + "}" + | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]" + | NUMBER n => implode (map (fn #"~" => #"-" | c => c) + (explode (Real.toString n))) + | STRING s => "\"" ^ stringEscape s ^ "\"" + | BOOL b => Bool.toString b + | NULL => "null" + + fun serialiseIndented json = + let fun indent 0 = "" + | indent i = " " ^ indent (i - 1) + fun serialiseIndented' i json = + let val ser = serialiseIndented' (i + 1) + in + case json of + OBJECT [] => "{}" + | ARRAY [] => "[]" + | OBJECT pp => "{\n" ^ indent (i + 1) ^ + String.concatWith + (",\n" ^ indent (i + 1)) + (map (fn (key, value) => + ser (STRING key) ^ ": " ^ + ser value) pp) ^ + "\n" ^ indent i ^ "}" + | ARRAY arr => "[\n" ^ indent (i + 1) ^ + String.concatWith + (",\n" ^ indent (i + 1)) + (map ser arr) ^ + "\n" ^ indent i ^ "]" + | other => serialise other + end + in + serialiseIndented' 0 json ^ "\n" + end + +end + + +structure JsonBits :> sig + val load_json_from : string -> Json.json (* filename -> json *) + val save_json_to : string -> Json.json -> unit + val lookup_optional : Json.json -> string list -> Json.json option + val lookup_optional_string : Json.json -> string list -> string option + val lookup_mandatory : Json.json -> string list -> Json.json + val lookup_mandatory_string : Json.json -> string list -> string +end = struct + + fun load_json_from filename = + case Json.parse (FileBits.file_contents filename) of + Json.OK json => json + | Json.ERROR e => raise Fail ("Failed to parse file: " ^ e) + + fun save_json_to filename json = + (* using binary I/O to avoid ever writing CR/LF line endings *) + let val jstr = Json.serialiseIndented json + val stream = BinIO.openOut filename + in + BinIO.output (stream, Byte.stringToBytes jstr); + BinIO.closeOut stream + end + + fun lookup_optional json kk = + let fun lookup key = + case json of + Json.OBJECT kvs => + (case List.find (fn (k, v) => k = key) kvs of + SOME (k, v) => SOME v + | NONE => NONE) + | _ => raise Fail "Object expected" + in + case kk of + [] => NONE + | key::[] => lookup key + | key::kk => case lookup key of + NONE => NONE + | SOME j => lookup_optional j kk + end + + fun lookup_optional_string json kk = + case lookup_optional json kk of + SOME (Json.STRING s) => SOME s + | SOME _ => raise Fail ("Value (if present) must be string: " ^ + (String.concatWith " -> " kk)) + | NONE => NONE + + fun lookup_mandatory json kk = + case lookup_optional json kk of + SOME v => v + | NONE => raise Fail ("Value is mandatory: " ^ + (String.concatWith " -> " kk) ^ " in json: " ^ + (Json.serialise json)) + + fun lookup_mandatory_string json kk = + case lookup_optional json kk of + SOME (Json.STRING s) => s + | _ => raise Fail ("Value must be string: " ^ + (String.concatWith " -> " kk)) +end + +structure Provider :> sig + val load_providers : Json.json -> provider list + val load_more_providers : provider list -> Json.json -> provider list + val remote_url : context -> vcs -> source -> libname -> string +end = struct + + val known_providers : provider list = + [ { + service = "bitbucket", + supports = [HG, GIT], + remote_spec = { + anon = SOME "https://bitbucket.org/{owner}/{repository}", + auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}" + } + }, + { + service = "github", + supports = [GIT], + remote_spec = { + anon = SOME "https://github.com/{owner}/{repository}", + auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}" + } + } + ] + + fun vcs_name vcs = + case vcs of GIT => "git" | + HG => "hg" + + fun vcs_from_name name = + case name of "git" => GIT + | "hg" => HG + | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"") + + fun load_more_providers previously_loaded json = + let open JsonBits + fun load pjson pname : provider = + { + service = pname, + supports = + case lookup_mandatory pjson ["vcs"] of + Json.ARRAY vv => + map (fn (Json.STRING v) => vcs_from_name v + | _ => raise Fail "Strings expected in vcs array") + vv + | _ => raise Fail "Array expected for vcs", + remote_spec = { + anon = lookup_optional_string pjson ["anonymous"], + auth = lookup_optional_string pjson ["authenticated"] + } + } + val loaded = + case lookup_optional json ["services"] of + NONE => [] + | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl + | _ => raise Fail "Object expected for services in config" + val newly_loaded = + List.filter (fn p => not (List.exists (fn pp => #service p = + #service pp) + previously_loaded)) + loaded + in + previously_loaded @ newly_loaded + end + + fun load_providers json = + load_more_providers known_providers json + + fun expand_spec spec { vcs, service, owner, repo } login = + (* ugly *) + let fun replace str = + case str of + "vcs" => vcs_name vcs + | "service" => service + | "owner" => + (case owner of + SOME ostr => ostr + | NONE => raise Fail ("Owner not specified for service " ^ + service)) + | "repository" => repo + | "account" => + (case login of + SOME acc => acc + | NONE => raise Fail ("Account not given for service " ^ + service)) + | other => raise Fail ("Unknown variable \"" ^ other ^ + "\" in spec for service " ^ service) + fun expand' acc sstr = + case Substring.splitl (fn c => c <> #"{") sstr of + (pfx, sfx) => + if Substring.isEmpty sfx + then rev (pfx :: acc) + else + case Substring.splitl (fn c => c <> #"}") sfx of + (tok, remainder) => + if Substring.isEmpty remainder + then rev (tok :: pfx :: acc) + else let val replacement = + replace + (* tok begins with "{": *) + (Substring.string + (Substring.triml 1 tok)) + in + expand' (Substring.full replacement :: + pfx :: acc) + (* remainder begins with "}": *) + (Substring.triml 1 remainder) + end + in + Substring.concat (expand' [] (Substring.full spec)) + end + + fun provider_url req login providers = + case providers of + [] => raise Fail ("Unknown service \"" ^ (#service req) ^ + "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"") + | ({ service, supports, remote_spec : remote_spec } :: rest) => + if service <> (#service req) orelse + not (List.exists (fn v => v = (#vcs req)) supports) + then provider_url req login rest + else + case (login, #auth remote_spec, #anon remote_spec) of + (SOME _, SOME auth, _) => expand_spec auth req login + | (SOME _, _, SOME anon) => expand_spec anon req NONE + | (NONE, _, SOME anon) => expand_spec anon req NONE + | _ => raise Fail ("No suitable anonymous or authenticated " ^ + "URL spec provided for service \"" ^ + service ^ "\"") + + fun login_for ({ accounts, ... } : context) service = + case List.find (fn a => service = #service a) accounts of + SOME { login, ... } => SOME login + | NONE => NONE + + fun remote_url (context : context) vcs source libname = + case source of + URL_SOURCE u => u + | SERVICE_SOURCE { service, owner, repo } => + provider_url { vcs = vcs, + service = service, + owner = owner, + repo = case repo of + SOME r => r + | NONE => libname } + (login_for context service) + (#providers context) +end + +structure HgControl :> VCS_CONTROL = struct + + type vcsstate = { id: string, modified: bool, + branch: string, tags: string list } + + val hg_args = [ "--config", "ui.interactive=true" ] + + fun hg_command context libname args = + FileBits.command context libname ("hg" :: hg_args @ args) + + fun hg_command_output context libname args = + FileBits.command_output context libname ("hg" :: hg_args @ args) + + fun exists context libname = + OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg")) + handle _ => OK false + + fun remote_for context (libname, source) = + Provider.remote_url context HG source libname + + fun current_state context libname : vcsstate result = + let fun is_branch text = text <> "" andalso #"(" = hd (explode text) + and extract_branch b = + if is_branch b (* need to remove enclosing parens *) + then (implode o rev o tl o rev o tl o explode) b + else "default" + and is_modified id = id <> "" andalso #"+" = hd (rev (explode id)) + and extract_id id = + if is_modified id (* need to remove trailing "+" *) + then (implode o rev o tl o rev o explode) id + else id + and split_tags tags = String.tokens (fn c => c = #"/") tags + and state_for (id, branch, tags) = + OK { id = extract_id id, + modified = is_modified id, + branch = extract_branch branch, + tags = split_tags tags } + in + case hg_command_output context libname ["id"] of + ERROR e => ERROR e + | OK out => + case String.tokens (fn x => x = #" ") out of + [id, branch, tags] => state_for (id, branch, tags) + | [id, other] => if is_branch other + then state_for (id, other, "") + else state_for (id, "", other) + | [id] => state_for (id, "", "") + | _ => ERROR ("Unexpected output from hg id: " ^ out) + end + + fun branch_name branch = case branch of + DEFAULT_BRANCH => "default" + | BRANCH "" => "default" + | BRANCH b => b + + fun id_of context libname = + case current_state context libname of + ERROR e => ERROR e + | OK { id, ... } => OK id + + fun is_at context (libname, id_or_tag) = + case current_state context libname of + ERROR e => ERROR e + | OK { id, tags, ... } => + OK (String.isPrefix id_or_tag id orelse + String.isPrefix id id_or_tag orelse + List.exists (fn t => t = id_or_tag) tags) + + fun is_on_branch context (libname, b) = + case current_state context libname of + ERROR e => ERROR e + | OK { branch, ... } => OK (branch = branch_name b) + + fun is_newest_locally context (libname, branch) = + case hg_command_output context libname + ["log", "-l1", + "-b", branch_name branch, + "--template", "{node}"] of + ERROR e => ERROR e + | OK newest_in_repo => is_at context (libname, newest_in_repo) + + fun pull context libname = + hg_command context libname + (if FileBits.verbose () + then ["pull"] + else ["pull", "-q"]) + + fun is_newest context (libname, branch) = + case is_newest_locally context (libname, branch) of + ERROR e => ERROR e + | OK false => OK false + | OK true => + case pull context libname of + ERROR e => ERROR e + | _ => is_newest_locally context (libname, branch) + + fun is_modified_locally context libname = + case current_state context libname of + ERROR e => ERROR e + | OK { modified, ... } => OK modified + + fun checkout context (libname, source, branch) = + let val url = remote_for context (libname, source) + in + case FileBits.mkpath (FileBits.extpath context) of + ERROR e => ERROR e + | _ => hg_command context "" + ["clone", "-u", branch_name branch, + url, libname] + end + + fun update context (libname, branch) = + let val pull_result = pull context libname + in + case hg_command context libname ["update", branch_name branch] of + ERROR e => ERROR e + | _ => + case pull_result of + ERROR e => ERROR e + | _ => id_of context libname + end + + fun update_to context (libname, "") = + ERROR "Non-empty id (tag or revision id) required for update_to" + | update_to context (libname, id) = + let val pull_result = pull context libname + in + case hg_command context libname ["update", "-r", id] of + OK _ => id_of context libname + | ERROR e => + case pull_result of + ERROR e' => ERROR e' (* this was the ur-error *) + | _ => ERROR e + end + +end + +structure GitControl :> VCS_CONTROL = struct + + (* With Git repos we always operate in detached HEAD state. Even + the master branch is checked out using the remote reference, + origin/master. *) + + fun git_command context libname args = + FileBits.command context libname ("git" :: args) + + fun git_command_output context libname args = + FileBits.command_output context libname ("git" :: args) + + fun exists context libname = + OK (OS.FileSys.isDir (FileBits.subpath context libname ".git")) + handle _ => OK false + + fun remote_for context (libname, source) = + Provider.remote_url context GIT source libname + + fun branch_name branch = case branch of + DEFAULT_BRANCH => "master" + | BRANCH "" => "master" + | BRANCH b => b + + fun remote_branch_name branch = "origin/" ^ branch_name branch + + fun checkout context (libname, source, branch) = + let val url = remote_for context (libname, source) + in + case FileBits.mkpath (FileBits.extpath context) of + OK () => git_command context "" + ["clone", "-b", + branch_name branch, + url, libname] + | ERROR e => ERROR e + end + + (* NB git rev-parse HEAD shows revision id of current checkout; + git rev-list -1 <tag> shows revision id of revision with that tag *) + + fun id_of context libname = + git_command_output context libname ["rev-parse", "HEAD"] + + fun is_at context (libname, id_or_tag) = + case id_of context libname of + ERROR e => ERROR e + | OK id => + if String.isPrefix id_or_tag id orelse + String.isPrefix id id_or_tag + then OK true + else + case git_command_output context libname + ["show-ref", + "refs/tags/" ^ id_or_tag] of + OK "" => OK false + | ERROR _ => OK false + | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s)) + + fun branch_tip context (libname, branch) = + git_command_output context libname + ["rev-list", "-1", + remote_branch_name branch] + + fun is_newest_locally context (libname, branch) = + case branch_tip context (libname, branch) of + ERROR e => ERROR e + | OK rev => is_at context (libname, rev) + + fun is_on_branch context (libname, branch) = + case branch_tip context (libname, branch) of + ERROR e => ERROR e + | OK rev => + case is_at context (libname, rev) of + ERROR e => ERROR e + | OK true => OK true + | OK false => + case git_command context libname + ["merge-base", "--is-ancestor", + "HEAD", remote_branch_name branch] of + ERROR e => OK false (* cmd returns non-zero for no *) + | _ => OK true + + fun is_newest context (libname, branch) = + case is_newest_locally context (libname, branch) of + ERROR e => ERROR e + | OK false => OK false + | OK true => + case git_command context libname ["fetch"] of + ERROR e => ERROR e + | _ => is_newest_locally context (libname, branch) + + fun is_modified_locally context libname = + case git_command_output context libname ["status", "--porcelain"] of + ERROR e => ERROR e + | OK "" => OK false + | OK _ => OK true + + (* This function updates to the latest revision on a branch rather + than to a specific id or tag. We can't just checkout the given + branch, as that will succeed even if the branch isn't up to + date. We could checkout the branch and then fetch and merge, + but it's perhaps cleaner not to maintain a local branch at all, + but instead checkout the remote branch as a detached head. *) + + fun update context (libname, branch) = + case git_command context libname ["fetch"] of + ERROR e => ERROR e + | _ => + case git_command context libname ["checkout", "--detach", + remote_branch_name branch] of + ERROR e => ERROR e + | _ => id_of context libname + + (* This function is dealing with a specific id or tag, so if we + can successfully check it out (detached) then that's all we + need to do, regardless of whether fetch succeeded or not. We do + attempt the fetch first, though, purely in order to avoid ugly + error messages in the common case where we're being asked to + update to a new pin (from the lock file) that hasn't been + fetched yet. *) + + fun update_to context (libname, "") = + ERROR "Non-empty id (tag or revision id) required for update_to" + | update_to context (libname, id) = + let val fetch_result = git_command context libname ["fetch"] + in + case git_command context libname ["checkout", "--detach", id] of + OK _ => id_of context libname + | ERROR e => + case fetch_result of + ERROR e' => ERROR e' (* this was the ur-error *) + | _ => ERROR e + end + +end + +structure AnyLibControl :> LIB_CONTROL = struct + + structure H = LibControlFn(HgControl) + structure G = LibControlFn(GitControl) + + fun review context (spec as { vcs, ... } : libspec) = + (fn HG => H.review | GIT => G.review) vcs context spec + + 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 +end + +val libobjname = "libraries" + +fun load_libspec spec_json lock_json libname : libspec = + let open JsonBits + val libobj = lookup_mandatory spec_json [libobjname, libname] + val vcs = lookup_mandatory_string libobj ["vcs"] + val retrieve = lookup_optional_string libobj + 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 lock_pin = case lookup_optional lock_json [libobjname, libname] of + SOME ll => lookup_optional_string ll ["pin"] + | NONE => NONE + in + { + libname = libname, + vcs = case vcs of + "hg" => HG + | "git" => GIT + | other => raise Fail ("Unknown version-control system \"" ^ + other ^ "\""), + source = case (url, service, owner, repo) of + (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, + branch = case branch of + SOME b => BRANCH b + | NONE => DEFAULT_BRANCH + } + end + +fun load_userconfig () : userconfig = + let val home = FileBits.homedir () + val conf_json = + JsonBits.load_json_from + (OS.Path.joinDirFile { + dir = home, + file = VextFilenames.user_config_file }) + handle IO.Io _ => Json.OBJECT [] + in + { + accounts = case JsonBits.lookup_optional conf_json ["accounts"] of + NONE => [] + | SOME (Json.OBJECT aa) => + map (fn (k, (Json.STRING v)) => + { service = k, login = v } + | _ => raise Fail + "String expected for account name") + aa + | _ => raise Fail "Array expected for accounts", + providers = Provider.load_providers conf_json + } + end + +datatype pintype = + NO_LOCKFILE | + USE_LOCKFILE + +fun load_project (userconfig : userconfig) rootpath pintype : project = + let val spec_file = FileBits.project_spec_path rootpath + val lock_file = FileBits.project_lock_path rootpath + val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ]) + handle OS.SysErr _ => false + then () + else raise Fail ("Failed to open project spec file " ^ + (VextFilenames.project_file) ^ " in " ^ + rootpath ^ + ".\nPlease ensure the spec file is in the " ^ + "project root and run this from there.") + val spec_json = JsonBits.load_json_from spec_file + val lock_json = if pintype = USE_LOCKFILE + then JsonBits.load_json_from lock_file + handle IO.Io _ => Json.OBJECT [] + else Json.OBJECT [] + val extdir = JsonBits.lookup_mandatory_string spec_json + ["config", "extdir"] + val spec_libs = JsonBits.lookup_optional spec_json [libobjname] + val lock_libs = JsonBits.lookup_optional lock_json [libobjname] + val providers = Provider.load_more_providers + (#providers userconfig) spec_json + val libnames = case spec_libs of + NONE => [] + | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll + | _ => raise Fail "Object expected for libs" + in + { + context = { + rootpath = rootpath, + extdir = extdir, + providers = providers, + accounts = #accounts userconfig + }, + libs = map (load_libspec spec_json lock_json) libnames + } + end + +fun save_lock_file rootpath locks = + let val lock_file = FileBits.project_lock_path rootpath + open Json + val lock_json = + OBJECT [ + (libobjname, + OBJECT (map (fn { libname, id_or_tag } => + (libname, + OBJECT [ ("pin", STRING id_or_tag) ])) + locks)) + ] + in + JsonBits.save_json_to lock_file lock_json + end + +fun pad_to n str = + if n <= String.size str then str + else pad_to n (str ^ " ") + +fun hline_to 0 = "" + | hline_to n = "-" ^ hline_to (n-1) + +val libname_width = 25 +val libstate_width = 11 +val localstate_width = 9 +val notes_width = 5 +val divider = " | " + +fun print_status_header () = + print ("\r" ^ pad_to 80 "" ^ "\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 " ^ + pad_to libname_width "Library" ^ divider ^ + pad_to libstate_width "Outcome" ^ divider ^ + "Notes" ^ "\n " ^ + hline_to libname_width ^ "-+-" ^ + hline_to libstate_width ^ "-+-" ^ + hline_to notes_width ^ "\n") + +fun print_status with_network (libname, status) = + let val libstate_str = + case status of + OK (ABSENT, _) => "Absent" + | OK (CORRECT, _) => if with_network then "Correct" else "Present" + | OK (SUPERSEDED, _) => "Superseded" + | OK (WRONG, _) => "Wrong" + | ERROR _ => "Error" + val localstate_str = + case status of + OK (_, MODIFIED) => "Modified" + | OK (_, UNMODIFIED) => "Clean" + | _ => "" + val error_str = + case status of + ERROR e => e + | _ => "" + in + print (" " ^ + pad_to libname_width libname ^ 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) = + 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 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 + val _ = print_header () + in + app print_line lines; + lines + end + +fun return_code_for outcomes = + foldl (fn ((_, result), acc) => + case result of + ERROR _ => OS.Process.failure + | _ => acc) + OS.Process.success + outcomes + +fun status_of_project ({ context, libs } : project) = + return_code_for (act_and_print (AnyLibControl.status context) + print_status_header (print_status false) + libs) + +fun review_project ({ context, libs } : project) = + return_code_for (act_and_print (AnyLibControl.review context) + print_status_header (print_status true) + libs) + +fun update_project ({ context, libs } : project) = + let val outcomes = act_and_print + (AnyLibControl.update context) + print_outcome_header print_update_outcome 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 + 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 + end + +fun with_local_project pintype f = + let val return_code = f (load_local_project pintype) + handle e => + (print ("Failed with exception: " ^ + (exnMessage e) ^ "\n"); + OS.Process.failure) + 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 update () = with_local_project NO_LOCKFILE update_project +fun install () = with_local_project USE_LOCKFILE update_project + +fun version () = + (print ("v" ^ vext_version ^ "\n"); + OS.Process.success) + +fun usage () = + (print "\nVext "; + version (); + print ("\nA simple manager for third-party source code dependencies.\n\n" + ^ "Usage:\n\n" + ^ " vext <command>\n\n" + ^ "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" + ^ " 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 () + | ["version"] => version () + | _ => usage () + in + OS.Process.exit return_code; + () + end + +fun main () = + vext (CommandLine.arguments ())