e945fe2d9503 — Chris Cannam 4 years ago
Add initial cut of code, which compiles but does nothing else yet
13 files changed, 4370 insertions(+), 0 deletions(-)

A => .hgignore
A => example.pro
A => repoint
A => repoint-lock.json
A => repoint-project.json
A => repoint.bat
A => repoint.ps1
A => repoint.sml
A => src/Interface.cpp
A => src/Interface.h
A => src/Processor.cpp
A => src/Processor.h
A => src/main.cpp
A => .hgignore +9 -0
@@ 0,0 1,9 @@ 
+syntax: glob
+.repoint*
+*.o
+moc_*
+*~
+.qmake.stash
+Example
+Makefile
+ext

          
A => example.pro +93 -0
@@ 0,0 1,93 @@ 
+
+TEMPLATE = app
+
+QT += gui widgets
+
+CONFIG += release c++11 object_parallel_to_source
+
+TARGET = "Example"
+
+DEFINES += USE_SPEEX USE_KISSFFT HAVE_PORTAUDIO
+
+LIBS += -lportaudio
+
+INCLUDEPATH += \
+        ext/rubberband \
+        ext/rubberband/src \
+        ext/bqresample \
+        ext/bqvec \
+        ext/bqvec/bqvec \
+        ext/bqaudioio \
+        ext/bqaudioio/bqaudioio \
+        ext/bqaudiostream \
+        ext/bqaudiostream/bqaudiostream \
+        ext/bqthingfactory
+        
+RB_SOURCES += \
+      	ext/rubberband/src/RubberBandStretcher.cpp \
+	ext/rubberband/src/StretcherProcess.cpp \
+	ext/rubberband/src/StretchCalculator.cpp \
+	ext/rubberband/src/base/Profiler.cpp \
+	ext/rubberband/src/dsp/AudioCurveCalculator.cpp \
+	ext/rubberband/src/audiocurves/CompoundAudioCurve.cpp \
+	ext/rubberband/src/audiocurves/SpectralDifferenceAudioCurve.cpp \
+	ext/rubberband/src/audiocurves/HighFrequencyAudioCurve.cpp \
+	ext/rubberband/src/audiocurves/SilentAudioCurve.cpp \
+	ext/rubberband/src/audiocurves/ConstantAudioCurve.cpp \
+	ext/rubberband/src/audiocurves/PercussiveAudioCurve.cpp \
+	ext/rubberband/src/dsp/Resampler.cpp \
+	ext/rubberband/src/dsp/FFT.cpp \
+	ext/rubberband/src/system/Allocators.cpp \
+	ext/rubberband/src/system/sysutils.cpp \
+	ext/rubberband/src/system/Thread.cpp \
+	ext/rubberband/src/StretcherChannelData.cpp \
+	ext/rubberband/src/StretcherImpl.cpp \
+	ext/rubberband/src/speex/resample.c \
+	ext/rubberband/src/kissfft/kiss_fft.c \
+	ext/rubberband/src/kissfft/kiss_fftr.c
+
+BQ_SOURCES += \
+	ext/bqvec/src/Allocators.cpp \
+	ext/bqvec/src/Barrier.cpp \
+	ext/bqvec/src/VectorOpsComplex.cpp \
+	ext/bqresample/src/Resampler.cpp \
+	ext/bqresample/speex/resample.c \
+	ext/bqaudioio/src/AudioFactory.cpp \
+	ext/bqaudioio/src/JACKAudioIO.cpp \
+	ext/bqaudioio/src/Log.cpp \
+	ext/bqaudioio/src/PortAudioIO.cpp \
+	ext/bqaudioio/src/PulseAudioIO.cpp \
+	ext/bqaudioio/src/ResamplerWrapper.cpp \
+	ext/bqaudioio/src/SystemPlaybackTarget.cpp \
+	ext/bqaudioio/src/SystemRecordSource.cpp \
+        ext/bqaudiostream/src/AudioReadStream.cpp \
+        ext/bqaudiostream/src/AudioReadStreamFactory.cpp \
+        ext/bqaudiostream/src/AudioStreamExceptions.cpp
+        
+win32-msvc* {
+    DEFINES += HAVE_MEDIAFOUNDATION _USE_MATH_DEFINES
+    LIBS += -lmfplat -lmfreadwrite -lmfuuid -lpropsys -ladvapi32 -lwinmm -lws2_32
+}
+
+macx* {
+    DEFINES += HAVE_COREAUDIO HAVE_VDSP USE_PTHREADS
+    LIBS += -framework CoreAudio -framework CoreMidi -framework AudioUnit -framework AudioToolbox -framework CoreFoundation -framework CoreServices -framework Accelerate
+}
+
+linux* {
+    DEFINES += HAVE_SNDFILE USE_PTHREADS
+    LIBS += -lsndfile
+}
+
+for (file, BQ_SOURCES)       { SOURCES += $$file }
+for (file, RB_SOURCES)       { SOURCES += $$file }
+
+HEADERS += \
+        src/Interface.h \
+        src/Processor.h
+
+SOURCES += \
+        src/Interface.cpp \
+        src/Processor.cpp \
+        src/main.cpp
+        

          
A => repoint +166 -0
@@ 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="polyml"
+    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
+    polyml)
+        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
+       

          
A => repoint-lock.json +22 -0
@@ 0,0 1,22 @@ 
+{
+  "libraries": {
+    "rubberband": {
+      "pin": "e553918012b8"
+    },
+    "bqvec": {
+      "pin": "cd235ecbeb31"
+    },
+    "bqresample": {
+      "pin": "c2fb51b31fe4"
+    },
+    "bqaudioio": {
+      "pin": "9f275ac85af1"
+    },
+    "bqaudiostream": {
+      "pin": "a0926b93e771"
+    },
+    "bqthingfactory": {
+      "pin": "7686116dcdd5"
+    }
+  }
+}

          
A => repoint-project.json +38 -0
@@ 0,0 1,38 @@ 
+{
+    "config": {
+        "extdir": "ext"
+    },
+    "libraries": {
+        "rubberband": {
+            "vcs": "hg",
+            "service": "sourcehut",
+            "owner": "breakfastquay"
+        },
+        "bqvec": {
+            "vcs": "hg",
+            "service": "sourcehut",
+            "owner": "breakfastquay"
+        },
+        "bqresample": {
+            "vcs": "hg",
+            "service": "sourcehut",
+            "owner": "breakfastquay"
+        },
+        "bqaudioio": {
+            "vcs": "hg",
+            "service": "sourcehut",
+            "owner": "breakfastquay"
+        },
+        "bqaudiostream": {
+            "vcs": "hg",
+            "service": "sourcehut",
+            "owner": "breakfastquay"
+        },
+        "bqthingfactory": {
+            "vcs": "hg",
+            "service": "sourcehut",
+            "owner": "breakfastquay"
+        }
+    }
+}
+

          
A => repoint.bat +3 -0
@@ 0,0 1,3 @@ 
+@echo off
+PowerShell -NoProfile -ExecutionPolicy Bypass -Command "& '%~dpn0.ps1' %*";
+

          
A => repoint.ps1 +117 -0
@@ 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
+}

          
A => repoint.sml +2726 -0
@@ 0,0 1,2726 @@ 
+(*
+    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 = "1.2"
+
+
+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 project_completion_file = ".repoint.point"
+    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 project_completion_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 project_completion_path rootpath =
+        project_file_path rootpath (RepointFilenames.project_completion_file)
+
+    fun trim str =
+        hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
+
+    fun make_canonical path =
+        (* SML/NJ doesn't properly handle "/" when splitting paths -
+           it should be a path separator even on Windows, but SML/NJ
+           treats it as a normal filename character there. So we must
+           convert these explicitly *)
+        OS.Path.mkCanonical
+            (if OS.Path.concat ("a", "b") = "a\\b"
+             then String.translate (fn #"/" => "\\" |
+                                    c => Char.toString c)
+                                   path
+             else path)
+            
+    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' (make_canonical 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' (make_canonical 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}"
+            }
+          },
+          { service = "sourcehut",
+            supports = [HG, GIT],
+            remote_spec = {
+                anon = SOME "https://{vcs}.sr.ht/%7E{owner}/{repository}",
+                auth = SOME "ssh://{vcs}@{vcs}.sr.ht/%7E{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 checkpoint_completion_file rootpath =
+    let val completion_file = FileBits.project_completion_path rootpath
+        val stream = TextIO.openOut completion_file
+    in
+        TextIO.closeOut stream
+    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
+        val return_code = return_code_for outcomes
+    in
+        if OS.Process.isSuccess return_code
+        then checkpoint_completion_file (#rootpath context)
+        else ();
+        return_code
+    end
+    
+fun load_local_project pintype =
+    let val userconfig = load_userconfig ()
+        val rootpath = OS.FileSys.getDir ()
+    in
+        load_project userconfig rootpath pintype
+    end    
+
+fun with_local_project pintype f =
+  let 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 ("\n  A simple manager for third-party source code dependencies.\n"
+            ^ "  http://all-day-breakfast.com/repoint/\n\n"
+            ^ "Usage:\n\n"
+            ^ "  repoint <command> [<options>]\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     rewrite lock file to match local library status\n"
+            ^ "  archive  pack up project and all libraries into an archive file:\n"
+            ^ "           invoke as 'repoint archive targetfile.tar.gz --exclude unwanted.txt'\n"
+            ^ "  version  print the Repoint version number and exit\n\n"
+            ^ "and <options> may include:\n\n"
+            ^ "  --directory <dir>\n"
+            ^ "           change to directory <dir> before doing anything; in particular,\n"
+            ^ "           expect to find project spec file in that directory\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 handleSystemArgs args =
+    let fun handleSystemArgs' leftover args =
+            case args of
+                "--directory"::dir::rest =>
+                (OS.FileSys.chDir dir;
+                 handleSystemArgs' leftover rest)
+              | arg::rest =>
+                handleSystemArgs' (leftover @ [arg]) rest
+              | [] => leftover
+    in
+        OK (handleSystemArgs' [] args)
+        handle e => ERROR (exnMessage e)
+    end
+                   
+fun repoint args =
+    case handleSystemArgs args of
+        ERROR e => (print ("Error: " ^ e ^ "\n");
+                    OS.Process.exit OS.Process.failure)
+      | OK 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 => src/Interface.cpp +94 -0
@@ 0,0 1,94 @@ 
+/* -*- c-basic-offset: 4 indent-tabs-mode: nil -*-  vi:set ts=8 sts=4 sw=4: */
+
+/* Copyright 2020 Particular Programs Ltd. All Rights Reserved. */
+
+#include "Interface.h"
+#include "Processor.h"
+
+#include <QFileDialog>
+#include <QMessageBox>
+
+#include <bqaudiostream/AudioReadStreamFactory.h>
+
+using namespace std;
+
+Interface::Interface(Processor *p, QWidget *parent) :
+    QMainWindow(parent),
+    m_processor(p)
+{
+}
+
+Interface::~Interface()
+{
+}
+
+void
+Interface::open()
+{
+    auto extensions =
+        breakfastquay::AudioReadStreamFactory().getSupportedFileExtensions();
+    QStringList exts;
+    for (auto e: extensions) exts.push_back(QString::fromUtf8(e.c_str()));
+    QString extStr = exts.join(" *.");
+
+    QString filename = QFileDialog::getOpenFileName
+        (this, tr("Select audio file to open"), {},
+         QString("Audio files (*.%1)\nAll files (*.*)").arg(extStr));
+
+    if (filename == "") {
+        return;
+    }
+
+    open(filename);
+}
+
+void
+Interface::open(QString filename)
+{
+    try {
+        m_processor->open(filename);
+    } catch (const exception &f) {
+        QMessageBox::critical
+            (this, tr("Failed to open file"),
+             tr("Could not open audio file \"%1\": %2")
+             .arg(filename).arg(QString::fromUtf8(f.what())));
+    }
+}
+
+void
+Interface::play()
+{
+    m_processor->play();
+}
+
+void
+Interface::pause()
+{
+    m_processor->pause();
+}
+
+void
+Interface::rewind()
+{
+    m_processor->rewind();
+}
+/*
+void
+Interface::speedUp()
+{
+    int v = m_speed->value();
+    v = (v/2) * 2 + 2; // target is always even
+    m_speed->setValue(v);
+    speedChange(m_speed->value());
+}
+
+void
+Interface::slowDown()
+{
+    int v = m_speed->value();
+    v = (v/2) * 2 - 2; // target is always even
+    m_speed->setValue(v);
+    speedChange(m_speed->value());
+}
+*/
+

          
A => src/Interface.h +43 -0
@@ 0,0 1,43 @@ 
+/* -*- c-basic-offset: 4 indent-tabs-mode: nil -*-  vi:set ts=8 sts=4 sw=4: */
+
+/* Copyright 2020 Particular Programs Ltd. All Rights Reserved. */
+
+#ifndef EXAMPLE_INTERFACE_H
+#define EXAMPLE_INTERFACE_H
+
+#include <QString>
+#include <QDialog>
+#include <QFrame>
+#include <QLabel>
+#include <QApplication>
+#include <QDoubleSpinBox>
+#include <QPushButton>
+#include <QMainWindow>
+
+class Processor;
+
+class Interface : public QMainWindow
+{
+    Q_OBJECT
+
+public:
+    Interface(Processor *p, QWidget *parent = 0);
+    virtual ~Interface();
+
+    void open(QString);
+
+protected slots:
+    void open();
+    void play();
+    void pause();
+    void rewind();
+//    void speedUp();
+//    void slowDown();
+    
+private:
+    Processor *m_processor;
+    QDoubleSpinBox *m_speedSpin;
+};
+
+
+#endif

          
A => src/Processor.cpp +807 -0
@@ 0,0 1,807 @@ 
+/* -*- c-basic-offset: 4 indent-tabs-mode: nil -*-  vi:set ts=8 sts=4 sw=4: */
+
+/* Copyright 2020 Particular Programs Ltd. All Rights Reserved. */
+
+#include "Processor.h"
+
+#include <bqaudiostream/AudioReadStreamFactory.h>
+#include <bqaudiostream/AudioWriteStreamFactory.h>
+#include <bqaudiostream/AudioReadStream.h>
+#include <bqaudiostream/AudioWriteStream.h>
+#include <bqvec/Allocators.h>
+
+#include <rubberband/RubberBandStretcher.h>
+
+#include <QSettings>
+#include <QFileInfo>
+#include <QUrl>
+#include <QDir>
+#include <QCoreApplication>
+
+using namespace std;
+using namespace breakfastquay;
+using namespace RubberBand;
+
+Processor::Processor() :
+    m_stretcher(0),
+    m_processBlock(0),
+    m_previewBlock(-1),
+    m_playing(false),
+    m_blockSize(2048),
+    m_blocks(0, 0, m_blockSize),
+    m_stretchIn(0),
+    m_stretchOutPtrs(0),
+    m_timeRatio(1.0),
+    m_pitchScale(1.0),
+    m_formantPreserving(false),
+    m_centreFocus(false),
+    m_lastCentreFocus(false),
+    m_crispness(5),
+    m_hqshift(false),
+    m_windowSort(1),
+    m_fileReadThread(0),
+    m_rs(0)
+{
+}
+
+Processor::~Processor()
+{
+    if (m_fileReadThread) {
+        m_fileReadThread->cancel();
+        m_fileReadThread->wait();
+        delete m_fileReadThread;
+        m_fileReadThread = 0;
+    }
+
+    delete m_rs;
+
+    clearBlocks(); // uses mutex, so must come before the locker
+
+    QMutexLocker locker(&m_mutex);
+
+    if (m_stretcher) {
+        for (int c = 0; c < (int)m_stretcher->getChannelCount(); ++c) {
+            delete[] m_stretchIn[c];
+        }
+        delete[] m_stretchIn;
+        delete[] m_stretchOutPtrs;
+        delete m_stretcher;
+    }
+}
+
+int
+Processor::getApplicationSampleRate() const
+{
+    return getSampleRate();
+}
+
+int
+Processor::getApplicationChannelCount() const
+{
+    return m_blocks.channels;
+}
+
+string
+Processor::getClientName() const
+{
+    return QCoreApplication::applicationName().toUtf8().data();
+}
+
+void
+Processor::setSystemPlaybackBlockSize(int)
+{
+}
+
+void
+Processor::setSystemPlaybackSampleRate(int)
+{
+}
+
+void
+Processor::setSystemPlaybackLatency(int)
+{
+}
+
+void
+Processor::setSystemPlaybackChannelCount(int)
+{
+}
+
+void
+Processor::setOutputLevels(float, float)
+{
+}
+
+QString
+Processor::getFilename() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_filename;
+}
+
+int
+Processor::getSampleRate() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_blocks.sampleRate;
+}
+
+int
+Processor::getChannelCount() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_blocks.channels;
+}
+
+double 
+Processor::getTimeRatio() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_timeRatio;
+}
+
+void 
+Processor::setTimeRatio(double ratio)
+{
+    QMutexLocker locker(&m_mutex);
+    m_timeRatio = ratio;
+}
+
+double 
+Processor::getPitchScale() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_pitchScale;
+}
+
+void 
+Processor::setPitchScale(double scale)
+{
+    QMutexLocker locker(&m_mutex);
+    m_pitchScale = scale;
+}
+
+bool 
+Processor::getFormantPreserving() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_formantPreserving;
+}
+
+void 
+Processor::setFormantPreserving(bool fp)
+{
+    QMutexLocker locker(&m_mutex);
+    m_formantPreserving = fp;
+}
+
+bool 
+Processor::getCentreFocus() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_centreFocus;
+}
+
+void 
+Processor::setCentreFocus(bool fp)
+{
+    QMutexLocker locker(&m_mutex);
+    m_centreFocus = fp;
+}
+
+int 
+Processor::getCrispness() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_crispness;
+}
+
+void 
+Processor::setCrispness(int c)
+{
+    QMutexLocker locker(&m_mutex);
+    m_crispness = c;
+}
+
+bool 
+Processor::getHighQualityShiftMode() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_hqshift;
+}
+
+void 
+Processor::setHighQualityShiftMode(bool h)
+{
+    QMutexLocker locker(&m_mutex);
+    m_hqshift = h;
+}
+
+bool 
+Processor::isPlaying() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_playing;
+}
+
+void
+Processor::play()
+{
+    QMutexLocker locker(&m_mutex);
+    m_playing = true;
+}
+
+void
+Processor::pause()
+{
+    QMutexLocker locker(&m_mutex);
+    m_playing = false;
+    if (m_stretcher) {
+        m_stretcher->reset();
+    }
+}
+
+void
+Processor::rewind()
+{
+    QMutexLocker locker(&m_mutex);
+    m_processBlock = 0;
+    if (m_stretcher) {
+        m_stretcher->reset();
+    }
+}
+
+Processor::BlockRec::~BlockRec()
+{
+    clear();
+}
+
+void
+Processor::BlockRec::clear()
+{
+    QMutexLocker locker(&mutex);
+    for (int i = 0; i < (int)blocks.size(); ++i) {
+        deallocate<float>(blocks[i]);
+    }
+    blocks.clear();
+}
+
+void
+Processor::clearBlocks()
+{
+    QMutexLocker locker(&m_mutex);
+    m_blocks.clear();
+}
+
+Processor::LoadStatus
+Processor::getLoadingStatus() const
+{
+    QMutexLocker locker(&m_mutex);
+    if (m_fileReadThread) {
+        switch (m_fileReadThread->getStatus()) {
+        case FileReadThread::Working: return LoadPending;
+        case FileReadThread::Done: return LoadComplete;
+        case FileReadThread::Cancelled: return LoadCancelled;
+        case FileReadThread::OutOfMemory: return LoadOutOfMemory;
+        }
+    }
+    // Note that this depends on m_fileReadThread always being set
+    // from the moment the first file load is requested (it is not
+    // deleted when file load completes, only when the next load
+    // happens)
+    return LoadNone;
+}
+
+Processor::PlayStatus
+Processor::getPlayStatus() const
+{
+    PlayStatus s;
+    {
+        QMutexLocker locker(&m_mutex);
+        s.playingBlock = m_processBlock;
+        s.totalBlocks = getTotalAudioBlocks();
+        s.totalFrames = getTotalAudioFrames();
+        s.blockSize = m_blockSize;
+        s.sampleRate = m_blocks.sampleRate;
+        s.channelCount = m_blocks.channels;
+        s.ratio = m_timeRatio;
+    }
+    s.loadStatus = getLoadingStatus();
+    return s;
+}
+
+void
+Processor::cancelFileLoad()
+{
+    QMutexLocker locker(&m_mutex);
+    if (m_fileReadThread) m_fileReadThread->cancel();
+}
+
+Processor::FileReadThread::FileReadThread(Processor *p,
+                                          BlockRec *rec,
+                                          AudioReadStream *rs) :
+    m_processor(p),
+    m_blocks(rec),
+    m_rs(rs),
+    m_status(Working)
+{
+}
+
+Processor::FileReadThread::~FileReadThread()
+{
+}
+
+void
+Processor::FileReadThread::cancel()
+{
+    m_status = Cancelled;
+}
+
+void
+Processor::FileReadThread::run()
+{
+    int bs = m_processor->m_blockSize;
+    int ch = m_rs->getChannelCount();
+
+    while (m_status == Working) {
+
+        //!!! this should be a call out to a function in m_processor
+
+        float *newBlock = 0;
+
+        try {
+            newBlock = allocate<float>(bs * ch);
+        } catch (const bad_alloc &) {
+            m_processor->clearBlocks();
+            cerr << "Failed to allocate " << bs << " frames "
+                      << " of " << ch << " channels" << endl;
+            m_status = OutOfMemory;
+            return;
+        }
+
+        int got = m_rs->getInterleavedFrames(bs, newBlock);
+
+        if (got < bs) {
+            v_zero(newBlock + got * ch, (bs - got) * ch);
+        }
+
+        m_blocks->mutex.lock();
+
+        if (got > 0) {
+            m_blocks->blocks.push_back(newBlock);
+        }
+
+        if (got < bs) {
+            if (got == 0 && !m_blocks->blocks.empty()) {
+                m_blocks->lastBlockFill = bs;
+            } else {
+                m_blocks->lastBlockFill = got;
+            }
+            m_status = Done;
+        }
+
+        m_blocks->mutex.unlock();
+    }
+
+    cerr << "Finished reading data" << endl;
+}    
+
+void
+Processor::open(QString filename)
+{
+    if (m_fileReadThread) {
+        m_fileReadThread->cancel();
+        m_fileReadThread->wait();
+        delete m_fileReadThread;
+        m_fileReadThread = 0;
+    }
+
+    delete m_rs;
+    m_rs = 0;
+
+    if (!QFileInfo(filename).exists()) {
+        // try it as a url
+        QUrl url(filename);
+        if (url.isValid() && QFileInfo(url.toLocalFile()).exists()) {
+            filename = url.toLocalFile();
+        }
+        if (!QFileInfo(filename).exists()) {
+            url = QUrl::fromEncoded(filename.toUtf8());
+            if (url.isValid() && QFileInfo(url.toLocalFile()).exists()) {
+                filename = url.toLocalFile();
+            }
+        }
+    }
+
+    m_filename = filename;
+
+    try {
+        m_rs = AudioReadStreamFactory::createReadStream
+            (m_filename.toUtf8().data()); // may throw
+    } catch (...) {
+        delete m_rs;
+        m_rs = 0;
+        throw;
+    }
+    if (!m_rs || !m_rs->getChannelCount()) {
+        delete m_rs;
+        m_rs = 0;
+        throw runtime_error("Unknown audio format");
+    }
+
+    // we could reuse these, but let's be lazy to start with
+    clearBlocks();
+
+    QMutexLocker locker(&m_mutex);
+    m_blocks.channels = m_rs->getChannelCount();
+    m_blocks.sampleRate = m_rs->getSampleRate();
+
+    if (m_stretcher) {
+        for (int c = 0; c < (int)m_stretcher->getChannelCount(); ++c) {
+            delete[] m_stretchIn[c];
+        }
+        delete[] m_stretchIn;
+        delete[] m_stretchOutPtrs;
+        delete m_stretcher;
+        m_stretcher = 0;
+    }
+
+    m_stretcher = new RubberBandStretcher
+        (m_blocks.sampleRate,
+         m_blocks.channels,
+         RubberBandStretcher::OptionProcessRealTime |
+         RubberBandStretcher::OptionDetectorCompound,
+         m_timeRatio,
+         m_pitchScale);
+
+    m_stretcher->setMaxProcessSize(m_blockSize);
+
+    m_stretchIn = new float *[m_stretcher->getChannelCount()];
+
+    for (int c = 0; c < (int)m_stretcher->getChannelCount(); ++c) {
+        m_stretchIn[c] = new float[m_blockSize];
+    }
+    m_stretchOutPtrs = new float *[m_stretcher->getChannelCount()];
+
+    m_fileReadThread = new FileReadThread(this, &m_blocks, m_rs);
+    m_fileReadThread->start();
+
+    m_stretcher->reset();
+
+    m_filename = filename;
+
+    m_processBlock = 0;
+    m_previewBlock = -1;
+}
+
+int
+Processor::getTotalAudioBlocks() const
+{
+    return getTotalAudioBlocks(m_blocks);
+}
+
+int
+Processor::getTotalAudioBlocks(const BlockRec &rec) 
+{
+    QMutexLocker locker(&rec.mutex);
+    int b = rec.blocks.size();
+    return b;
+}    
+
+int
+Processor::getTotalAudioFrames() const
+{
+    return getTotalAudioFrames(m_blocks);
+}
+
+int
+Processor::getTotalAudioFrames(const BlockRec &rec) 
+{
+    QMutexLocker locker(&rec.mutex);
+    int b = rec.blocks.size();
+    int lb = rec.lastBlockFill;
+    if (b == 0) return 0;
+    else return((b-1) * rec.blockSize) + lb;
+}
+
+int
+Processor::getPlayingAudioBlock() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_processBlock;
+}
+
+float
+Processor::getPlayProportion() const
+{
+    int p = getPlayingAudioBlock();
+    int n = getTotalAudioBlocks();
+    float proportion = 0.f;
+    if (n > 0) {
+        proportion = float(p)/float(n);
+    }
+    if (proportion > 1.f) {
+        proportion = 1.f;
+    }
+    return proportion;
+}
+
+int
+Processor::getBlockSize() const
+{
+    QMutexLocker locker(&m_mutex);
+    return m_blockSize;
+}
+
+void
+Processor::configure(RubberBandStretcher *stretcher,
+                     int crispness,
+                     bool formantPreserving,
+                     bool hqshift)
+{
+    stretcher->setFormantOption
+        (formantPreserving ?
+         RubberBandStretcher::OptionFormantPreserved :
+         RubberBandStretcher::OptionFormantShifted);
+
+    stretcher->setPitchOption
+        (hqshift ?
+         RubberBandStretcher::OptionPitchHighQuality :
+         RubberBandStretcher::OptionPitchHighSpeed);
+
+    switch (crispness) {
+    case 0:
+        stretcher->setTransientsOption(RubberBandStretcher::OptionTransientsSmooth);
+        stretcher->setPhaseOption(RubberBandStretcher::OptionPhaseIndependent);
+        stretcher->setDetectorOption(RubberBandStretcher::OptionDetectorCompound);
+        break;
+    case 1:
+        stretcher->setTransientsOption(RubberBandStretcher::OptionTransientsCrisp);
+        stretcher->setPhaseOption(RubberBandStretcher::OptionPhaseIndependent);
+        stretcher->setDetectorOption(RubberBandStretcher::OptionDetectorSoft);
+        break;
+    case 2:
+        stretcher->setTransientsOption(RubberBandStretcher::OptionTransientsSmooth);
+        stretcher->setPhaseOption(RubberBandStretcher::OptionPhaseIndependent);
+        stretcher->setDetectorOption(RubberBandStretcher::OptionDetectorCompound);
+        break;
+    case 3:
+        stretcher->setTransientsOption(RubberBandStretcher::OptionTransientsSmooth);
+        stretcher->setPhaseOption(RubberBandStretcher::OptionPhaseLaminar);
+        stretcher->setDetectorOption(RubberBandStretcher::OptionDetectorCompound);
+        break;
+    case 4:
+        stretcher->setTransientsOption(RubberBandStretcher::OptionTransientsMixed);
+        stretcher->setPhaseOption(RubberBandStretcher::OptionPhaseLaminar);
+        stretcher->setDetectorOption(RubberBandStretcher::OptionDetectorCompound);
+        break;
+    case 5:
+        stretcher->setTransientsOption(RubberBandStretcher::OptionTransientsCrisp);
+        stretcher->setPhaseOption(RubberBandStretcher::OptionPhaseLaminar);
+        stretcher->setDetectorOption(RubberBandStretcher::OptionDetectorCompound);
+        break;
+    case 6:
+        stretcher->setTransientsOption(RubberBandStretcher::OptionTransientsCrisp);
+        stretcher->setPhaseOption(RubberBandStretcher::OptionPhaseIndependent);
+        stretcher->setDetectorOption(RubberBandStretcher::OptionDetectorCompound);
+        break;
+    }        
+}
+
+int
+Processor::getSourceSamples(float *const *samples, int nchannels, int nframes)
+{
+    bool locked = false;
+    bool unavailable = false;
+
+    if (!m_mutex.tryLock()) {
+	unavailable = true;
+    } else {
+	locked = true;
+        if (!m_blocks.channels || m_blocks.blocks.empty()) {
+	    unavailable = true;
+        } else if (!m_stretcher) {
+            unavailable = true;
+        } else if (m_playing && (m_stretcher->available() < 0)) {
+	    unavailable = true;
+        } else if (!m_playing && (m_previewBlock < 0)) {
+            unavailable = true;
+	}
+    }
+    
+    if (unavailable) {
+
+        // not playing, nothing to play, or mutex unavailable: return zeros
+        for (int c = 0; c < nchannels; ++c) {
+            const int n = nframes;
+            for (int i = 0; i < n; ++i) {
+                samples[c][i] = 0.f;
+            }
+        }
+
+        if (locked) m_mutex.unlock();
+        return nframes;
+    }
+
+    const double timeRatio = m_timeRatio;
+    const double pitchScale = m_pitchScale;
+    const bool hqshift = m_hqshift;
+    const bool formantPreserving = m_formantPreserving;
+    const int crispness = m_crispness;
+
+    int windowSort = 1;
+
+    if (crispness == 6) {
+        windowSort = 0;
+    } else if (crispness == 0 || crispness == 1) {
+        windowSort = 2;
+    }
+    
+    if (m_windowSort != windowSort ||
+        m_centreFocus != m_lastCentreFocus ||
+        !m_stretcher ||
+        nchannels || m_stretcher->getChannelCount()) {
+        delete m_stretcher;
+        RubberBandStretcher::Options options =
+            RubberBandStretcher::OptionProcessRealTime |
+            RubberBandStretcher::OptionTransientsCrisp |
+            RubberBandStretcher::OptionPhaseIndependent;
+
+        if (windowSort == 0) options |= RubberBandStretcher::OptionWindowShort;
+        if (windowSort == 2) options |= RubberBandStretcher::OptionWindowLong;
+        if (m_centreFocus) options |= RubberBandStretcher::OptionChannelsTogether;
+
+        m_stretcher = new RubberBandStretcher
+            (m_blocks.sampleRate, nchannels, options, timeRatio, pitchScale);
+        m_windowSort = windowSort;
+    }
+
+    // These calls are very cheap if they won't change anything, so no
+    // harm in calling them every time
+    m_stretcher->setTimeRatio(timeRatio);
+    m_stretcher->setPitchScale(pitchScale);
+
+    configure(m_stretcher, crispness, formantPreserving, hqshift);
+
+    m_lastCentreFocus = m_centreFocus;
+
+    // We de-interleave the audio data and write the input for the
+    // stretcher into m_stretchIn.  m_blockSize is an arbitrary size
+    // which is both the number of interleaved frames in each block of
+    // m_blocks, and the amount of space allocated for m_stretchIn:
+    // the maximum we can de-interleave and feed in any one chunk.
+
+    int done = 0;
+    int fileChannels = m_blocks.channels;
+
+    while (done < (int)nframes) {
+
+//        cout << "getSourceSamples: nframes = "<< nframes << ", done = " << done << ", m_processBlock = " << m_processBlock << ", blocks = " << m_blocks.blocks.size() << endl;
+
+        int available = m_stretcher->available();
+        if (available < 0) break;
+
+        int reqd = m_stretcher->getSamplesRequired();
+
+        if (available < ((int)nframes - done) || reqd > 0) {
+        
+            int toProcess = m_blockSize;
+
+            bool lastBlock = false;
+            bool ended = false;
+            int block = getAndUpdateBlockNo(lastBlock, ended);
+
+            if (ended) {
+                m_playing = false;
+                emit playEnded();
+                break;
+            }
+            
+            float *source = 0;
+
+            m_blocks.mutex.lock();
+            if (m_blocks.blocks.empty()) {
+                m_blocks.mutex.unlock();
+                m_playing = false;
+                emit playEnded();
+                break;
+            }
+            if (block >= (int)m_blocks.blocks.size()) {
+                block = m_blocks.blocks.size() - 1;
+            }
+            if (block < 0) {
+                block = 0;
+            }
+            source = m_blocks.blocks[block];
+            int lastBlockFill = m_blocks.lastBlockFill;
+            m_blocks.mutex.unlock();
+
+            if (lastBlock) {
+                toProcess = lastBlockFill;
+                m_playing = false;
+                emit playEnded();
+            }
+
+            // nchannels is the number of channels required for output
+            // to the audio device. This value came directly from the
+            // device handler, and the stretcher has been configured
+            // with a matching channel count. fileChannels is the
+            // number in the audio file, which may differ. We always
+            // run the stretcher at the audio device channel count.
+
+            for (int c = 0; c < nchannels && c < fileChannels; ++c) {
+                for (int i = 0; i < toProcess; ++i) {
+                    m_stretchIn[c][i] = source[(i * fileChannels) + c];
+                }
+            }
+            
+            for (int c = fileChannels; c < nchannels; ++c) {
+                if (c > 0) {
+                    // excess channels on audio output: duplicate the
+                    // first file channel for them (an arbitrary decision)
+                    for (int i = 0; i < toProcess; ++i) {
+                        m_stretchIn[c][i] = m_stretchIn[0][i];
+                    }
+                } else {
+                    // zero channels in the file!
+                    for (int i = 0; i < toProcess; ++i) {
+                        m_stretchIn[c][i] = 0.f;
+                    }
+                }
+            }
+            
+            m_stretcher->process(m_stretchIn, toProcess, false);
+        }
+
+        int count = m_stretcher->available();
+        if (count == 0) continue;
+
+        if (count > ((int)nframes - done)) count = (int)nframes - done;
+
+        // m_stretchOutPtrs is a set of temporary pointers indicating
+        // where to write the output to, as a set of offsets into the
+        // desired samples arrays
+        for (int c = 0; c < nchannels; ++c) {
+            m_stretchOutPtrs[c] = samples[c] + done;
+        }
+
+        m_stretcher->retrieve(m_stretchOutPtrs, count);
+        done += count;
+    }
+
+    // any excess should be filled up with zero samples
+    for (int c = 0; c < nchannels; ++c) {
+        for (int i = done; i < (int)nframes; ++i) {
+            samples[c][i] = 0.f;
+        }
+    }
+
+    m_mutex.unlock();
+
+    return nframes;
+}
+
+int
+Processor::getAndUpdateBlockNo(bool &lastBlock, bool &ended)
+{
+    int block = m_processBlock;
+        
+    lastBlock = false;
+    ended = false;
+    
+    m_blocks.mutex.lock();
+
+    int n = (int)m_blocks.blocks.size();
+    
+    ++m_processBlock;
+
+    lastBlock = (block+1 >= n);
+
+    if (lastBlock) {
+        m_processBlock = 0;
+    }
+    m_blocks.mutex.unlock();
+
+    return block;
+}
+

          
A => src/Processor.h +197 -0
@@ 0,0 1,197 @@ 
+/* -*- c-basic-offset: 4 indent-tabs-mode: nil -*-  vi:set ts=8 sts=4 sw=4: */
+
+/* Copyright 2020 Particular Programs Ltd. All Rights Reserved. */
+
+#ifndef EXAMPLE_PROCESSOR_H
+#define EXAMPLE_PROCESSOR_H
+
+#include <bqaudioio/ApplicationPlaybackSource.h>
+#include <bqaudioio/AudioFactory.h>
+#include <bqaudiostream/AudioReadStream.h>
+
+#include <iostream>
+
+#include <set>
+#include <vector>
+
+#include <QThread>
+#include <QMutex>
+
+namespace RubberBand {
+    class RubberBandStretcher;
+}
+
+class Processor : public QObject,
+                  public breakfastquay::ApplicationPlaybackSource
+{
+    Q_OBJECT
+
+public:
+    Processor();
+    virtual ~Processor();
+
+    // ApplicationPlaybackSource methods
+    int getApplicationSampleRate() const override;
+    int getApplicationChannelCount() const override;
+    std::string getClientName() const override;
+    
+    void setSystemPlaybackBlockSize(int) override;
+    void setSystemPlaybackSampleRate(int) override;
+    void setSystemPlaybackLatency(int) override;
+    void setSystemPlaybackChannelCount(int) override;
+    void setOutputLevels(float, float) override;
+
+    int getSourceSamples(float *const *samples, int nchannels, int nframes) override;
+    
+    void cancelFileLoad();
+
+    QString getFilename() const;
+    
+    int getSampleRate() const;
+    int getChannelCount() const;
+    
+    double getTimeRatio() const;
+    void setTimeRatio(double ratio);
+
+    double getPitchScale() const;
+    void setPitchScale(double scale);
+
+    bool getFormantPreserving() const;
+    void setFormantPreserving(bool fp);
+
+    bool getCentreFocus() const;
+    void setCentreFocus(bool cf);
+
+    int getCrispness() const;
+    void setCrispness(int c);
+
+    bool getHighQualityShiftMode() const;
+    void setHighQualityShiftMode(bool);
+
+    bool isPlaying() const;
+
+    int getTotalAudioBlocks() const;
+    int getTotalAudioFrames() const;
+    int getPlayingAudioBlock() const;
+    float getPlayProportion() const;
+    bool isAtRangeStartOrEnd() const;
+    int getBlockSize() const;
+    
+    enum LoadStatus {
+        LoadNone,
+        LoadPending,
+        LoadCancelled,
+        LoadOutOfMemory,
+        LoadComplete
+    };
+    LoadStatus getLoadingStatus() const;
+
+    struct PlayStatus {
+        int playingBlock;
+        int totalBlocks;
+        int totalFrames;
+        int blockSize;
+        int sampleRate;
+        int channelCount;
+        double ratio;
+        LoadStatus loadStatus;
+    };
+    PlayStatus getPlayStatus() const;
+    
+    void open(QString filename); // may throw
+
+signals:
+    void playEnded();
+
+public slots:
+    void play();
+    void pause();
+    void rewind();
+
+protected:
+    QString m_filename;
+
+    breakfastquay::SystemPlaybackTarget *m_target;
+    RubberBand::RubberBandStretcher *m_stretcher;
+
+    int m_processBlock;
+    int m_previewBlock;
+    bool m_playing;
+
+    mutable QMutex m_mutex;
+
+    int m_blockSize;
+
+    struct BlockRec {
+        BlockRec(int rate, int c, int bs) :
+            sampleRate(rate),
+            channels(c),
+            blockSize(bs),
+            lastBlockFill(bs) { }
+        ~BlockRec();
+        void clear();
+
+        int sampleRate;
+        int channels;
+        int blockSize;
+        int lastBlockFill;
+        std::vector<float *> blocks;
+        mutable QMutex mutex;
+    };
+
+    BlockRec m_blocks;
+    void clearBlocks();
+
+    float **m_stretchIn;
+    float **m_stretchOutPtrs;
+
+    double m_timeRatio;
+    double m_pitchScale;
+
+    bool m_formantPreserving;
+    bool m_centreFocus;
+    bool m_lastCentreFocus;
+    int m_crispness;
+    bool m_hqshift;
+    int m_windowSort;
+
+    void configure(RubberBand::RubberBandStretcher *,
+                   int crispness,
+                   bool formantPreserving,
+                   bool hqshift);
+
+    static int getTotalAudioBlocks(const BlockRec &);
+    static int getTotalAudioFrames(const BlockRec &);
+
+    int getAndUpdateBlockNo(bool &lastBlock, bool &playEnded);
+    
+    class FileReadThread : public QThread
+    {
+    public:
+        FileReadThread(Processor *processor, BlockRec *blocks,
+                       breakfastquay::AudioReadStream *rs);
+        virtual ~FileReadThread();
+        
+        void cancel();
+        
+        enum Status {
+            Working,
+            Done,
+            Cancelled,
+            OutOfMemory
+        };
+        Status getStatus() const { return m_status; }
+
+    protected:
+        Processor *m_processor;
+        BlockRec *m_blocks;
+        breakfastquay::AudioReadStream *m_rs; // belongs to containing Processor object
+        void run() override;
+        Status m_status;
+    };
+
+    FileReadThread *m_fileReadThread;
+    breakfastquay::AudioReadStream *m_rs;
+};
+
+#endif

          
A => src/main.cpp +55 -0
@@ 0,0 1,55 @@ 
+/* -*- c-basic-offset: 4 indent-tabs-mode: nil -*-  vi:set ts=8 sts=4 sw=4: */
+
+/* Copyright 2020 Particular Programs Ltd. All Rights Reserved. */
+
+#include "Processor.h"
+#include "Interface.h"
+
+#include <QApplication>
+#include <QMessageBox>
+#include <QTranslator>
+
+#include <bqaudioio/AudioFactory.h>
+#include <bqaudioio/SystemPlaybackTarget.h>
+
+#include <rubberband/RubberBandStretcher.h>
+
+int main(int argc, char **argv)
+{
+    QApplication app(argc, argv);
+
+    QApplication::setOrganizationName("Breakfast Quay");
+    QApplication::setOrganizationDomain("breakfastquay.com");
+    QApplication::setApplicationName("Rubber Band Qt Example");
+
+    Processor *processor = new Processor();
+    Interface *iface = new Interface(processor);
+    iface->show();
+
+    std::string error;
+    breakfastquay::SystemPlaybackTarget *target =
+	breakfastquay::AudioFactory::createCallbackPlayTarget
+        (processor, {}, error);
+    if (!target || !target->isTargetOK()) {
+        QMessageBox::critical
+            (iface,
+             QObject::tr("Failed to open audio device"),
+             error == "" ?
+             QObject::tr("Failed to open audio device for playback.") :
+             QObject::tr("Failed to open audio device for playback: %1")
+             .arg(error.c_str()));
+    }
+
+    QStringList args = app.arguments();
+    if (args.size() > 1) iface->open(args[1]);
+
+    int rv = app.exec();
+
+    delete target;
+    delete iface;
+    delete processor;
+
+    return rv;
+}
+
+