Mercurial > hg > sonic-annotator

--- a/.hgignore	Tue Jan 02 10:56:52 2018 +0000
+++ b/.hgignore	Tue May 15 15:30:38 2018 +0100
@@ -23,4 +23,5 @@
 bqfft
 bqresample
 sv-dependency-builds
-glob:.vext-*.bin
+glob:.repoint-*.bin
+glob:.repoint-*.bin
--- a/configure	Tue Jan 02 10:56:52 2018 +0000
+++ b/configure	Tue May 15 15:30:38 2018 +0100
@@ -7609,22 +7609,22 @@
 fi


-if test -x vext ; then
+if test -x repoint ; 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
+      if ! ./repoint install; then
+         as_fn_error $? "Repoint 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;}
+      { $as_echo "$as_me:${as_lineno-$LINENO}: Repoint executable found but not in an Hg or Git working-copy: not running it" >&5
+$as_echo "$as_me: Repoint 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;}
+   { $as_echo "$as_me:${as_lineno-$LINENO}: No Repoint executable found: assuming external libraries are already here" >&5
+$as_echo "$as_me: No Repoint 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;}
--- a/configure.ac	Tue Jan 02 10:56:52 2018 +0000
+++ b/configure.ac	Tue May 15 15:30:38 2018 +0100
@@ -115,19 +115,19 @@

 AC_OUTPUT

-if test -x vext ; then
+if test -x repoint ; 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])
+      if ! ./repoint install; then
+         AC_MSG_ERROR([Repoint 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])
+      AC_MSG_NOTICE([Repoint 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])
+   AC_MSG_NOTICE([No Repoint 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
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/repoint	Tue May 15 15:30:38 2018 +0100
@@ -0,0 +1,166 @@
+#!/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="$REPOINT_SML"
+
+set -eu
+
+# avoid gussying up output
+export HGPLAIN=true
+
+mydir=$(dirname "$0")
+program="$mydir/repoint.sml"
+
+hasher=
+local_install=
+if [ -w "$mydir" ]; then
+    if echo | sha256sum >/dev/null 2>&1 ; then
+	hasher=sha256sum
+        local_install=true
+    elif echo | shasum >/dev/null 2>&1 ; then
+	hasher=shasum
+	local_install=true
+    else
+        echo "WARNING: sha256sum or shasum program not found" 1>&2
+    fi
+fi
+
+if [ -n "$local_install" ]; then
+    hash=$(echo "$sml" | cat "$program" - | $hasher | cut -c1-16)
+    gen_sml=$mydir/.repoint-$hash.sml
+    gen_out=$mydir/.repoint-$hash.bin
+    trap 'rm -f $gen_sml' 0
+else
+    gen_sml=$(mktemp /tmp/repoint-XXXXXXXX.sml)
+    gen_out=$(mktemp /tmp/repoint-XXXXXXXX.bin)
+    trap 'rm -f $gen_sml $gen_out' 0
+fi
+
+if [ -x "$gen_out" ]; then
+    exec "$gen_out" "$@"
+fi
+
+# 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
+	sml="mlton"
+    elif 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 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
+EOF
+	cat 1>&2 <<EOF
+
+  The Repoint 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
+       - may be found in a distribution package called: smlnj
+       - executable name: sml
+
+    2. Poly/ML
+       - may be found in a distribution package called: polyml
+       - executable name: poly
+
+    3. 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
+fi
+
+arglist=""
+for arg in "$@"; do
+    if [ -n "$arglist" ]; then arglist="$arglist,"; fi
+    if echo "$arg" | grep -q '["'"'"']' ; then
+	arglist="$arglist\"usage\""
+    else
+	arglist="$arglist\"$arg\""
+    fi
+done
+
+case "$sml" in
+    poly)
+        if [ -n "$local_install" ] && polyc --help >/dev/null 2>&1 ; then
+            if [ ! -x "$gen_out" ]; then
+                polyc -o "$gen_out" "$program"
+            fi
+	    "$gen_out" "$@"
+        else
+            echo 'use "'"$program"'"; repoint ['"$arglist"'];' |
+                poly -q --error-exit
+        fi ;;
+    mlton)
+        if [ ! -x "$gen_out" ]; then
+	    echo "[Precompiling Repoint binary...]" 1>&2
+	    echo "val _ = main ()" | cat "$program" - > "$gen_sml"
+	    mlton -output "$gen_out" "$gen_sml"
+        fi
+	"$gen_out" "$@" ;;
+    mlkit)
+        if [ ! -x "$gen_out" ]; then
+	    echo "[Precompiling Repoint binary...]" 1>&2
+	    echo "val _ = main ()" | cat "$program" - > "$gen_sml"
+	    mlkit -output "$gen_out" "$gen_sml"
+        fi
+	"$gen_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 _ = repoint [$arglist];
+val _ = OS.Process.exit (OS.Process.success);
+EOF
+            ) > "$gen_sml"
+	CM_VERBOSE=false sml "$gen_sml" ;;
+    *)
+	echo "ERROR: Unknown SML implementation name: $sml" 1>&2;
+	exit 2 ;;
+esac
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/repoint-lock.json	Tue May 15 15:30:38 2018 +0100
@@ -0,0 +1,28 @@
+{
+  "libraries": {
+    "vamp-plugin-sdk": {
+      "pin": "5d9af3140f05"
+    },
+    "svcore": {
+      "pin": "a533662c17f4"
+    },
+    "piper-cpp": {
+      "pin": "85394095a5b04f99a0785ccd32a5a98c90d984b2"
+    },
+    "dataquay": {
+      "pin": "807b55408d9e"
+    },
+    "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/repoint-project.json	Tue May 15 15:30:38 2018 +0100
@@ -0,0 +1,53 @@
+{
+    "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"
+        },
+        "dataquay": {
+            "vcs": "hg",
+            "service": "bitbucket",
+            "owner": "breakfastquay"
+        },
+        "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/repoint.bat	Tue May 15 15:30:38 2018 +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/repoint.ps1	Tue May 15 15:30:38 2018 +0100
@@ -0,0 +1,117 @@
+<#
+
+.SYNOPSIS
+A simple manager for third-party source code dependencies.
+Run "repoint help" for more documentation.
+
+#>
+
+Set-StrictMode -Version 2.0
+$ErrorActionPreference = "Stop"
+$env:HGPLAIN = "true"
+
+$sml = $env:REPOINT_SML
+
+$mydir = Split-Path $MyInvocation.MyCommand.Path -Parent
+$program = "$mydir/repoint.sml"
+
+# 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"
+    } elseif (Get-Command "polyml" -ErrorAction SilentlyContinue) {
+       $sml = "poly"
+    } else {
+       echo @"
+
+ERROR: No supported SML compiler or interpreter found
+
+  The Repoint 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
+       - executable name: sml
+
+    2. Poly/ML
+       - executable name: polyml
+
+"@
+       exit 1
+    }
+}
+
+if ($args -match "'""") {
+    $arglist = '["usage"]'
+} else {
+    $arglist = '["' + ($args -join '","') + '"]'
+}
+
+if ($sml -eq "poly") {
+
+    $program = $program -replace "\\","\\\\"
+    echo "use ""$program""; repoint $arglist" | polyml -q --error-exit | Out-Host
+
+    if (-not $?) {
+        exit $LastExitCode
+    }
+
+} 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 _ = repoint $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
+
+    if (-not $?) {
+        del $tmpfile
+        exit $LastExitCode
+    }
+
+    del $tmpfile
+
+} else {
+
+    "Unknown SML implementation name: $sml"
+    exit 2
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/repoint.sml	Tue May 15 15:30:38 2018 +0100
@@ -0,0 +1,2669 @@
+(*
+    DO NOT EDIT THIS FILE.
+    This file is automatically generated from the individual
+    source files in the Repoint repository.
+*)
+
+(*
+    Repoint
+
+    A simple manager for third-party source code dependencies
+
+    Copyright 2018 Chris Cannam, Particular Programs Ltd,
+    and Queen Mary, University of London
+
+    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,
+    Particular Programs Ltd, and Queen Mary, University of London
+    shall not be used in advertising or otherwise to promote the sale,
+    use or other dealings in this Software without prior written
+    authorization.
+*)
+
+val repoint_version = "0.9.98"
+
+
+datatype vcs =
+         HG |
+         GIT |
+         SVN
+
+datatype source =
+         URL_SOURCE of string |
+         SERVICE_SOURCE of {
+             service : string,
+             owner : string option,
+             repo : string option
+         }
+
+type id_or_tag = string
+
+datatype pin =
+         UNPINNED |
+         PINNED of id_or_tag
+
+datatype libstate =
+         ABSENT |
+         CORRECT |
+         SUPERSEDED |
+         WRONG
+
+datatype localstate =
+         MODIFIED |
+         LOCK_MISMATCHED |
+         CLEAN
+
+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 libspec = {
+    libname : libname,
+    vcs : vcs,
+    source : source,
+    branch : branch,
+    project_pin : pin,
+    lock_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 RepointFilenames = struct
+    val project_file = "repoint-project.json"
+    val project_lock_file = "repoint-lock.json"
+    val user_config_file = ".repoint.json"
+    val archive_dir = ".repoint-archive"
+end
+
+signature VCS_CONTROL = sig
+
+    (** Check whether the given VCS is installed and working *)
+    val is_working : context -> bool result
+
+    (** Test whether the library is present locally at all *)
+    val exists : context -> libname -> bool result
+
+    (** Return the id (hash) of the current revision for the library *)
+    val id_of : context -> libname -> id_or_tag result
+
+    (** 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 * source * 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. Assumes that a
+        local copy of the library already exists *)
+    val update : context -> libname * source * branch -> unit result
+
+    (** Update the library to the given specific id or tag *)
+    val update_to : context -> libname * source * id_or_tag -> unit result
+
+    (** Return a URL from which the library can be cloned, given that
+        the local copy already exists. For a DVCS this can be the
+        local copy, but for a centralised VCS it will have to be the
+        remote repository URL. Used for archiving *)
+    val copy_url_for : context -> libname -> string result
+end
+
+signature LIB_CONTROL = sig
+    val review : context -> libspec -> (libstate * localstate) result
+    val status : context -> libspec -> (libstate * localstate) result
+    val update : context -> libspec -> unit result
+    val id_of : context -> libspec -> id_or_tag result
+    val is_working : context -> vcs -> bool result
+end
+
+structure FileBits :> sig
+    val extpath : context -> string
+    val libpath : context -> libname -> string
+    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_url : string -> string
+    val file_contents : string -> string
+    val mydir : unit -> string
+    val homedir : unit -> string
+    val mkpath : string -> unit result
+    val rmpath : string -> unit result
+    val nonempty_dir_exists : string -> bool
+    val project_spec_path : string -> string
+    val project_lock_path : string -> string
+    val verbose : unit -> bool
+end = struct
+
+    fun verbose () =
+        case OS.Process.getEnv "REPOINT_VERBOSE" of
+            SOME "0" => false
+          | SOME _ => true
+          | NONE => false
+
+    fun split_relative path desc =
+        case OS.Path.fromString path of
+            { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
+          | { arcs, ... } => arcs
+
+    fun extpath ({ rootpath, extdir, ... } : context) =
+        let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
+        in OS.Path.toString {
+                isAbs = isAbs,
+                vol = vol,
+                arcs = arcs @
+                       split_relative extdir "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
+        in OS.Path.toString {
+                isAbs = isAbs,
+                vol = vol,
+                arcs = arcs @
+                       split_relative extdir "extdir" @
+                       split_relative libname "library path" @
+                       split_relative remainder "subpath"
+            }
+        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 (RepointFilenames.project_file)
+
+    fun project_lock_path rootpath =
+        project_file_path rootpath (RepointFilenames.project_lock_file)
+
+    fun trim str =
+        hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
+
+    fun file_url path =
+        let val forward_path =
+                String.translate (fn #"\\" => "/" |
+                                  c => Char.toString c)
+                                 (OS.Path.mkCanonical path)
+        in
+            (* Path is expected to be absolute already, but if it
+               starts with a drive letter, we'll need an extra slash *)
+            case explode forward_path of
+                #"/"::rest => "file:///" ^ implode rest
+              | _ => "file:///" ^ forward_path
+        end
+
+    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 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. *)
+        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 orelse
+                               c > chr 127
+                            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 70 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 ("\n=== " ^ dir ^ "\n<<< " ^ cmd ^ "\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
+            val _ = if verbose ()
+                    then print (">>> \"" ^ contents ^ "\"\n")
+                    else ()
+        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))
+
+    fun mkpath path =
+        mkpath' (OS.Path.mkCanonical path)
+
+    fun dir_contents dir =
+        let open OS
+            fun files_from dirstream =
+                case FileSys.readDir dirstream of
+                    NONE => []
+                  | SOME file =>
+                    (* readDir is supposed to filter these,
+                       but let's be extra cautious: *)
+                    if file = Path.parentArc orelse file = Path.currentArc
+                    then files_from dirstream
+                    else file :: files_from dirstream
+            val stream = FileSys.openDir dir
+            val files = map (fn f => Path.joinDirFile
+                                         { dir = dir, file = f })
+                            (files_from stream)
+            val _ = FileSys.closeDir stream
+        in
+            files
+        end
+
+    fun rmpath' path =
+        let open OS
+            fun remove path =
+                if FileSys.isLink path (* dangling links bother isDir *)
+                then FileSys.remove path
+                else if FileSys.isDir path
+                then (app remove (dir_contents path); FileSys.rmDir path)
+                else FileSys.remove path
+        in
+            (remove path; OK ())
+            handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
+        end
+
+    fun rmpath path =
+        rmpath' (OS.Path.mkCanonical path)
+
+    fun nonempty_dir_exists path =
+        let open OS.FileSys
+        in
+            (not (isLink path) andalso
+             isDir path andalso
+             dir_contents path <> [])
+            handle _ => false
+        end
+
+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, source, branch,
+                 project_pin, lock_pin, ... } : libspec) =
+        let fun check_unpinned () =
+                let val newest =
+                        if with_network
+                        then V.is_newest context (libname, source, branch)
+                        else V.is_newest_locally context (libname, branch)
+                in
+                    case newest 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_remote () =
+                case project_pin of
+                    UNPINNED => check_unpinned ()
+                  | PINNED target => check_pinned target
+            fun check_local () =
+                case V.is_modified_locally context libname of
+                    ERROR e => ERROR e
+                  | OK true  => OK MODIFIED
+                  | OK false =>
+                    case lock_pin of
+                        UNPINNED => OK CLEAN
+                      | PINNED target =>
+                        case V.is_at context (libname, target) of
+                            ERROR e => ERROR e
+                          | OK true => OK CLEAN
+                          | OK false => OK LOCK_MISMATCHED
+        in
+            case V.exists context libname of
+                ERROR e => ERROR e
+              | OK false => OK (ABSENT, CLEAN)
+              | OK true =>
+                case (check_remote (), check_local ()) of
+                    (ERROR e, _) => ERROR e
+                  | (_, ERROR e) => ERROR e
+                  | (OK r, OK l) => OK (r, l)
+        end
+
+    val review = check true
+    val status = check false
+
+    fun update context
+               ({ libname, source, branch,
+                  project_pin, lock_pin, ... } : libspec) =
+        let fun update_unpinned () =
+                case V.is_newest context (libname, source, branch) of
+                    ERROR e => ERROR e
+                  | OK true => OK ()
+                  | OK false => V.update context (libname, source, branch)
+            fun update_pinned target =
+                case V.is_at context (libname, target) of
+                    ERROR e => ERROR e
+                  | OK true => OK ()
+                  | OK false => V.update_to context (libname, source, target)
+            fun update' () =
+                case lock_pin of
+                    PINNED target => update_pinned target
+                  | UNPINNED =>
+                    case project_pin of
+                        PINNED target => update_pinned target
+                      | UNPINNED => update_unpinned ()
+        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
+
+    fun id_of context ({ libname, ... } : libspec) =
+        V.id_of context libname
+
+    fun is_working context vcs =
+        V.is_working context
+
+end
+
+(* Simple Standard ML JSON parser
+   https://bitbucket.org/cannam/sml-simplejson
+   Copyright 2017 Chris Cannam. BSD licence.
+   Parts based on the JSON parser in the Ponyo library by Phil Eaton.
+*)
+
+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
+    exception Config of string
+    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
+
+    exception Config of string
+
+    fun load_json_from filename =
+        case Json.parse (FileBits.file_contents filename) of
+            Json.OK json => json
+          | Json.ERROR e => raise Config ("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.filter (fn (k, v) => k = key) kvs of
+                         [] => NONE
+                       | [(_,v)] => SOME v
+                       | _ => raise Config ("Duplicate key: " ^
+                                            (String.concatWith " -> " kk)))
+                  | _ => raise Config "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 Config ("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 Config ("Value is mandatory: " ^
+                                  (String.concatWith " -> " kk))
+
+    fun lookup_mandatory_string json kk =
+        case lookup_optional json kk of
+            SOME (Json.STRING s) => s
+          | _ => raise Config ("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 HG => "hg"
+                  | GIT => "git"
+                  | SVN => "svn"
+
+    fun vcs_from_name name =
+        case name of "hg" => HG
+                   | "git" => GIT
+                   | "svn" => SVN
+                   | 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 reponame_for path =
+        case String.tokens (fn c => c = #"/") path of
+            [] => raise Fail "Non-empty library path required"
+          | toks => hd (rev toks)
+
+    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 => reponame_for libname }
+                         (login_for context service)
+                         (#providers context)
+end
+
+structure HgControl :> VCS_CONTROL = struct
+
+    (* Pulls always use an explicit URL, never just the default
+       remote, in order to ensure we update properly if the location
+       given in the project file changes. *)
+
+    type vcsstate = { id: string, modified: bool,
+                      branch: string, tags: string list }
+
+    val hg_program = "hg"
+
+    val hg_args = [ "--config", "ui.interactive=true",
+                    "--config", "ui.merge=:merge" ]
+
+    fun hg_command context libname args =
+        FileBits.command context libname (hg_program :: hg_args @ args)
+
+    fun hg_command_output context libname args =
+        FileBits.command_output context libname (hg_program :: hg_args @ args)
+
+    fun is_working context =
+        case hg_command_output context "" ["--version"] of
+            OK "" => OK false
+          | OK _ => OK true
+          | ERROR e => ERROR e
+
+    fun exists context libname =
+        OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
+        handle _ => OK false
+
+    fun remote_for context (libname, source) =
+        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 => OK false (* desired branch does not exist *)
+          | OK newest_in_repo => is_at context (libname, newest_in_repo)
+
+    fun pull context (libname, source) =
+        let val url = remote_for context (libname, source)
+        in
+            hg_command context libname
+                       (if FileBits.verbose ()
+                        then ["pull", url]
+                        else ["pull", "-q", url])
+        end
+
+    fun is_newest context (libname, source, branch) =
+        case is_newest_locally context (libname, branch) of
+            ERROR e => ERROR e
+          | OK false => OK false
+          | OK true =>
+            case pull context (libname, source) 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
+            (* make the lib dir rather than just the ext dir, since
+               the lib dir might be nested and hg will happily check
+               out into an existing empty dir anyway *)
+            case FileBits.mkpath (FileBits.libpath context libname) of
+                ERROR e => ERROR e
+              | _ => hg_command context ""
+                                ["clone", "-u", branch_name branch,
+                                 url, libname]
+        end
+
+    fun update context (libname, source, branch) =
+        let val pull_result = pull context (libname, source)
+        in
+            case hg_command context libname ["update", branch_name branch] of
+                ERROR e => ERROR e
+              | _ =>
+                case pull_result of
+                    ERROR e => ERROR e
+                  | _ => OK ()
+        end
+
+    fun update_to context (libname, _, "") =
+        ERROR "Non-empty id (tag or revision id) required for update_to"
+      | update_to context (libname, source, id) =
+        let val pull_result = pull context (libname, source)
+        in
+            case hg_command context libname ["update", "-r", id] of
+                OK _ => OK ()
+              | ERROR e =>
+                case pull_result of
+                    ERROR e' => ERROR e' (* this was the ur-error *)
+                  | _ => ERROR e
+        end
+
+    fun copy_url_for context libname =
+        OK (FileBits.file_url (FileBits.libpath context libname))
+
+end
+
+structure GitControl :> VCS_CONTROL = struct
+
+    (* With Git repos we always operate in detached HEAD state. Even
+       the master branch is checked out using a remote reference
+       (repoint/master). The remote we use is always named repoint, and we
+       update it to the expected URL each time we fetch, in order to
+       ensure we update properly if the location given in the project
+       file changes. The origin remote is unused. *)
+
+    val git_program = "git"
+
+    fun git_command context libname args =
+        FileBits.command context libname (git_program :: args)
+
+    fun git_command_output context libname args =
+        FileBits.command_output context libname (git_program :: args)
+
+    fun is_working context =
+        case git_command_output context "" ["--version"] of
+            OK "" => OK false
+          | OK _ => OK true
+          | ERROR e => ERROR e
+
+    fun exists context libname =
+        OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
+        handle _ => OK false
+
+    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
+
+    val our_remote = "repoint"
+
+    fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
+
+    fun checkout context (libname, source, branch) =
+        let val url = remote_for context (libname, source)
+        in
+            (* make the lib dir rather than just the ext dir, since
+               the lib dir might be nested and git will happily check
+               out into an existing empty dir anyway *)
+            case FileBits.mkpath (FileBits.libpath context libname) of
+                OK () => git_command context ""
+                                     ["clone", "--origin", our_remote,
+                                      "--branch", branch_name branch,
+                                      url, libname]
+              | ERROR e => ERROR e
+        end
+
+    fun add_our_remote context (libname, source) =
+        (* When we do the checkout ourselves (above), we add the
+           remote at the same time. But if the repo was cloned by
+           someone else, we'll need to do it after the fact. Git
+           doesn't seem to have a means to add a remote or change its
+           url if it already exists; seems we have to do this: *)
+        let val url = remote_for context (libname, source)
+        in
+            case git_command context libname
+                             ["remote", "set-url", our_remote, url] of
+                OK () => OK ()
+              | ERROR e => git_command context libname
+                                       ["remote", "add", "-f", our_remote, url]
+        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 => OK false (* HEAD nonexistent, expected in empty repo *)
+          | OK id =>
+            if String.isPrefix id_or_tag id orelse
+               String.isPrefix id id_or_tag
+            then OK true
+            else is_at_tag context (libname, id, id_or_tag)
+
+    and is_at_tag context (libname, id, tag) =
+        (* For annotated tags (with message) show-ref returns the tag
+           object ref rather than that of the revision being tagged;
+           we need the subsequent rev-list to chase that up. In fact
+           the rev-list on its own is enough to get us the id direct
+           from the tag name, but it fails with an error if the tag
+           doesn't exist, whereas we want to handle that quietly in
+           case the tag simply hasn't been pulled yet *)
+        case git_command_output context libname
+                                ["show-ref", "refs/tags/" ^ tag, "--"] of
+            OK "" => OK false (* Not a tag *)
+          | ERROR _ => OK false
+          | OK s =>
+            let val tag_ref = hd (String.tokens (fn c => c = #" ") s)
+            in
+                case git_command_output context libname
+                                        ["rev-list", "-1", tag_ref] of
+                    OK tagged => OK (id = tagged)
+                  | ERROR _ => OK false
+            end
+
+    fun branch_tip context (libname, branch) =
+        (* We don't have access to the source info or the network
+           here, as this is used by status (e.g. via is_on_branch) as
+           well as review. It's possible the remote branch won't exist,
+           e.g. if the repo was checked out by something other than
+           Repoint, and if that's the case, we can't add it here; we'll
+           just have to fail, since checking against local branches
+           instead could produce the wrong result. *)
+        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 => OK false
+          | OK rev => is_at context (libname, rev)
+
+    fun is_on_branch context (libname, branch) =
+        case branch_tip context (libname, branch) of
+            ERROR e => OK false
+          | 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 fetch context (libname, source) =
+        case add_our_remote context (libname, source) of
+            ERROR e => ERROR e
+          | _ => git_command context libname ["fetch", our_remote]
+
+    fun is_newest context (libname, source, branch) =
+        case add_our_remote context (libname, source) of
+            ERROR e => ERROR e
+          | OK () =>
+            case is_newest_locally context (libname, branch) of
+                ERROR e => ERROR e
+              | OK false => OK false
+              | OK true =>
+                case fetch context (libname, source) 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, source, branch) =
+        case fetch context (libname, source) of
+            ERROR e => ERROR e
+          | _ =>
+            case git_command context libname ["checkout", "--detach",
+                                              remote_branch_name branch] of
+                ERROR e => ERROR e
+              | _ => OK ()
+
+    (* 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, source, id) =
+        let val fetch_result = fetch context (libname, source)
+        in
+            case git_command context libname ["checkout", "--detach", id] of
+                OK _ => OK ()
+              | ERROR e =>
+                case fetch_result of
+                    ERROR e' => ERROR e' (* this was the ur-error *)
+                  | _ => ERROR e
+        end
+
+    fun copy_url_for context libname =
+        OK (FileBits.file_url (FileBits.libpath context libname))
+
+end
+
+(* SubXml - A parser for a subset of XML
+   https://bitbucket.org/cannam/sml-subxml
+   Copyright 2018 Chris Cannam. BSD licence.
+*)
+
+signature SUBXML = sig
+
+    datatype node = ELEMENT of { name : string, children : node list }
+                  | ATTRIBUTE of { name : string, value : string }
+                  | TEXT of string
+                  | CDATA of string
+                  | COMMENT of string
+
+    datatype document = DOCUMENT of { name : string, children : node list }
+
+    datatype 'a result = OK of 'a
+                       | ERROR of string
+
+    val parse : string -> document result
+    val serialise : document -> string
+
+end
+
+structure SubXml :> SUBXML = struct
+
+    datatype node = ELEMENT of { name : string, children : node list }
+                  | ATTRIBUTE of { name : string, value : string }
+                  | TEXT of string
+                  | CDATA of string
+                  | COMMENT of string
+
+    datatype document = DOCUMENT of { name : string, children : node list }
+
+    datatype 'a result = OK of 'a
+                       | ERROR of string
+
+    structure T = struct
+        datatype token = ANGLE_L
+                       | ANGLE_R
+                       | ANGLE_SLASH_L
+                       | SLASH_ANGLE_R
+                       | EQUAL
+                       | NAME of string
+                       | TEXT of string
+                       | CDATA of string
+                       | COMMENT of string
+
+        fun name t =
+            case t of ANGLE_L => "<"
+                    | ANGLE_R => ">"
+                    | ANGLE_SLASH_L => "</"
+                    | SLASH_ANGLE_R => "/>"
+                    | EQUAL => "="
+                    | NAME s => "name \"" ^ s ^ "\""
+                    | TEXT s => "text"
+                    | CDATA _ => "CDATA section"
+                    | COMMENT _ => "comment"
+    end
+
+    structure Lex :> sig
+                  val lex : string -> T.token list result
+              end = struct
+
+        fun error pos text =
+            ERROR (text ^ " at character position " ^ Int.toString (pos-1))
+        fun tokenError pos token =
+            error pos ("Unexpected token '" ^ Char.toString token ^ "'")
+
+        val nameEnd = explode " \t\n\r\"'</>!=?"
+
+        fun quoted quote pos acc cc =
+            let fun quoted' pos text [] =
+                    error pos "Document ends during quoted string"
+                  | quoted' pos text (x::xs) =
+                    if x = quote
+                    then OK (rev text, xs, pos+1)
+                    else quoted' (pos+1) (x::text) xs
+            in
+                case quoted' pos [] cc of
+                    ERROR e => ERROR e
+                  | OK (text, rest, newpos) =>
+                    inside newpos (T.TEXT (implode text) :: acc) rest
+            end
+
+        and name first pos acc cc =
+            let fun name' pos text [] =
+                    error pos "Document ends during name"
+                  | name' pos text (x::xs) =
+                    if List.find (fn c => c = x) nameEnd <> NONE
+                    then OK (rev text, (x::xs), pos)
+                    else name' (pos+1) (x::text) xs
+            in
+                case name' (pos-1) [] (first::cc) of
+                    ERROR e => ERROR e
+                  | OK ([], [], pos) => error pos "Document ends before name"
+                  | OK ([], (x::xs), pos) => tokenError pos x
+                  | OK (text, rest, pos) =>
+                    inside pos (T.NAME (implode text) :: acc) rest
+            end
+
+        and comment pos acc cc =
+            let fun comment' pos text cc =
+                    case cc of
+                        #"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3)
+                      | x :: xs => comment' (pos+1) (x::text) xs
+                      | [] => error pos "Document ends during comment"
+            in
+                case comment' pos [] cc of
+                    ERROR e => ERROR e
+                  | OK (text, rest, pos) =>
+                    outside pos (T.COMMENT (implode text) :: acc) rest
+            end
+
+        and instruction pos acc cc =
+            case cc of
+                #"?" :: #">" :: xs => outside (pos+2) acc xs
+              | #">" :: _ => tokenError pos #">"
+              | x :: xs => instruction (pos+1) acc xs
+              | [] => error pos "Document ends during processing instruction"
+
+        and cdata pos acc cc =
+            let fun cdata' pos text cc =
+                    case cc of
+                        #"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3)
+                      | x :: xs => cdata' (pos+1) (x::text) xs
+                      | [] => error pos "Document ends during CDATA section"
+            in
+                case cdata' pos [] cc of
+                    ERROR e => ERROR e
+                  | OK (text, rest, pos) =>
+                    outside pos (T.CDATA (implode text) :: acc) rest
+            end
+
+        and doctype pos acc cc =
+            case cc of
+                #">" :: xs => outside (pos+1) acc xs
+              | x :: xs => doctype (pos+1) acc xs
+              | [] => error pos "Document ends during DOCTYPE"
+
+        and declaration pos acc cc =
+            case cc of
+                #"-" :: #"-" :: xs =>
+                comment (pos+2) acc xs
+              | #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs =>
+                cdata (pos+7) acc xs
+              | #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs =>
+                doctype (pos+7) acc xs
+              | [] => error pos "Document ends during declaration"
+              | _ => error pos "Unsupported declaration type"
+
+        and left pos acc cc =
+            case cc of
+                #"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs
+              | #"!" :: xs => declaration (pos+1) acc xs
+              | #"?" :: xs => instruction (pos+1) acc xs
+              | xs => inside pos (T.ANGLE_L :: acc) xs
+
+        and slash pos acc cc =
+            case cc of
+                #">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs
+              | x :: _ => tokenError pos x
+              | [] => error pos "Document ends before element closed"
+
+        and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs
+
+        and equal pos acc xs = inside pos (T.EQUAL :: acc) xs
+
+        and outside pos acc [] = OK acc
+          | outside pos acc cc =
+            let fun textOf text = T.TEXT (implode (rev text))
+                fun outside' pos [] acc [] = OK acc
+                  | outside' pos text acc [] = OK (textOf text :: acc)
+                  | outside' pos text acc (x::xs) =
+                    case x of
+                        #"<" => if text = []
+                                then left (pos+1) acc xs
+                                else left (pos+1) (textOf text :: acc) xs
+                      | x => outside' (pos+1) (x::text) acc xs
+            in
+                outside' pos [] acc cc
+            end
+
+        and inside pos acc [] = error pos "Document ends within tag"
+          | inside pos acc (#"<"::_) = tokenError pos #"<"
+          | inside pos acc (x::xs) =
+            (case x of
+                 #" " => inside | #"\t" => inside
+               | #"\n" => inside | #"\r" => inside
+               | #"\"" => quoted x | #"'" => quoted x
+               | #"/" => slash | #">" => close | #"=" => equal
+               | x => name x) (pos+1) acc xs
+
+        fun lex str =
+            case outside 1 [] (explode str) of
+                ERROR e => ERROR e
+              | OK tokens => OK (rev tokens)
+    end
+
+    structure Parse :> sig
+                  val parse : string -> document result
+              end = struct
+
+        fun show [] = "end of input"
+          | show (tok :: _) = T.name tok
+
+        fun error toks text = ERROR (text ^ " before " ^ show toks)
+
+        fun attribute elt name toks =
+            case toks of
+                T.EQUAL :: T.TEXT value :: xs =>
+                namedElement {
+                    name = #name elt,
+                    children = ATTRIBUTE { name = name, value = value } ::
+                               #children elt
+                } xs
+              | T.EQUAL :: xs => error xs "Expected attribute value"
+              | toks => error toks "Expected attribute assignment"
+
+        and content elt toks =
+            case toks of
+                T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs =>
+                if n = #name elt
+                then OK (elt, xs)
+                else ERROR ("Closing tag </" ^ n ^ "> " ^
+                            "does not match opening <" ^ #name elt ^ ">")
+              | T.TEXT text :: xs =>
+                content {
+                    name = #name elt,
+                    children = TEXT text :: #children elt
+                } xs
+              | T.CDATA text :: xs =>
+                content {
+                    name = #name elt,
+                    children = CDATA text :: #children elt
+                } xs
+              | T.COMMENT text :: xs =>
+                content {
+                    name = #name elt,
+                    children = COMMENT text :: #children elt
+                } xs
+              | T.ANGLE_L :: xs =>
+                (case element xs of
+                     ERROR e => ERROR e
+                   | OK (child, xs) =>
+                     content {
+                         name = #name elt,
+                         children = ELEMENT child :: #children elt
+                     } xs)
+              | tok :: xs =>
+                error xs ("Unexpected token " ^ T.name tok)
+              | [] =>
+                ERROR ("Document ends within element \"" ^ #name elt ^ "\"")
+
+        and namedElement elt toks =
+            case toks of
+                T.SLASH_ANGLE_R :: xs => OK (elt, xs)
+              | T.NAME name :: xs => attribute elt name xs
+              | T.ANGLE_R :: xs => content elt xs
+              | x :: xs => error xs ("Unexpected token " ^ T.name x)
+              | [] => ERROR "Document ends within opening tag"
+
+        and element toks =
+            case toks of
+                T.NAME name :: xs =>
+                (case namedElement { name = name, children = [] } xs of
+                     ERROR e => ERROR e
+                   | OK ({ name, children }, xs) =>
+                     OK ({ name = name, children = rev children }, xs))
+              | toks => error toks "Expected element name"
+
+        and document [] = ERROR "Empty document"
+          | document (tok :: xs) =
+            case tok of
+                T.TEXT _ => document xs
+              | T.COMMENT _ => document xs
+              | T.ANGLE_L =>
+                (case element xs of
+                     ERROR e => ERROR e
+                   | OK (elt, []) => OK (DOCUMENT elt)
+                   | OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt)
+                   | OK (elt, xs) => error xs "Extra data after document")
+              | _ => error xs ("Unexpected token " ^ T.name tok)
+
+        fun parse str =
+            case Lex.lex str of
+                ERROR e => ERROR e
+              | OK tokens => document tokens
+    end
+
+    structure Serialise :> sig
+                  val serialise : document -> string
+              end = struct
+
+        fun attributes nodes =
+            String.concatWith
+                " "
+                (map node (List.filter
+                               (fn ATTRIBUTE _ => true | _ => false)
+                               nodes))
+
+        and nonAttributes nodes =
+            String.concat
+                (map node (List.filter
+                               (fn ATTRIBUTE _ => false | _ => true)
+                               nodes))
+
+        and node n =
+            case n of
+                TEXT string =>
+                string
+              | CDATA string =>
+                "<![CDATA[" ^ string ^ "]]>"
+              | COMMENT string =>
+                "<!-- " ^ string ^ "-->"
+              | ATTRIBUTE { name, value } =>
+                name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*)
+              | ELEMENT { name, children } =>
+                "<" ^ name ^
+                (case (attributes children) of
+                     "" => ""
+                   | s => " " ^ s) ^
+                (case (nonAttributes children) of
+                     "" => "/>"
+                   | s => ">" ^ s ^ "</" ^ name ^ ">")
+
+        fun serialise (DOCUMENT { name, children }) =
+            "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ^
+            node (ELEMENT { name = name, children = children })
+    end
+
+    val parse = Parse.parse
+    val serialise = Serialise.serialise
+
+end
+
+
+structure SvnControl :> VCS_CONTROL = struct
+
+    val svn_program = "svn"
+
+    fun svn_command context libname args =
+        FileBits.command context libname (svn_program :: args)
+
+    fun svn_command_output context libname args =
+        FileBits.command_output context libname (svn_program :: args)
+
+    fun svn_command_lines context libname args =
+        case svn_command_output context libname args of
+            ERROR e => ERROR e
+          | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s)
+
+    fun split_line_pair line =
+        let fun strip_leading_ws str = case explode str of
+                                           #" "::rest => implode rest
+                                         | _ => str
+        in
+            case String.tokens (fn c => c = #":") line of
+                [] => ("", "")
+              | first::rest =>
+                (first, strip_leading_ws (String.concatWith ":" rest))
+        end
+
+    fun is_working context =
+        case svn_command_output context "" ["--version"] of
+            OK "" => OK false
+          | OK _ => OK true
+          | ERROR e => ERROR e
+
+    structure X = SubXml
+
+    fun svn_info context libname route =
+        (* SVN 1.9 has info --show-item which is just what we need,
+           but at this point we still have 1.8 on the CI boxes so we
+           might as well aim to support it. For that we really have to
+           use the XML output format, since the default info output is
+           localised. This is the only thing our mini-XML parser is
+           used for though, so it would be good to trim it at some
+           point *)
+        let fun find elt [] = OK elt
+              | find { children, ... } (first :: rest) =
+                case List.find (fn (X.ELEMENT { name, ... }) => name = first
+                               | _ => false)
+                               children of
+                    NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML")
+                  | SOME (X.ELEMENT e) => find e rest
+                  | SOME _ => ERROR "Internal error"
+        in
+            case svn_command_output context libname ["info", "--xml"] of
+                ERROR e => ERROR e
+              | OK xml =>
+                case X.parse xml of
+                    X.ERROR e => ERROR e
+                  | X.OK (X.DOCUMENT doc) => find doc route
+        end
+
+    fun exists context libname =
+        OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn"))
+        handle _ => OK false
+
+    fun remote_for context (libname, source) =
+        Provider.remote_url context SVN source libname
+
+    (* Remote the checkout came from, not necessarily the one we want *)
+    fun actual_remote_for context libname =
+        case svn_info context libname ["entry", "url"] of
+            ERROR e => ERROR e
+          | OK { children, ... } =>
+            case List.find (fn (X.TEXT _) => true | _ => false) children of
+                NONE => ERROR "No content for URL in SVN info XML"
+              | SOME (X.TEXT url) => OK url
+              | SOME _ => ERROR "Internal error"
+
+    fun id_of context libname =
+        case svn_info context libname ["entry"] of
+            ERROR e => ERROR e
+          | OK { children, ... } =>
+            case List.find
+                     (fn (X.ATTRIBUTE { name = "revision", ... }) => true
+                     | _ => false)
+                     children of
+                NONE => ERROR "No revision for entry in SVN info XML"
+              | SOME (X.ATTRIBUTE { value, ... }) => OK value
+              | SOME _ => ERROR "Internal error"
+
+    fun is_at context (libname, id_or_tag) =
+        case id_of context libname of
+            ERROR e => ERROR e
+          | OK id => OK (id = id_or_tag)
+
+    fun is_on_branch context (libname, b) =
+        OK (b = DEFAULT_BRANCH)
+
+    fun check_remote context (libname, source) =
+      case (remote_for context (libname, source),
+            actual_remote_for context libname) of
+          (_, ERROR e) => ERROR e
+        | (url, OK actual) =>
+          if actual = url
+          then OK ()
+          else svn_command context libname ["relocate", url]
+
+    fun is_newest context (libname, source, branch) =
+        case check_remote context (libname, source) of
+            ERROR e => ERROR e
+          | OK () =>
+            case svn_command_lines context libname
+                                   ["status", "--show-updates"] of
+                ERROR e => ERROR e
+              | OK lines =>
+                case rev lines of
+                    [] => ERROR "No result returned for server status"
+                  | last_line::_ =>
+                    case rev (String.tokens (fn c => c = #" ") last_line) of
+                        [] => ERROR "No revision field found in server status"
+                      | server_id::_ => is_at context (libname, server_id)
+
+    fun is_newest_locally context (libname, branch) =
+        OK true (* no local history *)
+
+    fun is_modified_locally context libname =
+        case svn_command_output context libname ["status"] of
+            ERROR e => ERROR e
+          | OK "" => OK false
+          | OK _ => OK true
+
+    fun checkout context (libname, source, branch) =
+        let val url = remote_for context (libname, source)
+            val path = FileBits.libpath context libname
+        in
+            if FileBits.nonempty_dir_exists path
+            then (* Surprisingly, SVN itself has no problem with
+                    this. But for consistency with other VCSes we
+                    don't allow it *)
+                ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"")
+            else
+                (* make the lib dir rather than just the ext dir, since
+                   the lib dir might be nested and svn will happily check
+                   out into an existing empty dir anyway *)
+                case FileBits.mkpath (FileBits.libpath context libname) of
+                    ERROR e => ERROR e
+                  | _ => svn_command context "" ["checkout", url, libname]
+        end
+
+    fun update context (libname, source, branch) =
+        case check_remote context (libname, source) of
+            ERROR e => ERROR e
+          | OK () =>
+            case svn_command context libname
+                             ["update", "--accept", "postpone"] of
+                ERROR e => ERROR e
+              | _ => OK ()
+
+    fun update_to context (libname, _, "") =
+        ERROR "Non-empty id (tag or revision id) required for update_to"
+      | update_to context (libname, source, id) =
+        case check_remote context (libname, source) of
+            ERROR e => ERROR e
+          | OK () =>
+            case svn_command context libname
+                             ["update", "-r", id, "--accept", "postpone"] of
+                ERROR e => ERROR e
+              | OK _ => OK ()
+
+    fun copy_url_for context libname =
+        actual_remote_for context libname
+
+end
+
+structure AnyLibControl :> LIB_CONTROL = struct
+
+    structure H = LibControlFn(HgControl)
+    structure G = LibControlFn(GitControl)
+    structure S = LibControlFn(SvnControl)
+
+    fun review context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec
+
+    fun status context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec
+
+    fun update context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec
+
+    fun id_of context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec
+
+    fun is_working context vcs =
+        (fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working)
+            vcs context vcs
+
+end
+
+
+type exclusions = string list
+
+structure Archive :> sig
+
+    val archive : string * exclusions -> project -> OS.Process.status
+
+end = struct
+
+    (* The idea of "archive" is to replace hg/git archive, which won't
+       include files, like the Repoint-introduced external libraries,
+       that are not under version control with the main repo.
+
+       The process goes like this:
+
+       - Make sure we have a target filename from the user, and take
+         its basename as our archive directory name
+
+       - Make an "archive root" subdir of the project repo, named
+         typically .repoint-archive
+
+       - Identify the VCS used for the project repo. Note that any
+         explicit references to VCS type in this structure are to
+         the VCS used for the project (something Repoint doesn't
+         otherwise care about), not for an individual library
+
+       - Synthesise a Repoint project with the archive root as its
+         root path, "." as its extdir, with one library whose
+         name is the user-supplied basename and whose explicit
+         source URL is the original project root; update that
+         project -- thus cloning the original project to a subdir
+         of the archive root
+
+       - Synthesise a Repoint project identical to the original one for
+         this project, but with the newly-cloned copy as its root
+         path; update that project -- thus checking out clean copies
+         of the external library dirs
+
+       - Call out to an archive program to archive up the new copy,
+         running e.g.
+         tar cvzf project-release.tar.gz \
+             --exclude=.hg --exclude=.git project-release
+         in the archive root dir
+
+       - (We also omit the repoint-project.json file and any trace of
+         Repoint. It can't properly be run in a directory where the
+         external project folders already exist but their repo history
+         does not. End users shouldn't get to see Repoint)
+
+       - Clean up by deleting the new copy
+    *)
+
+    fun project_vcs_id_and_url dir =
+        let val context = {
+                rootpath = dir,
+                extdir = ".",
+                providers = [],
+                accounts = []
+            }
+            val vcs_maybe =
+                case [HgControl.exists context ".",
+                      GitControl.exists context ".",
+                      SvnControl.exists context "."] of
+                    [OK true, OK false, OK false] => OK HG
+                  | [OK false, OK true, OK false] => OK GIT
+                  | [OK false, OK false, OK true] => OK SVN
+                  | _ => ERROR ("Unable to identify VCS for directory " ^ dir)
+        in
+            case vcs_maybe of
+                ERROR e => ERROR e
+              | OK vcs =>
+                case (fn HG => HgControl.id_of
+                       | GIT => GitControl.id_of
+                       | SVN => SvnControl.id_of)
+                         vcs context "." of
+                    ERROR e => ERROR ("Unable to find id of project repo: " ^ e)
+                  | OK id =>
+                    case (fn HG => HgControl.copy_url_for
+                           | GIT => GitControl.copy_url_for
+                           | SVN => SvnControl.copy_url_for)
+                             vcs context "." of
+                        ERROR e => ERROR ("Unable to find URL of project repo: "
+                                          ^ e)
+                      | OK url => OK (vcs, id, url)
+        end
+
+    fun make_archive_root (context : context) =
+        let val path = OS.Path.joinDirFile {
+                    dir = #rootpath context,
+                    file = RepointFilenames.archive_dir
+                }
+        in
+            case FileBits.mkpath path of
+                ERROR e => raise Fail ("Failed to create archive directory \""
+                                       ^ path ^ "\": " ^ e)
+              | OK () => path
+        end
+
+    fun archive_path archive_dir target_name =
+        OS.Path.joinDirFile {
+            dir = archive_dir,
+            file = target_name
+        }
+
+    fun check_nonexistent path =
+        case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
+            NONE => ()
+          | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
+
+    fun make_archive_copy target_name (vcs, project_id, source_url)
+                          ({ context, ... } : project) =
+        let val archive_root = make_archive_root context
+            val synthetic_context = {
+                rootpath = archive_root,
+                extdir = ".",
+                providers = [],
+                accounts = []
+            }
+            val synthetic_library = {
+                libname = target_name,
+                vcs = vcs,
+                source = URL_SOURCE source_url,
+                branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
+                project_pin = PINNED project_id,
+                lock_pin = PINNED project_id
+            }
+            val path = archive_path archive_root target_name
+            val _ = print ("Cloning original project to " ^ path
+                           ^ " at revision " ^ project_id ^ "...\n");
+            val _ = check_nonexistent path
+        in
+            case AnyLibControl.update synthetic_context synthetic_library of
+                ERROR e => ERROR ("Failed to clone original project to "
+                                  ^ path ^ ": " ^ e)
+              | OK _ => OK archive_root
+        end
+
+    fun update_archive archive_root target_name
+                       (project as { context, ... } : project) =
+        let val synthetic_context = {
+                rootpath = archive_path archive_root target_name,
+                extdir = #extdir context,
+                providers = #providers context,
+                accounts = #accounts context
+            }
+        in
+            foldl (fn (lib, acc) =>
+                      case acc of
+                          ERROR e => ERROR e
+                        | OK () => AnyLibControl.update synthetic_context lib)
+                  (OK ())
+                  (#libs project)
+        end
+
+    datatype packer = TAR
+                    | TAR_GZ
+                    | TAR_BZ2
+                    | TAR_XZ
+    (* could add other packers, e.g. zip, if we knew how to
+       handle the file omissions etc properly in pack_archive *)
+
+    fun packer_and_basename path =
+        let val extensions = [ (".tar", TAR),
+                               (".tar.gz", TAR_GZ),
+                               (".tar.bz2", TAR_BZ2),
+                               (".tar.xz", TAR_XZ)]
+            val filename = OS.Path.file path
+        in
+            foldl (fn ((ext, packer), acc) =>
+                      if String.isSuffix ext filename
+                      then SOME (packer,
+                                 String.substring (filename, 0,
+                                                   String.size filename -
+                                                   String.size ext))
+                      else acc)
+                  NONE
+                  extensions
+        end
+
+    fun pack_archive archive_root target_name target_path packer exclusions =
+        case FileBits.command {
+                rootpath = archive_root,
+                extdir = ".",
+                providers = [],
+                accounts = []
+            } "" ([
+                     "tar",
+                     case packer of
+                         TAR => "cf"
+                       | TAR_GZ => "czf"
+                       | TAR_BZ2 => "cjf"
+                       | TAR_XZ => "cJf",
+                     target_path,
+                     "--exclude=.hg",
+                     "--exclude=.git",
+                     "--exclude=.svn",
+                     "--exclude=repoint",
+                     "--exclude=repoint.sml",
+                     "--exclude=repoint.ps1",
+                     "--exclude=repoint.bat",
+                     "--exclude=repoint-project.json",
+                     "--exclude=repoint-lock.json"
+                 ] @ (map (fn e => "--exclude=" ^ e) exclusions) @
+                  [ target_name ])
+         of
+            ERROR e => ERROR e
+          | OK _ => FileBits.rmpath (archive_path archive_root target_name)
+
+    fun archive (target_path, exclusions) (project : project) =
+        let val _ = check_nonexistent target_path
+            val (packer, name) =
+                case packer_and_basename target_path of
+                    NONE => raise Fail ("Unsupported archive file extension in "
+                                        ^ target_path)
+                  | SOME pn => pn
+            val details =
+                case project_vcs_id_and_url (#rootpath (#context project)) of
+                    ERROR e => raise Fail e
+                  | OK details => details
+            val archive_root =
+                case make_archive_copy name details project of
+                    ERROR e => raise Fail e
+                  | OK archive_root => archive_root
+            val outcome =
+                case update_archive archive_root name project of
+                    ERROR e => ERROR e
+                  | OK _ =>
+                    case pack_archive archive_root name
+                                      target_path packer exclusions of
+                        ERROR e => ERROR e
+                      | OK _ => OK ()
+        in
+            case outcome of
+                ERROR e => raise Fail e
+              | OK () => OS.Process.success
+        end
+
+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 project_pin = case retrieve ["pin"] of
+                              NONE => UNPINNED
+                            | SOME p => PINNED p
+        val lock_pin = case lookup_optional lock_json [libobjname, libname] of
+                           NONE => UNPINNED
+                         | SOME ll => case lookup_optional_string ll ["pin"] of
+                                          SOME p => PINNED p
+                                        | NONE => UNPINNED
+    in
+        {
+          libname = libname,
+          vcs = case vcs of
+                    "hg" => HG
+                  | "git" => GIT
+                  | "svn" => SVN
+                  | 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"),
+          project_pin = project_pin,
+          lock_pin = lock_pin,
+          branch = case branch of
+                       NONE => DEFAULT_BRANCH
+                     | SOME b =>
+                       case vcs of
+                           "svn" => raise Fail ("Branches not supported for " ^
+                                                "svn repositories; change " ^
+                                                "URL instead")
+                         | _ => BRANCH b
+        }
+    end
+
+fun load_userconfig () : userconfig =
+    let val home = FileBits.homedir ()
+        val conf_json =
+            JsonBits.load_json_from
+                (OS.Path.joinDirFile {
+                      dir = home,
+                      file = RepointFilenames.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 " ^
+                                 (RepointFilenames.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 = 28
+val libstate_width = 11
+val localstate_width = 17
+val notes_width = 5
+val divider = " | "
+val clear_line = "\r" ^ pad_to 80 "";
+
+fun print_status_header () =
+    print (clear_line ^ "\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 (clear_line ^ "\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 (lib : libspec, status) =
+    let val libstate_str =
+            case status of
+                OK (ABSENT, _) => "Absent"
+              | OK (CORRECT, _) => if with_network then "Correct" else "Present"
+              | OK (SUPERSEDED, _) => "Superseded"
+              | OK (WRONG, _) => "Wrong"
+              | ERROR _ => "Error"
+        val localstate_str =
+            case status of
+                OK (_, MODIFIED) => "Modified"
+              | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
+              | OK (_, CLEAN) => "Clean"
+              | ERROR _ => ""
+        val error_str =
+            case status of
+                ERROR e => e
+              | _ => ""
+    in
+        print (" " ^
+               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 (lib : libspec, outcome) =
+    let val outcome_str =
+            case outcome of
+                OK id => "Ok"
+              | ERROR e => "Failed"
+        val error_str =
+            case outcome of
+                ERROR e => e
+              | _ => ""
+    in
+        print (" " ^
+               pad_to libname_width (#libname lib) ^ divider ^
+               pad_to libstate_width outcome_str ^ divider ^
+               error_str ^ "\n")
+    end
+
+fun vcs_name HG = ("Mercurial", "hg")
+  | vcs_name GIT = ("Git", "git")
+  | vcs_name SVN = ("Subversion", "svn")
+
+fun print_problem_summary context lines =
+    let val failed_vcs =
+            foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc
+                  | (_, acc) => acc) [] lines
+        fun report_nonworking vcs error =
+            print ((if error = "" then "" else error ^ "\n\n") ^
+                   "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^
+                   " version control system, but its\n" ^
+                   "executable program (" ^ (#2 (vcs_name vcs)) ^
+                   ") does not appear to be installed in the program path\n\n")
+        fun check_working [] checked = ()
+          | check_working (vcs::rest) checked =
+            if List.exists (fn v => vcs = v) checked
+            then check_working rest checked
+            else
+                case AnyLibControl.is_working context vcs of
+                    OK true => check_working rest checked
+                  | OK false => (report_nonworking vcs "";
+                                 check_working rest (vcs::checked))
+                  | ERROR e => (report_nonworking vcs e;
+                                check_working rest (vcs::checked))
+    in
+        print "\nError: Some operations failed\n\n";
+        check_working failed_vcs []
+    end
+
+fun act_and_print action print_header print_line context (libs : libspec list) =
+    let val lines = map (fn lib => (lib, action lib)) libs
+        val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines
+        val _ = print_header ()
+    in
+        app print_line lines;
+        if imperfect then print_problem_summary context lines else ();
+        lines
+    end
+
+fun return_code_for outcomes =
+    foldl (fn ((_, result), acc) =>
+              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)
+                                   context libs)
+
+fun review_project ({ context, libs } : project) =
+    return_code_for (act_and_print (AnyLibControl.review context)
+                                   print_status_header (print_status true)
+                                   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 => (lib, AnyLibControl.id_of context lib))
+                           libs
+        val locks =
+            List.concat
+                (map (fn (lib : libspec, result) =>
+                         case result of
+                             ERROR _ => []
+                           | OK id => [{ libname = #libname lib,
+                                         id_or_tag = id }])
+                     outcomes)
+        val return_code = return_code_for outcomes
+        val _ = print clear_line
+    in
+        if OS.Process.isSuccess return_code
+        then save_lock_file (#rootpath context) locks
+        else ();
+        return_code
+    end
+
+fun update_project (project as { context, libs }) =
+    let val outcomes = act_and_print
+                           (AnyLibControl.update context)
+                           print_outcome_header print_update_outcome
+                           context libs
+        val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
+                then lock_project project
+                else OS.Process.success
+    in
+        return_code_for outcomes
+    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 open OS.Process
+      val return_code =
+          f (load_local_project pintype)
+          handle Fail msg =>
+                 failure before print ("Error: " ^ msg)
+               | JsonBits.Config msg =>
+                 failure before print ("Error in configuration: " ^ msg)
+               | e =>
+                 failure before print ("Error: " ^ exnMessage e)
+        val _ = print "\n";
+    in
+        return_code
+    end
+
+fun review () = with_local_project USE_LOCKFILE review_project
+fun status () = with_local_project USE_LOCKFILE status_of_project
+fun update () = with_local_project NO_LOCKFILE update_project
+fun lock () = with_local_project NO_LOCKFILE lock_project
+fun install () = with_local_project USE_LOCKFILE update_project
+
+fun version () =
+    (print ("v" ^ repoint_version ^ "\n");
+     OS.Process.success)
+
+fun usage () =
+    (print "\nRepoint ";
+     version ();
+     print ("\nA simple manager for third-party source code dependencies.\n\n"
+            ^ "Usage:\n\n"
+            ^ "  repoint <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"
+            ^ "  lock     update lock file to match local library status\n"
+            ^ "  archive  pack up project and all libraries into an archive file\n"
+            ^ "           (invoke as 'repoint archive target-file.tar.gz')\n"
+            ^ "  version  print the Repoint version number and exit\n\n");
+    OS.Process.failure)
+
+fun archive target args =
+    case args of
+        [] =>
+        with_local_project USE_LOCKFILE (Archive.archive (target, []))
+      | "--exclude"::xs =>
+        with_local_project USE_LOCKFILE (Archive.archive (target, xs))
+      | _ => usage ()
+
+fun repoint args =
+    let val return_code =
+            case args of
+                ["review"] => review ()
+              | ["status"] => status ()
+              | ["install"] => install ()
+              | ["update"] => update ()
+              | ["lock"] => lock ()
+              | ["version"] => version ()
+              | "archive"::target::args => archive target args
+              | arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n");
+                           usage ())
+              | _ => usage ()
+    in
+        OS.Process.exit return_code;
+        ()
+    end
+
+fun main () =
+    repoint (CommandLine.arguments ())
--- a/vext	Tue Jan 02 10:56:52 2018 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,148 +0,0 @@
-#!/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"
-
-hasher=
-local_install=
-if [ -w "$mydir" ]; then
-    if echo | sha256sum >/dev/null 2>&1 ; then
-	hasher=sha256sum
-        local_install=true
-    elif echo | shasum >/dev/null 2>&1 ; then
-	hasher=shasum
-	local_install=true
-    else
-        echo "WARNING: sha256sum or shasum program not found" 1>&2
-    fi
-fi
-
-if [ -n "$local_install" ]; then
-    hash=$(echo "$sml" | cat "$program" - | $hasher | cut -c1-16)
-    gen_sml=$mydir/.vext-$hash.sml
-    gen_out=$mydir/.vext-$hash.bin
-    trap 'rm -f $gen_sml' 0
-else
-    gen_sml=$(mktemp /tmp/vext-XXXXXXXX.sml)
-    gen_out=$(mktemp /tmp/vext-XXXXXXXX.bin)
-    trap 'rm -f $gen_sml $gen_out' 0
-fi
-
-if [ -x "$gen_out" ]; then
-    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.
-
-if [ -z "$sml" ]; then
-    if [ -n "$local_install" ] && mlton 2>&1 | grep -q 'MLton'; then
-	sml="mlton"
-    elif 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 1>&2 <<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
-
-arglist=""
-for arg in "$@"; do
-    if [ -n "$arglist" ]; then arglist="$arglist,"; fi
-    if echo "$arg" | grep -q '["'"'"']' ; then
-	arglist="$arglist\"usage\""
-    else
-	arglist="$arglist\"$arg\""
-    fi
-done
-
-case "$sml" in
-    poly)
-        if [ -n "$local_install" ] && polyc --help >/dev/null 2>&1 ; then
-            if [ ! -x "$gen_out" ]; then
-                polyc -o "$gen_out" "$program"
-            fi
-	    "$gen_out" "$@"
-        else
-            echo 'use "'"$program"'"; vext ['"$arglist"'];' |
-                poly -q --error-exit
-        fi ;;
-    mlton)
-        if [ ! -x "$gen_out" ]; then
-	    echo "[Precompiling Vext binary...]" 1>&2
-	    echo "val _ = main ()" | cat "$program" - > "$gen_sml"
-	    mlton -output "$gen_out" "$gen_sml"
-        fi
-	"$gen_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
-            ) > "$gen_sml"
-	CM_VERBOSE=false sml "$gen_sml" ;;
-    *)
-	echo "ERROR: Unknown SML implementation name: $sml" 1>&2;
-	exit 2 ;;
-esac
-
--- a/vext-lock.json	Tue Jan 02 10:56:52 2018 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-{
-  "libraries": {
-    "vamp-plugin-sdk": {
-      "pin": "5d9af3140f05"
-    },
-    "svcore": {
-      "pin": "a533662c17f4"
-    },
-    "piper-cpp": {
-      "pin": "85394095a5b04f99a0785ccd32a5a98c90d984b2"
-    },
-    "dataquay": {
-      "pin": "807b55408d9e"
-    },
-    "bqvec": {
-      "pin": "e345a5e32c53"
-    },
-    "bqfft": {
-      "pin": "81b50ec12d9a"
-    },
-    "bqresample": {
-      "pin": "39a30cdbb421"
-    },
-    "sv-dependency-builds": {
-      "pin": "a69c1527268d"
-    }
-  }
-}
--- a/vext-project.json	Tue Jan 02 10:56:52 2018 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,53 +0,0 @@
-{
-    "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"
-        },
-        "dataquay": {
-            "vcs": "hg",
-            "service": "bitbucket",
-            "owner": "breakfastquay"
-        },
-        "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"
-        }
-    }
-}
-
--- a/vext.bat	Tue Jan 02 10:56:52 2018 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-@echo off
-PowerShell -NoProfile -ExecutionPolicy Bypass -Command "& '%~dpn0.ps1' %*";
-
--- a/vext.ps1	Tue Jan 02 10:56:52 2018 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,113 +0,0 @@
-<#
-
-.SYNOPSIS
-A simple manager for third-party source code dependencies.
-Run "vext help" for more documentation.
-
-#>
-
-Set-StrictMode -Version 2.0
-$ErrorActionPreference = "Stop"
-
-$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 "sml" -ErrorAction SilentlyContinue) {
-       $sml = "smlnj"
-    } elseif (Get-Command "polyml" -ErrorAction SilentlyContinue) {
-       $sml = "poly"
-    } 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. Standard ML of New Jersey
-       - executable name: sml
-
-    2. Poly/ML
-       - executable name: polyml
-
-"@
-       exit 1
-    }
-}
-
-if ($args -match "'""") {
-    $arglist = '["usage"]'
-} else {
-    $arglist = '["' + ($args -join '","') + '"]'
-}
-
-if ($sml -eq "poly") {
-
-    $program = $program -replace "\\","\\\\"
-    echo "use ""$program""; vext $arglist" | polyml -q --error-exit | Out-Host
-
-    if (-not $?) {
-        exit $LastExitCode
-    }
-
-} 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
-
-    if (-not $?) {
-        del $tmpfile
-        exit $LastExitCode
-    }
-
-    del $tmpfile
-
-} else {
-
-    "Unknown SML implementation name: $sml"
-    exit 2
-}
--- a/vext.sml	Tue Jan 02 10:56:52 2018 +0000
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,2239 +0,0 @@
-(*
-    DO NOT EDIT THIS FILE.
-    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, Particular Programs Ltd,
-    and Queen Mary, University of London
-
-    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,
-    Particular Programs Ltd, and Queen Mary, University of London
-    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.92"
-
-
-datatype vcs =
-         HG |
-         GIT |
-         SVN
-
-datatype source =
-         URL_SOURCE of string |
-         SERVICE_SOURCE of {
-             service : string,
-             owner : string option,
-             repo : string option
-         }
-
-type id_or_tag = string
-
-datatype pin =
-         UNPINNED |
-         PINNED of id_or_tag
-
-datatype libstate =
-         ABSENT |
-         CORRECT |
-         SUPERSEDED |
-         WRONG
-
-datatype localstate =
-         MODIFIED |
-         LOCK_MISMATCHED |
-         CLEAN
-
-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 libspec = {
-    libname : libname,
-    vcs : vcs,
-    source : source,
-    branch : branch,
-    project_pin : pin,
-    lock_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"
-    val archive_dir = ".vext-archive"
-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 * source * 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. Assumes that a
-        local copy of the library already exists *)
-    val update : context -> libname * source * branch -> unit result
-
-    (** Update the library to the given specific id or tag *)
-    val update_to : context -> libname * source * id_or_tag -> unit result
-
-    (** Return a URL from which the library can be cloned, given that
-        the local copy already exists. For a DVCS this can be the
-        local copy, but for a centralised VCS it will have to be the
-        remote repository URL. Used for archiving *)
-    val copy_url_for : context -> libname -> string result
-end
-
-signature LIB_CONTROL = sig
-    val review : context -> libspec -> (libstate * localstate) result
-    val status : context -> libspec -> (libstate * localstate) result
-    val update : context -> libspec -> unit result
-    val id_of : context -> libspec -> id_or_tag result
-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_url : string -> string
-    val file_contents : string -> string
-    val mydir : unit -> string
-    val homedir : unit -> string
-    val mkpath : string -> unit result
-    val rmpath : string -> unit result
-    val nonempty_dir_exists : string -> bool
-    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 split_relative path desc =
-        case OS.Path.fromString path of
-            { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
-          | { arcs, ... } => arcs
-
-    fun extpath ({ rootpath, extdir, ... } : context) =
-        let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
-        in OS.Path.toString {
-                isAbs = isAbs,
-                vol = vol,
-                arcs = arcs @
-                       split_relative extdir "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
-        in OS.Path.toString {
-                isAbs = isAbs,
-                vol = vol,
-                arcs = arcs @
-                       split_relative extdir "extdir" @
-                       split_relative libname "library path" @
-                       split_relative remainder "subpath"
-            }
-        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_url path =
-        let val forward_path =
-                String.translate (fn #"\\" => "/" |
-                                  c => Char.toString c)
-                                 (OS.Path.mkCanonical path)
-        in
-            (* Path is expected to be absolute already, but if it
-               starts with a drive letter, we'll need an extra slash *)
-            case explode forward_path of
-                #"/"::rest => "file:///" ^ implode rest
-              | _ => "file:///" ^ forward_path
-        end
-
-    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
-            val _ = if verbose ()
-                    then print ("Output was:\n\"" ^ contents ^ "\"\n")
-                    else ()
-        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))
-
-    fun mkpath path =
-        mkpath' (OS.Path.mkCanonical path)
-
-    fun dir_contents dir =
-        let open OS
-            fun files_from dirstream =
-                case FileSys.readDir dirstream of
-                    NONE => []
-                  | SOME file =>
-                    (* readDir is supposed to filter these,
-                       but let's be extra cautious: *)
-                    if file = Path.parentArc orelse file = Path.currentArc
-                    then files_from dirstream
-                    else file :: files_from dirstream
-            val stream = FileSys.openDir dir
-            val files = map (fn f => Path.joinDirFile
-                                         { dir = dir, file = f })
-                            (files_from stream)
-            val _ = FileSys.closeDir stream
-        in
-            files
-        end
-
-    fun rmpath' path =
-        let open OS
-            fun remove path =
-                if FileSys.isLink path (* dangling links bother isDir *)
-                then FileSys.remove path
-                else if FileSys.isDir path
-                then (app remove (dir_contents path); FileSys.rmDir path)
-                else FileSys.remove path
-        in
-            (remove path; OK ())
-            handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
-        end
-
-    fun rmpath path =
-        rmpath' (OS.Path.mkCanonical path)
-
-    fun nonempty_dir_exists path =
-        let open OS.FileSys
-        in
-            (not (isLink path) andalso
-             isDir path andalso
-             dir_contents path <> [])
-            handle _ => false
-        end
-
-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, source, branch,
-                 project_pin, lock_pin, ... } : libspec) =
-        let fun check_unpinned () =
-                let val newest =
-                        if with_network
-                        then V.is_newest context (libname, source, branch)
-                        else V.is_newest_locally context (libname, branch)
-                in
-                    case newest 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_remote () =
-                case project_pin of
-                    UNPINNED => check_unpinned ()
-                  | PINNED target => check_pinned target
-            fun check_local () =
-                case V.is_modified_locally context libname of
-                    ERROR e => ERROR e
-                  | OK true  => OK MODIFIED
-                  | OK false =>
-                    case lock_pin of
-                        UNPINNED => OK CLEAN
-                      | PINNED target =>
-                        case V.is_at context (libname, target) of
-                            ERROR e => ERROR e
-                          | OK true => OK CLEAN
-                          | OK false => OK LOCK_MISMATCHED
-        in
-            case V.exists context libname of
-                ERROR e => ERROR e
-              | OK false => OK (ABSENT, CLEAN)
-              | OK true =>
-                case (check_remote (), check_local ()) of
-                    (ERROR e, _) => ERROR e
-                  | (_, ERROR e) => ERROR e
-                  | (OK r, OK l) => OK (r, l)
-        end
-
-    val review = check true
-    val status = check false
-
-    fun update context
-               ({ libname, source, branch,
-                  project_pin, lock_pin, ... } : libspec) =
-        let fun update_unpinned () =
-                case V.is_newest context (libname, source, branch) of
-                    ERROR e => ERROR e
-                  | OK true => OK ()
-                  | OK false => V.update context (libname, source, branch)
-            fun update_pinned target =
-                case V.is_at context (libname, target) of
-                    ERROR e => ERROR e
-                  | OK true => OK ()
-                  | OK false => V.update_to context (libname, source, target)
-            fun update' () =
-                case lock_pin of
-                    PINNED target => update_pinned target
-                  | UNPINNED =>
-                    case project_pin of
-                        PINNED target => update_pinned target
-                      | UNPINNED => update_unpinned ()
-        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
-
-    fun id_of context ({ libname, ... } : libspec) =
-        V.id_of context libname
-
-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 HG => "hg"
-                  | GIT => "git"
-                  | SVN => "svn"
-
-    fun vcs_from_name name =
-        case name of "hg" => HG
-                   | "git" => GIT
-                   | "svn" => SVN
-                   | 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 reponame_for path =
-        case String.tokens (fn c => c = #"/") path of
-            [] => raise Fail "Non-empty library path required"
-          | toks => hd (rev toks)
-
-    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 => reponame_for libname }
-                         (login_for context service)
-                         (#providers context)
-end
-
-structure HgControl :> VCS_CONTROL = struct
-
-    (* Pulls always use an explicit URL, never just the default
-       remote, in order to ensure we update properly if the location
-       given in the project file changes. *)
-
-    type vcsstate = { id: string, modified: bool,
-                      branch: string, tags: string list }
-
-    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)
-
-    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 => OK false (* desired branch does not exist *)
-          | OK newest_in_repo => is_at context (libname, newest_in_repo)
-
-    fun pull context (libname, source) =
-        let val url = remote_for context (libname, source)
-        in
-            hg_command context libname
-                       (if FileBits.verbose ()
-                        then ["pull", url]
-                        else ["pull", "-q", url])
-        end
-
-    fun is_newest context (libname, source, branch) =
-        case is_newest_locally context (libname, branch) of
-            ERROR e => ERROR e
-          | OK false => OK false
-          | OK true =>
-            case pull context (libname, source) 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
-            (* make the lib dir rather than just the ext dir, since
-               the lib dir might be nested and hg will happily check
-               out into an existing empty dir anyway *)
-            case FileBits.mkpath (FileBits.libpath context libname) of
-                ERROR e => ERROR e
-              | _ => hg_command context ""
-                                ["clone", "-u", branch_name branch,
-                                 url, libname]
-        end
-
-    fun update context (libname, source, branch) =
-        let val pull_result = pull context (libname, source)
-        in
-            case hg_command context libname ["update", branch_name branch] of
-                ERROR e => ERROR e
-              | _ =>
-                case pull_result of
-                    ERROR e => ERROR e
-                  | _ => OK ()
-        end
-
-    fun update_to context (libname, _, "") =
-        ERROR "Non-empty id (tag or revision id) required for update_to"
-      | update_to context (libname, source, id) =
-        let val pull_result = pull context (libname, source)
-        in
-            case hg_command context libname ["update", "-r", id] of
-                OK _ => OK ()
-              | ERROR e =>
-                case pull_result of
-                    ERROR e' => ERROR e' (* this was the ur-error *)
-                  | _ => ERROR e
-        end
-
-    fun copy_url_for context libname =
-        OK (FileBits.file_url (FileBits.libpath context libname))
-
-end
-
-structure GitControl :> VCS_CONTROL = struct
-
-    (* With Git repos we always operate in detached HEAD state. Even
-       the master branch is checked out using a remote reference
-       (vext/master). The remote we use is always named vext, and we
-       update it to the expected URL each time we fetch, in order to
-       ensure we update properly if the location given in the project
-       file changes. The origin remote is unused. *)
-
-    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
-
-    val our_remote = "vext"
-
-    fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
-
-    fun checkout context (libname, source, branch) =
-        let val url = remote_for context (libname, source)
-        in
-            (* make the lib dir rather than just the ext dir, since
-               the lib dir might be nested and git will happily check
-               out into an existing empty dir anyway *)
-            case FileBits.mkpath (FileBits.libpath context libname) of
-                OK () => git_command context ""
-                                     ["clone", "--origin", our_remote,
-                                      "--branch", branch_name branch,
-                                      url, libname]
-              | ERROR e => ERROR e
-        end
-
-    fun add_our_remote context (libname, source) =
-        (* When we do the checkout ourselves (above), we add the
-           remote at the same time. But if the repo was cloned by
-           someone else, we'll need to do it after the fact. Git
-           doesn't seem to have a means to add a remote or change its
-           url if it already exists; seems we have to do this: *)
-        let val url = remote_for context (libname, source)
-        in
-            case git_command context libname
-                             ["remote", "set-url", our_remote, url] of
-                OK () => OK ()
-              | ERROR e => git_command context libname
-                                       ["remote", "add", "-f", our_remote, url]
-        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 => OK false (* HEAD nonexistent, expected in empty repo *)
-          | 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) =
-        (* We don't have access to the source info or the network
-           here, as this is used by status (e.g. via is_on_branch) as
-           well as review. It's possible the remote branch won't exist,
-           e.g. if the repo was checked out by something other than
-           Vext, and if that's the case, we can't add it here; we'll
-           just have to fail, since checking against local branches
-           instead could produce the wrong result. *)
-        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 => OK false
-          | OK rev => is_at context (libname, rev)
-
-    fun is_on_branch context (libname, branch) =
-        case branch_tip context (libname, branch) of
-            ERROR e => OK false
-          | 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 fetch context (libname, source) =
-        case add_our_remote context (libname, source) of
-            ERROR e => ERROR e
-          | _ => git_command context libname ["fetch", our_remote]
-
-    fun is_newest context (libname, source, branch) =
-        case add_our_remote context (libname, source) of
-            ERROR e => ERROR e
-          | OK () =>
-            case is_newest_locally context (libname, branch) of
-                ERROR e => ERROR e
-              | OK false => OK false
-              | OK true =>
-                case fetch context (libname, source) 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, source, branch) =
-        case fetch context (libname, source) of
-            ERROR e => ERROR e
-          | _ =>
-            case git_command context libname ["checkout", "--detach",
-                                              remote_branch_name branch] of
-                ERROR e => ERROR e
-              | _ => OK ()
-
-    (* 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, source, id) =
-        let val fetch_result = fetch context (libname, source)
-        in
-            case git_command context libname ["checkout", "--detach", id] of
-                OK _ => OK ()
-              | ERROR e =>
-                case fetch_result of
-                    ERROR e' => ERROR e' (* this was the ur-error *)
-                  | _ => ERROR e
-        end
-
-    fun copy_url_for context libname =
-        OK (FileBits.file_url (FileBits.libpath context libname))
-
-end
-
-structure SvnControl :> VCS_CONTROL = struct
-
-    fun svn_command context libname args =
-        FileBits.command context libname ("svn" :: args)
-
-    fun svn_command_output context libname args =
-        FileBits.command_output context libname ("svn" :: args)
-
-    fun svn_command_lines context libname args =
-        case svn_command_output context libname args of
-            ERROR e => ERROR e
-          | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s)
-
-    fun split_line_pair line =
-        let fun strip_leading_ws str = case explode str of
-                                           #" "::rest => implode rest
-                                         | _ => str
-        in
-            case String.tokens (fn c => c = #":") line of
-                [] => ("", "")
-              | first::rest =>
-                (first, strip_leading_ws (String.concatWith ":" rest))
-        end
-
-    fun svn_info_item context libname key =
-        (* SVN 1.9 has info --show-item which is what we need, but at
-           this point we still have 1.8 on the CI boxes so we might as
-           well aim to support it *)
-        case svn_command_lines context libname ["info"] of
-            ERROR e => ERROR e
-          | OK lines =>
-            case List.find (fn (k, v) => k = key) (map split_line_pair lines) of
-                NONE => ERROR ("Key \"" ^ key ^ "\" not found in output")
-              | SOME (_, v) => OK v
-
-    fun exists context libname =
-        OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn"))
-        handle _ => OK false
-
-    fun remote_for context (libname, source) =
-        Provider.remote_url context SVN source libname
-
-    fun id_of context libname =
-        svn_info_item context libname "Revision" (*!!! check: does svn localise this? should we ensure C locale? *)
-
-    fun is_at context (libname, id_or_tag) =
-        case id_of context libname of
-            ERROR e => ERROR e
-          | OK id => OK (id = id_or_tag)
-
-    fun is_on_branch context (libname, b) =
-        OK (b = DEFAULT_BRANCH)
-
-    fun is_newest context (libname, source, branch) =
-        case svn_command_lines context libname ["status", "--show-updates"] of
-            ERROR e => ERROR e
-          | OK lines =>
-            case rev lines of
-                [] => ERROR "No result returned for server status"
-              | last_line::_ =>
-                case rev (String.tokens (fn c => c = #" ") last_line) of
-                    [] => ERROR "No revision field found in server status"
-                  | server_id::_ => is_at context (libname, server_id)
-
-    fun is_newest_locally context (libname, branch) =
-        OK true (* no local history *)
-
-    fun is_modified_locally context libname =
-        case svn_command_output context libname ["status"] of
-            ERROR e => ERROR e
-          | OK "" => OK false
-          | OK _ => OK true
-
-    fun checkout context (libname, source, branch) =
-        let val url = remote_for context (libname, source)
-            val path = FileBits.libpath context libname
-        in
-            if FileBits.nonempty_dir_exists path
-            then (* Surprisingly, SVN itself has no problem with
-                    this. But for consistency with other VCSes we
-                    don't allow it *)
-                ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"")
-            else
-                (* make the lib dir rather than just the ext dir, since
-                   the lib dir might be nested and svn will happily check
-                   out into an existing empty dir anyway *)
-                case FileBits.mkpath (FileBits.libpath context libname) of
-                    ERROR e => ERROR e
-                  | _ => svn_command context "" ["checkout", url, libname]
-        end
-
-    fun update context (libname, source, branch) =
-        case svn_command context libname
-                         ["update", "--accept", "postpone"] of
-            ERROR e => ERROR e
-          | _ => OK ()
-
-    fun update_to context (libname, _, "") =
-        ERROR "Non-empty id (tag or revision id) required for update_to"
-      | update_to context (libname, source, id) =
-        case svn_command context libname
-                         ["update", "-r", id, "--accept", "postpone"] of
-            ERROR e => ERROR e
-          | OK _ => OK ()
-
-    fun copy_url_for context libname =
-        svn_info_item context libname "URL"
-
-end
-
-structure AnyLibControl :> LIB_CONTROL = struct
-
-    structure H = LibControlFn(HgControl)
-    structure G = LibControlFn(GitControl)
-    structure S = LibControlFn(SvnControl)
-
-    fun review context (spec as { vcs, ... } : libspec) =
-        (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec
-
-    fun status context (spec as { vcs, ... } : libspec) =
-        (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec
-
-    fun update context (spec as { vcs, ... } : libspec) =
-        (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec
-
-    fun id_of context (spec as { vcs, ... } : libspec) =
-        (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec
-
-end
-
-
-type exclusions = string list
-
-structure Archive :> sig
-
-    val archive : string * exclusions -> project -> OS.Process.status
-
-end = struct
-
-    (* The idea of "archive" is to replace hg/git archive, which won't
-       include files, like the Vext-introduced external libraries,
-       that are not under version control with the main repo.
-
-       The process goes like this:
-
-       - Make sure we have a target filename from the user, and take
-         its basename as our archive directory name
-
-       - Make an "archive root" subdir of the project repo, named
-         typically .vext-archive
-
-       - Identify the VCS used for the project repo. Note that any
-         explicit references to VCS type in this structure are to
-         the VCS used for the project (something Vext doesn't
-         otherwise care about), not for an individual library
-
-       - Synthesise a Vext project with the archive root as its
-         root path, "." as its extdir, with one library whose
-         name is the user-supplied basename and whose explicit
-         source URL is the original project root; update that
-         project -- thus cloning the original project to a subdir
-         of the archive root
-
-       - Synthesise a Vext project identical to the original one for
-         this project, but with the newly-cloned copy as its root
-         path; update that project -- thus checking out clean copies
-         of the external library dirs
-
-       - Call out to an archive program to archive up the new copy,
-         running e.g.
-         tar cvzf project-release.tar.gz \
-             --exclude=.hg --exclude=.git project-release
-         in the archive root dir
-
-       - (We also omit the vext-project.json file and any trace of
-         Vext. It can't properly be run in a directory where the
-         external project folders already exist but their repo history
-         does not. End users shouldn't get to see Vext)
-
-       - Clean up by deleting the new copy
-    *)
-
-    fun project_vcs_id_and_url dir =
-        let val context = {
-                rootpath = dir,
-                extdir = ".",
-                providers = [],
-                accounts = []
-            }
-            val vcs_maybe =
-                case [HgControl.exists context ".",
-                      GitControl.exists context ".",
-                      SvnControl.exists context "."] of
-                    [OK true, OK false, OK false] => OK HG
-                  | [OK false, OK true, OK false] => OK GIT
-                  | [OK false, OK false, OK true] => OK SVN
-                  | _ => ERROR ("Unable to identify VCS for directory " ^ dir)
-        in
-            case vcs_maybe of
-                ERROR e => ERROR e
-              | OK vcs =>
-                case (fn HG => HgControl.id_of
-                       | GIT => GitControl.id_of
-                       | SVN => SvnControl.id_of)
-                         vcs context "." of
-                    ERROR e => ERROR ("Unable to find id of project repo: " ^ e)
-                  | OK id =>
-                    case (fn HG => HgControl.copy_url_for
-                           | GIT => GitControl.copy_url_for
-                           | SVN => SvnControl.copy_url_for)
-                             vcs context "." of
-                        ERROR e => ERROR ("Unable to find URL of project repo: "
-                                          ^ e)
-                      | OK url => OK (vcs, id, url)
-        end
-
-    fun make_archive_root (context : context) =
-        let val path = OS.Path.joinDirFile {
-                    dir = #rootpath context,
-                    file = VextFilenames.archive_dir
-                }
-        in
-            case FileBits.mkpath path of
-                ERROR e => raise Fail ("Failed to create archive directory \""
-                                       ^ path ^ "\": " ^ e)
-              | OK () => path
-        end
-
-    fun archive_path archive_dir target_name =
-        OS.Path.joinDirFile {
-            dir = archive_dir,
-            file = target_name
-        }
-
-    fun check_nonexistent path =
-        case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
-            NONE => ()
-          | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
-
-    fun make_archive_copy target_name (vcs, project_id, source_url)
-                          ({ context, ... } : project) =
-        let val archive_root = make_archive_root context
-            val synthetic_context = {
-                rootpath = archive_root,
-                extdir = ".",
-                providers = [],
-                accounts = []
-            }
-            val synthetic_library = {
-                libname = target_name,
-                vcs = vcs,
-                source = URL_SOURCE source_url,
-                branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
-                project_pin = PINNED project_id,
-                lock_pin = PINNED project_id
-            }
-            val path = archive_path archive_root target_name
-            val _ = print ("Cloning original project to " ^ path
-                           ^ " at revision " ^ project_id ^ "...\n");
-            val _ = check_nonexistent path
-        in
-            case AnyLibControl.update synthetic_context synthetic_library of
-                ERROR e => ERROR ("Failed to clone original project to "
-                                  ^ path ^ ": " ^ e)
-              | OK _ => OK archive_root
-        end
-
-    fun update_archive archive_root target_name
-                       (project as { context, ... } : project) =
-        let val synthetic_context = {
-                rootpath = archive_path archive_root target_name,
-                extdir = #extdir context,
-                providers = #providers context,
-                accounts = #accounts context
-            }
-        in
-            foldl (fn (lib, acc) =>
-                      case acc of
-                          ERROR e => ERROR e
-                        | OK () => AnyLibControl.update synthetic_context lib)
-                  (OK ())
-                  (#libs project)
-        end
-
-    datatype packer = TAR
-                    | TAR_GZ
-                    | TAR_BZ2
-                    | TAR_XZ
-    (* could add other packers, e.g. zip, if we knew how to
-       handle the file omissions etc properly in pack_archive *)
-
-    fun packer_and_basename path =
-        let val extensions = [ (".tar", TAR),
-                               (".tar.gz", TAR_GZ),
-                               (".tar.bz2", TAR_BZ2),
-                               (".tar.xz", TAR_XZ)]
-            val filename = OS.Path.file path
-        in
-            foldl (fn ((ext, packer), acc) =>
-                      if String.isSuffix ext filename
-                      then SOME (packer,
-                                 String.substring (filename, 0,
-                                                   String.size filename -
-                                                   String.size ext))
-                      else acc)
-                  NONE
-                  extensions
-        end
-
-    fun pack_archive archive_root target_name target_path packer exclusions =
-        case FileBits.command {
-                rootpath = archive_root,
-                extdir = ".",
-                providers = [],
-                accounts = []
-            } "" ([
-                     "tar",
-                     case packer of
-                         TAR => "cf"
-                       | TAR_GZ => "czf"
-                       | TAR_BZ2 => "cjf"
-                       | TAR_XZ => "cJf",
-                     target_path,
-                     "--exclude=.hg",
-                     "--exclude=.git",
-                     "--exclude=.svn",
-                     "--exclude=vext",
-                     "--exclude=vext.sml",
-                     "--exclude=vext.ps1",
-                     "--exclude=vext.bat",
-                     "--exclude=vext-project.json",
-                     "--exclude=vext-lock.json"
-                 ] @ (map (fn e => "--exclude=" ^ e) exclusions) @
-                  [ target_name ])
-         of
-            ERROR e => ERROR e
-          | OK _ => FileBits.rmpath (archive_path archive_root target_name)
-
-    fun archive (target_path, exclusions) (project : project) =
-        let val _ = check_nonexistent target_path
-            val (packer, name) =
-                case packer_and_basename target_path of
-                    NONE => raise Fail ("Unsupported archive file extension in "
-                                        ^ target_path)
-                  | SOME pn => pn
-            val details =
-                case project_vcs_id_and_url (#rootpath (#context project)) of
-                    ERROR e => raise Fail e
-                  | OK details => details
-            val archive_root =
-                case make_archive_copy name details project of
-                    ERROR e => raise Fail e
-                  | OK archive_root => archive_root
-            val outcome =
-                case update_archive archive_root name project of
-                    ERROR e => ERROR e
-                  | OK _ =>
-                    case pack_archive archive_root name
-                                      target_path packer exclusions of
-                        ERROR e => ERROR e
-                      | OK _ => OK ()
-        in
-            case outcome of
-                ERROR e => raise Fail e
-              | OK () => OS.Process.success
-        end
-
-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 project_pin = case retrieve ["pin"] of
-                              NONE => UNPINNED
-                            | SOME p => PINNED p
-        val lock_pin = case lookup_optional lock_json [libobjname, libname] of
-                           NONE => UNPINNED
-                         | SOME ll => case lookup_optional_string ll ["pin"] of
-                                          SOME p => PINNED p
-                                        | NONE => UNPINNED
-    in
-        {
-          libname = libname,
-          vcs = case vcs of
-                    "hg" => HG
-                  | "git" => GIT
-                  | "svn" => SVN
-                  | 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"),
-          project_pin = project_pin,
-          lock_pin = lock_pin,
-          branch = case branch of
-                       NONE => DEFAULT_BRANCH
-                     | SOME b =>
-                       case vcs of
-                           "svn" => raise Fail ("Branches not supported for " ^
-                                                "svn repositories; change " ^
-                                                "URL instead")
-                         | _ => BRANCH b
-        }
-    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 = 17
-val notes_width = 5
-val divider = " | "
-val clear_line = "\r" ^ pad_to 80 "";
-
-fun print_status_header () =
-    print (clear_line ^ "\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 (clear_line ^ "\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 (_, LOCK_MISMATCHED) => "Differs from Lock"
-              | OK (_, CLEAN) => "Clean"
-              | ERROR _ => ""
-        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 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))
-                           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
-        val _ = print clear_line
-    in
-        if OS.Process.isSuccess return_code
-        then save_lock_file (#rootpath context) locks
-        else ();
-        return_code
-    end
-
-fun update_project (project as { context, libs }) =
-    let val outcomes = act_and_print
-                           (AnyLibControl.update context)
-                           print_outcome_header print_update_outcome libs
-        val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
-                then lock_project project
-                else OS.Process.success
-    in
-        return_code_for outcomes
-    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 ("Error: " ^ exnMessage e);
-                                       OS.Process.failure)
-        val _ = print "\n";
-    in
-        return_code
-    end
-
-fun review () = with_local_project USE_LOCKFILE review_project
-fun status () = with_local_project USE_LOCKFILE status_of_project
-fun update () = with_local_project NO_LOCKFILE update_project
-fun lock () = with_local_project NO_LOCKFILE lock_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"
-            ^ "  lock     update lock file to match local library status\n"
-            ^ "  archive  pack up project and all libraries into an archive file\n"
-            ^ "           (invoke as 'vext archive target-file.tar.gz')\n"
-            ^ "  version  print the Vext version number and exit\n\n");
-    OS.Process.failure)
-
-fun archive target args =
-    case args of
-        [] =>
-        with_local_project USE_LOCKFILE (Archive.archive (target, []))
-      | "--exclude"::xs =>
-        with_local_project USE_LOCKFILE (Archive.archive (target, xs))
-      | _ => usage ()
-
-fun vext args =
-    let val return_code =
-            case args of
-                ["review"] => review ()
-              | ["status"] => status ()
-              | ["install"] => install ()
-              | ["update"] => update ()
-              | ["lock"] => lock ()
-              | ["version"] => version ()
-              | "archive"::target::args => archive target args
-              | _ => usage ()
-    in
-        OS.Process.exit return_code;
-        ()
-    end
-
-fun main () =
-    vext (CommandLine.arguments ())