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