sonic-visualiser: repoint.sml comparison

comparison repoint.sml @ 1808:adc8a48f4e4c repoint

Vext -> Repoint. Let's see how this goes.

author	Chris Cannam
date	Wed, 09 May 2018 13:28:55 +0100
parents
children	1b6ffed298a2

comparison

equal deleted inserted replaced

-:dc4e6eb475ed
+:adc8a48f4e4c
+(*
+DO NOT EDIT THIS FILE.
+This file is automatically generated from the individual
+source files in the Repoint repository.
+*)
+(*
+Repoint
+A simple manager for third-party source code dependencies
+Copyright 2018 Chris Cannam, Particular Programs Ltd,
+and Queen Mary, University of London
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use, copy,
+modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
+ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+Except as contained in this notice, the names of Chris Cannam,
+Particular Programs Ltd, and Queen Mary, University of London
+shall not be used in advertising or otherwise to promote the sale,
+use or other dealings in this Software without prior written
+authorization.
+*)
+val repoint_version = "0.9.98"
+datatype vcs =
+HG |
+GIT |
+SVN
+datatype source =
+URL_SOURCE of string |
+SERVICE_SOURCE of {
+service : string,
+owner : string option,
+repo : string option
+}
+type id_or_tag = string
+datatype pin =
+UNPINNED |
+PINNED of id_or_tag
+datatype libstate =
+ABSENT |
+CORRECT |
+SUPERSEDED |
+WRONG
+datatype localstate =
+MODIFIED |
+LOCK_MISMATCHED |
+CLEAN
+datatype branch =
+BRANCH of string |
+DEFAULT_BRANCH
+(* If we can recover from an error, for example by reporting failure
+for this one thing and going on to the next thing, then the error
+should usually be returned through a result type rather than an
+exception. *)
+datatype 'a result =
+OK of 'a |
+ERROR of string
+type libname = string
+type libspec = {
+libname : libname,
+vcs : vcs,
+source : source,
+branch : branch,
+project_pin : pin,
+lock_pin : pin
+}
+type lock = {
+libname : libname,
+id_or_tag : id_or_tag
+}
+type remote_spec = {
+anon : string option,
+auth : string option
+}
+type provider = {
+service : string,
+supports : vcs list,
+remote_spec : remote_spec
+}
+type account = {
+service : string,
+login : string
+}
+type context = {
+rootpath : string,
+extdir : string,
+providers : provider list,
+accounts : account list
+}
+type userconfig = {
+providers : provider list,
+accounts : account list
+}
+type project = {
+context : context,
+libs : libspec list
+}
+structure RepointFilenames = struct
+val project_file = "repoint-project.json"
+val project_lock_file = "repoint-lock.json"
+val user_config_file = ".repoint.json"
+val archive_dir = ".repoint-archive"
+end
+signature VCS_CONTROL = sig
+(** Check whether the given VCS is installed and working *)
+val is_working : context -> bool result
+(** Test whether the library is present locally at all *)
+val exists : context -> libname -> bool result
+(** Return the id (hash) of the current revision for the library *)
+val id_of : context -> libname -> id_or_tag result
+(** Test whether the library is at the given id *)
+val is_at : context -> libname * id_or_tag -> bool result
+(** Test whether the library is on the given branch, i.e. is at
+the branch tip or an ancestor of it *)
+val is_on_branch : context -> libname * branch -> bool result
+(** Test whether the library is at the newest revision for the
+given branch. False may indicate that the branch has advanced
+or that the library is not on the branch at all. This function
+may use the network to check for new revisions *)
+val is_newest : context -> libname * source * branch -> bool result
+(** Test whether the library is at the newest revision available
+locally for the given branch. False may indicate that the
+branch has advanced or that the library is not on the branch
+at all. This function must not use the network *)
+val is_newest_locally : context -> libname * branch -> bool result
+(** Test whether the library has been modified in the local
+working copy *)
+val is_modified_locally : context -> libname -> bool result
+(** Check out, i.e. clone a fresh copy of, the repo for the given
+library on the given branch *)
+val checkout : context -> libname * source * branch -> unit result
+(** Update the library to the given branch tip. Assumes that a
+local copy of the library already exists *)
+val update : context -> libname * source * branch -> unit result
+(** Update the library to the given specific id or tag *)
+val update_to : context -> libname * source * id_or_tag -> unit result
+(** Return a URL from which the library can be cloned, given that
+the local copy already exists. For a DVCS this can be the
+local copy, but for a centralised VCS it will have to be the
+remote repository URL. Used for archiving *)
+val copy_url_for : context -> libname -> string result
+end
+signature LIB_CONTROL = sig
+val review : context -> libspec -> (libstate * localstate) result
+val status : context -> libspec -> (libstate * localstate) result
+val update : context -> libspec -> unit result
+val id_of : context -> libspec -> id_or_tag result
+val is_working : context -> vcs -> bool result
+end
+structure FileBits :> sig
+val extpath : context -> string
+val libpath : context -> libname -> string
+val subpath : context -> libname -> string -> string
+val command_output : context -> libname -> string list -> string result
+val command : context -> libname -> string list -> unit result
+val file_url : string -> string
+val file_contents : string -> string
+val mydir : unit -> string
+val homedir : unit -> string
+val mkpath : string -> unit result
+val rmpath : string -> unit result
+val nonempty_dir_exists : string -> bool
+val project_spec_path : string -> string
+val project_lock_path : string -> string
+val verbose : unit -> bool
+end = struct
+fun verbose () =
+case OS.Process.getEnv "REPOINT_VERBOSE" of
+SOME "0" => false
+| SOME _ => true
+| NONE => false
+fun split_relative path desc =
+case OS.Path.fromString path of
+{ isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
+| { arcs, ... } => arcs
+fun extpath ({ rootpath, extdir, ... } : context) =
+let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
+in OS.Path.toString {
+isAbs = isAbs,
+vol = vol,
+arcs = arcs @
+split_relative extdir "extdir"
+}
+end
+fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
+(* NB libname is allowed to be a path fragment, e.g. foo/bar *)
+let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
+in OS.Path.toString {
+isAbs = isAbs,
+vol = vol,
+arcs = arcs @
+split_relative extdir "extdir" @
+split_relative libname "library path" @
+split_relative remainder "subpath"
+}
+end
+fun libpath context "" =
+extpath context
+| libpath context libname =
+subpath context libname ""
+fun project_file_path rootpath filename =
+let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
+in OS.Path.toString {
+isAbs = isAbs,
+vol = vol,
+arcs = arcs @ [ filename ]
+}
+end
+fun project_spec_path rootpath =
+project_file_path rootpath (RepointFilenames.project_file)
+fun project_lock_path rootpath =
+project_file_path rootpath (RepointFilenames.project_lock_file)
+fun trim str =
+hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
+fun file_url path =
+let val forward_path =
+String.translate (fn #"\\" => "/" |
+c => Char.toString c)
+(OS.Path.mkCanonical path)
+in
+(* Path is expected to be absolute already, but if it
+starts with a drive letter, we'll need an extra slash *)
+case explode forward_path of
+#"/"::rest => "file:///" ^ implode rest
+| _ => "file:///" ^ forward_path
+end
+fun file_contents filename =
+let val stream = TextIO.openIn filename
+fun read_all str acc =
+case TextIO.inputLine str of
+SOME line => read_all str (trim line :: acc)
+| NONE => rev acc
+val contents = read_all stream []
+val _ = TextIO.closeIn stream
+in
+String.concatWith "\n" contents
+end
+fun expand_commandline cmdlist =
+(* We are quite strict about what we accept here, except
+for the first element in cmdlist which is assumed to be a
+known command location rather than arbitrary user input. *)
+let open Char
+fun quote arg =
+if List.all
+(fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
+(explode arg)
+then arg
+else "\"" ^ arg ^ "\""
+fun check arg =
+let val valid = explode " /#:;?,._-{}@=+"
+in
+app (fn c =>
+if isAlphaNum c orelse
+List.exists (fn v => v = c) valid orelse
+c > chr 127
+then ()
+else raise Fail ("Invalid character '" ^
+(Char.toString c) ^
+"' in command list"))
+(explode arg);
+arg
+end
+in
+String.concatWith " "
+(map quote
+(hd cmdlist :: map check (tl cmdlist)))
+end
+val tick_cycle = ref 0
+val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
+fun tick libname cmdlist =
+let val n = Vector.length tick_chars
+fun pad_to n str =
+if n <= String.size str then str
+else pad_to n (str ^ " ")
+val name = if libname <> "" then libname
+else if cmdlist = nil then ""
+else hd (rev cmdlist)
+in
+print ("  " ^
+Vector.sub(tick_chars, !tick_cycle) ^ " " ^
+pad_to 70 name ^
+"\r");
+tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
+end
+fun run_command context libname cmdlist redirect =
+let open OS
+val dir = libpath context libname
+val cmd = expand_commandline cmdlist
+val _ = if verbose ()
+then print ("\n=== " ^ dir ^ "\n<<< " ^ cmd ^ "\n")
+else tick libname cmdlist
+val _ = FileSys.chDir dir
+val status = case redirect of
+NONE => Process.system cmd
+| SOME file => Process.system (cmd ^ ">" ^ file)
+in
+if Process.isSuccess status
+then OK ()
+else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
+end
+handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
+fun command context libname cmdlist =
+run_command context libname cmdlist NONE
+fun command_output context libname cmdlist =
+let open OS
+val tmpFile = FileSys.tmpName ()
+val result = run_command context libname cmdlist (SOME tmpFile)
+val contents = file_contents tmpFile
+val _ = if verbose ()
+then print (">>> \"" ^ contents ^ "\"\n")
+else ()
+in
+FileSys.remove tmpFile handle _ => ();
+case result of
+OK () => OK contents
+| ERROR e => ERROR e
+end
+fun mydir () =
+let open OS
+val { dir, file } = Path.splitDirFile (CommandLine.name ())
+in
+FileSys.realPath
+(if Path.isAbsolute dir
+then dir
+else Path.concat (FileSys.getDir (), dir))
+end
+fun homedir () =
+(* Failure is not routine, so we use an exception here *)
+case (OS.Process.getEnv "HOME",
+OS.Process.getEnv "HOMEPATH") of
+(SOME home, _) => home
+| (NONE, SOME home) => home
+| (NONE, NONE) =>
+raise Fail "Failed to look up home directory from environment"
+fun mkpath' path =
+if OS.FileSys.isDir path handle _ => false
+then OK ()
+else case OS.Path.fromString path of
+{ arcs = nil, ... } => OK ()
+| { isAbs = false, ... } => ERROR "mkpath requires absolute path"
+| { isAbs, vol, arcs } =>
+case mkpath' (OS.Path.toString {      (* parent *)
+isAbs = isAbs,
+vol = vol,
+arcs = rev (tl (rev arcs)) }) of
+ERROR e => ERROR e
+| OK () => ((OS.FileSys.mkDir path; OK ())
+handle OS.SysErr (e, _) =>
+ERROR ("Directory creation failed: " ^ e))
+fun mkpath path =
+mkpath' (OS.Path.mkCanonical path)
+fun dir_contents dir =
+let open OS
+fun files_from dirstream =
+case FileSys.readDir dirstream of
+NONE => []
+| SOME file =>
+(* readDir is supposed to filter these,
+but let's be extra cautious: *)
+if file = Path.parentArc orelse file = Path.currentArc
+then files_from dirstream
+else file :: files_from dirstream
+val stream = FileSys.openDir dir
+val files = map (fn f => Path.joinDirFile
+{ dir = dir, file = f })
+(files_from stream)
+val _ = FileSys.closeDir stream
+in
+files
+end
+fun rmpath' path =
+let open OS
+fun remove path =
+if FileSys.isLink path (* dangling links bother isDir *)
+then FileSys.remove path
+else if FileSys.isDir path
+then (app remove (dir_contents path); FileSys.rmDir path)
+else FileSys.remove path
+in
+(remove path; OK ())
+handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
+end
+fun rmpath path =
+rmpath' (OS.Path.mkCanonical path)
+fun nonempty_dir_exists path =
+let open OS.FileSys
+in
+(not (isLink path) andalso
+isDir path andalso
+dir_contents path <> [])
+handle _ => false
+end
+end
+functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
+(* Valid states for unpinned libraries:
+- CORRECT: We are on the right branch and are up-to-date with
+it as far as we can tell. (If not using the network, this
+should be reported to user as "Present" rather than "Correct"
+as the remote repo may have advanced without us knowing.)
+- SUPERSEDED: We are on the right branch but we can see that
+there is a newer revision either locally or on the remote (in
+Git terms, we are at an ancestor of the desired branch tip).
+- WRONG: We are on the wrong branch (in Git terms, we are not
+at the desired branch tip or any ancestor of it).
+- ABSENT: Repo doesn't exist here at all.
+Valid states for pinned libraries:
+- CORRECT: We are at the pinned revision.
+- WRONG: We are at any revision other than the pinned one.
+- ABSENT: Repo doesn't exist here at all.
+*)
+fun check with_network context
+({ libname, source, branch,
+project_pin, lock_pin, ... } : libspec) =
+let fun check_unpinned () =
+let val newest =
+if with_network
+then V.is_newest context (libname, source, branch)
+else V.is_newest_locally context (libname, branch)
+in
+case newest of
+ERROR e => ERROR e
+| OK true => OK CORRECT
+| OK false =>
+case V.is_on_branch context (libname, branch) of
+ERROR e => ERROR e
+| OK true => OK SUPERSEDED
+| OK false => OK WRONG
+end
+fun check_pinned target =
+case V.is_at context (libname, target) of
+ERROR e => ERROR e
+| OK true => OK CORRECT
+| OK false => OK WRONG
+fun check_remote () =
+case project_pin of
+UNPINNED => check_unpinned ()
+| PINNED target => check_pinned target
+fun check_local () =
+case V.is_modified_locally context libname of
+ERROR e => ERROR e
+| OK true  => OK MODIFIED
+| OK false =>
+case lock_pin of
+UNPINNED => OK CLEAN
+| PINNED target =>
+case V.is_at context (libname, target) of
+ERROR e => ERROR e
+| OK true => OK CLEAN
+| OK false => OK LOCK_MISMATCHED
+in
+case V.exists context libname of
+ERROR e => ERROR e
+| OK false => OK (ABSENT, CLEAN)
+| OK true =>
+case (check_remote (), check_local ()) of
+(ERROR e, _) => ERROR e
+| (_, ERROR e) => ERROR e
+| (OK r, OK l) => OK (r, l)
+end
+val review = check true
+val status = check false
+fun update context
+({ libname, source, branch,
+project_pin, lock_pin, ... } : libspec) =
+let fun update_unpinned () =
+case V.is_newest context (libname, source, branch) of
+ERROR e => ERROR e
+| OK true => OK ()
+| OK false => V.update context (libname, source, branch)
+fun update_pinned target =
+case V.is_at context (libname, target) of
+ERROR e => ERROR e
+| OK true => OK ()
+| OK false => V.update_to context (libname, source, target)
+fun update' () =
+case lock_pin of
+PINNED target => update_pinned target
+| UNPINNED =>
+case project_pin of
+PINNED target => update_pinned target
+| UNPINNED => update_unpinned ()
+in
+case V.exists context libname of
+ERROR e => ERROR e
+| OK true => update' ()
+| OK false =>
+case V.checkout context (libname, source, branch) of
+ERROR e => ERROR e
+| OK () => update' ()
+end
+fun id_of context ({ libname, ... } : libspec) =
+V.id_of context libname
+fun is_working context vcs =
+V.is_working context
+end
+(* Simple Standard ML JSON parser
+https://bitbucket.org/cannam/sml-simplejson
+Copyright 2017 Chris Cannam. BSD licence.
+Parts based on the JSON parser in the Ponyo library by Phil Eaton.
+*)
+signature JSON = sig
+datatype json = OBJECT of (string * json) list
+| ARRAY of json list
+| NUMBER of real
+| STRING of string
+| BOOL of bool
+| NULL
+datatype 'a result = OK of 'a
+| ERROR of string
+val parse : string -> json result
+val serialise : json -> string
+val serialiseIndented : json -> string
+end
+structure Json :> JSON = struct
+datatype json = OBJECT of (string * json) list
+| ARRAY of json list
+| NUMBER of real
+| STRING of string
+| BOOL of bool
+| NULL
+datatype 'a result = OK of 'a
+| ERROR of string
+structure T = struct
+datatype token = NUMBER of char list
+| STRING of string
+| BOOL of bool
+| NULL
+| CURLY_L
+| CURLY_R
+| SQUARE_L
+| SQUARE_R
+| COLON
+| COMMA
+fun toString t =
+case t of NUMBER digits => implode digits
+| STRING s => s
+| BOOL b => Bool.toString b
+| NULL => "null"
+| CURLY_L => "{"
+| CURLY_R => "}"
+| SQUARE_L => "["
+| SQUARE_R => "]"
+| COLON => ":"
+| COMMA => ","
+end
+fun bmpToUtf8 cp =  (* convert a codepoint in Unicode BMP to utf8 bytes *)
+let open Word
+	    infix 6 orb andb >>
+in
+map (Char.chr o toInt)
+(if cp < 0wx80 then
+[cp]
+else if cp < 0wx800 then
+[0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
+else if cp < 0wx10000 then
+[0wxe0 orb (cp >> 0w12),
+0wx80 orb ((cp >> 0w6) andb 0wx3f),
+		      0wx80 orb (cp andb 0wx3f)]
+else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
+end
+fun error pos text = ERROR (text ^ " at character position " ^
+Int.toString (pos - 1))
+fun token_error pos = error pos ("Unexpected token")
+fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
+lex (pos + 3) (T.NULL :: acc) xs
+| lexNull pos acc _ = token_error pos
+and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
+lex (pos + 3) (T.BOOL true :: acc) xs
+| lexTrue pos acc _ = token_error pos
+and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
+lex (pos + 4) (T.BOOL false :: acc) xs
+| lexFalse pos acc _ = token_error pos
+and lexChar tok pos acc xs =
+lex pos (tok :: acc) xs
+and lexString pos acc cc =
+let datatype escaped = ESCAPED | NORMAL
+fun lexString' pos text ESCAPED [] =
+error pos "End of input during escape sequence"
+| lexString' pos text NORMAL [] =
+error pos "End of input during string"
+| lexString' pos text ESCAPED (x :: xs) =
+let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
+in case x of
+#"\"" => esc x
+| #"\\" => esc x
+| #"/"  => esc x
+| #"b"  => esc #"\b"
+| #"f"  => esc #"\f"
+| #"n"  => esc #"\n"
+| #"r"  => esc #"\r"
+| #"t"  => esc #"\t"
+| _     => error pos ("Invalid escape \\" ^
+Char.toString x)
+end
+| lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
+if List.all Char.isHexDigit [a,b,c,d]
+then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
+SOME w => (let val utf = rev (bmpToUtf8 w) in
+lexString' (pos + 6) (utf @ text)
+NORMAL xs
+end
+handle Fail err => error pos err)
+| NONE => error pos "Invalid Unicode BMP escape sequence"
+else error pos "Invalid Unicode BMP escape sequence"
+| lexString' pos text NORMAL (x :: xs) =
+if Char.ord x < 0x20
+then error pos "Invalid unescaped control character"
+else
+case x of
+#"\"" => OK (rev text, xs, pos + 1)
+| #"\\" => lexString' (pos + 1) text ESCAPED xs
+| _     => lexString' (pos + 1) (x :: text) NORMAL xs
+in
+case lexString' pos [] NORMAL cc of
+OK (text, rest, newpos) =>
+lex newpos (T.STRING (implode text) :: acc) rest
+| ERROR e => ERROR e
+end
+and lexNumber firstChar pos acc cc =
+let val valid = explode ".+-e"
+fun lexNumber' pos digits [] = (rev digits, [], pos)
+| lexNumber' pos digits (x :: xs) =
+if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
+else if Char.isDigit x orelse List.exists (fn c => x = c) valid
+then lexNumber' (pos + 1) (x :: digits) xs
+else (rev digits, x :: xs, pos)
+val (digits, rest, newpos) =
+lexNumber' (pos - 1) [] (firstChar :: cc)
+in
+case digits of
+[] => token_error pos
+| _ => lex newpos (T.NUMBER digits :: acc) rest
+end
+and lex pos acc [] = OK (rev acc)
+| lex pos acc (x::xs) =
+(case x of
+#" "  => lex
+| #"\t" => lex
+| #"\n" => lex
+| #"\r" => lex
+| #"{"  => lexChar T.CURLY_L
+| #"}"  => lexChar T.CURLY_R
+| #"["  => lexChar T.SQUARE_L
+| #"]"  => lexChar T.SQUARE_R
+| #":"  => lexChar T.COLON
+| #","  => lexChar T.COMMA
+| #"\"" => lexString
+| #"t"  => lexTrue
+| #"f"  => lexFalse
+| #"n"  => lexNull
+| x     => lexNumber x) (pos + 1) acc xs
+fun show [] = "end of input"
+| show (tok :: _) = T.toString tok
+fun parseNumber digits =
+(* Note lexNumber already case-insensitised the E for us *)
+let open Char
+fun okExpDigits [] = false
+| okExpDigits (c :: []) = isDigit c
+| okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
+fun okExponent [] = false
+| okExponent (#"+" :: cs) = okExpDigits cs
+| okExponent (#"-" :: cs) = okExpDigits cs
+| okExponent cc = okExpDigits cc
+fun okFracTrailing [] = true
+| okFracTrailing (c :: cs) =
+(isDigit c andalso okFracTrailing cs) orelse
+(c = #"e" andalso okExponent cs)
+fun okFraction [] = false
+| okFraction (c :: cs) =
+isDigit c andalso okFracTrailing cs
+fun okPosTrailing [] = true
+| okPosTrailing (#"." :: cs) = okFraction cs
+| okPosTrailing (#"e" :: cs) = okExponent cs
+| okPosTrailing (c :: cs) =
+isDigit c andalso okPosTrailing cs
+fun okPositive [] = false
+| okPositive (#"0" :: []) = true
+| okPositive (#"0" :: #"." :: cs) = okFraction cs
+| okPositive (#"0" :: #"e" :: cs) = okExponent cs
+| okPositive (#"0" :: cs) = false
+| okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
+fun okNumber (#"-" :: cs) = okPositive cs
+| okNumber cc = okPositive cc
+in
+if okNumber digits
+then case Real.fromString (implode digits) of
+NONE => ERROR "Number out of range"
+| SOME r => OK r
+else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
+end
+fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
+| parseObject tokens =
+let fun parsePair (T.STRING key :: T.COLON :: xs) =
+(case parseTokens xs of
+ERROR e => ERROR e
+| OK (j, xs) => OK ((key, j), xs))
+| parsePair other =
+ERROR ("Object key/value pair expected around \"" ^
+show other ^ "\"")
+fun parseObject' acc [] = ERROR "End of input during object"
+| parseObject' acc tokens =
+case parsePair tokens of
+ERROR e => ERROR e
+| OK (pair, T.COMMA :: xs) =>
+parseObject' (pair :: acc) xs
+| OK (pair, T.CURLY_R :: xs) =>
+OK (OBJECT (rev (pair :: acc)), xs)
+| OK (_, _) => ERROR "Expected , or } after object element"
+in
+parseObject' [] tokens
+end
+and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
+| parseArray tokens =
+let fun parseArray' acc [] = ERROR "End of input during array"
+| parseArray' acc tokens =
+case parseTokens tokens of
+ERROR e => ERROR e
+| OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
+| OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
+| OK (_, _) => ERROR "Expected , or ] after array element"
+in
+parseArray' [] tokens
+end
+and parseTokens [] = ERROR "Value expected"
+| parseTokens (tok :: xs) =
+(case tok of
+T.NUMBER d => (case parseNumber d of
+OK r => OK (NUMBER r, xs)
+| ERROR e => ERROR e)
+| T.STRING s => OK (STRING s, xs)
+| T.BOOL b   => OK (BOOL b, xs)
+| T.NULL     => OK (NULL, xs)
+| T.CURLY_L  => parseObject xs
+| T.SQUARE_L => parseArray xs
+| _ => ERROR ("Unexpected token " ^ T.toString tok ^
+" before " ^ show xs))
+fun parse str =
+case lex 1 [] (explode str) of
+ERROR e => ERROR e
+| OK tokens => case parseTokens tokens of
+OK (value, []) => OK value
+| OK (_, _) => ERROR "Extra data after input"
+| ERROR e => ERROR e
+fun stringEscape s =
+let fun esc x = [x, #"\\"]
+fun escape' acc [] = rev acc
+| escape' acc (x :: xs) =
+escape' (case x of
+#"\"" => esc x @ acc
+| #"\\" => esc x @ acc
+| #"\b" => esc #"b" @ acc
+| #"\f" => esc #"f" @ acc
+| #"\n" => esc #"n" @ acc
+| #"\r" => esc #"r" @ acc
+| #"\t" => esc #"t" @ acc
+| _ =>
+let val c = Char.ord x
+in
+if c < 0x20
+then let val hex = Word.toString (Word.fromInt c)
+in (rev o explode) (if c < 0x10
+then ("\\u000" ^ hex)
+else ("\\u00" ^ hex))
+end @ acc
+else
+x :: acc
+end)
+xs
+in
+implode (escape' [] (explode s))
+end
+fun serialise json =
+case json of
+OBJECT pp => "{" ^ String.concatWith
+"," (map (fn (key, value) =>
+serialise (STRING key) ^ ":" ^
+serialise value) pp) ^
+"}"
+| ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
+| NUMBER n => implode (map (fn #"~" => #"-" | c => c)
+(explode (Real.toString n)))
+| STRING s => "\"" ^ stringEscape s ^ "\""
+| BOOL b => Bool.toString b
+| NULL => "null"
+fun serialiseIndented json =
+let fun indent 0 = ""
+| indent i = "  " ^ indent (i - 1)
+fun serialiseIndented' i json =
+let val ser = serialiseIndented' (i + 1)
+in
+case json of
+OBJECT [] => "{}"
+| ARRAY [] => "[]"
+| OBJECT pp => "{\n" ^ indent (i + 1) ^
+String.concatWith
+(",\n" ^ indent (i + 1))
+(map (fn (key, value) =>
+ser (STRING key) ^ ": " ^
+ser value) pp) ^
+"\n" ^ indent i ^ "}"
+| ARRAY arr => "[\n" ^ indent (i + 1) ^
+String.concatWith
+(",\n" ^ indent (i + 1))
+(map ser arr) ^
+"\n" ^ indent i ^ "]"
+| other => serialise other
+end
+in
+serialiseIndented' 0 json ^ "\n"
+end
+end
+structure JsonBits :> sig
+exception Config of string
+val load_json_from : string -> Json.json (* filename -> json *)
+val save_json_to : string -> Json.json -> unit
+val lookup_optional : Json.json -> string list -> Json.json option
+val lookup_optional_string : Json.json -> string list -> string option
+val lookup_mandatory : Json.json -> string list -> Json.json
+val lookup_mandatory_string : Json.json -> string list -> string
+end = struct
+exception Config of string
+fun load_json_from filename =
+case Json.parse (FileBits.file_contents filename) of
+Json.OK json => json
+| Json.ERROR e => raise Config ("Failed to parse file: " ^ e)
+fun save_json_to filename json =
+(* using binary I/O to avoid ever writing CR/LF line endings *)
+let val jstr = Json.serialiseIndented json
+val stream = BinIO.openOut filename
+in
+BinIO.output (stream, Byte.stringToBytes jstr);
+BinIO.closeOut stream
+end
+fun lookup_optional json kk =
+let fun lookup key =
+case json of
+Json.OBJECT kvs =>
+(case List.filter (fn (k, v) => k = key) kvs of
+[] => NONE
+| [(_,v)] => SOME v
+| _ => raise Config ("Duplicate key: " ^
+(String.concatWith " -> " kk)))
+| _ => raise Config "Object expected"
+in
+case kk of
+[] => NONE
+| key::[] => lookup key
+| key::kk => case lookup key of
+NONE => NONE
+| SOME j => lookup_optional j kk
+end
+fun lookup_optional_string json kk =
+case lookup_optional json kk of
+SOME (Json.STRING s) => SOME s
+| SOME _ => raise Config ("Value (if present) must be string: " ^
+(String.concatWith " -> " kk))
+| NONE => NONE
+fun lookup_mandatory json kk =
+case lookup_optional json kk of
+SOME v => v
+| NONE => raise Config ("Value is mandatory: " ^
+(String.concatWith " -> " kk))
+fun lookup_mandatory_string json kk =
+case lookup_optional json kk of
+SOME (Json.STRING s) => s
+| _ => raise Config ("Value must be string: " ^
+(String.concatWith " -> " kk))
+end
+structure Provider :> sig
+val load_providers : Json.json -> provider list
+val load_more_providers : provider list -> Json.json -> provider list
+val remote_url : context -> vcs -> source -> libname -> string
+end = struct
+val known_providers : provider list =
+[ {
+service = "bitbucket",
+supports = [HG, GIT],
+remote_spec = {
+anon = SOME "https://bitbucket.org/{owner}/{repository}",
+auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}"
+}
+},
+{
+service = "github",
+supports = [GIT],
+remote_spec = {
+anon = SOME "https://github.com/{owner}/{repository}",
+auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}"
+}
+}
+]
+fun vcs_name vcs =
+case vcs of HG => "hg"
+| GIT => "git"
+| SVN => "svn"
+fun vcs_from_name name =
+case name of "hg" => HG
+| "git" => GIT
+| "svn" => SVN
+| other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
+fun load_more_providers previously_loaded json =
+let open JsonBits
+fun load pjson pname : provider =
+{
+service = pname,
+supports =
+case lookup_mandatory pjson ["vcs"] of
+Json.ARRAY vv =>
+map (fn (Json.STRING v) => vcs_from_name v
+| _ => raise Fail "Strings expected in vcs array")
+vv
+| _ => raise Fail "Array expected for vcs",
+remote_spec = {
+anon = lookup_optional_string pjson ["anonymous"],
+auth = lookup_optional_string pjson ["authenticated"]
+}
+}
+val loaded =
+case lookup_optional json ["services"] of
+NONE => []
+| SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
+| _ => raise Fail "Object expected for services in config"
+val newly_loaded =
+List.filter (fn p => not (List.exists (fn pp => #service p =
+#service pp)
+previously_loaded))
+loaded
+in
+previously_loaded @ newly_loaded
+end
+fun load_providers json =
+load_more_providers known_providers json
+fun expand_spec spec { vcs, service, owner, repo } login =
+(* ugly *)
+let fun replace str =
+case str of
+"vcs" => vcs_name vcs
+| "service" => service
+| "owner" =>
+(case owner of
+SOME ostr => ostr
+| NONE => raise Fail ("Owner not specified for service " ^
+service))
+| "repository" => repo
+| "account" =>
+(case login of
+SOME acc => acc
+| NONE => raise Fail ("Account not given for service " ^
+service))
+| other => raise Fail ("Unknown variable \"" ^ other ^
+"\" in spec for service " ^ service)
+fun expand' acc sstr =
+case Substring.splitl (fn c => c <> #"{") sstr of
+(pfx, sfx) =>
+if Substring.isEmpty sfx
+then rev (pfx :: acc)
+else
+case Substring.splitl (fn c => c <> #"}") sfx of
+(tok, remainder) =>
+if Substring.isEmpty remainder
+then rev (tok :: pfx :: acc)
+else let val replacement =
+replace
+(* tok begins with "{": *)
+(Substring.string
+(Substring.triml 1 tok))
+in
+expand' (Substring.full replacement ::
+pfx :: acc)
+(* remainder begins with "}": *)
+(Substring.triml 1 remainder)
+end
+in
+Substring.concat (expand' [] (Substring.full spec))
+end
+fun provider_url req login providers =
+case providers of
+[] => raise Fail ("Unknown service \"" ^ (#service req) ^
+"\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
+| ({ service, supports, remote_spec : remote_spec } :: rest) =>
+if service <> (#service req) orelse
+not (List.exists (fn v => v = (#vcs req)) supports)
+then provider_url req login rest
+else
+case (login, #auth remote_spec, #anon remote_spec) of
+(SOME _, SOME auth, _) => expand_spec auth req login
+| (SOME _, _, SOME anon) => expand_spec anon req NONE
+| (NONE,   _, SOME anon) => expand_spec anon req NONE
+| _ => raise Fail ("No suitable anonymous or authenticated " ^
+"URL spec provided for service \"" ^
+service ^ "\"")
+fun login_for ({ accounts, ... } : context) service =
+case List.find (fn a => service = #service a) accounts of
+SOME { login, ... } => SOME login
+| NONE => NONE
+fun reponame_for path =
+case String.tokens (fn c => c = #"/") path of
+[] => raise Fail "Non-empty library path required"
+| toks => hd (rev toks)
+fun remote_url (context : context) vcs source libname =
+case source of
+URL_SOURCE u => u
+| SERVICE_SOURCE { service, owner, repo } =>
+provider_url { vcs = vcs,
+service = service,
+owner = owner,
+repo = case repo of
+SOME r => r
+| NONE => reponame_for libname }
+(login_for context service)
+(#providers context)
+end
+structure HgControl :> VCS_CONTROL = struct
+(* Pulls always use an explicit URL, never just the default
+remote, in order to ensure we update properly if the location
+given in the project file changes. *)
+type vcsstate = { id: string, modified: bool,
+branch: string, tags: string list }
+val hg_program = "hg"
+val hg_args = [ "--config", "ui.interactive=true",
+"--config", "ui.merge=:merge" ]
+fun hg_command context libname args =
+FileBits.command context libname (hg_program :: hg_args @ args)
+fun hg_command_output context libname args =
+FileBits.command_output context libname (hg_program :: hg_args @ args)
+fun is_working context =
+case hg_command_output context "" ["--version"] of
+OK "" => OK false
+| OK _ => OK true
+| ERROR e => ERROR e
+fun exists context libname =
+OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
+handle _ => OK false
+fun remote_for context (libname, source) =
+Provider.remote_url context HG source libname
+fun current_state context libname : vcsstate result =
+let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
+and extract_branch b =
+if is_branch b     (* need to remove enclosing parens *)
+then (implode o rev o tl o rev o tl o explode) b
+else "default"
+and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
+and extract_id id =
+if is_modified id  (* need to remove trailing "+" *)
+then (implode o rev o tl o rev o explode) id
+else id
+and split_tags tags = String.tokens (fn c => c = #"/") tags
+and state_for (id, branch, tags) =
+OK { id = extract_id id,
+modified = is_modified id,
+branch = extract_branch branch,
+tags = split_tags tags }
+in
+case hg_command_output context libname ["id"] of
+ERROR e => ERROR e
+| OK out =>
+case String.tokens (fn x => x = #" ") out of
+[id, branch, tags] => state_for (id, branch, tags)
+| [id, other] => if is_branch other
+then state_for (id, other, "")
+else state_for (id, "", other)
+| [id] => state_for (id, "", "")
+| _ => ERROR ("Unexpected output from hg id: " ^ out)
+end
+fun branch_name branch = case branch of
+DEFAULT_BRANCH => "default"
+| BRANCH "" => "default"
+| BRANCH b => b
+fun id_of context libname =
+case current_state context libname of
+ERROR e => ERROR e
+| OK { id, ... } => OK id
+fun is_at context (libname, id_or_tag) =
+case current_state context libname of
+ERROR e => ERROR e
+| OK { id, tags, ... } =>
+OK (String.isPrefix id_or_tag id orelse
+String.isPrefix id id_or_tag orelse
+List.exists (fn t => t = id_or_tag) tags)
+fun is_on_branch context (libname, b) =
+case current_state context libname of
+ERROR e => ERROR e
+| OK { branch, ... } => OK (branch = branch_name b)
+fun is_newest_locally context (libname, branch) =
+case hg_command_output context libname
+["log", "-l1",
+"-b", branch_name branch,
+"--template", "{node}"] of
+ERROR e => OK false (* desired branch does not exist *)
+| OK newest_in_repo => is_at context (libname, newest_in_repo)
+fun pull context (libname, source) =
+let val url = remote_for context (libname, source)
+in
+hg_command context libname
+(if FileBits.verbose ()
+then ["pull", url]
+else ["pull", "-q", url])
+end
+fun is_newest context (libname, source, branch) =
+case is_newest_locally context (libname, branch) of
+ERROR e => ERROR e
+| OK false => OK false
+| OK true =>
+case pull context (libname, source) of
+ERROR e => ERROR e
+| _ => is_newest_locally context (libname, branch)
+fun is_modified_locally context libname =
+case current_state context libname of
+ERROR e => ERROR e
+| OK { modified, ... } => OK modified
+fun checkout context (libname, source, branch) =
+let val url = remote_for context (libname, source)
+in
+(* make the lib dir rather than just the ext dir, since
+the lib dir might be nested and hg will happily check
+out into an existing empty dir anyway *)
+case FileBits.mkpath (FileBits.libpath context libname) of
+ERROR e => ERROR e
+| _ => hg_command context ""
+["clone", "-u", branch_name branch,
+url, libname]
+end
+fun update context (libname, source, branch) =
+let val pull_result = pull context (libname, source)
+in
+case hg_command context libname ["update", branch_name branch] of
+ERROR e => ERROR e
+| _ =>
+case pull_result of
+ERROR e => ERROR e
+| _ => OK ()
+end
+fun update_to context (libname, _, "") =
+ERROR "Non-empty id (tag or revision id) required for update_to"
+| update_to context (libname, source, id) =
+let val pull_result = pull context (libname, source)
+in
+case hg_command context libname ["update", "-r", id] of
+OK _ => OK ()
+| ERROR e =>
+case pull_result of
+ERROR e' => ERROR e' (* this was the ur-error *)
+| _ => ERROR e
+end
+fun copy_url_for context libname =
+OK (FileBits.file_url (FileBits.libpath context libname))
+end
+structure GitControl :> VCS_CONTROL = struct
+(* With Git repos we always operate in detached HEAD state. Even
+the master branch is checked out using a remote reference
+(repoint/master). The remote we use is always named repoint, and we
+update it to the expected URL each time we fetch, in order to
+ensure we update properly if the location given in the project
+file changes. The origin remote is unused. *)
+val git_program = "git"
+fun git_command context libname args =
+FileBits.command context libname (git_program :: args)
+fun git_command_output context libname args =
+FileBits.command_output context libname (git_program :: args)
+fun is_working context =
+case git_command_output context "" ["--version"] of
+OK "" => OK false
+| OK _ => OK true
+| ERROR e => ERROR e
+fun exists context libname =
+OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
+handle _ => OK false
+fun remote_for context (libname, source) =
+Provider.remote_url context GIT source libname
+fun branch_name branch = case branch of
+DEFAULT_BRANCH => "master"
+| BRANCH "" => "master"
+| BRANCH b => b
+val our_remote = "repoint"
+fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
+fun checkout context (libname, source, branch) =
+let val url = remote_for context (libname, source)
+in
+(* make the lib dir rather than just the ext dir, since
+the lib dir might be nested and git will happily check
+out into an existing empty dir anyway *)
+case FileBits.mkpath (FileBits.libpath context libname) of
+OK () => git_command context ""
+["clone", "--origin", our_remote,
+"--branch", branch_name branch,
+url, libname]
+| ERROR e => ERROR e
+end
+fun add_our_remote context (libname, source) =
+(* When we do the checkout ourselves (above), we add the
+remote at the same time. But if the repo was cloned by
+someone else, we'll need to do it after the fact. Git
+doesn't seem to have a means to add a remote or change its
+url if it already exists; seems we have to do this: *)
+let val url = remote_for context (libname, source)
+in
+case git_command context libname
+["remote", "set-url", our_remote, url] of
+OK () => OK ()
+| ERROR e => git_command context libname
+["remote", "add", "-f", our_remote, url]
+end
+(* NB git rev-parse HEAD shows revision id of current checkout;
+git rev-list -1 <tag> shows revision id of revision with that tag *)
+fun id_of context libname =
+git_command_output context libname ["rev-parse", "HEAD"]
+fun is_at context (libname, id_or_tag) =
+case id_of context libname of
+ERROR e => OK false (* HEAD nonexistent, expected in empty repo *)
+| OK id =>
+if String.isPrefix id_or_tag id orelse
+String.isPrefix id id_or_tag
+then OK true
+else is_at_tag context (libname, id, id_or_tag)
+and is_at_tag context (libname, id, tag) =
+(* For annotated tags (with message) show-ref returns the tag
+object ref rather than that of the revision being tagged;
+we need the subsequent rev-list to chase that up. In fact
+the rev-list on its own is enough to get us the id direct
+from the tag name, but it fails with an error if the tag
+doesn't exist, whereas we want to handle that quietly in
+case the tag simply hasn't been pulled yet *)
+case git_command_output context libname
+["show-ref", "refs/tags/" ^ tag, "--"] of
+OK "" => OK false (* Not a tag *)
+| ERROR _ => OK false
+| OK s =>
+let val tag_ref = hd (String.tokens (fn c => c = #" ") s)
+in
+case git_command_output context libname
+["rev-list", "-1", tag_ref] of
+OK tagged => OK (id = tagged)
+| ERROR _ => OK false
+end
+fun branch_tip context (libname, branch) =
+(* We don't have access to the source info or the network
+here, as this is used by status (e.g. via is_on_branch) as
+well as review. It's possible the remote branch won't exist,
+e.g. if the repo was checked out by something other than
+Repoint, and if that's the case, we can't add it here; we'll
+just have to fail, since checking against local branches
+instead could produce the wrong result. *)
+git_command_output context libname
+["rev-list", "-1",
+remote_branch_name branch, "--"]
+fun is_newest_locally context (libname, branch) =
+case branch_tip context (libname, branch) of
+ERROR e => OK false
+| OK rev => is_at context (libname, rev)
+fun is_on_branch context (libname, branch) =
+case branch_tip context (libname, branch) of
+ERROR e => OK false
+| OK rev =>
+case is_at context (libname, rev) of
+ERROR e => ERROR e
+| OK true => OK true
+| OK false =>
+case git_command context libname
+["merge-base", "--is-ancestor",
+"HEAD", remote_branch_name branch] of
+ERROR e => OK false  (* cmd returns non-zero for no *)
+| _ => OK true
+fun fetch context (libname, source) =
+case add_our_remote context (libname, source) of
+ERROR e => ERROR e
+| _ => git_command context libname ["fetch", our_remote]
+fun is_newest context (libname, source, branch) =
+case add_our_remote context (libname, source) of
+ERROR e => ERROR e
+| OK () =>
+case is_newest_locally context (libname, branch) of
+ERROR e => ERROR e
+| OK false => OK false
+| OK true =>
+case fetch context (libname, source) of
+ERROR e => ERROR e
+| _ => is_newest_locally context (libname, branch)
+fun is_modified_locally context libname =
+case git_command_output context libname ["status", "--porcelain"] of
+ERROR e => ERROR e
+| OK "" => OK false
+| OK _ => OK true
+(* This function updates to the latest revision on a branch rather
+than to a specific id or tag. We can't just checkout the given
+branch, as that will succeed even if the branch isn't up to
+date. We could checkout the branch and then fetch and merge,
+but it's perhaps cleaner not to maintain a local branch at all,
+but instead checkout the remote branch as a detached head. *)
+fun update context (libname, source, branch) =
+case fetch context (libname, source) of
+ERROR e => ERROR e
+| _ =>
+case git_command context libname ["checkout", "--detach",
+remote_branch_name branch] of
+ERROR e => ERROR e
+| _ => OK ()
+(* This function is dealing with a specific id or tag, so if we
+can successfully check it out (detached) then that's all we
+need to do, regardless of whether fetch succeeded or not. We do
+attempt the fetch first, though, purely in order to avoid ugly
+error messages in the common case where we're being asked to
+update to a new pin (from the lock file) that hasn't been
+fetched yet. *)
+fun update_to context (libname, _, "") =
+ERROR "Non-empty id (tag or revision id) required for update_to"
+| update_to context (libname, source, id) =
+let val fetch_result = fetch context (libname, source)
+in
+case git_command context libname ["checkout", "--detach", id] of
+OK _ => OK ()
+| ERROR e =>
+case fetch_result of
+ERROR e' => ERROR e' (* this was the ur-error *)
+| _ => ERROR e
+end
+fun copy_url_for context libname =
+OK (FileBits.file_url (FileBits.libpath context libname))
+end
+(* SubXml - A parser for a subset of XML
+https://bitbucket.org/cannam/sml-subxml
+Copyright 2018 Chris Cannam. BSD licence.
+*)
+signature SUBXML = sig
+datatype node = ELEMENT of { name : string, children : node list }
+| ATTRIBUTE of { name : string, value : string }
+| TEXT of string
+| CDATA of string
+| COMMENT of string
+datatype document = DOCUMENT of { name : string, children : node list }
+datatype 'a result = OK of 'a
+| ERROR of string
+val parse : string -> document result
+val serialise : document -> string
+end
+structure SubXml :> SUBXML = struct
+datatype node = ELEMENT of { name : string, children : node list }
+| ATTRIBUTE of { name : string, value : string }
+| TEXT of string
+| CDATA of string
+| COMMENT of string
+datatype document = DOCUMENT of { name : string, children : node list }
+datatype 'a result = OK of 'a
+| ERROR of string
+structure T = struct
+datatype token = ANGLE_L
+| ANGLE_R
+| ANGLE_SLASH_L
+| SLASH_ANGLE_R
+| EQUAL
+| NAME of string
+| TEXT of string
+| CDATA of string
+| COMMENT of string
+fun name t =
+case t of ANGLE_L => "<"
+| ANGLE_R => ">"
+| ANGLE_SLASH_L => "</"
+| SLASH_ANGLE_R => "/>"
+| EQUAL => "="
+| NAME s => "name \"" ^ s ^ "\""
+| TEXT s => "text"
+| CDATA _ => "CDATA section"
+| COMMENT _ => "comment"
+end
+structure Lex :> sig
+val lex : string -> T.token list result
+end = struct
+fun error pos text =
+ERROR (text ^ " at character position " ^ Int.toString (pos-1))
+fun tokenError pos token =
+error pos ("Unexpected token '" ^ Char.toString token ^ "'")
+val nameEnd = explode " \t\n\r\"'</>!=?"
+fun quoted quote pos acc cc =
+let fun quoted' pos text [] =
+error pos "Document ends during quoted string"
+| quoted' pos text (x::xs) =
+if x = quote
+then OK (rev text, xs, pos+1)
+else quoted' (pos+1) (x::text) xs
+in
+case quoted' pos [] cc of
+ERROR e => ERROR e
+| OK (text, rest, newpos) =>
+inside newpos (T.TEXT (implode text) :: acc) rest
+end
+and name first pos acc cc =
+let fun name' pos text [] =
+error pos "Document ends during name"
+| name' pos text (x::xs) =
+if List.find (fn c => c = x) nameEnd <> NONE
+then OK (rev text, (x::xs), pos)
+else name' (pos+1) (x::text) xs
+in
+case name' (pos-1) [] (first::cc) of
+ERROR e => ERROR e
+| OK ([], [], pos) => error pos "Document ends before name"
+| OK ([], (x::xs), pos) => tokenError pos x
+| OK (text, rest, pos) =>
+inside pos (T.NAME (implode text) :: acc) rest
+end
+and comment pos acc cc =
+let fun comment' pos text cc =
+case cc of
+#"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3)
+| x :: xs => comment' (pos+1) (x::text) xs
+| [] => error pos "Document ends during comment"
+in
+case comment' pos [] cc of
+ERROR e => ERROR e
+| OK (text, rest, pos) =>
+outside pos (T.COMMENT (implode text) :: acc) rest
+end
+and instruction pos acc cc =
+case cc of
+#"?" :: #">" :: xs => outside (pos+2) acc xs
+| #">" :: _ => tokenError pos #">"
+| x :: xs => instruction (pos+1) acc xs
+| [] => error pos "Document ends during processing instruction"
+and cdata pos acc cc =
+let fun cdata' pos text cc =
+case cc of
+#"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3)
+| x :: xs => cdata' (pos+1) (x::text) xs
+| [] => error pos "Document ends during CDATA section"
+in
+case cdata' pos [] cc of
+ERROR e => ERROR e
+| OK (text, rest, pos) =>
+outside pos (T.CDATA (implode text) :: acc) rest
+end
+and doctype pos acc cc =
+case cc of
+#">" :: xs => outside (pos+1) acc xs
+| x :: xs => doctype (pos+1) acc xs
+| [] => error pos "Document ends during DOCTYPE"
+and declaration pos acc cc =
+case cc of
+#"-" :: #"-" :: xs =>
+comment (pos+2) acc xs
+| #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs =>
+cdata (pos+7) acc xs
+| #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs =>
+doctype (pos+7) acc xs
+| [] => error pos "Document ends during declaration"
+| _ => error pos "Unsupported declaration type"
+and left pos acc cc =
+case cc of
+#"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs
+| #"!" :: xs => declaration (pos+1) acc xs
+| #"?" :: xs => instruction (pos+1) acc xs
+| xs => inside pos (T.ANGLE_L :: acc) xs
+and slash pos acc cc =
+case cc of
+#">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs
+| x :: _ => tokenError pos x
+| [] => error pos "Document ends before element closed"
+and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs
+and equal pos acc xs = inside pos (T.EQUAL :: acc) xs
+and outside pos acc [] = OK acc
+| outside pos acc cc =
+let fun textOf text = T.TEXT (implode (rev text))
+fun outside' pos [] acc [] = OK acc
+| outside' pos text acc [] = OK (textOf text :: acc)
+| outside' pos text acc (x::xs) =
+case x of
+#"<" => if text = []
+then left (pos+1) acc xs
+else left (pos+1) (textOf text :: acc) xs
+| x => outside' (pos+1) (x::text) acc xs
+in
+outside' pos [] acc cc
+end
+and inside pos acc [] = error pos "Document ends within tag"
+| inside pos acc (#"<"::_) = tokenError pos #"<"
+| inside pos acc (x::xs) =
+(case x of
+#" " => inside | #"\t" => inside
+| #"\n" => inside | #"\r" => inside
+| #"\"" => quoted x | #"'" => quoted x
+| #"/" => slash | #">" => close | #"=" => equal
+| x => name x) (pos+1) acc xs
+fun lex str =
+case outside 1 [] (explode str) of
+ERROR e => ERROR e
+| OK tokens => OK (rev tokens)
+end
+structure Parse :> sig
+val parse : string -> document result
+end = struct
+fun show [] = "end of input"
+| show (tok :: _) = T.name tok
+fun error toks text = ERROR (text ^ " before " ^ show toks)
+fun attribute elt name toks =
+case toks of
+T.EQUAL :: T.TEXT value :: xs =>
+namedElement {
+name = #name elt,
+children = ATTRIBUTE { name = name, value = value } ::
+#children elt
+} xs
+| T.EQUAL :: xs => error xs "Expected attribute value"
+| toks => error toks "Expected attribute assignment"
+and content elt toks =
+case toks of
+T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs =>
+if n = #name elt
+then OK (elt, xs)
+else ERROR ("Closing tag </" ^ n ^ "> " ^
+"does not match opening <" ^ #name elt ^ ">")
+| T.TEXT text :: xs =>
+content {
+name = #name elt,
+children = TEXT text :: #children elt
+} xs
+| T.CDATA text :: xs =>
+content {
+name = #name elt,
+children = CDATA text :: #children elt
+} xs
+| T.COMMENT text :: xs =>
+content {
+name = #name elt,
+children = COMMENT text :: #children elt
+} xs
+| T.ANGLE_L :: xs =>
+(case element xs of
+ERROR e => ERROR e
+| OK (child, xs) =>
+content {
+name = #name elt,
+children = ELEMENT child :: #children elt
+} xs)
+| tok :: xs =>
+error xs ("Unexpected token " ^ T.name tok)
+| [] =>
+ERROR ("Document ends within element \"" ^ #name elt ^ "\"")
+and namedElement elt toks =
+case toks of
+T.SLASH_ANGLE_R :: xs => OK (elt, xs)
+| T.NAME name :: xs => attribute elt name xs
+| T.ANGLE_R :: xs => content elt xs
+| x :: xs => error xs ("Unexpected token " ^ T.name x)
+| [] => ERROR "Document ends within opening tag"
+and element toks =
+case toks of
+T.NAME name :: xs =>
+(case namedElement { name = name, children = [] } xs of
+ERROR e => ERROR e
+| OK ({ name, children }, xs) =>
+OK ({ name = name, children = rev children }, xs))
+| toks => error toks "Expected element name"
+and document [] = ERROR "Empty document"
+| document (tok :: xs) =
+case tok of
+T.TEXT _ => document xs
+| T.COMMENT _ => document xs
+| T.ANGLE_L =>
+(case element xs of
+ERROR e => ERROR e
+| OK (elt, []) => OK (DOCUMENT elt)
+| OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt)
+| OK (elt, xs) => error xs "Extra data after document")
+| _ => error xs ("Unexpected token " ^ T.name tok)
+fun parse str =
+case Lex.lex str of
+ERROR e => ERROR e
+| OK tokens => document tokens
+end
+structure Serialise :> sig
+val serialise : document -> string
+end = struct
+fun attributes nodes =
+String.concatWith
+" "
+(map node (List.filter
+(fn ATTRIBUTE _ => true | _ => false)
+nodes))
+and nonAttributes nodes =
+String.concat
+(map node (List.filter
+(fn ATTRIBUTE _ => false | _ => true)
+nodes))
+and node n =
+case n of
+TEXT string =>
+string
+| CDATA string =>
+"<![CDATA[" ^ string ^ "]]>"
+| COMMENT string =>
+"<!-- " ^ string ^ "-->"
+| ATTRIBUTE { name, value } =>
+name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*)
+| ELEMENT { name, children } =>
+"<" ^ name ^
+(case (attributes children) of
+"" => ""
+| s => " " ^ s) ^
+(case (nonAttributes children) of
+"" => "/>"
+| s => ">" ^ s ^ "</" ^ name ^ ">")
+fun serialise (DOCUMENT { name, children }) =
+"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ^
+node (ELEMENT { name = name, children = children })
+end
+val parse = Parse.parse
+val serialise = Serialise.serialise
+end
+structure SvnControl :> VCS_CONTROL = struct
+val svn_program = "svn"
+fun svn_command context libname args =
+FileBits.command context libname (svn_program :: args)
+fun svn_command_output context libname args =
+FileBits.command_output context libname (svn_program :: args)
+fun svn_command_lines context libname args =
+case svn_command_output context libname args of
+ERROR e => ERROR e
+| OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s)
+fun split_line_pair line =
+let fun strip_leading_ws str = case explode str of
+#" "::rest => implode rest
+| _ => str
+in
+case String.tokens (fn c => c = #":") line of
+[] => ("", "")
+| first::rest =>
+(first, strip_leading_ws (String.concatWith ":" rest))
+end
+fun is_working context =
+case svn_command_output context "" ["--version"] of
+OK "" => OK false
+| OK _ => OK true
+| ERROR e => ERROR e
+structure X = SubXml
+fun svn_info context libname route =
+(* SVN 1.9 has info --show-item which is just what we need,
+but at this point we still have 1.8 on the CI boxes so we
+might as well aim to support it. For that we really have to
+use the XML output format, since the default info output is
+localised. This is the only thing our mini-XML parser is
+used for though, so it would be good to trim it at some
+point *)
+let fun find elt [] = OK elt
+| find { children, ... } (first :: rest) =
+case List.find (fn (X.ELEMENT { name, ... }) => name = first
+| _ => false)
+children of
+NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML")
+| SOME (X.ELEMENT e) => find e rest
+| SOME _ => ERROR "Internal error"
+in
+case svn_command_output context libname ["info", "--xml"] of
+ERROR e => ERROR e
+| OK xml =>
+case X.parse xml of
+X.ERROR e => ERROR e
+| X.OK (X.DOCUMENT doc) => find doc route
+end
+fun exists context libname =
+OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn"))
+handle _ => OK false
+fun remote_for context (libname, source) =
+Provider.remote_url context SVN source libname
+(* Remote the checkout came from, not necessarily the one we want *)
+fun actual_remote_for context libname =
+case svn_info context libname ["entry", "url"] of
+ERROR e => ERROR e
+| OK { children, ... } =>
+case List.find (fn (X.TEXT _) => true | _ => false) children of
+NONE => ERROR "No content for URL in SVN info XML"
+| SOME (X.TEXT url) => OK url
+| SOME _ => ERROR "Internal error"
+fun id_of context libname =
+case svn_info context libname ["entry"] of
+ERROR e => ERROR e
+| OK { children, ... } =>
+case List.find
+(fn (X.ATTRIBUTE { name = "revision", ... }) => true
+| _ => false)
+children of
+NONE => ERROR "No revision for entry in SVN info XML"
+| SOME (X.ATTRIBUTE { value, ... }) => OK value
+| SOME _ => ERROR "Internal error"
+fun is_at context (libname, id_or_tag) =
+case id_of context libname of
+ERROR e => ERROR e
+| OK id => OK (id = id_or_tag)
+fun is_on_branch context (libname, b) =
+OK (b = DEFAULT_BRANCH)
+fun check_remote context (libname, source) =
+case (remote_for context (libname, source),
+actual_remote_for context libname) of
+(_, ERROR e) => ERROR e
+| (url, OK actual) =>
+if actual = url
+then OK ()
+else svn_command context libname ["relocate", url]
+fun is_newest context (libname, source, branch) =
+case check_remote context (libname, source) of
+ERROR e => ERROR e
+| OK () =>
+case svn_command_lines context libname
+["status", "--show-updates"] of
+ERROR e => ERROR e
+| OK lines =>
+case rev lines of
+[] => ERROR "No result returned for server status"
+| last_line::_ =>
+case rev (String.tokens (fn c => c = #" ") last_line) of
+[] => ERROR "No revision field found in server status"
+| server_id::_ => is_at context (libname, server_id)
+fun is_newest_locally context (libname, branch) =
+OK true (* no local history *)
+fun is_modified_locally context libname =
+case svn_command_output context libname ["status"] of
+ERROR e => ERROR e
+| OK "" => OK false
+| OK _ => OK true
+fun checkout context (libname, source, branch) =
+let val url = remote_for context (libname, source)
+val path = FileBits.libpath context libname
+in
+if FileBits.nonempty_dir_exists path
+then (* Surprisingly, SVN itself has no problem with
+this. But for consistency with other VCSes we
+don't allow it *)
+ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"")
+else
+(* make the lib dir rather than just the ext dir, since
+the lib dir might be nested and svn will happily check
+out into an existing empty dir anyway *)
+case FileBits.mkpath (FileBits.libpath context libname) of
+ERROR e => ERROR e
+| _ => svn_command context "" ["checkout", url, libname]
+end
+fun update context (libname, source, branch) =
+case check_remote context (libname, source) of
+ERROR e => ERROR e
+| OK () =>
+case svn_command context libname
+["update", "--accept", "postpone"] of
+ERROR e => ERROR e
+| _ => OK ()
+fun update_to context (libname, _, "") =
+ERROR "Non-empty id (tag or revision id) required for update_to"
+| update_to context (libname, source, id) =
+case check_remote context (libname, source) of
+ERROR e => ERROR e
+| OK () =>
+case svn_command context libname
+["update", "-r", id, "--accept", "postpone"] of
+ERROR e => ERROR e
+| OK _ => OK ()
+fun copy_url_for context libname =
+actual_remote_for context libname
+end
+structure AnyLibControl :> LIB_CONTROL = struct
+structure H = LibControlFn(HgControl)
+structure G = LibControlFn(GitControl)
+structure S = LibControlFn(SvnControl)
+fun review context (spec as { vcs, ... } : libspec) =
+(fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec
+fun status context (spec as { vcs, ... } : libspec) =
+(fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec
+fun update context (spec as { vcs, ... } : libspec) =
+(fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec
+fun id_of context (spec as { vcs, ... } : libspec) =
+(fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec
+fun is_working context vcs =
+(fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working)
+vcs context vcs
+end
+type exclusions = string list
+structure Archive :> sig
+val archive : string * exclusions -> project -> OS.Process.status
+end = struct
+(* The idea of "archive" is to replace hg/git archive, which won't
+include files, like the Repoint-introduced external libraries,
+that are not under version control with the main repo.
+The process goes like this:
+- Make sure we have a target filename from the user, and take
+its basename as our archive directory name
+- Make an "archive root" subdir of the project repo, named
+typically .repoint-archive
+- Identify the VCS used for the project repo. Note that any
+explicit references to VCS type in this structure are to
+the VCS used for the project (something Repoint doesn't
+otherwise care about), not for an individual library
+- Synthesise a Repoint project with the archive root as its
+root path, "." as its extdir, with one library whose
+name is the user-supplied basename and whose explicit
+source URL is the original project root; update that
+project -- thus cloning the original project to a subdir
+of the archive root
+- Synthesise a Repoint project identical to the original one for
+this project, but with the newly-cloned copy as its root
+path; update that project -- thus checking out clean copies
+of the external library dirs
+- Call out to an archive program to archive up the new copy,
+running e.g.
+tar cvzf project-release.tar.gz \
+--exclude=.hg --exclude=.git project-release
+in the archive root dir
+- (We also omit the repoint-project.json file and any trace of
+Repoint. It can't properly be run in a directory where the
+external project folders already exist but their repo history
+does not. End users shouldn't get to see Repoint)
+- Clean up by deleting the new copy
+*)
+fun project_vcs_id_and_url dir =
+let val context = {
+rootpath = dir,
+extdir = ".",
+providers = [],
+accounts = []
+}
+val vcs_maybe =
+case [HgControl.exists context ".",
+GitControl.exists context ".",
+SvnControl.exists context "."] of
+[OK true, OK false, OK false] => OK HG
+| [OK false, OK true, OK false] => OK GIT
+| [OK false, OK false, OK true] => OK SVN
+| _ => ERROR ("Unable to identify VCS for directory " ^ dir)
+in
+case vcs_maybe of
+ERROR e => ERROR e
+| OK vcs =>
+case (fn HG => HgControl.id_of
+| GIT => GitControl.id_of
+| SVN => SvnControl.id_of)
+vcs context "." of
+ERROR e => ERROR ("Unable to find id of project repo: " ^ e)
+| OK id =>
+case (fn HG => HgControl.copy_url_for
+| GIT => GitControl.copy_url_for
+| SVN => SvnControl.copy_url_for)
+vcs context "." of
+ERROR e => ERROR ("Unable to find URL of project repo: "
+^ e)
+| OK url => OK (vcs, id, url)
+end
+fun make_archive_root (context : context) =
+let val path = OS.Path.joinDirFile {
+dir = #rootpath context,
+file = RepointFilenames.archive_dir
+}
+in
+case FileBits.mkpath path of
+ERROR e => raise Fail ("Failed to create archive directory \""
+^ path ^ "\": " ^ e)
+| OK () => path
+end
+fun archive_path archive_dir target_name =
+OS.Path.joinDirFile {
+dir = archive_dir,
+file = target_name
+}
+fun check_nonexistent path =
+case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
+NONE => ()
+| _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
+fun make_archive_copy target_name (vcs, project_id, source_url)
+({ context, ... } : project) =
+let val archive_root = make_archive_root context
+val synthetic_context = {
+rootpath = archive_root,
+extdir = ".",
+providers = [],
+accounts = []
+}
+val synthetic_library = {
+libname = target_name,
+vcs = vcs,
+source = URL_SOURCE source_url,
+branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
+project_pin = PINNED project_id,
+lock_pin = PINNED project_id
+}
+val path = archive_path archive_root target_name
+val _ = print ("Cloning original project to " ^ path
+^ " at revision " ^ project_id ^ "...\n");
+val _ = check_nonexistent path
+in
+case AnyLibControl.update synthetic_context synthetic_library of
+ERROR e => ERROR ("Failed to clone original project to "
+^ path ^ ": " ^ e)
+| OK _ => OK archive_root
+end
+fun update_archive archive_root target_name
+(project as { context, ... } : project) =
+let val synthetic_context = {
+rootpath = archive_path archive_root target_name,
+extdir = #extdir context,
+providers = #providers context,
+accounts = #accounts context
+}
+in
+foldl (fn (lib, acc) =>
+case acc of
+ERROR e => ERROR e
+| OK () => AnyLibControl.update synthetic_context lib)
+(OK ())
+(#libs project)
+end
+datatype packer = TAR
+| TAR_GZ
+| TAR_BZ2
+| TAR_XZ
+(* could add other packers, e.g. zip, if we knew how to
+handle the file omissions etc properly in pack_archive *)
+fun packer_and_basename path =
+let val extensions = [ (".tar", TAR),
+(".tar.gz", TAR_GZ),
+(".tar.bz2", TAR_BZ2),
+(".tar.xz", TAR_XZ)]
+val filename = OS.Path.file path
+in
+foldl (fn ((ext, packer), acc) =>
+if String.isSuffix ext filename
+then SOME (packer,
+String.substring (filename, 0,
+String.size filename -
+String.size ext))
+else acc)
+NONE
+extensions
+end
+fun pack_archive archive_root target_name target_path packer exclusions =
+case FileBits.command {
+rootpath = archive_root,
+extdir = ".",
+providers = [],
+accounts = []
+} "" ([
+"tar",
+case packer of
+TAR => "cf"
+| TAR_GZ => "czf"
+| TAR_BZ2 => "cjf"
+| TAR_XZ => "cJf",
+target_path,
+"--exclude=.hg",
+"--exclude=.git",
+"--exclude=.svn",
+"--exclude=repoint",
+"--exclude=repoint.sml",
+"--exclude=repoint.ps1",
+"--exclude=repoint.bat",
+"--exclude=repoint-project.json",
+"--exclude=repoint-lock.json"
+] @ (map (fn e => "--exclude=" ^ e) exclusions) @
+[ target_name ])
+of
+ERROR e => ERROR e
+| OK _ => FileBits.rmpath (archive_path archive_root target_name)
+fun archive (target_path, exclusions) (project : project) =
+let val _ = check_nonexistent target_path
+val (packer, name) =
+case packer_and_basename target_path of
+NONE => raise Fail ("Unsupported archive file extension in "
+^ target_path)
+| SOME pn => pn
+val details =
+case project_vcs_id_and_url (#rootpath (#context project)) of
+ERROR e => raise Fail e
+| OK details => details
+val archive_root =
+case make_archive_copy name details project of
+ERROR e => raise Fail e
+| OK archive_root => archive_root
+val outcome =
+case update_archive archive_root name project of
+ERROR e => ERROR e
+| OK _ =>
+case pack_archive archive_root name
+target_path packer exclusions of
+ERROR e => ERROR e
+| OK _ => OK ()
+in
+case outcome of
+ERROR e => raise Fail e
+| OK () => OS.Process.success
+end
+end
+val libobjname = "libraries"
+fun load_libspec spec_json lock_json libname : libspec =
+let open JsonBits
+val libobj   = lookup_mandatory spec_json [libobjname, libname]
+val vcs      = lookup_mandatory_string libobj ["vcs"]
+val retrieve = lookup_optional_string libobj
+val service  = retrieve ["service"]
+val owner    = retrieve ["owner"]
+val repo     = retrieve ["repository"]
+val url      = retrieve ["url"]
+val branch   = retrieve ["branch"]
+val project_pin = case retrieve ["pin"] of
+NONE => UNPINNED
+| SOME p => PINNED p
+val lock_pin = case lookup_optional lock_json [libobjname, libname] of
+NONE => UNPINNED
+| SOME ll => case lookup_optional_string ll ["pin"] of
+SOME p => PINNED p
+| NONE => UNPINNED
+in
+{
+libname = libname,
+vcs = case vcs of
+"hg" => HG
+| "git" => GIT
+| "svn" => SVN
+| other => raise Fail ("Unknown version-control system \"" ^
+other ^ "\""),
+source = case (url, service, owner, repo) of
+(SOME u, NONE, _, _) => URL_SOURCE u
+| (NONE, SOME ss, owner, repo) =>
+SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
+| _ => raise Fail ("Must have exactly one of service " ^
+"or url string"),
+project_pin = project_pin,
+lock_pin = lock_pin,
+branch = case branch of
+NONE => DEFAULT_BRANCH
+| SOME b =>
+case vcs of
+"svn" => raise Fail ("Branches not supported for " ^
+"svn repositories; change " ^
+"URL instead")
+| _ => BRANCH b
+}
+end
+fun load_userconfig () : userconfig =
+let val home = FileBits.homedir ()
+val conf_json =
+JsonBits.load_json_from
+(OS.Path.joinDirFile {
+dir = home,
+file = RepointFilenames.user_config_file })
+handle IO.Io _ => Json.OBJECT []
+in
+{
+accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
+NONE => []
+| SOME (Json.OBJECT aa) =>
+map (fn (k, (Json.STRING v)) =>
+{ service = k, login = v }
+| _ => raise Fail
+"String expected for account name")
+aa
+| _ => raise Fail "Array expected for accounts",
+providers = Provider.load_providers conf_json
+}
+end
+datatype pintype =
+NO_LOCKFILE |
+USE_LOCKFILE
+fun load_project (userconfig : userconfig) rootpath pintype : project =
+let val spec_file = FileBits.project_spec_path rootpath
+val lock_file = FileBits.project_lock_path rootpath
+val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
+handle OS.SysErr _ => false
+then ()
+else raise Fail ("Failed to open project spec file " ^
+(RepointFilenames.project_file) ^ " in " ^
+rootpath ^
+".\nPlease ensure the spec file is in the " ^
+"project root and run this from there.")
+val spec_json = JsonBits.load_json_from spec_file
+val lock_json = if pintype = USE_LOCKFILE
+then JsonBits.load_json_from lock_file
+handle IO.Io _ => Json.OBJECT []
+else Json.OBJECT []
+val extdir = JsonBits.lookup_mandatory_string spec_json
+["config", "extdir"]
+val spec_libs = JsonBits.lookup_optional spec_json [libobjname]
+val lock_libs = JsonBits.lookup_optional lock_json [libobjname]
+val providers = Provider.load_more_providers
+(#providers userconfig) spec_json
+val libnames = case spec_libs of
+NONE => []
+| SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
+| _ => raise Fail "Object expected for libs"
+in
+{
+context = {
+rootpath = rootpath,
+extdir = extdir,
+providers = providers,
+accounts = #accounts userconfig
+},
+libs = map (load_libspec spec_json lock_json) libnames
+}
+end
+fun save_lock_file rootpath locks =
+let val lock_file = FileBits.project_lock_path rootpath
+open Json
+val lock_json =
+OBJECT [
+(libobjname,
+OBJECT (map (fn { libname, id_or_tag } =>
+(libname,
+OBJECT [ ("pin", STRING id_or_tag) ]))
+locks))
+]
+in
+JsonBits.save_json_to lock_file lock_json
+end
+fun pad_to n str =
+if n <= String.size str then str
+else pad_to n (str ^ " ")
+fun hline_to 0 = ""
+| hline_to n = "-" ^ hline_to (n-1)
+val libname_width = 28
+val libstate_width = 11
+val localstate_width = 17
+val notes_width = 5
+val divider = " | "
+val clear_line = "\r" ^ pad_to 80 "";
+fun print_status_header () =
+print (clear_line ^ "\n " ^
+pad_to libname_width "Library" ^ divider ^
+pad_to libstate_width "State" ^ divider ^
+pad_to localstate_width "Local" ^ divider ^
+"Notes" ^ "\n " ^
+hline_to libname_width ^ "-+-" ^
+hline_to libstate_width ^ "-+-" ^
+hline_to localstate_width ^ "-+-" ^
+hline_to notes_width ^ "\n")
+fun print_outcome_header () =
+print (clear_line ^ "\n " ^
+pad_to libname_width "Library" ^ divider ^
+pad_to libstate_width "Outcome" ^ divider ^
+"Notes" ^ "\n " ^
+hline_to libname_width ^ "-+-" ^
+hline_to libstate_width ^ "-+-" ^
+hline_to notes_width ^ "\n")
+fun print_status with_network (lib : libspec, status) =
+let val libstate_str =
+case status of
+OK (ABSENT, _) => "Absent"
+| OK (CORRECT, _) => if with_network then "Correct" else "Present"
+| OK (SUPERSEDED, _) => "Superseded"
+| OK (WRONG, _) => "Wrong"
+| ERROR _ => "Error"
+val localstate_str =
+case status of
+OK (_, MODIFIED) => "Modified"
+| OK (_, LOCK_MISMATCHED) => "Differs from Lock"
+| OK (_, CLEAN) => "Clean"
+| ERROR _ => ""
+val error_str =
+case status of
+ERROR e => e
+| _ => ""
+in
+print (" " ^
+pad_to libname_width (#libname lib) ^ divider ^
+pad_to libstate_width libstate_str ^ divider ^
+pad_to localstate_width localstate_str ^ divider ^
+error_str ^ "\n")
+end
+fun print_update_outcome (lib : libspec, outcome) =
+let val outcome_str =
+case outcome of
+OK id => "Ok"
+| ERROR e => "Failed"
+val error_str =
+case outcome of
+ERROR e => e
+| _ => ""
+in
+print (" " ^
+pad_to libname_width (#libname lib) ^ divider ^
+pad_to libstate_width outcome_str ^ divider ^
+error_str ^ "\n")
+end
+fun vcs_name HG = ("Mercurial", "hg")
+| vcs_name GIT = ("Git", "git")
+| vcs_name SVN = ("Subversion", "svn")
+fun print_problem_summary context lines =
+let val failed_vcs =
+foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc
+| (_, acc) => acc) [] lines
+fun report_nonworking vcs error =
+print ((if error = "" then "" else error ^ "\n\n") ^
+"Error: The project uses the " ^ (#1 (vcs_name vcs)) ^
+" version control system, but its\n" ^
+"executable program (" ^ (#2 (vcs_name vcs)) ^
+") does not appear to be installed in the program path\n\n")
+fun check_working [] checked = ()
+| check_working (vcs::rest) checked =
+if List.exists (fn v => vcs = v) checked
+then check_working rest checked
+else
+case AnyLibControl.is_working context vcs of
+OK true => check_working rest checked
+| OK false => (report_nonworking vcs "";
+check_working rest (vcs::checked))
+| ERROR e => (report_nonworking vcs e;
+check_working rest (vcs::checked))
+in
+print "\nError: Some operations failed\n\n";
+check_working failed_vcs []
+end
+fun act_and_print action print_header print_line context (libs : libspec list) =
+let val lines = map (fn lib => (lib, action lib)) libs
+val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines
+val _ = print_header ()
+in
+app print_line lines;
+if imperfect then print_problem_summary context lines else ();
+lines
+end
+fun return_code_for outcomes =
+foldl (fn ((_, result), acc) =>
+case result of
+ERROR _ => OS.Process.failure
+| _ => acc)
+OS.Process.success
+outcomes
+fun status_of_project ({ context, libs } : project) =
+return_code_for (act_and_print (AnyLibControl.status context)
+print_status_header (print_status false)
+context libs)
+fun review_project ({ context, libs } : project) =
+return_code_for (act_and_print (AnyLibControl.review context)
+print_status_header (print_status true)
+context libs)
+fun lock_project ({ context, libs } : project) =
+let val _ = if FileBits.verbose ()
+then print ("Scanning IDs for lock file...\n")
+else ()
+val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib))
+libs
+val locks =
+List.concat
+(map (fn (lib : libspec, result) =>
+case result of
+ERROR _ => []
+| OK id => [{ libname = #libname lib,
+id_or_tag = id }])
+outcomes)
+val return_code = return_code_for outcomes
+val _ = print clear_line
+in
+if OS.Process.isSuccess return_code
+then save_lock_file (#rootpath context) locks
+else ();
+return_code
+end
+fun update_project (project as { context, libs }) =
+let val outcomes = act_and_print
+(AnyLibControl.update context)
+print_outcome_header print_update_outcome
+context libs
+val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
+then lock_project project
+else OS.Process.success
+in
+return_code_for outcomes
+end
+fun load_local_project pintype =
+let val userconfig = load_userconfig ()
+val rootpath = OS.FileSys.getDir ()
+in
+load_project userconfig rootpath pintype
+end
+fun with_local_project pintype f =
+let open OS.Process
+val return_code =
+f (load_local_project pintype)
+handle Fail msg =>
+failure before print ("Error: " ^ msg)
+| JsonBits.Config msg =>
+failure before print ("Error in configuration: " ^ msg)
+| e =>
+failure before print ("Error: " ^ exnMessage e)
+val _ = print "\n";
+in
+return_code
+end
+fun review () = with_local_project USE_LOCKFILE review_project
+fun status () = with_local_project USE_LOCKFILE status_of_project
+fun update () = with_local_project NO_LOCKFILE update_project
+fun lock () = with_local_project NO_LOCKFILE lock_project
+fun install () = with_local_project USE_LOCKFILE update_project
+fun version () =
+(print ("v" ^ repoint_version ^ "\n");
+OS.Process.success)
+fun usage () =
+(print "\nRepoint ";
+version ();
+print ("\nA simple manager for third-party source code dependencies.\n\n"
+^ "Usage:\n\n"
+^ "  repoint <command>\n\n"
+^ "where <command> is one of:\n\n"
+^ "  status   print quick report on local status only, without using network\n"
+^ "  review   check configured libraries against their providers, and report\n"
+^ "  install  update configured libraries according to project specs and lock file\n"
+^ "  update   update configured libraries and lock file according to project specs\n"
+^ "  lock     update lock file to match local library status\n"
+^ "  archive  pack up project and all libraries into an archive file\n"
+^ "           (invoke as 'repoint archive target-file.tar.gz')\n"
+^ "  version  print the Repoint version number and exit\n\n");
+OS.Process.failure)
+fun archive target args =
+case args of
+[] =>
+with_local_project USE_LOCKFILE (Archive.archive (target, []))
+| "--exclude"::xs =>
+with_local_project USE_LOCKFILE (Archive.archive (target, xs))
+| _ => usage ()
+fun repoint args =
+let val return_code =
+case args of
+["review"] => review ()
+| ["status"] => status ()
+| ["install"] => install ()
+| ["update"] => update ()
+| ["lock"] => lock ()
+| ["version"] => version ()
+| "archive"::target::args => archive target args
+| arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n");
+usage ())
+| _ => usage ()
+in
+OS.Process.exit return_code;
+()
+end
+fun main () =
+repoint (CommandLine.arguments ())

Mercurial > hg > sonic-visualiser

comparison repoint.sml @ 1808:adc8a48f4e4c repoint