sonic-visualiser: vext.sml comparison

comparison vext.sml @ 1761:cd10346cc810

Update Vext

author	Chris Cannam
date	Tue, 23 Jan 2018 12:54:58 +0000
parents	42d57c382e56
children	762ef5d2722a

comparison

equal deleted inserted replaced

-:89a6d56803fd
+:cd10346cc810
 (*
 Vext
 A simple manager for third-party source code dependencies
-Copyright 2017 Chris Cannam, Particular Programs Ltd,
+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
 shall not be used in advertising or otherwise to promote the sale,
 use or other dealings in this Software without prior written
 authorization.
 *)
-val vext_version = "0.9.92"
+val vext_version = "0.9.94"
 datatype vcs =
 HG |
 GIT |
 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
 (explode arg)
 then arg
 else "\"" ^ arg ^ "\""
 fun check arg =
-let val valid = explode " /#:;?,._-{}@="
+let val valid = explode " /#:;?,._-{}@=+"
 in
 app (fn c =>
 if isAlphaNum c orelse
-List.exists (fn v => v = c) valid
+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);
 V.id_of context libname
 end
 (* Simple Standard ML JSON parser
-==============================
 https://bitbucket.org/cannam/sml-simplejson
+Copyright 2017 Chris Cannam. BSD licence.
-An RFC-compliant JSON parser in one SML file with no dependency
-on anything outside the Basis library. Also includes a simple
-serialiser.
-Tested with MLton, Poly/ML, and SML/NJ compilers.
-Parser notes:
-* Complies with RFC 7159, The JavaScript Object Notation (JSON)
-Data Interchange Format
-* Passes all of the JSONTestSuite parser accept/reject tests that
-exist at the time of writing, as listed in "Parsing JSON is a
-Minefield" (http://seriot.ch/parsing_json.php)
-* Two-pass parser using naive exploded strings, therefore not
-particularly fast and not suitable for large input files
-* Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check
-that JSON strings are valid UTF-8 -- the caller must do that --
-but does handle \u escapes
-* Converts all numbers to type "real". If that is a 64-bit IEEE
-float type (common but not guaranteed in SML) then we're pretty
-standard for a JSON parser
-Copyright 2017 Chris Cannam.
 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
-Permission is hereby granted, free of charge, to any person
-obtaining a copy of this software and associated documentation
-files (the "Software"), to deal in the Software without
-restriction, including without limitation the rights to use, copy,
-modify, merge, publish, distribute, sublicense, and/or sell copies
-of the Software, and to permit persons to whom the Software is
-furnished to do so, subject to the following conditions:
-The above copyright notice and this permission notice shall be
-included in all copies or substantial portions of the Software.
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
-ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
-CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
-WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-Except as contained in this notice, the names of Chris Cannam and
-Particular Programs Ltd shall not be used in advertising or
-otherwise to promote the sale, use or other dealings in this
-Software without prior written authorization.
 *)
 signature JSON = sig
 datatype json = OBJECT of (string * json) list
 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-simplexml
+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
 fun svn_command context libname args =
 FileBits.command context libname ("svn" :: args)
 case String.tokens (fn c => c = #":") line of
 [] => ("", "")
 | first::rest =>
 (first, strip_leading_ws (String.concatWith ":" rest))
 end
-fun svn_info_item context libname key =
+structure X = SubXml
-(* SVN 1.9 has info --show-item which is what we need, but at
-this point we still have 1.8 on the CI boxes so we might as
+fun svn_info context libname route =
-well aim to support it *)
+(* SVN 1.9 has info --show-item which is just what we need,
-case svn_command_lines context libname ["info"] of
+but at this point we still have 1.8 on the CI boxes so we
-ERROR e => ERROR e
+might as well aim to support it. For that we really have to
-| OK lines =>
+use the XML output format, since the default info output is
-case List.find (fn (k, v) => k = key) (map split_line_pair lines) of
+localised. This is the only thing our mini-XML parser is
-NONE => ERROR ("Key \"" ^ key ^ "\" not found in output")
+used for though, so it would be good to trim it at some
-| SOME (_, v) => OK v
+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 =
-svn_info_item context libname "Revision" (*!!! check: does svn localise this? should we ensure C locale? *)
+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 svn_command_lines context libname ["status", "--show-updates"] of
+case check_remote context (libname, source) of
 ERROR e => ERROR e
-| OK lines =>
+| OK () =>
-case rev lines of
+case svn_command_lines context libname
-[] => ERROR "No result returned for server status"
+["status", "--show-updates"] of
-| last_line::_ =>
+ERROR e => ERROR e
-case rev (String.tokens (fn c => c = #" ") last_line) of
+| OK lines =>
-[] => ERROR "No revision field found in server status"
+case rev lines of
-| server_id::_ => is_at context (libname, server_id)
+[] => 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 =
 ERROR e => ERROR e
 | _ => svn_command context "" ["checkout", url, libname]
 end
 fun update context (libname, source, branch) =
-case svn_command context libname
+case check_remote context (libname, source) of
-["update", "--accept", "postpone"] of
 ERROR e => ERROR e
-| _ => OK ()
+| 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 svn_command context libname
+case check_remote context (libname, source) of
-["update", "-r", id, "--accept", "postpone"] of
 ERROR e => ERROR e
-| OK _ => OK ()
+| OK () =>
+case svn_command context libname
+["update", "-r", id, "--accept", "postpone"] of
+ERROR e => ERROR e
+| OK _ => OK ()
 fun copy_url_for context libname =
-svn_info_item context libname "URL"
+actual_remote_for context libname
 end
 structure AnyLibControl :> LIB_CONTROL = struct

Mercurial > hg > sonic-visualiser

comparison vext.sml @ 1761:cd10346cc810