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