diff vext.sml @ 303:523f8f1789b4

Switch to Vext
author Chris Cannam
date Mon, 10 Jul 2017 18:57:08 +0100
parents
children d741e2c90eab
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vext.sml	Mon Jul 10 18:57:08 2017 +0100
@@ -0,0 +1,1671 @@
+(* This file is automatically generated from the individual 
+   source files in the Vext repository. *)
+
+(* 
+    Vext
+
+    A simple manager for third-party source code dependencies
+
+    Copyright 2017 Chris Cannam.
+
+    Permission is hereby granted, free of charge, to any person
+    obtaining a copy of this software and associated documentation
+    files (the "Software"), to deal in the Software without
+    restriction, including without limitation the rights to use, copy,
+    modify, merge, publish, distribute, sublicense, and/or sell copies
+    of the Software, and to permit persons to whom the Software is
+    furnished to do so, subject to the following conditions:
+
+    The above copyright notice and this permission notice shall be
+    included in all copies or substantial portions of the Software.
+
+    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+    EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+    MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+    NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
+    ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
+    CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+    WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+    Except as contained in this notice, the names of Chris Cannam and
+    Particular Programs Ltd shall not be used in advertising or
+    otherwise to promote the sale, use or other dealings in this
+    Software without prior written authorization.
+*)
+
+val vext_version = "0.9.4"
+
+
+datatype vcs =
+         HG |
+         GIT
+
+datatype source =
+         URL_SOURCE of string |
+         SERVICE_SOURCE of {
+             service : string,
+             owner : string option,
+             repo : string option
+         }
+
+datatype pin =
+         UNPINNED |
+         PINNED of string
+
+datatype libstate =
+         ABSENT |
+         CORRECT |
+         SUPERSEDED |
+         WRONG
+
+datatype localstate =
+         MODIFIED |
+         UNMODIFIED
+
+datatype branch =
+         BRANCH of string |
+         DEFAULT_BRANCH
+             
+(* If we can recover from an error, for example by reporting failure
+   for this one thing and going on to the next thing, then the error
+   should usually be returned through a result type rather than an
+   exception. *)
+             
+datatype 'a result =
+         OK of 'a |
+         ERROR of string
+
+type libname = string
+
+type id_or_tag = string
+
+type libspec = {
+    libname : libname,
+    vcs : vcs,
+    source : source,
+    branch : branch,
+    pin : pin
+}
+
+type lock = {
+    libname : libname,
+    id_or_tag : id_or_tag
+}
+                   
+type remote_spec = {
+    anon : string option,
+    auth : string option
+}
+
+type provider = {
+    service : string,
+    supports : vcs list,
+    remote_spec : remote_spec
+}
+
+type account = {
+    service : string,
+    login : string
+}
+                    
+type context = {
+    rootpath : string,
+    extdir : string,
+    providers : provider list,
+    accounts : account list
+}
+
+type userconfig = {
+    providers : provider list,
+    accounts : account list
+}
+                   
+type project = {
+    context : context,
+    libs : libspec list
+}
+
+structure VextFilenames = struct
+    val project_file = "vext-project.json"
+    val project_lock_file = "vext-lock.json"
+    val user_config_file = ".vext.json"
+end
+                   
+signature VCS_CONTROL = sig
+
+    (** Test whether the library is present locally at all *)
+    val exists : context -> libname -> bool result
+                                            
+    (** Return the id (hash) of the current revision for the library *)
+    val id_of : context -> libname -> id_or_tag result
+
+    (** Test whether the library is at the given id *)
+    val is_at : context -> libname * id_or_tag -> bool result
+
+    (** Test whether the library is on the given branch, i.e. is at
+        the branch tip or an ancestor of it *)
+    val is_on_branch : context -> libname * branch -> bool result
+
+    (** Test whether the library is at the newest revision for the
+        given branch. False may indicate that the branch has advanced
+        or that the library is not on the branch at all. This function
+        may use the network to check for new revisions *)
+    val is_newest : context -> libname * branch -> bool result
+
+    (** Test whether the library is at the newest revision available
+        locally for the given branch. False may indicate that the
+        branch has advanced or that the library is not on the branch
+        at all. This function must not use the network *)
+    val is_newest_locally : context -> libname * branch -> bool result
+
+    (** Test whether the library has been modified in the local
+        working copy *)
+    val is_modified_locally : context -> libname -> bool result
+
+    (** Check out, i.e. clone a fresh copy of, the repo for the given
+        library on the given branch *)
+    val checkout : context -> libname * source * branch -> unit result
+
+    (** Update the library to the given branch tip *)
+    val update : context -> libname * branch -> id_or_tag result
+
+    (** Update the library to the given specific id or tag *)
+    val update_to : context -> libname * id_or_tag -> id_or_tag result
+end
+
+signature LIB_CONTROL = sig
+    val review : context -> libspec -> (libstate * localstate) result
+    val status : context -> libspec -> (libstate * localstate) result
+    val update : context -> libspec -> id_or_tag result
+end
+
+structure FileBits :> sig
+    val extpath : context -> string
+    val libpath : context -> libname -> string
+    val subpath : context -> libname -> string -> string
+    val command_output : context -> libname -> string list -> string result
+    val command : context -> libname -> string list -> unit result
+    val file_contents : string -> string
+    val mydir : unit -> string
+    val homedir : unit -> string
+    val mkpath : string -> unit result
+    val project_spec_path : string -> string
+    val project_lock_path : string -> string
+    val verbose : unit -> bool
+end = struct
+
+    fun verbose () =
+        case OS.Process.getEnv "VEXT_VERBOSE" of
+            SOME "0" => false
+          | SOME _ => true
+          | NONE => false
+
+    fun extpath ({ rootpath, extdir, ... } : context) =
+        let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
+        in OS.Path.toString {
+                isAbs = isAbs,
+                vol = vol,
+                arcs = arcs @ [ extdir ]
+            }
+        end
+    
+    fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
+        (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
+        let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
+            val split = String.fields (fn c => c = #"/")
+        in OS.Path.toString {
+                isAbs = isAbs,
+                vol = vol,
+                arcs = arcs @ [ extdir ] @ split libname @ split remainder
+            }
+        end
+
+    fun libpath context "" =
+        extpath context
+      | libpath context libname =
+        subpath context libname ""
+
+    fun project_file_path rootpath filename =
+        let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
+        in OS.Path.toString {
+                isAbs = isAbs,
+                vol = vol,
+                arcs = arcs @ [ filename ]
+            }
+        end
+                
+    fun project_spec_path rootpath =
+        project_file_path rootpath (VextFilenames.project_file)
+
+    fun project_lock_path rootpath =
+        project_file_path rootpath (VextFilenames.project_lock_file)
+
+    fun trim str =
+        hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
+        
+    fun file_contents filename =
+        let val stream = TextIO.openIn filename
+            fun read_all str acc =
+                case TextIO.inputLine str of
+                    SOME line => read_all str (trim line :: acc)
+                  | NONE => rev acc
+            val contents = read_all stream []
+            val _ = TextIO.closeIn stream
+        in
+            String.concatWith "\n" contents
+        end
+
+    fun expand_commandline cmdlist =
+        (* We are quite [too] strict about what we accept here, except
+           for the first element in cmdlist which is assumed to be a
+           known command location rather than arbitrary user input. NB
+           only ASCII accepted at this point. *)
+        let open Char
+            fun quote arg =
+                if List.all
+                       (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
+                       (explode arg)
+                then arg
+                else "\"" ^ arg ^ "\""
+            fun check arg =
+                let val valid = explode " /#:;?,._-{}@="
+                in
+                    app (fn c =>
+                            if isAlphaNum c orelse
+                               List.exists (fn v => v = c) valid
+                            then ()
+                            else raise Fail ("Invalid character '" ^
+                                             (Char.toString c) ^
+                                             "' in command list"))
+                        (explode arg);
+                    arg
+                end
+        in
+            String.concatWith " "
+                              (map quote
+                                   (hd cmdlist :: map check (tl cmdlist)))
+        end
+
+    val tick_cycle = ref 0
+    val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
+
+    fun tick libname cmdlist =
+        let val n = Vector.length tick_chars
+            fun pad_to n str =
+                if n <= String.size str then str
+                else pad_to n (str ^ " ")
+            val name = if libname <> "" then libname
+                       else if cmdlist = nil then ""
+                       else hd (rev cmdlist)
+        in
+            print ("  " ^
+                   Vector.sub(tick_chars, !tick_cycle) ^ " " ^
+                   pad_to 24 name ^
+                   "\r");
+            tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
+        end
+            
+    fun run_command context libname cmdlist redirect =
+        let open OS
+            val dir = libpath context libname
+            val cmd = expand_commandline cmdlist
+            val _ = if verbose ()
+                    then print ("Running: " ^ cmd ^
+                                " (in dir " ^ dir ^ ")...\n")
+                    else tick libname cmdlist
+            val _ = FileSys.chDir dir
+            val status = case redirect of
+                             NONE => Process.system cmd
+                           | SOME file => Process.system (cmd ^ ">" ^ file)
+        in
+            if Process.isSuccess status
+            then OK ()
+            else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
+        end
+        handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
+
+    fun command context libname cmdlist =
+        run_command context libname cmdlist NONE
+            
+    fun command_output context libname cmdlist =
+        let open OS
+            val tmpFile = FileSys.tmpName ()
+            val result = run_command context libname cmdlist (SOME tmpFile)
+            val contents = file_contents tmpFile
+        in
+            FileSys.remove tmpFile handle _ => ();
+            case result of
+                OK () => OK contents
+              | ERROR e => ERROR e
+        end
+
+    fun mydir () =
+        let open OS
+            val { dir, file } = Path.splitDirFile (CommandLine.name ())
+        in
+            FileSys.realPath
+                (if Path.isAbsolute dir
+                 then dir
+                 else Path.concat (FileSys.getDir (), dir))
+        end
+
+    fun homedir () =
+        (* Failure is not routine, so we use an exception here *)
+        case (OS.Process.getEnv "HOME",
+              OS.Process.getEnv "HOMEPATH") of
+            (SOME home, _) => home
+          | (NONE, SOME home) => home
+          | (NONE, NONE) =>
+            raise Fail "Failed to look up home directory from environment"
+
+    fun mkpath path =
+        if OS.FileSys.isDir path handle _ => false
+        then OK ()
+        else case OS.Path.fromString path of
+                 { arcs = nil, ... } => OK ()
+               | { isAbs = false, ... } => ERROR "mkpath requires absolute path"
+               | { isAbs, vol, arcs } => 
+                 case mkpath (OS.Path.toString {      (* parent *)
+                                   isAbs = isAbs,
+                                   vol = vol,
+                                   arcs = rev (tl (rev arcs)) }) of
+                     ERROR e => ERROR e
+                   | OK () => ((OS.FileSys.mkDir path; OK ())
+                               handle OS.SysErr (e, _) =>
+                                      ERROR ("Directory creation failed: " ^ e))
+end
+                                         
+functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
+
+    (* Valid states for unpinned libraries:
+
+       - CORRECT: We are on the right branch and are up-to-date with
+         it as far as we can tell. (If not using the network, this
+         should be reported to user as "Present" rather than "Correct"
+         as the remote repo may have advanced without us knowing.)
+
+       - SUPERSEDED: We are on the right branch but we can see that
+         there is a newer revision either locally or on the remote (in
+         Git terms, we are at an ancestor of the desired branch tip).
+
+       - WRONG: We are on the wrong branch (in Git terms, we are not
+         at the desired branch tip or any ancestor of it).
+
+       - ABSENT: Repo doesn't exist here at all.
+
+       Valid states for pinned libraries:
+
+       - CORRECT: We are at the pinned revision.
+
+       - WRONG: We are at any revision other than the pinned one.
+
+       - ABSENT: Repo doesn't exist here at all.
+    *)
+
+    fun check with_network context ({ libname, branch, pin, ... } : libspec) =
+        let fun check_unpinned () =
+                let val is_newest = if with_network
+                                    then V.is_newest
+                                    else V.is_newest_locally
+                in
+                    case is_newest context (libname, branch) of
+                         ERROR e => ERROR e
+                       | OK true => OK CORRECT
+                       | OK false =>
+                         case V.is_on_branch context (libname, branch) of
+                             ERROR e => ERROR e
+                           | OK true => OK SUPERSEDED
+                           | OK false => OK WRONG
+                end
+            fun check_pinned target =
+                case V.is_at context (libname, target) of
+                    ERROR e => ERROR e
+                  | OK true => OK CORRECT
+                  | OK false => OK WRONG
+            fun check' () =
+                case pin of
+                    UNPINNED => check_unpinned ()
+                  | PINNED target => check_pinned target
+        in
+            case V.exists context libname of
+                ERROR e => ERROR e
+              | OK false => OK (ABSENT, UNMODIFIED)
+              | OK true =>
+                case (check' (), V.is_modified_locally context libname) of
+                    (ERROR e, _) => ERROR e
+                  | (_, ERROR e) => ERROR e
+                  | (OK state, OK true) => OK (state, MODIFIED)
+                  | (OK state, OK false) => OK (state, UNMODIFIED)
+        end
+
+    val review = check true
+    val status = check false
+                         
+    fun update context ({ libname, source, branch, pin, ... } : libspec) =
+        let fun update_unpinned () =
+                case V.is_newest context (libname, branch) of
+                    ERROR e => ERROR e
+                  | OK true => V.id_of context libname
+                  | OK false => V.update context (libname, branch)
+            fun update_pinned target =
+                case V.is_at context (libname, target) of
+                    ERROR e => ERROR e
+                  | OK true => OK target
+                  | OK false => V.update_to context (libname, target)
+            fun update' () =
+                case pin of
+                    UNPINNED => update_unpinned ()
+                  | PINNED target => update_pinned target
+        in
+            case V.exists context libname of
+                ERROR e => ERROR e
+              | OK true => update' ()
+              | OK false =>
+                case V.checkout context (libname, source, branch) of
+                    ERROR e => ERROR e
+                  | OK () => update' ()
+        end
+end
+
+(* Simple Standard ML JSON parser
+   ==============================
+
+   https://bitbucket.org/cannam/sml-simplejson
+
+   An RFC-compliant JSON parser in one SML file with no dependency 
+   on anything outside the Basis library. Also includes a simple
+   serialiser.
+
+   Tested with MLton, Poly/ML, and SML/NJ compilers.
+
+   Parser notes:
+
+   * Complies with RFC 7159, The JavaScript Object Notation (JSON)
+     Data Interchange Format
+
+   * Passes all of the JSONTestSuite parser accept/reject tests that
+     exist at the time of writing, as listed in "Parsing JSON is a
+     Minefield" (http://seriot.ch/parsing_json.php)
+ 
+   * Two-pass parser using naive exploded strings, therefore not
+     particularly fast and not suitable for large input files
+
+   * Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check
+     that JSON strings are valid UTF-8 -- the caller must do that --
+     but does handle \u escapes
+
+   * Converts all numbers to type "real". If that is a 64-bit IEEE
+     float type (common but not guaranteed in SML) then we're pretty
+     standard for a JSON parser
+
+   Copyright 2017 Chris Cannam.
+   Parts based on the JSON parser in the Ponyo library by Phil Eaton.
+
+   Permission is hereby granted, free of charge, to any person
+   obtaining a copy of this software and associated documentation
+   files (the "Software"), to deal in the Software without
+   restriction, including without limitation the rights to use, copy,
+   modify, merge, publish, distribute, sublicense, and/or sell copies
+   of the Software, and to permit persons to whom the Software is
+   furnished to do so, subject to the following conditions:
+
+   The above copyright notice and this permission notice shall be
+   included in all copies or substantial portions of the Software.
+
+   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
+   ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
+   CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+   WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+   Except as contained in this notice, the names of Chris Cannam and
+   Particular Programs Ltd shall not be used in advertising or
+   otherwise to promote the sale, use or other dealings in this
+   Software without prior written authorization.
+*)
+
+signature JSON = sig
+
+    datatype json = OBJECT of (string * json) list
+                  | ARRAY of json list
+                  | NUMBER of real
+                  | STRING of string
+                  | BOOL of bool
+                  | NULL
+
+    datatype 'a result = OK of 'a
+                       | ERROR of string
+
+    val parse : string -> json result
+    val serialise : json -> string
+    val serialiseIndented : json -> string
+
+end
+
+structure Json :> JSON = struct
+
+    datatype json = OBJECT of (string * json) list
+                  | ARRAY of json list
+                  | NUMBER of real
+                  | STRING of string
+                  | BOOL of bool
+                  | NULL
+
+    datatype 'a result = OK of 'a
+                       | ERROR of string
+
+    structure T = struct
+        datatype token = NUMBER of char list
+                       | STRING of string
+                       | BOOL of bool
+                       | NULL
+                       | CURLY_L
+                       | CURLY_R
+                       | SQUARE_L
+                       | SQUARE_R
+                       | COLON
+                       | COMMA
+
+        fun toString t =
+            case t of NUMBER digits => implode digits
+                    | STRING s => s
+                    | BOOL b => Bool.toString b
+                    | NULL => "null"
+                    | CURLY_L => "{"
+                    | CURLY_R => "}"
+                    | SQUARE_L => "["
+                    | SQUARE_R => "]"
+                    | COLON => ":"
+                    | COMMA => ","
+    end
+
+    fun bmpToUtf8 cp =  (* convert a codepoint in Unicode BMP to utf8 bytes *)
+        let open Word
+	    infix 6 orb andb >>
+        in
+            map (Char.chr o toInt)
+                (if cp < 0wx80 then
+                     [cp]
+                 else if cp < 0wx800 then
+                     [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
+                 else if cp < 0wx10000 then
+                     [0wxe0 orb (cp >> 0w12),
+                      0wx80 orb ((cp >> 0w6) andb 0wx3f),
+		      0wx80 orb (cp andb 0wx3f)]
+                 else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
+        end
+                      
+    fun error pos text = ERROR (text ^ " at character position " ^
+                                Int.toString (pos - 1))
+    fun token_error pos = error pos ("Unexpected token")
+
+    fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
+        lex (pos + 3) (T.NULL :: acc) xs
+      | lexNull pos acc _ = token_error pos
+
+    and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
+        lex (pos + 3) (T.BOOL true :: acc) xs
+      | lexTrue pos acc _ = token_error pos
+
+    and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
+        lex (pos + 4) (T.BOOL false :: acc) xs
+      | lexFalse pos acc _ = token_error pos
+
+    and lexChar tok pos acc xs =
+        lex pos (tok :: acc) xs
+        
+    and lexString pos acc cc =
+        let datatype escaped = ESCAPED | NORMAL
+            fun lexString' pos text ESCAPED [] =
+                error pos "End of input during escape sequence"
+              | lexString' pos text NORMAL [] = 
+                error pos "End of input during string"
+              | lexString' pos text ESCAPED (x :: xs) =
+                let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
+                in case x of
+                       #"\"" => esc x
+                     | #"\\" => esc x
+                     | #"/"  => esc x
+                     | #"b"  => esc #"\b"
+                     | #"f"  => esc #"\f"
+                     | #"n"  => esc #"\n"
+                     | #"r"  => esc #"\r"
+                     | #"t"  => esc #"\t"
+                     | _     => error pos ("Invalid escape \\" ^
+                                           Char.toString x)
+                end
+              | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
+                if List.all Char.isHexDigit [a,b,c,d]
+                then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
+                         SOME w => (let val utf = rev (bmpToUtf8 w) in
+                                        lexString' (pos + 6) (utf @ text)
+                                                   NORMAL xs
+                                    end
+                                    handle Fail err => error pos err)
+                       | NONE => error pos "Invalid Unicode BMP escape sequence"
+                else error pos "Invalid Unicode BMP escape sequence"
+              | lexString' pos text NORMAL (x :: xs) =
+                if Char.ord x < 0x20
+                then error pos "Invalid unescaped control character"
+                else
+                    case x of
+                        #"\"" => OK (rev text, xs, pos + 1)
+                      | #"\\" => lexString' (pos + 1) text ESCAPED xs
+                      | _     => lexString' (pos + 1) (x :: text) NORMAL xs
+        in
+            case lexString' pos [] NORMAL cc of
+                OK (text, rest, newpos) =>
+                lex newpos (T.STRING (implode text) :: acc) rest
+              | ERROR e => ERROR e
+        end
+
+    and lexNumber firstChar pos acc cc =
+        let val valid = explode ".+-e"
+            fun lexNumber' pos digits [] = (rev digits, [], pos)
+              | lexNumber' pos digits (x :: xs) =
+                if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
+                else if Char.isDigit x orelse List.exists (fn c => x = c) valid
+                then lexNumber' (pos + 1) (x :: digits) xs
+                else (rev digits, x :: xs, pos)
+            val (digits, rest, newpos) =
+                lexNumber' (pos - 1) [] (firstChar :: cc)
+        in
+            case digits of
+                [] => token_error pos
+              | _ => lex newpos (T.NUMBER digits :: acc) rest
+        end
+                                           
+    and lex pos acc [] = OK (rev acc)
+      | lex pos acc (x::xs) = 
+        (case x of
+             #" "  => lex
+           | #"\t" => lex
+           | #"\n" => lex
+           | #"\r" => lex
+           | #"{"  => lexChar T.CURLY_L
+           | #"}"  => lexChar T.CURLY_R
+           | #"["  => lexChar T.SQUARE_L
+           | #"]"  => lexChar T.SQUARE_R
+           | #":"  => lexChar T.COLON
+           | #","  => lexChar T.COMMA
+           | #"\"" => lexString
+           | #"t"  => lexTrue
+           | #"f"  => lexFalse
+           | #"n"  => lexNull
+           | x     => lexNumber x) (pos + 1) acc xs
+
+    fun show [] = "end of input"
+      | show (tok :: _) = T.toString tok
+
+    fun parseNumber digits =
+        (* Note lexNumber already case-insensitised the E for us *)
+        let open Char
+
+            fun okExpDigits [] = false
+              | okExpDigits (c :: []) = isDigit c
+              | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
+
+            fun okExponent [] = false
+              | okExponent (#"+" :: cs) = okExpDigits cs
+              | okExponent (#"-" :: cs) = okExpDigits cs
+              | okExponent cc = okExpDigits cc
+
+            fun okFracTrailing [] = true
+              | okFracTrailing (c :: cs) =
+                (isDigit c andalso okFracTrailing cs) orelse
+                (c = #"e" andalso okExponent cs)
+
+            fun okFraction [] = false
+              | okFraction (c :: cs) =
+                isDigit c andalso okFracTrailing cs
+
+            fun okPosTrailing [] = true
+              | okPosTrailing (#"." :: cs) = okFraction cs
+              | okPosTrailing (#"e" :: cs) = okExponent cs
+              | okPosTrailing (c :: cs) =
+                isDigit c andalso okPosTrailing cs
+                                                      
+            fun okPositive [] = false
+              | okPositive (#"0" :: []) = true
+              | okPositive (#"0" :: #"." :: cs) = okFraction cs
+              | okPositive (#"0" :: #"e" :: cs) = okExponent cs
+              | okPositive (#"0" :: cs) = false
+              | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
+                    
+            fun okNumber (#"-" :: cs) = okPositive cs
+              | okNumber cc = okPositive cc
+        in
+            if okNumber digits
+            then case Real.fromString (implode digits) of
+                     NONE => ERROR "Number out of range"
+                   | SOME r => OK r
+            else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
+        end
+                                     
+    fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
+      | parseObject tokens =
+        let fun parsePair (T.STRING key :: T.COLON :: xs) =
+                (case parseTokens xs of
+                     ERROR e => ERROR e
+                   | OK (j, xs) => OK ((key, j), xs))
+              | parsePair other =
+                ERROR ("Object key/value pair expected around \"" ^
+                       show other ^ "\"")
+            fun parseObject' acc [] = ERROR "End of input during object"
+              | parseObject' acc tokens =
+                case parsePair tokens of
+                    ERROR e => ERROR e
+                  | OK (pair, T.COMMA :: xs) =>
+                    parseObject' (pair :: acc) xs
+                  | OK (pair, T.CURLY_R :: xs) =>
+                    OK (OBJECT (rev (pair :: acc)), xs)
+                  | OK (_, _) => ERROR "Expected , or } after object element"
+        in
+            parseObject' [] tokens
+        end
+
+    and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
+      | parseArray tokens =
+        let fun parseArray' acc [] = ERROR "End of input during array"
+              | parseArray' acc tokens =
+                case parseTokens tokens of
+                    ERROR e => ERROR e
+                  | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
+                  | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
+                  | OK (_, _) => ERROR "Expected , or ] after array element"
+        in
+            parseArray' [] tokens
+        end
+
+    and parseTokens [] = ERROR "Value expected"
+      | parseTokens (tok :: xs) =
+        (case tok of
+             T.NUMBER d => (case parseNumber d of
+                                OK r => OK (NUMBER r, xs)
+                              | ERROR e => ERROR e)
+           | T.STRING s => OK (STRING s, xs)
+           | T.BOOL b   => OK (BOOL b, xs)
+           | T.NULL     => OK (NULL, xs)
+           | T.CURLY_L  => parseObject xs
+           | T.SQUARE_L => parseArray xs
+           | _ => ERROR ("Unexpected token " ^ T.toString tok ^
+                         " before " ^ show xs))
+                                   
+    fun parse str =
+        case lex 1 [] (explode str) of
+           ERROR e => ERROR e
+         | OK tokens => case parseTokens tokens of
+                            OK (value, []) => OK value
+                          | OK (_, _) => ERROR "Extra data after input"
+                          | ERROR e => ERROR e
+
+    fun stringEscape s =
+        let fun esc x = [x, #"\\"]
+            fun escape' acc [] = rev acc
+              | escape' acc (x :: xs) =
+                escape' (case x of
+                             #"\"" => esc x @ acc
+                           | #"\\" => esc x @ acc
+                           | #"\b" => esc #"b" @ acc
+                           | #"\f" => esc #"f" @ acc
+                           | #"\n" => esc #"n" @ acc
+                           | #"\r" => esc #"r" @ acc
+                           | #"\t" => esc #"t" @ acc
+                           | _ =>
+                             let val c = Char.ord x
+                             in
+                                 if c < 0x20
+                                 then let val hex = Word.toString (Word.fromInt c)
+                                      in (rev o explode) (if c < 0x10
+                                                          then ("\\u000" ^ hex)
+                                                          else ("\\u00" ^ hex))
+                                      end @ acc
+                                 else 
+                                     x :: acc
+                             end)
+                        xs
+        in
+            implode (escape' [] (explode s))
+        end
+        
+    fun serialise json =
+        case json of
+            OBJECT pp => "{" ^ String.concatWith
+                                   "," (map (fn (key, value) =>
+                                                serialise (STRING key) ^ ":" ^
+                                                serialise value) pp) ^
+                         "}"
+          | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
+          | NUMBER n => implode (map (fn #"~" => #"-" | c => c) 
+                                     (explode (Real.toString n)))
+          | STRING s => "\"" ^ stringEscape s ^ "\""
+          | BOOL b => Bool.toString b
+          | NULL => "null"
+        
+    fun serialiseIndented json =
+        let fun indent 0 = ""
+              | indent i = "  " ^ indent (i - 1)
+            fun serialiseIndented' i json =
+                let val ser = serialiseIndented' (i + 1)
+                in
+                    case json of
+                        OBJECT [] => "{}"
+                      | ARRAY [] => "[]"
+                      | OBJECT pp => "{\n" ^ indent (i + 1) ^
+                                     String.concatWith
+                                         (",\n" ^ indent (i + 1))
+                                         (map (fn (key, value) =>
+                                                  ser (STRING key) ^ ": " ^
+                                                  ser value) pp) ^
+                                     "\n" ^ indent i ^ "}"
+                      | ARRAY arr => "[\n" ^ indent (i + 1) ^
+                                     String.concatWith
+                                         (",\n" ^ indent (i + 1))
+                                         (map ser arr) ^
+                                     "\n" ^ indent i ^ "]"
+                      | other => serialise other
+                end
+        in
+            serialiseIndented' 0 json ^ "\n"
+        end
+                                             
+end
+
+
+structure JsonBits :> sig
+    val load_json_from : string -> Json.json (* filename -> json *)
+    val save_json_to : string -> Json.json -> unit
+    val lookup_optional : Json.json -> string list -> Json.json option
+    val lookup_optional_string : Json.json -> string list -> string option
+    val lookup_mandatory : Json.json -> string list -> Json.json
+    val lookup_mandatory_string : Json.json -> string list -> string
+end = struct
+
+    fun load_json_from filename =
+        case Json.parse (FileBits.file_contents filename) of
+            Json.OK json => json
+          | Json.ERROR e => raise Fail ("Failed to parse file: " ^ e)
+
+    fun save_json_to filename json =
+        (* using binary I/O to avoid ever writing CR/LF line endings *)
+        let val jstr = Json.serialiseIndented json
+            val stream = BinIO.openOut filename
+        in
+            BinIO.output (stream, Byte.stringToBytes jstr);
+            BinIO.closeOut stream
+        end
+                                  
+    fun lookup_optional json kk =
+        let fun lookup key =
+                case json of
+                    Json.OBJECT kvs =>
+                    (case List.find (fn (k, v) => k = key) kvs of
+                         SOME (k, v) => SOME v
+                       | NONE => NONE)
+                  | _ => raise Fail "Object expected"
+        in
+            case kk of
+                [] => NONE
+              | key::[] => lookup key
+              | key::kk => case lookup key of
+                               NONE => NONE
+                             | SOME j => lookup_optional j kk
+        end
+                       
+    fun lookup_optional_string json kk =
+        case lookup_optional json kk of
+            SOME (Json.STRING s) => SOME s
+          | SOME _ => raise Fail ("Value (if present) must be string: " ^
+                                  (String.concatWith " -> " kk))
+          | NONE => NONE
+
+    fun lookup_mandatory json kk =
+        case lookup_optional json kk of
+            SOME v => v
+          | NONE => raise Fail ("Value is mandatory: " ^
+                                (String.concatWith " -> " kk) ^ " in json: " ^
+                                (Json.serialise json))
+                          
+    fun lookup_mandatory_string json kk =
+        case lookup_optional json kk of
+            SOME (Json.STRING s) => s
+          | _ => raise Fail ("Value must be string: " ^
+                             (String.concatWith " -> " kk))
+end
+
+structure Provider :> sig
+    val load_providers : Json.json -> provider list
+    val load_more_providers : provider list -> Json.json -> provider list
+    val remote_url : context -> vcs -> source -> libname -> string
+end = struct
+
+    val known_providers : provider list =
+        [ {
+            service = "bitbucket",
+            supports = [HG, GIT],
+            remote_spec = {
+                anon = SOME "https://bitbucket.org/{owner}/{repository}",
+                auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}"
+            }
+          },
+          {
+            service = "github",
+            supports = [GIT],
+            remote_spec = {
+                anon = SOME "https://github.com/{owner}/{repository}",
+                auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}"
+            }
+          }
+        ]
+
+    fun vcs_name vcs =
+        case vcs of GIT => "git" |
+                    HG => "hg"
+                                             
+    fun vcs_from_name name =
+        case name of "git" => GIT 
+                   | "hg" => HG
+                   | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
+
+    fun load_more_providers previously_loaded json =
+        let open JsonBits
+            fun load pjson pname : provider =
+                {
+                  service = pname,
+                  supports =
+                  case lookup_mandatory pjson ["vcs"] of
+                      Json.ARRAY vv =>
+                      map (fn (Json.STRING v) => vcs_from_name v
+                          | _ => raise Fail "Strings expected in vcs array")
+                          vv
+                    | _ => raise Fail "Array expected for vcs",
+                  remote_spec = {
+                      anon = lookup_optional_string pjson ["anonymous"],
+                      auth = lookup_optional_string pjson ["authenticated"]
+                  }
+                }
+            val loaded = 
+                case lookup_optional json ["services"] of
+                    NONE => []
+                  | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
+                  | _ => raise Fail "Object expected for services in config"
+            val newly_loaded =
+                List.filter (fn p => not (List.exists (fn pp => #service p =
+                                                                #service pp)
+                                                      previously_loaded))
+                            loaded
+        in
+            previously_loaded @ newly_loaded
+        end
+
+    fun load_providers json =
+        load_more_providers known_providers json
+                                                    
+    fun expand_spec spec { vcs, service, owner, repo } login =
+        (* ugly *)
+        let fun replace str = 
+                case str of
+                    "vcs" => vcs_name vcs
+                  | "service" => service
+                  | "owner" =>
+                    (case owner of
+                         SOME ostr => ostr
+                       | NONE => raise Fail ("Owner not specified for service " ^
+                                             service))
+                  | "repository" => repo
+                  | "account" =>
+                    (case login of
+                         SOME acc => acc
+                       | NONE => raise Fail ("Account not given for service " ^
+                                             service))
+                  | other => raise Fail ("Unknown variable \"" ^ other ^
+                                         "\" in spec for service " ^ service)
+            fun expand' acc sstr =
+                case Substring.splitl (fn c => c <> #"{") sstr of
+                    (pfx, sfx) =>
+                    if Substring.isEmpty sfx
+                    then rev (pfx :: acc)
+                    else 
+                        case Substring.splitl (fn c => c <> #"}") sfx of
+                            (tok, remainder) =>
+                            if Substring.isEmpty remainder
+                            then rev (tok :: pfx :: acc)
+                            else let val replacement =
+                                         replace
+                                             (* tok begins with "{": *)
+                                             (Substring.string
+                                                  (Substring.triml 1 tok))
+                                 in
+                                     expand' (Substring.full replacement ::
+                                              pfx :: acc)
+                                             (* remainder begins with "}": *)
+                                             (Substring.triml 1 remainder)
+                                 end
+        in
+            Substring.concat (expand' [] (Substring.full spec))
+        end
+        
+    fun provider_url req login providers =
+        case providers of
+            [] => raise Fail ("Unknown service \"" ^ (#service req) ^
+                              "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
+          | ({ service, supports, remote_spec : remote_spec } :: rest) =>
+            if service <> (#service req) orelse
+               not (List.exists (fn v => v = (#vcs req)) supports)
+            then provider_url req login rest
+            else
+                case (login, #auth remote_spec, #anon remote_spec) of
+                    (SOME _, SOME auth, _) => expand_spec auth req login
+                  | (SOME _, _, SOME anon) => expand_spec anon req NONE
+                  | (NONE,   _, SOME anon) => expand_spec anon req NONE
+                  | _ => raise Fail ("No suitable anonymous or authenticated " ^
+                                     "URL spec provided for service \"" ^
+                                     service ^ "\"")
+
+    fun login_for ({ accounts, ... } : context) service =
+        case List.find (fn a => service = #service a) accounts of
+            SOME { login, ... } => SOME login
+          | NONE => NONE
+                                          
+    fun remote_url (context : context) vcs source libname =
+        case source of
+            URL_SOURCE u => u
+          | SERVICE_SOURCE { service, owner, repo } =>
+            provider_url { vcs = vcs,
+                           service = service,
+                           owner = owner,
+                           repo = case repo of
+                                      SOME r => r
+                                    | NONE => libname }
+                         (login_for context service)
+                         (#providers context)
+end
+
+structure HgControl :> VCS_CONTROL = struct
+                            
+    type vcsstate = { id: string, modified: bool,
+                      branch: string, tags: string list }
+
+    val hg_args = [ "--config", "ui.interactive=true" ]
+                        
+    fun hg_command context libname args =
+        FileBits.command context libname ("hg" :: hg_args @ args)
+
+    fun hg_command_output context libname args =
+        FileBits.command_output context libname ("hg" :: hg_args @ args)
+                        
+    fun exists context libname =
+        OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
+        handle _ => OK false
+
+    fun remote_for context (libname, source) =
+        Provider.remote_url context HG source libname
+
+    fun current_state context libname : vcsstate result =
+        let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
+            and extract_branch b =
+                if is_branch b     (* need to remove enclosing parens *)
+                then (implode o rev o tl o rev o tl o explode) b
+                else "default"
+            and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
+            and extract_id id =
+                if is_modified id  (* need to remove trailing "+" *)
+                then (implode o rev o tl o rev o explode) id
+                else id
+            and split_tags tags = String.tokens (fn c => c = #"/") tags
+            and state_for (id, branch, tags) =
+                OK { id = extract_id id,
+                     modified = is_modified id,
+                     branch = extract_branch branch,
+                     tags = split_tags tags }
+        in        
+            case hg_command_output context libname ["id"] of
+                ERROR e => ERROR e
+              | OK out =>
+                case String.tokens (fn x => x = #" ") out of
+                    [id, branch, tags] => state_for (id, branch, tags)
+                  | [id, other] => if is_branch other
+                                   then state_for (id, other, "")
+                                   else state_for (id, "", other)
+                  | [id] => state_for (id, "", "")
+                  | _ => ERROR ("Unexpected output from hg id: " ^ out)
+        end
+
+    fun branch_name branch = case branch of
+                                 DEFAULT_BRANCH => "default"
+                               | BRANCH "" => "default"
+                               | BRANCH b => b
+
+    fun id_of context libname =
+        case current_state context libname of
+            ERROR e => ERROR e
+          | OK { id, ... } => OK id
+
+    fun is_at context (libname, id_or_tag) =
+        case current_state context libname of
+            ERROR e => ERROR e
+          | OK { id, tags, ... } => 
+            OK (String.isPrefix id_or_tag id orelse
+                String.isPrefix id id_or_tag orelse
+                List.exists (fn t => t = id_or_tag) tags)
+
+    fun is_on_branch context (libname, b) =
+        case current_state context libname of
+            ERROR e => ERROR e
+          | OK { branch, ... } => OK (branch = branch_name b)
+               
+    fun is_newest_locally context (libname, branch) =
+        case hg_command_output context libname
+                               ["log", "-l1",
+                                "-b", branch_name branch,
+                                "--template", "{node}"] of
+            ERROR e => ERROR e
+          | OK newest_in_repo => is_at context (libname, newest_in_repo)
+
+    fun pull context libname =
+        hg_command context libname
+                   (if FileBits.verbose ()
+                    then ["pull"]
+                    else ["pull", "-q"])
+
+    fun is_newest context (libname, branch) =
+        case is_newest_locally context (libname, branch) of
+            ERROR e => ERROR e
+          | OK false => OK false
+          | OK true =>
+            case pull context libname of
+                ERROR e => ERROR e
+              | _ => is_newest_locally context (libname, branch)
+
+    fun is_modified_locally context libname =
+        case current_state context libname of
+            ERROR e => ERROR e
+          | OK { modified, ... } => OK modified
+                
+    fun checkout context (libname, source, branch) =
+        let val url = remote_for context (libname, source)
+        in
+            case FileBits.mkpath (FileBits.extpath context) of
+                ERROR e => ERROR e
+              | _ => hg_command context ""
+                                ["clone", "-u", branch_name branch,
+                                 url, libname]
+        end
+                                                    
+    fun update context (libname, branch) =
+        let val pull_result = pull context libname
+        in
+            case hg_command context libname ["update", branch_name branch] of
+                ERROR e => ERROR e
+              | _ =>
+                case pull_result of
+                    ERROR e => ERROR e
+                  | _ => id_of context libname
+        end
+
+    fun update_to context (libname, "") =
+        ERROR "Non-empty id (tag or revision id) required for update_to"
+      | update_to context (libname, id) = 
+        let val pull_result = pull context libname
+        in
+            case hg_command context libname ["update", "-r", id] of
+                OK _ => id_of context libname
+              | ERROR e =>
+                case pull_result of
+                    ERROR e' => ERROR e' (* this was the ur-error *)
+                  | _ => ERROR e
+        end
+                  
+end
+
+structure GitControl :> VCS_CONTROL = struct
+
+    (* With Git repos we always operate in detached HEAD state. Even
+       the master branch is checked out using the remote reference,
+       origin/master. *)
+
+    fun git_command context libname args =
+        FileBits.command context libname ("git" :: args)
+
+    fun git_command_output context libname args =
+        FileBits.command_output context libname ("git" :: args)
+                            
+    fun exists context libname =
+        OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
+        handle _ => OK false
+
+    fun remote_for context (libname, source) =
+        Provider.remote_url context GIT source libname
+
+    fun branch_name branch = case branch of
+                                 DEFAULT_BRANCH => "master"
+                               | BRANCH "" => "master"
+                               | BRANCH b => b
+
+    fun remote_branch_name branch = "origin/" ^ branch_name branch
+
+    fun checkout context (libname, source, branch) =
+        let val url = remote_for context (libname, source)
+        in
+            case FileBits.mkpath (FileBits.extpath context) of
+                OK () => git_command context ""
+                                     ["clone", "-b",
+                                      branch_name branch,
+                                      url, libname]
+              | ERROR e => ERROR e
+        end
+
+    (* NB git rev-parse HEAD shows revision id of current checkout;
+       git rev-list -1 <tag> shows revision id of revision with that tag *)
+
+    fun id_of context libname =
+        git_command_output context libname ["rev-parse", "HEAD"]
+            
+    fun is_at context (libname, id_or_tag) =
+        case id_of context libname of
+            ERROR e => ERROR e
+          | OK id =>
+            if String.isPrefix id_or_tag id orelse
+               String.isPrefix id id_or_tag
+            then OK true
+            else 
+                case git_command_output context libname
+                                        ["show-ref",
+                                         "refs/tags/" ^ id_or_tag] of
+                    OK "" => OK false
+                  | ERROR _ => OK false
+                  | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s))
+
+    fun branch_tip context (libname, branch) =
+        git_command_output context libname
+                           ["rev-list", "-1",
+                            remote_branch_name branch]
+                       
+    fun is_newest_locally context (libname, branch) =
+        case branch_tip context (libname, branch) of
+            ERROR e => ERROR e
+          | OK rev => is_at context (libname, rev)
+
+    fun is_on_branch context (libname, branch) =
+        case branch_tip context (libname, branch) of
+            ERROR e => ERROR e
+          | OK rev =>
+            case is_at context (libname, rev) of
+                ERROR e => ERROR e
+              | OK true => OK true
+              | OK false =>
+                case git_command context libname
+                                 ["merge-base", "--is-ancestor",
+                                  "HEAD", remote_branch_name branch] of
+                    ERROR e => OK false  (* cmd returns non-zero for no *)
+                  | _ => OK true
+
+    fun is_newest context (libname, branch) =
+        case is_newest_locally context (libname, branch) of
+            ERROR e => ERROR e
+          | OK false => OK false
+          | OK true =>
+            case git_command context libname ["fetch"] of
+                ERROR e => ERROR e
+              | _ => is_newest_locally context (libname, branch)
+
+    fun is_modified_locally context libname =
+        case git_command_output context libname ["status", "--porcelain"] of
+            ERROR e => ERROR e
+          | OK "" => OK false
+          | OK _ => OK true
+
+    (* This function updates to the latest revision on a branch rather
+       than to a specific id or tag. We can't just checkout the given
+       branch, as that will succeed even if the branch isn't up to
+       date. We could checkout the branch and then fetch and merge,
+       but it's perhaps cleaner not to maintain a local branch at all,
+       but instead checkout the remote branch as a detached head. *)
+
+    fun update context (libname, branch) =
+        case git_command context libname ["fetch"] of
+            ERROR e => ERROR e
+          | _ =>
+            case git_command context libname ["checkout", "--detach",
+                                              remote_branch_name branch] of
+                ERROR e => ERROR e
+              | _ => id_of context libname
+
+    (* This function is dealing with a specific id or tag, so if we
+       can successfully check it out (detached) then that's all we
+       need to do, regardless of whether fetch succeeded or not. We do
+       attempt the fetch first, though, purely in order to avoid ugly
+       error messages in the common case where we're being asked to
+       update to a new pin (from the lock file) that hasn't been
+       fetched yet. *)
+
+    fun update_to context (libname, "") = 
+        ERROR "Non-empty id (tag or revision id) required for update_to"
+      | update_to context (libname, id) =
+        let val fetch_result = git_command context libname ["fetch"]
+        in
+            case git_command context libname ["checkout", "--detach", id] of
+                OK _ => id_of context libname
+              | ERROR e =>
+                case fetch_result of
+                    ERROR e' => ERROR e' (* this was the ur-error *)
+                  | _ => ERROR e
+        end
+            
+end
+
+structure AnyLibControl :> LIB_CONTROL = struct
+
+    structure H = LibControlFn(HgControl)
+    structure G = LibControlFn(GitControl)
+
+    fun review context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.review | GIT => G.review) vcs context spec
+
+    fun status context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.status | GIT => G.status) vcs context spec
+
+    fun update context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.update | GIT => G.update) vcs context spec
+end
+
+val libobjname = "libraries"
+                                             
+fun load_libspec spec_json lock_json libname : libspec =
+    let open JsonBits
+        val libobj   = lookup_mandatory spec_json [libobjname, libname]
+        val vcs      = lookup_mandatory_string libobj ["vcs"]
+        val retrieve = lookup_optional_string libobj
+        val service  = retrieve ["service"]
+        val owner    = retrieve ["owner"]
+        val repo     = retrieve ["repository"]
+        val url      = retrieve ["url"]
+        val branch   = retrieve ["branch"]
+        val user_pin = retrieve ["pin"]
+        val lock_pin = case lookup_optional lock_json [libobjname, libname] of
+                           SOME ll => lookup_optional_string ll ["pin"]
+                         | NONE => NONE
+    in
+        {
+          libname = libname,
+          vcs = case vcs of
+                    "hg" => HG
+                  | "git" => GIT
+                  | other => raise Fail ("Unknown version-control system \"" ^
+                                         other ^ "\""),
+          source = case (url, service, owner, repo) of
+                       (SOME u, NONE, _, _) => URL_SOURCE u
+                     | (NONE, SOME ss, owner, repo) =>
+                       SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
+                     | _ => raise Fail ("Must have exactly one of service " ^
+                                        "or url string"),
+          pin = case lock_pin of
+                    SOME p => PINNED p
+                  | NONE =>
+                    case user_pin of
+                        SOME p => PINNED p
+                      | NONE => UNPINNED,
+          branch = case branch of
+                       SOME b => BRANCH b
+                     | NONE => DEFAULT_BRANCH
+        }
+    end  
+
+fun load_userconfig () : userconfig =
+    let val home = FileBits.homedir ()
+        val conf_json = 
+            JsonBits.load_json_from
+                (OS.Path.joinDirFile {
+                      dir = home,
+                      file = VextFilenames.user_config_file })
+            handle IO.Io _ => Json.OBJECT []
+    in
+        {
+          accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
+                         NONE => []
+                       | SOME (Json.OBJECT aa) =>
+                         map (fn (k, (Json.STRING v)) =>
+                                 { service = k, login = v }
+                             | _ => raise Fail
+                                          "String expected for account name")
+                             aa
+                       | _ => raise Fail "Array expected for accounts",
+          providers = Provider.load_providers conf_json
+        }
+    end
+
+datatype pintype =
+         NO_LOCKFILE |
+         USE_LOCKFILE
+        
+fun load_project (userconfig : userconfig) rootpath pintype : project =
+    let val spec_file = FileBits.project_spec_path rootpath
+        val lock_file = FileBits.project_lock_path rootpath
+        val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
+                   handle OS.SysErr _ => false
+                then ()
+                else raise Fail ("Failed to open project spec file " ^
+                                 (VextFilenames.project_file) ^ " in " ^
+                                 rootpath ^
+                                 ".\nPlease ensure the spec file is in the " ^
+                                 "project root and run this from there.")
+        val spec_json = JsonBits.load_json_from spec_file
+        val lock_json = if pintype = USE_LOCKFILE
+                        then JsonBits.load_json_from lock_file
+                             handle IO.Io _ => Json.OBJECT []
+                        else Json.OBJECT []
+        val extdir = JsonBits.lookup_mandatory_string spec_json
+                                                      ["config", "extdir"]
+        val spec_libs = JsonBits.lookup_optional spec_json [libobjname]
+        val lock_libs = JsonBits.lookup_optional lock_json [libobjname]
+        val providers = Provider.load_more_providers
+                            (#providers userconfig) spec_json
+        val libnames = case spec_libs of
+                           NONE => []
+                         | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
+                         | _ => raise Fail "Object expected for libs"
+    in
+        {
+          context = {
+            rootpath = rootpath,
+            extdir = extdir,
+            providers = providers,
+            accounts = #accounts userconfig
+          },
+          libs = map (load_libspec spec_json lock_json) libnames
+        }
+    end
+
+fun save_lock_file rootpath locks =
+    let val lock_file = FileBits.project_lock_path rootpath
+        open Json
+        val lock_json =
+            OBJECT [
+                (libobjname,
+                 OBJECT (map (fn { libname, id_or_tag } =>
+                                 (libname,
+                                  OBJECT [ ("pin", STRING id_or_tag) ]))
+                             locks))
+            ]
+    in
+        JsonBits.save_json_to lock_file lock_json
+    end
+        
+fun pad_to n str =
+    if n <= String.size str then str
+    else pad_to n (str ^ " ")
+
+fun hline_to 0 = ""
+  | hline_to n = "-" ^ hline_to (n-1)
+
+val libname_width = 25
+val libstate_width = 11
+val localstate_width = 9
+val notes_width = 5
+val divider = " | "
+
+fun print_status_header () =
+    print ("\r" ^ pad_to 80 "" ^ "\n " ^
+           pad_to libname_width "Library" ^ divider ^
+           pad_to libstate_width "State" ^ divider ^
+           pad_to localstate_width "Local" ^ divider ^
+           "Notes" ^ "\n " ^
+           hline_to libname_width ^ "-+-" ^
+           hline_to libstate_width ^ "-+-" ^
+           hline_to localstate_width ^ "-+-" ^
+           hline_to notes_width ^ "\n")
+
+fun print_outcome_header () =
+    print ("\r" ^ pad_to 80 "" ^ "\n " ^
+           pad_to libname_width "Library" ^ divider ^
+           pad_to libstate_width "Outcome" ^ divider ^
+           "Notes" ^ "\n " ^
+           hline_to libname_width ^ "-+-" ^
+           hline_to libstate_width ^ "-+-" ^
+           hline_to notes_width ^ "\n")
+                        
+fun print_status with_network (libname, status) =
+    let val libstate_str =
+            case status of
+                OK (ABSENT, _) => "Absent"
+              | OK (CORRECT, _) => if with_network then "Correct" else "Present"
+              | OK (SUPERSEDED, _) => "Superseded"
+              | OK (WRONG, _) => "Wrong"
+              | ERROR _ => "Error"
+        val localstate_str =
+            case status of
+                OK (_, MODIFIED) => "Modified"
+              | OK (_, UNMODIFIED) => "Clean"
+              | _ => ""
+        val error_str =
+            case status of
+                ERROR e => e
+              | _ => ""
+    in
+        print (" " ^
+               pad_to libname_width libname ^ divider ^
+               pad_to libstate_width libstate_str ^ divider ^
+               pad_to localstate_width localstate_str ^ divider ^
+               error_str ^ "\n")
+    end
+
+fun print_update_outcome (libname, outcome) =
+    let val outcome_str =
+            case outcome of
+                OK id => "Ok"
+              | ERROR e => "Failed"
+        val error_str =
+            case outcome of
+                ERROR e => e
+              | _ => ""
+    in
+        print (" " ^
+               pad_to libname_width libname ^ divider ^
+               pad_to libstate_width outcome_str ^ divider ^
+               error_str ^ "\n")
+    end
+
+fun act_and_print action print_header print_line (libs : libspec list) =
+    let val lines = map (fn lib => (#libname lib, action lib)) libs
+        val _ = print_header ()
+    in
+        app print_line lines;
+        lines
+    end
+
+fun return_code_for outcomes =
+    foldl (fn ((_, result), acc) =>
+              case result of
+                  ERROR _ => OS.Process.failure
+                | _ => acc)
+          OS.Process.success
+          outcomes
+        
+fun status_of_project ({ context, libs } : project) =
+    return_code_for (act_and_print (AnyLibControl.status context)
+                                   print_status_header (print_status false)
+                                   libs)
+                                             
+fun review_project ({ context, libs } : project) =
+    return_code_for (act_and_print (AnyLibControl.review context)
+                                   print_status_header (print_status true)
+                                   libs)
+
+fun update_project ({ context, libs } : project) =
+    let val outcomes = act_and_print
+                           (AnyLibControl.update context)
+                           print_outcome_header print_update_outcome libs
+        val locks =
+            List.concat
+                (map (fn (libname, result) =>
+                         case result of
+                             ERROR _ => []
+                           | OK id => [{ libname = libname, id_or_tag = id }])
+                     outcomes)
+        val return_code = return_code_for outcomes
+    in
+        if OS.Process.isSuccess return_code
+        then save_lock_file (#rootpath context) locks
+        else ();
+        return_code
+    end
+
+fun load_local_project pintype =
+    let val userconfig = load_userconfig ()
+        val rootpath = OS.FileSys.getDir ()
+    in
+        load_project userconfig rootpath pintype
+    end    
+
+fun with_local_project pintype f =
+    let val return_code = f (load_local_project pintype)
+                          handle e =>
+                                 (print ("Failed with exception: " ^
+                                         (exnMessage e) ^ "\n");
+                                  OS.Process.failure)
+        val _ = print "\n";
+    in
+        return_code
+    end
+        
+fun review () = with_local_project NO_LOCKFILE review_project
+fun status () = with_local_project NO_LOCKFILE status_of_project
+fun update () = with_local_project NO_LOCKFILE update_project
+fun install () = with_local_project USE_LOCKFILE update_project
+
+fun version () =
+    (print ("v" ^ vext_version ^ "\n");
+     OS.Process.success)
+                      
+fun usage () =
+    (print "\nVext ";
+     version ();
+     print ("\nA simple manager for third-party source code dependencies.\n\n"
+            ^ "Usage:\n\n"
+            ^ "  vext <command>\n\n"
+            ^ "where <command> is one of:\n\n"
+            ^ "  status   print quick report on local status only, without using network\n"
+            ^ "  review   check configured libraries against their providers, and report\n"
+            ^ "  install  update configured libraries according to project specs and lock file\n"
+            ^ "  update   update configured libraries and lock file according to project specs\n"
+            ^ "  version  print the Vext version number and exit\n\n");
+    OS.Process.failure)
+
+fun vext args =
+    let val return_code = 
+            case args of
+                ["review"] => review ()
+              | ["status"] => status ()
+              | ["install"] => install ()
+              | ["update"] => update ()
+              | ["version"] => version ()
+              | _ => usage ()
+    in
+        OS.Process.exit return_code;
+        ()
+    end
+        
+fun main () =
+    vext (CommandLine.arguments ())