annotate vext.sml @ 1815:ec7d4f243ffa

Subrepo update
author Chris Cannam
date Tue, 15 May 2018 13:30:09 +0100
parents 316c4fd7e7bc
children
rev   line source
Chris@1746 1 (*
Chris@1746 2 DO NOT EDIT THIS FILE.
Chris@1746 3 This file is automatically generated from the individual
Chris@1746 4 source files in the Vext repository.
Chris@1746 5 *)
Chris@1706 6
Chris@1706 7 (*
Chris@1706 8 Vext
Chris@1706 9
Chris@1706 10 A simple manager for third-party source code dependencies
Chris@1706 11
Chris@1761 12 Copyright 2018 Chris Cannam, Particular Programs Ltd,
Chris@1746 13 and Queen Mary, University of London
Chris@1706 14
Chris@1706 15 Permission is hereby granted, free of charge, to any person
Chris@1706 16 obtaining a copy of this software and associated documentation
Chris@1706 17 files (the "Software"), to deal in the Software without
Chris@1706 18 restriction, including without limitation the rights to use, copy,
Chris@1706 19 modify, merge, publish, distribute, sublicense, and/or sell copies
Chris@1706 20 of the Software, and to permit persons to whom the Software is
Chris@1706 21 furnished to do so, subject to the following conditions:
Chris@1706 22
Chris@1706 23 The above copyright notice and this permission notice shall be
Chris@1706 24 included in all copies or substantial portions of the Software.
Chris@1706 25
Chris@1706 26 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
Chris@1706 27 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
Chris@1706 28 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
Chris@1706 29 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
Chris@1706 30 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
Chris@1706 31 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
Chris@1706 32 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Chris@1706 33
Chris@1746 34 Except as contained in this notice, the names of Chris Cannam,
Chris@1746 35 Particular Programs Ltd, and Queen Mary, University of London
Chris@1746 36 shall not be used in advertising or otherwise to promote the sale,
Chris@1746 37 use or other dealings in this Software without prior written
Chris@1746 38 authorization.
Chris@1706 39 *)
Chris@1706 40
Chris@1776 41 val vext_version = "0.9.98"
Chris@1706 42
Chris@1706 43
Chris@1706 44 datatype vcs =
Chris@1706 45 HG |
Chris@1756 46 GIT |
Chris@1756 47 SVN
Chris@1706 48
Chris@1706 49 datatype source =
Chris@1721 50 URL_SOURCE of string |
Chris@1721 51 SERVICE_SOURCE of {
Chris@1706 52 service : string,
Chris@1706 53 owner : string option,
Chris@1706 54 repo : string option
Chris@1706 55 }
Chris@1706 56
Chris@1740 57 type id_or_tag = string
Chris@1740 58
Chris@1706 59 datatype pin =
Chris@1706 60 UNPINNED |
Chris@1740 61 PINNED of id_or_tag
Chris@1706 62
Chris@1706 63 datatype libstate =
Chris@1706 64 ABSENT |
Chris@1706 65 CORRECT |
Chris@1706 66 SUPERSEDED |
Chris@1706 67 WRONG
Chris@1706 68
Chris@1706 69 datatype localstate =
Chris@1706 70 MODIFIED |
Chris@1740 71 LOCK_MISMATCHED |
Chris@1740 72 CLEAN
Chris@1706 73
Chris@1706 74 datatype branch =
Chris@1706 75 BRANCH of string |
Chris@1706 76 DEFAULT_BRANCH
Chris@1706 77
Chris@1706 78 (* If we can recover from an error, for example by reporting failure
Chris@1706 79 for this one thing and going on to the next thing, then the error
Chris@1706 80 should usually be returned through a result type rather than an
Chris@1706 81 exception. *)
Chris@1706 82
Chris@1706 83 datatype 'a result =
Chris@1706 84 OK of 'a |
Chris@1706 85 ERROR of string
Chris@1706 86
Chris@1706 87 type libname = string
Chris@1706 88
Chris@1706 89 type libspec = {
Chris@1706 90 libname : libname,
Chris@1706 91 vcs : vcs,
Chris@1706 92 source : source,
Chris@1706 93 branch : branch,
Chris@1740 94 project_pin : pin,
Chris@1740 95 lock_pin : pin
Chris@1706 96 }
Chris@1706 97
Chris@1706 98 type lock = {
Chris@1706 99 libname : libname,
Chris@1706 100 id_or_tag : id_or_tag
Chris@1706 101 }
Chris@1740 102
Chris@1706 103 type remote_spec = {
Chris@1706 104 anon : string option,
Chris@1706 105 auth : string option
Chris@1706 106 }
Chris@1706 107
Chris@1706 108 type provider = {
Chris@1706 109 service : string,
Chris@1706 110 supports : vcs list,
Chris@1706 111 remote_spec : remote_spec
Chris@1706 112 }
Chris@1706 113
Chris@1706 114 type account = {
Chris@1706 115 service : string,
Chris@1706 116 login : string
Chris@1706 117 }
Chris@1706 118
Chris@1706 119 type context = {
Chris@1706 120 rootpath : string,
Chris@1706 121 extdir : string,
Chris@1706 122 providers : provider list,
Chris@1706 123 accounts : account list
Chris@1706 124 }
Chris@1706 125
Chris@1706 126 type userconfig = {
Chris@1706 127 providers : provider list,
Chris@1706 128 accounts : account list
Chris@1706 129 }
Chris@1706 130
Chris@1706 131 type project = {
Chris@1706 132 context : context,
Chris@1706 133 libs : libspec list
Chris@1706 134 }
Chris@1706 135
Chris@1706 136 structure VextFilenames = struct
Chris@1706 137 val project_file = "vext-project.json"
Chris@1706 138 val project_lock_file = "vext-lock.json"
Chris@1706 139 val user_config_file = ".vext.json"
Chris@1746 140 val archive_dir = ".vext-archive"
Chris@1706 141 end
Chris@1706 142
Chris@1706 143 signature VCS_CONTROL = sig
Chris@1706 144
Chris@1772 145 (** Check whether the given VCS is installed and working *)
Chris@1772 146 val is_working : context -> bool result
Chris@1772 147
Chris@1706 148 (** Test whether the library is present locally at all *)
Chris@1706 149 val exists : context -> libname -> bool result
Chris@1706 150
Chris@1706 151 (** Return the id (hash) of the current revision for the library *)
Chris@1706 152 val id_of : context -> libname -> id_or_tag result
Chris@1706 153
Chris@1706 154 (** Test whether the library is at the given id *)
Chris@1706 155 val is_at : context -> libname * id_or_tag -> bool result
Chris@1706 156
Chris@1706 157 (** Test whether the library is on the given branch, i.e. is at
Chris@1706 158 the branch tip or an ancestor of it *)
Chris@1706 159 val is_on_branch : context -> libname * branch -> bool result
Chris@1706 160
Chris@1706 161 (** Test whether the library is at the newest revision for the
Chris@1706 162 given branch. False may indicate that the branch has advanced
Chris@1706 163 or that the library is not on the branch at all. This function
Chris@1706 164 may use the network to check for new revisions *)
Chris@1752 165 val is_newest : context -> libname * source * branch -> bool result
Chris@1706 166
Chris@1706 167 (** Test whether the library is at the newest revision available
Chris@1706 168 locally for the given branch. False may indicate that the
Chris@1706 169 branch has advanced or that the library is not on the branch
Chris@1706 170 at all. This function must not use the network *)
Chris@1706 171 val is_newest_locally : context -> libname * branch -> bool result
Chris@1706 172
Chris@1706 173 (** Test whether the library has been modified in the local
Chris@1706 174 working copy *)
Chris@1706 175 val is_modified_locally : context -> libname -> bool result
Chris@1706 176
Chris@1706 177 (** Check out, i.e. clone a fresh copy of, the repo for the given
Chris@1706 178 library on the given branch *)
Chris@1706 179 val checkout : context -> libname * source * branch -> unit result
Chris@1706 180
Chris@1756 181 (** Update the library to the given branch tip. Assumes that a
Chris@1758 182 local copy of the library already exists *)
Chris@1758 183 val update : context -> libname * source * branch -> unit result
Chris@1706 184
Chris@1706 185 (** Update the library to the given specific id or tag *)
Chris@1758 186 val update_to : context -> libname * source * id_or_tag -> unit result
Chris@1756 187
Chris@1756 188 (** Return a URL from which the library can be cloned, given that
Chris@1756 189 the local copy already exists. For a DVCS this can be the
Chris@1756 190 local copy, but for a centralised VCS it will have to be the
Chris@1756 191 remote repository URL. Used for archiving *)
Chris@1756 192 val copy_url_for : context -> libname -> string result
Chris@1706 193 end
Chris@1706 194
Chris@1706 195 signature LIB_CONTROL = sig
Chris@1706 196 val review : context -> libspec -> (libstate * localstate) result
Chris@1706 197 val status : context -> libspec -> (libstate * localstate) result
Chris@1758 198 val update : context -> libspec -> unit result
Chris@1740 199 val id_of : context -> libspec -> id_or_tag result
Chris@1772 200 val is_working : context -> vcs -> bool result
Chris@1706 201 end
Chris@1706 202
Chris@1706 203 structure FileBits :> sig
Chris@1706 204 val extpath : context -> string
Chris@1706 205 val libpath : context -> libname -> string
Chris@1706 206 val subpath : context -> libname -> string -> string
Chris@1706 207 val command_output : context -> libname -> string list -> string result
Chris@1706 208 val command : context -> libname -> string list -> unit result
Chris@1756 209 val file_url : string -> string
Chris@1706 210 val file_contents : string -> string
Chris@1706 211 val mydir : unit -> string
Chris@1706 212 val homedir : unit -> string
Chris@1706 213 val mkpath : string -> unit result
Chris@1746 214 val rmpath : string -> unit result
Chris@1756 215 val nonempty_dir_exists : string -> bool
Chris@1706 216 val project_spec_path : string -> string
Chris@1706 217 val project_lock_path : string -> string
Chris@1706 218 val verbose : unit -> bool
Chris@1706 219 end = struct
Chris@1706 220
Chris@1706 221 fun verbose () =
Chris@1706 222 case OS.Process.getEnv "VEXT_VERBOSE" of
Chris@1706 223 SOME "0" => false
Chris@1706 224 | SOME _ => true
Chris@1706 225 | NONE => false
Chris@1706 226
Chris@1752 227 fun split_relative path desc =
Chris@1752 228 case OS.Path.fromString path of
Chris@1752 229 { isAbs = true, ... } => raise Fail (desc ^ " may not be absolute")
Chris@1752 230 | { arcs, ... } => arcs
Chris@1752 231
Chris@1706 232 fun extpath ({ rootpath, extdir, ... } : context) =
Chris@1706 233 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1706 234 in OS.Path.toString {
Chris@1706 235 isAbs = isAbs,
Chris@1706 236 vol = vol,
Chris@1752 237 arcs = arcs @
Chris@1752 238 split_relative extdir "extdir"
Chris@1706 239 }
Chris@1706 240 end
Chris@1706 241
Chris@1706 242 fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
Chris@1706 243 (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
Chris@1706 244 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1706 245 in OS.Path.toString {
Chris@1706 246 isAbs = isAbs,
Chris@1706 247 vol = vol,
Chris@1752 248 arcs = arcs @
Chris@1752 249 split_relative extdir "extdir" @
Chris@1752 250 split_relative libname "library path" @
Chris@1752 251 split_relative remainder "subpath"
Chris@1706 252 }
Chris@1706 253 end
Chris@1706 254
Chris@1706 255 fun libpath context "" =
Chris@1706 256 extpath context
Chris@1706 257 | libpath context libname =
Chris@1706 258 subpath context libname ""
Chris@1706 259
Chris@1706 260 fun project_file_path rootpath filename =
Chris@1706 261 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1706 262 in OS.Path.toString {
Chris@1706 263 isAbs = isAbs,
Chris@1706 264 vol = vol,
Chris@1706 265 arcs = arcs @ [ filename ]
Chris@1706 266 }
Chris@1706 267 end
Chris@1706 268
Chris@1706 269 fun project_spec_path rootpath =
Chris@1706 270 project_file_path rootpath (VextFilenames.project_file)
Chris@1706 271
Chris@1706 272 fun project_lock_path rootpath =
Chris@1706 273 project_file_path rootpath (VextFilenames.project_lock_file)
Chris@1706 274
Chris@1706 275 fun trim str =
Chris@1706 276 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
Chris@1756 277
Chris@1756 278 fun file_url path =
Chris@1756 279 let val forward_path =
Chris@1756 280 String.translate (fn #"\\" => "/" |
Chris@1756 281 c => Char.toString c)
Chris@1756 282 (OS.Path.mkCanonical path)
Chris@1756 283 in
Chris@1756 284 (* Path is expected to be absolute already, but if it
Chris@1756 285 starts with a drive letter, we'll need an extra slash *)
Chris@1756 286 case explode forward_path of
Chris@1756 287 #"/"::rest => "file:///" ^ implode rest
Chris@1756 288 | _ => "file:///" ^ forward_path
Chris@1756 289 end
Chris@1706 290
Chris@1706 291 fun file_contents filename =
Chris@1706 292 let val stream = TextIO.openIn filename
Chris@1706 293 fun read_all str acc =
Chris@1706 294 case TextIO.inputLine str of
Chris@1706 295 SOME line => read_all str (trim line :: acc)
Chris@1706 296 | NONE => rev acc
Chris@1706 297 val contents = read_all stream []
Chris@1706 298 val _ = TextIO.closeIn stream
Chris@1706 299 in
Chris@1706 300 String.concatWith "\n" contents
Chris@1706 301 end
Chris@1706 302
Chris@1706 303 fun expand_commandline cmdlist =
Chris@1706 304 (* We are quite [too] strict about what we accept here, except
Chris@1706 305 for the first element in cmdlist which is assumed to be a
Chris@1706 306 known command location rather than arbitrary user input. NB
Chris@1706 307 only ASCII accepted at this point. *)
Chris@1706 308 let open Char
Chris@1706 309 fun quote arg =
Chris@1706 310 if List.all
Chris@1706 311 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
Chris@1706 312 (explode arg)
Chris@1706 313 then arg
Chris@1706 314 else "\"" ^ arg ^ "\""
Chris@1706 315 fun check arg =
Chris@1761 316 let val valid = explode " /#:;?,._-{}@=+"
Chris@1706 317 in
Chris@1706 318 app (fn c =>
Chris@1706 319 if isAlphaNum c orelse
Chris@1761 320 List.exists (fn v => v = c) valid orelse
Chris@1761 321 c > chr 127
Chris@1706 322 then ()
Chris@1706 323 else raise Fail ("Invalid character '" ^
Chris@1706 324 (Char.toString c) ^
Chris@1706 325 "' in command list"))
Chris@1706 326 (explode arg);
Chris@1706 327 arg
Chris@1706 328 end
Chris@1706 329 in
Chris@1706 330 String.concatWith " "
Chris@1706 331 (map quote
Chris@1706 332 (hd cmdlist :: map check (tl cmdlist)))
Chris@1706 333 end
Chris@1706 334
Chris@1706 335 val tick_cycle = ref 0
Chris@1706 336 val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
Chris@1706 337
Chris@1716 338 fun tick libname cmdlist =
Chris@1706 339 let val n = Vector.length tick_chars
Chris@1706 340 fun pad_to n str =
Chris@1716 341 if n <= String.size str then str
Chris@1716 342 else pad_to n (str ^ " ")
Chris@1716 343 val name = if libname <> "" then libname
Chris@1716 344 else if cmdlist = nil then ""
Chris@1716 345 else hd (rev cmdlist)
Chris@1706 346 in
Chris@1716 347 print (" " ^
Chris@1706 348 Vector.sub(tick_chars, !tick_cycle) ^ " " ^
Chris@1766 349 pad_to 70 name ^
Chris@1716 350 "\r");
Chris@1706 351 tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
Chris@1706 352 end
Chris@1706 353
Chris@1706 354 fun run_command context libname cmdlist redirect =
Chris@1706 355 let open OS
Chris@1706 356 val dir = libpath context libname
Chris@1706 357 val cmd = expand_commandline cmdlist
Chris@1706 358 val _ = if verbose ()
Chris@1766 359 then print ("\n=== " ^ dir ^ "\n<<< " ^ cmd ^ "\n")
Chris@1716 360 else tick libname cmdlist
Chris@1706 361 val _ = FileSys.chDir dir
Chris@1706 362 val status = case redirect of
Chris@1706 363 NONE => Process.system cmd
Chris@1706 364 | SOME file => Process.system (cmd ^ ">" ^ file)
Chris@1706 365 in
Chris@1706 366 if Process.isSuccess status
Chris@1706 367 then OK ()
Chris@1706 368 else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
Chris@1706 369 end
Chris@1706 370 handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
Chris@1706 371
Chris@1706 372 fun command context libname cmdlist =
Chris@1706 373 run_command context libname cmdlist NONE
Chris@1706 374
Chris@1706 375 fun command_output context libname cmdlist =
Chris@1706 376 let open OS
Chris@1706 377 val tmpFile = FileSys.tmpName ()
Chris@1706 378 val result = run_command context libname cmdlist (SOME tmpFile)
Chris@1706 379 val contents = file_contents tmpFile
Chris@1756 380 val _ = if verbose ()
Chris@1766 381 then print (">>> \"" ^ contents ^ "\"\n")
Chris@1756 382 else ()
Chris@1706 383 in
Chris@1706 384 FileSys.remove tmpFile handle _ => ();
Chris@1706 385 case result of
Chris@1706 386 OK () => OK contents
Chris@1706 387 | ERROR e => ERROR e
Chris@1706 388 end
Chris@1706 389
Chris@1706 390 fun mydir () =
Chris@1706 391 let open OS
Chris@1706 392 val { dir, file } = Path.splitDirFile (CommandLine.name ())
Chris@1706 393 in
Chris@1706 394 FileSys.realPath
Chris@1706 395 (if Path.isAbsolute dir
Chris@1706 396 then dir
Chris@1706 397 else Path.concat (FileSys.getDir (), dir))
Chris@1706 398 end
Chris@1706 399
Chris@1706 400 fun homedir () =
Chris@1706 401 (* Failure is not routine, so we use an exception here *)
Chris@1706 402 case (OS.Process.getEnv "HOME",
Chris@1706 403 OS.Process.getEnv "HOMEPATH") of
Chris@1706 404 (SOME home, _) => home
Chris@1706 405 | (NONE, SOME home) => home
Chris@1706 406 | (NONE, NONE) =>
Chris@1706 407 raise Fail "Failed to look up home directory from environment"
Chris@1706 408
Chris@1747 409 fun mkpath' path =
Chris@1706 410 if OS.FileSys.isDir path handle _ => false
Chris@1706 411 then OK ()
Chris@1706 412 else case OS.Path.fromString path of
Chris@1706 413 { arcs = nil, ... } => OK ()
Chris@1706 414 | { isAbs = false, ... } => ERROR "mkpath requires absolute path"
Chris@1706 415 | { isAbs, vol, arcs } =>
Chris@1747 416 case mkpath' (OS.Path.toString { (* parent *)
Chris@1747 417 isAbs = isAbs,
Chris@1747 418 vol = vol,
Chris@1747 419 arcs = rev (tl (rev arcs)) }) of
Chris@1706 420 ERROR e => ERROR e
Chris@1706 421 | OK () => ((OS.FileSys.mkDir path; OK ())
Chris@1706 422 handle OS.SysErr (e, _) =>
Chris@1706 423 ERROR ("Directory creation failed: " ^ e))
Chris@1746 424
Chris@1747 425 fun mkpath path =
Chris@1752 426 mkpath' (OS.Path.mkCanonical path)
Chris@1747 427
Chris@1756 428 fun dir_contents dir =
Chris@1746 429 let open OS
Chris@1746 430 fun files_from dirstream =
Chris@1746 431 case FileSys.readDir dirstream of
Chris@1746 432 NONE => []
Chris@1746 433 | SOME file =>
Chris@1746 434 (* readDir is supposed to filter these,
Chris@1746 435 but let's be extra cautious: *)
Chris@1746 436 if file = Path.parentArc orelse file = Path.currentArc
Chris@1746 437 then files_from dirstream
Chris@1746 438 else file :: files_from dirstream
Chris@1756 439 val stream = FileSys.openDir dir
Chris@1756 440 val files = map (fn f => Path.joinDirFile
Chris@1756 441 { dir = dir, file = f })
Chris@1756 442 (files_from stream)
Chris@1756 443 val _ = FileSys.closeDir stream
Chris@1756 444 in
Chris@1756 445 files
Chris@1756 446 end
Chris@1756 447
Chris@1756 448 fun rmpath' path =
Chris@1756 449 let open OS
Chris@1746 450 fun remove path =
Chris@1746 451 if FileSys.isLink path (* dangling links bother isDir *)
Chris@1746 452 then FileSys.remove path
Chris@1746 453 else if FileSys.isDir path
Chris@1756 454 then (app remove (dir_contents path); FileSys.rmDir path)
Chris@1746 455 else FileSys.remove path
Chris@1746 456 in
Chris@1746 457 (remove path; OK ())
Chris@1746 458 handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
Chris@1746 459 end
Chris@1752 460
Chris@1752 461 fun rmpath path =
Chris@1752 462 rmpath' (OS.Path.mkCanonical path)
Chris@1752 463
Chris@1756 464 fun nonempty_dir_exists path =
Chris@1756 465 let open OS.FileSys
Chris@1756 466 in
Chris@1756 467 (not (isLink path) andalso
Chris@1756 468 isDir path andalso
Chris@1756 469 dir_contents path <> [])
Chris@1756 470 handle _ => false
Chris@1756 471 end
Chris@1756 472
Chris@1706 473 end
Chris@1706 474
Chris@1706 475 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
Chris@1706 476
Chris@1706 477 (* Valid states for unpinned libraries:
Chris@1706 478
Chris@1706 479 - CORRECT: We are on the right branch and are up-to-date with
Chris@1706 480 it as far as we can tell. (If not using the network, this
Chris@1706 481 should be reported to user as "Present" rather than "Correct"
Chris@1706 482 as the remote repo may have advanced without us knowing.)
Chris@1706 483
Chris@1706 484 - SUPERSEDED: We are on the right branch but we can see that
Chris@1706 485 there is a newer revision either locally or on the remote (in
Chris@1706 486 Git terms, we are at an ancestor of the desired branch tip).
Chris@1706 487
Chris@1706 488 - WRONG: We are on the wrong branch (in Git terms, we are not
Chris@1706 489 at the desired branch tip or any ancestor of it).
Chris@1706 490
Chris@1706 491 - ABSENT: Repo doesn't exist here at all.
Chris@1706 492
Chris@1706 493 Valid states for pinned libraries:
Chris@1706 494
Chris@1706 495 - CORRECT: We are at the pinned revision.
Chris@1706 496
Chris@1706 497 - WRONG: We are at any revision other than the pinned one.
Chris@1706 498
Chris@1706 499 - ABSENT: Repo doesn't exist here at all.
Chris@1706 500 *)
Chris@1706 501
Chris@1740 502 fun check with_network context
Chris@1752 503 ({ libname, source, branch,
Chris@1752 504 project_pin, lock_pin, ... } : libspec) =
Chris@1706 505 let fun check_unpinned () =
Chris@1752 506 let val newest =
Chris@1752 507 if with_network
Chris@1752 508 then V.is_newest context (libname, source, branch)
Chris@1752 509 else V.is_newest_locally context (libname, branch)
Chris@1706 510 in
Chris@1752 511 case newest of
Chris@1706 512 ERROR e => ERROR e
Chris@1706 513 | OK true => OK CORRECT
Chris@1706 514 | OK false =>
Chris@1706 515 case V.is_on_branch context (libname, branch) of
Chris@1706 516 ERROR e => ERROR e
Chris@1706 517 | OK true => OK SUPERSEDED
Chris@1706 518 | OK false => OK WRONG
Chris@1706 519 end
Chris@1706 520 fun check_pinned target =
Chris@1706 521 case V.is_at context (libname, target) of
Chris@1706 522 ERROR e => ERROR e
Chris@1706 523 | OK true => OK CORRECT
Chris@1706 524 | OK false => OK WRONG
Chris@1740 525 fun check_remote () =
Chris@1740 526 case project_pin of
Chris@1706 527 UNPINNED => check_unpinned ()
Chris@1706 528 | PINNED target => check_pinned target
Chris@1740 529 fun check_local () =
Chris@1740 530 case V.is_modified_locally context libname of
Chris@1740 531 ERROR e => ERROR e
Chris@1740 532 | OK true => OK MODIFIED
Chris@1740 533 | OK false =>
Chris@1740 534 case lock_pin of
Chris@1740 535 UNPINNED => OK CLEAN
Chris@1740 536 | PINNED target =>
Chris@1740 537 case V.is_at context (libname, target) of
Chris@1740 538 ERROR e => ERROR e
Chris@1740 539 | OK true => OK CLEAN
Chris@1740 540 | OK false => OK LOCK_MISMATCHED
Chris@1706 541 in
Chris@1706 542 case V.exists context libname of
Chris@1706 543 ERROR e => ERROR e
Chris@1740 544 | OK false => OK (ABSENT, CLEAN)
Chris@1706 545 | OK true =>
Chris@1740 546 case (check_remote (), check_local ()) of
Chris@1706 547 (ERROR e, _) => ERROR e
Chris@1706 548 | (_, ERROR e) => ERROR e
Chris@1740 549 | (OK r, OK l) => OK (r, l)
Chris@1706 550 end
Chris@1706 551
Chris@1706 552 val review = check true
Chris@1706 553 val status = check false
Chris@1740 554
Chris@1740 555 fun update context
Chris@1740 556 ({ libname, source, branch,
Chris@1740 557 project_pin, lock_pin, ... } : libspec) =
Chris@1706 558 let fun update_unpinned () =
Chris@1752 559 case V.is_newest context (libname, source, branch) of
Chris@1706 560 ERROR e => ERROR e
Chris@1758 561 | OK true => OK ()
Chris@1752 562 | OK false => V.update context (libname, source, branch)
Chris@1706 563 fun update_pinned target =
Chris@1706 564 case V.is_at context (libname, target) of
Chris@1706 565 ERROR e => ERROR e
Chris@1758 566 | OK true => OK ()
Chris@1752 567 | OK false => V.update_to context (libname, source, target)
Chris@1706 568 fun update' () =
Chris@1740 569 case lock_pin of
Chris@1740 570 PINNED target => update_pinned target
Chris@1740 571 | UNPINNED =>
Chris@1740 572 case project_pin of
Chris@1740 573 PINNED target => update_pinned target
Chris@1740 574 | UNPINNED => update_unpinned ()
Chris@1706 575 in
Chris@1706 576 case V.exists context libname of
Chris@1706 577 ERROR e => ERROR e
Chris@1706 578 | OK true => update' ()
Chris@1706 579 | OK false =>
Chris@1706 580 case V.checkout context (libname, source, branch) of
Chris@1706 581 ERROR e => ERROR e
Chris@1706 582 | OK () => update' ()
Chris@1706 583 end
Chris@1740 584
Chris@1740 585 fun id_of context ({ libname, ... } : libspec) =
Chris@1740 586 V.id_of context libname
Chris@1772 587
Chris@1772 588 fun is_working context vcs =
Chris@1772 589 V.is_working context
Chris@1740 590
Chris@1706 591 end
Chris@1706 592
Chris@1706 593 (* Simple Standard ML JSON parser
Chris@1706 594 https://bitbucket.org/cannam/sml-simplejson
Chris@1761 595 Copyright 2017 Chris Cannam. BSD licence.
Chris@1706 596 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
Chris@1706 597 *)
Chris@1706 598
Chris@1706 599 signature JSON = sig
Chris@1706 600
Chris@1706 601 datatype json = OBJECT of (string * json) list
Chris@1706 602 | ARRAY of json list
Chris@1706 603 | NUMBER of real
Chris@1706 604 | STRING of string
Chris@1706 605 | BOOL of bool
Chris@1706 606 | NULL
Chris@1706 607
Chris@1706 608 datatype 'a result = OK of 'a
Chris@1706 609 | ERROR of string
Chris@1706 610
Chris@1706 611 val parse : string -> json result
Chris@1706 612 val serialise : json -> string
Chris@1706 613 val serialiseIndented : json -> string
Chris@1706 614
Chris@1706 615 end
Chris@1706 616
Chris@1706 617 structure Json :> JSON = struct
Chris@1706 618
Chris@1706 619 datatype json = OBJECT of (string * json) list
Chris@1706 620 | ARRAY of json list
Chris@1706 621 | NUMBER of real
Chris@1706 622 | STRING of string
Chris@1706 623 | BOOL of bool
Chris@1706 624 | NULL
Chris@1706 625
Chris@1706 626 datatype 'a result = OK of 'a
Chris@1706 627 | ERROR of string
Chris@1706 628
Chris@1706 629 structure T = struct
Chris@1706 630 datatype token = NUMBER of char list
Chris@1706 631 | STRING of string
Chris@1706 632 | BOOL of bool
Chris@1706 633 | NULL
Chris@1706 634 | CURLY_L
Chris@1706 635 | CURLY_R
Chris@1706 636 | SQUARE_L
Chris@1706 637 | SQUARE_R
Chris@1706 638 | COLON
Chris@1706 639 | COMMA
Chris@1706 640
Chris@1706 641 fun toString t =
Chris@1706 642 case t of NUMBER digits => implode digits
Chris@1706 643 | STRING s => s
Chris@1706 644 | BOOL b => Bool.toString b
Chris@1706 645 | NULL => "null"
Chris@1706 646 | CURLY_L => "{"
Chris@1706 647 | CURLY_R => "}"
Chris@1706 648 | SQUARE_L => "["
Chris@1706 649 | SQUARE_R => "]"
Chris@1706 650 | COLON => ":"
Chris@1706 651 | COMMA => ","
Chris@1706 652 end
Chris@1706 653
Chris@1706 654 fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *)
Chris@1706 655 let open Word
Chris@1706 656 infix 6 orb andb >>
Chris@1706 657 in
Chris@1706 658 map (Char.chr o toInt)
Chris@1706 659 (if cp < 0wx80 then
Chris@1706 660 [cp]
Chris@1706 661 else if cp < 0wx800 then
Chris@1706 662 [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
Chris@1706 663 else if cp < 0wx10000 then
Chris@1706 664 [0wxe0 orb (cp >> 0w12),
Chris@1706 665 0wx80 orb ((cp >> 0w6) andb 0wx3f),
Chris@1706 666 0wx80 orb (cp andb 0wx3f)]
Chris@1706 667 else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
Chris@1706 668 end
Chris@1706 669
Chris@1706 670 fun error pos text = ERROR (text ^ " at character position " ^
Chris@1706 671 Int.toString (pos - 1))
Chris@1706 672 fun token_error pos = error pos ("Unexpected token")
Chris@1706 673
Chris@1706 674 fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
Chris@1706 675 lex (pos + 3) (T.NULL :: acc) xs
Chris@1706 676 | lexNull pos acc _ = token_error pos
Chris@1706 677
Chris@1706 678 and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
Chris@1706 679 lex (pos + 3) (T.BOOL true :: acc) xs
Chris@1706 680 | lexTrue pos acc _ = token_error pos
Chris@1706 681
Chris@1706 682 and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
Chris@1706 683 lex (pos + 4) (T.BOOL false :: acc) xs
Chris@1706 684 | lexFalse pos acc _ = token_error pos
Chris@1706 685
Chris@1706 686 and lexChar tok pos acc xs =
Chris@1706 687 lex pos (tok :: acc) xs
Chris@1706 688
Chris@1706 689 and lexString pos acc cc =
Chris@1706 690 let datatype escaped = ESCAPED | NORMAL
Chris@1706 691 fun lexString' pos text ESCAPED [] =
Chris@1706 692 error pos "End of input during escape sequence"
Chris@1706 693 | lexString' pos text NORMAL [] =
Chris@1706 694 error pos "End of input during string"
Chris@1706 695 | lexString' pos text ESCAPED (x :: xs) =
Chris@1706 696 let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
Chris@1706 697 in case x of
Chris@1706 698 #"\"" => esc x
Chris@1706 699 | #"\\" => esc x
Chris@1706 700 | #"/" => esc x
Chris@1706 701 | #"b" => esc #"\b"
Chris@1706 702 | #"f" => esc #"\f"
Chris@1706 703 | #"n" => esc #"\n"
Chris@1706 704 | #"r" => esc #"\r"
Chris@1706 705 | #"t" => esc #"\t"
Chris@1706 706 | _ => error pos ("Invalid escape \\" ^
Chris@1706 707 Char.toString x)
Chris@1706 708 end
Chris@1706 709 | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
Chris@1706 710 if List.all Char.isHexDigit [a,b,c,d]
Chris@1706 711 then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
Chris@1706 712 SOME w => (let val utf = rev (bmpToUtf8 w) in
Chris@1706 713 lexString' (pos + 6) (utf @ text)
Chris@1706 714 NORMAL xs
Chris@1706 715 end
Chris@1706 716 handle Fail err => error pos err)
Chris@1706 717 | NONE => error pos "Invalid Unicode BMP escape sequence"
Chris@1706 718 else error pos "Invalid Unicode BMP escape sequence"
Chris@1706 719 | lexString' pos text NORMAL (x :: xs) =
Chris@1706 720 if Char.ord x < 0x20
Chris@1706 721 then error pos "Invalid unescaped control character"
Chris@1706 722 else
Chris@1706 723 case x of
Chris@1706 724 #"\"" => OK (rev text, xs, pos + 1)
Chris@1706 725 | #"\\" => lexString' (pos + 1) text ESCAPED xs
Chris@1706 726 | _ => lexString' (pos + 1) (x :: text) NORMAL xs
Chris@1706 727 in
Chris@1706 728 case lexString' pos [] NORMAL cc of
Chris@1706 729 OK (text, rest, newpos) =>
Chris@1706 730 lex newpos (T.STRING (implode text) :: acc) rest
Chris@1706 731 | ERROR e => ERROR e
Chris@1706 732 end
Chris@1706 733
Chris@1706 734 and lexNumber firstChar pos acc cc =
Chris@1706 735 let val valid = explode ".+-e"
Chris@1706 736 fun lexNumber' pos digits [] = (rev digits, [], pos)
Chris@1706 737 | lexNumber' pos digits (x :: xs) =
Chris@1706 738 if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
Chris@1706 739 else if Char.isDigit x orelse List.exists (fn c => x = c) valid
Chris@1706 740 then lexNumber' (pos + 1) (x :: digits) xs
Chris@1706 741 else (rev digits, x :: xs, pos)
Chris@1706 742 val (digits, rest, newpos) =
Chris@1706 743 lexNumber' (pos - 1) [] (firstChar :: cc)
Chris@1706 744 in
Chris@1706 745 case digits of
Chris@1706 746 [] => token_error pos
Chris@1706 747 | _ => lex newpos (T.NUMBER digits :: acc) rest
Chris@1706 748 end
Chris@1706 749
Chris@1706 750 and lex pos acc [] = OK (rev acc)
Chris@1706 751 | lex pos acc (x::xs) =
Chris@1706 752 (case x of
Chris@1706 753 #" " => lex
Chris@1706 754 | #"\t" => lex
Chris@1706 755 | #"\n" => lex
Chris@1706 756 | #"\r" => lex
Chris@1706 757 | #"{" => lexChar T.CURLY_L
Chris@1706 758 | #"}" => lexChar T.CURLY_R
Chris@1706 759 | #"[" => lexChar T.SQUARE_L
Chris@1706 760 | #"]" => lexChar T.SQUARE_R
Chris@1706 761 | #":" => lexChar T.COLON
Chris@1706 762 | #"," => lexChar T.COMMA
Chris@1706 763 | #"\"" => lexString
Chris@1706 764 | #"t" => lexTrue
Chris@1706 765 | #"f" => lexFalse
Chris@1706 766 | #"n" => lexNull
Chris@1706 767 | x => lexNumber x) (pos + 1) acc xs
Chris@1706 768
Chris@1706 769 fun show [] = "end of input"
Chris@1706 770 | show (tok :: _) = T.toString tok
Chris@1706 771
Chris@1706 772 fun parseNumber digits =
Chris@1706 773 (* Note lexNumber already case-insensitised the E for us *)
Chris@1706 774 let open Char
Chris@1706 775
Chris@1706 776 fun okExpDigits [] = false
Chris@1706 777 | okExpDigits (c :: []) = isDigit c
Chris@1706 778 | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
Chris@1706 779
Chris@1706 780 fun okExponent [] = false
Chris@1706 781 | okExponent (#"+" :: cs) = okExpDigits cs
Chris@1706 782 | okExponent (#"-" :: cs) = okExpDigits cs
Chris@1706 783 | okExponent cc = okExpDigits cc
Chris@1706 784
Chris@1706 785 fun okFracTrailing [] = true
Chris@1706 786 | okFracTrailing (c :: cs) =
Chris@1706 787 (isDigit c andalso okFracTrailing cs) orelse
Chris@1706 788 (c = #"e" andalso okExponent cs)
Chris@1706 789
Chris@1706 790 fun okFraction [] = false
Chris@1706 791 | okFraction (c :: cs) =
Chris@1706 792 isDigit c andalso okFracTrailing cs
Chris@1706 793
Chris@1706 794 fun okPosTrailing [] = true
Chris@1706 795 | okPosTrailing (#"." :: cs) = okFraction cs
Chris@1706 796 | okPosTrailing (#"e" :: cs) = okExponent cs
Chris@1706 797 | okPosTrailing (c :: cs) =
Chris@1706 798 isDigit c andalso okPosTrailing cs
Chris@1706 799
Chris@1706 800 fun okPositive [] = false
Chris@1706 801 | okPositive (#"0" :: []) = true
Chris@1706 802 | okPositive (#"0" :: #"." :: cs) = okFraction cs
Chris@1706 803 | okPositive (#"0" :: #"e" :: cs) = okExponent cs
Chris@1706 804 | okPositive (#"0" :: cs) = false
Chris@1706 805 | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
Chris@1706 806
Chris@1706 807 fun okNumber (#"-" :: cs) = okPositive cs
Chris@1706 808 | okNumber cc = okPositive cc
Chris@1706 809 in
Chris@1706 810 if okNumber digits
Chris@1706 811 then case Real.fromString (implode digits) of
Chris@1706 812 NONE => ERROR "Number out of range"
Chris@1706 813 | SOME r => OK r
Chris@1706 814 else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
Chris@1706 815 end
Chris@1706 816
Chris@1706 817 fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
Chris@1706 818 | parseObject tokens =
Chris@1706 819 let fun parsePair (T.STRING key :: T.COLON :: xs) =
Chris@1706 820 (case parseTokens xs of
Chris@1706 821 ERROR e => ERROR e
Chris@1706 822 | OK (j, xs) => OK ((key, j), xs))
Chris@1706 823 | parsePair other =
Chris@1706 824 ERROR ("Object key/value pair expected around \"" ^
Chris@1706 825 show other ^ "\"")
Chris@1706 826 fun parseObject' acc [] = ERROR "End of input during object"
Chris@1706 827 | parseObject' acc tokens =
Chris@1706 828 case parsePair tokens of
Chris@1706 829 ERROR e => ERROR e
Chris@1706 830 | OK (pair, T.COMMA :: xs) =>
Chris@1706 831 parseObject' (pair :: acc) xs
Chris@1706 832 | OK (pair, T.CURLY_R :: xs) =>
Chris@1706 833 OK (OBJECT (rev (pair :: acc)), xs)
Chris@1706 834 | OK (_, _) => ERROR "Expected , or } after object element"
Chris@1706 835 in
Chris@1706 836 parseObject' [] tokens
Chris@1706 837 end
Chris@1706 838
Chris@1706 839 and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
Chris@1706 840 | parseArray tokens =
Chris@1706 841 let fun parseArray' acc [] = ERROR "End of input during array"
Chris@1706 842 | parseArray' acc tokens =
Chris@1706 843 case parseTokens tokens of
Chris@1706 844 ERROR e => ERROR e
Chris@1706 845 | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
Chris@1706 846 | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
Chris@1706 847 | OK (_, _) => ERROR "Expected , or ] after array element"
Chris@1706 848 in
Chris@1706 849 parseArray' [] tokens
Chris@1706 850 end
Chris@1706 851
Chris@1706 852 and parseTokens [] = ERROR "Value expected"
Chris@1706 853 | parseTokens (tok :: xs) =
Chris@1706 854 (case tok of
Chris@1706 855 T.NUMBER d => (case parseNumber d of
Chris@1706 856 OK r => OK (NUMBER r, xs)
Chris@1706 857 | ERROR e => ERROR e)
Chris@1706 858 | T.STRING s => OK (STRING s, xs)
Chris@1706 859 | T.BOOL b => OK (BOOL b, xs)
Chris@1706 860 | T.NULL => OK (NULL, xs)
Chris@1706 861 | T.CURLY_L => parseObject xs
Chris@1706 862 | T.SQUARE_L => parseArray xs
Chris@1706 863 | _ => ERROR ("Unexpected token " ^ T.toString tok ^
Chris@1706 864 " before " ^ show xs))
Chris@1706 865
Chris@1706 866 fun parse str =
Chris@1706 867 case lex 1 [] (explode str) of
Chris@1706 868 ERROR e => ERROR e
Chris@1706 869 | OK tokens => case parseTokens tokens of
Chris@1706 870 OK (value, []) => OK value
Chris@1706 871 | OK (_, _) => ERROR "Extra data after input"
Chris@1706 872 | ERROR e => ERROR e
Chris@1706 873
Chris@1706 874 fun stringEscape s =
Chris@1706 875 let fun esc x = [x, #"\\"]
Chris@1706 876 fun escape' acc [] = rev acc
Chris@1706 877 | escape' acc (x :: xs) =
Chris@1706 878 escape' (case x of
Chris@1706 879 #"\"" => esc x @ acc
Chris@1706 880 | #"\\" => esc x @ acc
Chris@1706 881 | #"\b" => esc #"b" @ acc
Chris@1706 882 | #"\f" => esc #"f" @ acc
Chris@1706 883 | #"\n" => esc #"n" @ acc
Chris@1706 884 | #"\r" => esc #"r" @ acc
Chris@1706 885 | #"\t" => esc #"t" @ acc
Chris@1706 886 | _ =>
Chris@1706 887 let val c = Char.ord x
Chris@1706 888 in
Chris@1706 889 if c < 0x20
Chris@1706 890 then let val hex = Word.toString (Word.fromInt c)
Chris@1706 891 in (rev o explode) (if c < 0x10
Chris@1706 892 then ("\\u000" ^ hex)
Chris@1706 893 else ("\\u00" ^ hex))
Chris@1706 894 end @ acc
Chris@1706 895 else
Chris@1706 896 x :: acc
Chris@1706 897 end)
Chris@1706 898 xs
Chris@1706 899 in
Chris@1706 900 implode (escape' [] (explode s))
Chris@1706 901 end
Chris@1706 902
Chris@1706 903 fun serialise json =
Chris@1706 904 case json of
Chris@1706 905 OBJECT pp => "{" ^ String.concatWith
Chris@1706 906 "," (map (fn (key, value) =>
Chris@1706 907 serialise (STRING key) ^ ":" ^
Chris@1706 908 serialise value) pp) ^
Chris@1706 909 "}"
Chris@1706 910 | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
Chris@1706 911 | NUMBER n => implode (map (fn #"~" => #"-" | c => c)
Chris@1706 912 (explode (Real.toString n)))
Chris@1706 913 | STRING s => "\"" ^ stringEscape s ^ "\""
Chris@1706 914 | BOOL b => Bool.toString b
Chris@1706 915 | NULL => "null"
Chris@1706 916
Chris@1706 917 fun serialiseIndented json =
Chris@1706 918 let fun indent 0 = ""
Chris@1706 919 | indent i = " " ^ indent (i - 1)
Chris@1706 920 fun serialiseIndented' i json =
Chris@1706 921 let val ser = serialiseIndented' (i + 1)
Chris@1706 922 in
Chris@1706 923 case json of
Chris@1706 924 OBJECT [] => "{}"
Chris@1706 925 | ARRAY [] => "[]"
Chris@1706 926 | OBJECT pp => "{\n" ^ indent (i + 1) ^
Chris@1706 927 String.concatWith
Chris@1706 928 (",\n" ^ indent (i + 1))
Chris@1706 929 (map (fn (key, value) =>
Chris@1706 930 ser (STRING key) ^ ": " ^
Chris@1706 931 ser value) pp) ^
Chris@1706 932 "\n" ^ indent i ^ "}"
Chris@1706 933 | ARRAY arr => "[\n" ^ indent (i + 1) ^
Chris@1706 934 String.concatWith
Chris@1706 935 (",\n" ^ indent (i + 1))
Chris@1706 936 (map ser arr) ^
Chris@1706 937 "\n" ^ indent i ^ "]"
Chris@1706 938 | other => serialise other
Chris@1706 939 end
Chris@1706 940 in
Chris@1706 941 serialiseIndented' 0 json ^ "\n"
Chris@1706 942 end
Chris@1706 943
Chris@1706 944 end
Chris@1706 945
Chris@1706 946
Chris@1706 947 structure JsonBits :> sig
Chris@1776 948 exception Config of string
Chris@1706 949 val load_json_from : string -> Json.json (* filename -> json *)
Chris@1706 950 val save_json_to : string -> Json.json -> unit
Chris@1706 951 val lookup_optional : Json.json -> string list -> Json.json option
Chris@1706 952 val lookup_optional_string : Json.json -> string list -> string option
Chris@1706 953 val lookup_mandatory : Json.json -> string list -> Json.json
Chris@1706 954 val lookup_mandatory_string : Json.json -> string list -> string
Chris@1706 955 end = struct
Chris@1706 956
Chris@1776 957 exception Config of string
Chris@1776 958
Chris@1706 959 fun load_json_from filename =
Chris@1706 960 case Json.parse (FileBits.file_contents filename) of
Chris@1706 961 Json.OK json => json
Chris@1776 962 | Json.ERROR e => raise Config ("Failed to parse file: " ^ e)
Chris@1706 963
Chris@1706 964 fun save_json_to filename json =
Chris@1732 965 (* using binary I/O to avoid ever writing CR/LF line endings *)
Chris@1706 966 let val jstr = Json.serialiseIndented json
Chris@1732 967 val stream = BinIO.openOut filename
Chris@1706 968 in
Chris@1732 969 BinIO.output (stream, Byte.stringToBytes jstr);
Chris@1732 970 BinIO.closeOut stream
Chris@1706 971 end
Chris@1706 972
Chris@1706 973 fun lookup_optional json kk =
Chris@1706 974 let fun lookup key =
Chris@1706 975 case json of
Chris@1706 976 Json.OBJECT kvs =>
Chris@1776 977 (case List.filter (fn (k, v) => k = key) kvs of
Chris@1776 978 [] => NONE
Chris@1776 979 | [(_,v)] => SOME v
Chris@1776 980 | _ => raise Config ("Duplicate key: " ^
Chris@1776 981 (String.concatWith " -> " kk)))
Chris@1776 982 | _ => raise Config "Object expected"
Chris@1706 983 in
Chris@1706 984 case kk of
Chris@1706 985 [] => NONE
Chris@1706 986 | key::[] => lookup key
Chris@1706 987 | key::kk => case lookup key of
Chris@1706 988 NONE => NONE
Chris@1706 989 | SOME j => lookup_optional j kk
Chris@1706 990 end
Chris@1706 991
Chris@1706 992 fun lookup_optional_string json kk =
Chris@1706 993 case lookup_optional json kk of
Chris@1706 994 SOME (Json.STRING s) => SOME s
Chris@1776 995 | SOME _ => raise Config ("Value (if present) must be string: " ^
Chris@1776 996 (String.concatWith " -> " kk))
Chris@1706 997 | NONE => NONE
Chris@1706 998
Chris@1706 999 fun lookup_mandatory json kk =
Chris@1706 1000 case lookup_optional json kk of
Chris@1706 1001 SOME v => v
Chris@1776 1002 | NONE => raise Config ("Value is mandatory: " ^
Chris@1776 1003 (String.concatWith " -> " kk))
Chris@1706 1004
Chris@1706 1005 fun lookup_mandatory_string json kk =
Chris@1706 1006 case lookup_optional json kk of
Chris@1706 1007 SOME (Json.STRING s) => s
Chris@1776 1008 | _ => raise Config ("Value must be string: " ^
Chris@1776 1009 (String.concatWith " -> " kk))
Chris@1706 1010 end
Chris@1706 1011
Chris@1706 1012 structure Provider :> sig
Chris@1706 1013 val load_providers : Json.json -> provider list
Chris@1706 1014 val load_more_providers : provider list -> Json.json -> provider list
Chris@1706 1015 val remote_url : context -> vcs -> source -> libname -> string
Chris@1706 1016 end = struct
Chris@1706 1017
Chris@1706 1018 val known_providers : provider list =
Chris@1706 1019 [ {
Chris@1706 1020 service = "bitbucket",
Chris@1706 1021 supports = [HG, GIT],
Chris@1706 1022 remote_spec = {
Chris@1724 1023 anon = SOME "https://bitbucket.org/{owner}/{repository}",
Chris@1724 1024 auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}"
Chris@1706 1025 }
Chris@1706 1026 },
Chris@1706 1027 {
Chris@1706 1028 service = "github",
Chris@1706 1029 supports = [GIT],
Chris@1706 1030 remote_spec = {
Chris@1724 1031 anon = SOME "https://github.com/{owner}/{repository}",
Chris@1724 1032 auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}"
Chris@1706 1033 }
Chris@1706 1034 }
Chris@1706 1035 ]
Chris@1706 1036
Chris@1706 1037 fun vcs_name vcs =
Chris@1756 1038 case vcs of HG => "hg"
Chris@1756 1039 | GIT => "git"
Chris@1756 1040 | SVN => "svn"
Chris@1706 1041
Chris@1706 1042 fun vcs_from_name name =
Chris@1756 1043 case name of "hg" => HG
Chris@1756 1044 | "git" => GIT
Chris@1756 1045 | "svn" => SVN
Chris@1706 1046 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
Chris@1706 1047
Chris@1706 1048 fun load_more_providers previously_loaded json =
Chris@1706 1049 let open JsonBits
Chris@1706 1050 fun load pjson pname : provider =
Chris@1706 1051 {
Chris@1706 1052 service = pname,
Chris@1706 1053 supports =
Chris@1706 1054 case lookup_mandatory pjson ["vcs"] of
Chris@1706 1055 Json.ARRAY vv =>
Chris@1706 1056 map (fn (Json.STRING v) => vcs_from_name v
Chris@1706 1057 | _ => raise Fail "Strings expected in vcs array")
Chris@1706 1058 vv
Chris@1706 1059 | _ => raise Fail "Array expected for vcs",
Chris@1706 1060 remote_spec = {
Chris@1724 1061 anon = lookup_optional_string pjson ["anonymous"],
Chris@1724 1062 auth = lookup_optional_string pjson ["authenticated"]
Chris@1706 1063 }
Chris@1706 1064 }
Chris@1706 1065 val loaded =
Chris@1721 1066 case lookup_optional json ["services"] of
Chris@1706 1067 NONE => []
Chris@1706 1068 | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
Chris@1721 1069 | _ => raise Fail "Object expected for services in config"
Chris@1706 1070 val newly_loaded =
Chris@1706 1071 List.filter (fn p => not (List.exists (fn pp => #service p =
Chris@1706 1072 #service pp)
Chris@1706 1073 previously_loaded))
Chris@1706 1074 loaded
Chris@1706 1075 in
Chris@1706 1076 previously_loaded @ newly_loaded
Chris@1706 1077 end
Chris@1706 1078
Chris@1706 1079 fun load_providers json =
Chris@1706 1080 load_more_providers known_providers json
Chris@1706 1081
Chris@1706 1082 fun expand_spec spec { vcs, service, owner, repo } login =
Chris@1706 1083 (* ugly *)
Chris@1706 1084 let fun replace str =
Chris@1706 1085 case str of
Chris@1706 1086 "vcs" => vcs_name vcs
Chris@1706 1087 | "service" => service
Chris@1706 1088 | "owner" =>
Chris@1706 1089 (case owner of
Chris@1706 1090 SOME ostr => ostr
Chris@1706 1091 | NONE => raise Fail ("Owner not specified for service " ^
Chris@1706 1092 service))
Chris@1724 1093 | "repository" => repo
Chris@1706 1094 | "account" =>
Chris@1706 1095 (case login of
Chris@1706 1096 SOME acc => acc
Chris@1706 1097 | NONE => raise Fail ("Account not given for service " ^
Chris@1706 1098 service))
Chris@1706 1099 | other => raise Fail ("Unknown variable \"" ^ other ^
Chris@1706 1100 "\" in spec for service " ^ service)
Chris@1706 1101 fun expand' acc sstr =
Chris@1706 1102 case Substring.splitl (fn c => c <> #"{") sstr of
Chris@1706 1103 (pfx, sfx) =>
Chris@1706 1104 if Substring.isEmpty sfx
Chris@1706 1105 then rev (pfx :: acc)
Chris@1706 1106 else
Chris@1706 1107 case Substring.splitl (fn c => c <> #"}") sfx of
Chris@1706 1108 (tok, remainder) =>
Chris@1706 1109 if Substring.isEmpty remainder
Chris@1706 1110 then rev (tok :: pfx :: acc)
Chris@1706 1111 else let val replacement =
Chris@1706 1112 replace
Chris@1706 1113 (* tok begins with "{": *)
Chris@1706 1114 (Substring.string
Chris@1706 1115 (Substring.triml 1 tok))
Chris@1706 1116 in
Chris@1706 1117 expand' (Substring.full replacement ::
Chris@1706 1118 pfx :: acc)
Chris@1706 1119 (* remainder begins with "}": *)
Chris@1706 1120 (Substring.triml 1 remainder)
Chris@1706 1121 end
Chris@1706 1122 in
Chris@1706 1123 Substring.concat (expand' [] (Substring.full spec))
Chris@1706 1124 end
Chris@1706 1125
Chris@1706 1126 fun provider_url req login providers =
Chris@1706 1127 case providers of
Chris@1706 1128 [] => raise Fail ("Unknown service \"" ^ (#service req) ^
Chris@1706 1129 "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
Chris@1706 1130 | ({ service, supports, remote_spec : remote_spec } :: rest) =>
Chris@1706 1131 if service <> (#service req) orelse
Chris@1706 1132 not (List.exists (fn v => v = (#vcs req)) supports)
Chris@1706 1133 then provider_url req login rest
Chris@1706 1134 else
Chris@1706 1135 case (login, #auth remote_spec, #anon remote_spec) of
Chris@1706 1136 (SOME _, SOME auth, _) => expand_spec auth req login
Chris@1706 1137 | (SOME _, _, SOME anon) => expand_spec anon req NONE
Chris@1706 1138 | (NONE, _, SOME anon) => expand_spec anon req NONE
Chris@1724 1139 | _ => raise Fail ("No suitable anonymous or authenticated " ^
Chris@1724 1140 "URL spec provided for service \"" ^
Chris@1724 1141 service ^ "\"")
Chris@1706 1142
Chris@1706 1143 fun login_for ({ accounts, ... } : context) service =
Chris@1706 1144 case List.find (fn a => service = #service a) accounts of
Chris@1706 1145 SOME { login, ... } => SOME login
Chris@1706 1146 | NONE => NONE
Chris@1747 1147
Chris@1747 1148 fun reponame_for path =
Chris@1747 1149 case String.tokens (fn c => c = #"/") path of
Chris@1747 1150 [] => raise Fail "Non-empty library path required"
Chris@1747 1151 | toks => hd (rev toks)
Chris@1747 1152
Chris@1706 1153 fun remote_url (context : context) vcs source libname =
Chris@1706 1154 case source of
Chris@1721 1155 URL_SOURCE u => u
Chris@1721 1156 | SERVICE_SOURCE { service, owner, repo } =>
Chris@1706 1157 provider_url { vcs = vcs,
Chris@1706 1158 service = service,
Chris@1706 1159 owner = owner,
Chris@1706 1160 repo = case repo of
Chris@1706 1161 SOME r => r
Chris@1747 1162 | NONE => reponame_for libname }
Chris@1706 1163 (login_for context service)
Chris@1706 1164 (#providers context)
Chris@1706 1165 end
Chris@1706 1166
Chris@1706 1167 structure HgControl :> VCS_CONTROL = struct
Chris@1752 1168
Chris@1752 1169 (* Pulls always use an explicit URL, never just the default
Chris@1752 1170 remote, in order to ensure we update properly if the location
Chris@1752 1171 given in the project file changes. *)
Chris@1752 1172
Chris@1706 1173 type vcsstate = { id: string, modified: bool,
Chris@1706 1174 branch: string, tags: string list }
Chris@1706 1175
Chris@1772 1176 val hg_program = "hg"
Chris@1772 1177
Chris@1756 1178 val hg_args = [ "--config", "ui.interactive=true",
Chris@1756 1179 "--config", "ui.merge=:merge" ]
Chris@1706 1180
Chris@1706 1181 fun hg_command context libname args =
Chris@1772 1182 FileBits.command context libname (hg_program :: hg_args @ args)
Chris@1706 1183
Chris@1706 1184 fun hg_command_output context libname args =
Chris@1772 1185 FileBits.command_output context libname (hg_program :: hg_args @ args)
Chris@1772 1186
Chris@1772 1187 fun is_working context =
Chris@1772 1188 case hg_command_output context "" ["--version"] of
Chris@1772 1189 OK "" => OK false
Chris@1772 1190 | OK _ => OK true
Chris@1772 1191 | ERROR e => ERROR e
Chris@1772 1192
Chris@1706 1193 fun exists context libname =
Chris@1706 1194 OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
Chris@1706 1195 handle _ => OK false
Chris@1706 1196
Chris@1706 1197 fun remote_for context (libname, source) =
Chris@1706 1198 Provider.remote_url context HG source libname
Chris@1706 1199
Chris@1706 1200 fun current_state context libname : vcsstate result =
Chris@1706 1201 let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
Chris@1706 1202 and extract_branch b =
Chris@1706 1203 if is_branch b (* need to remove enclosing parens *)
Chris@1706 1204 then (implode o rev o tl o rev o tl o explode) b
Chris@1706 1205 else "default"
Chris@1706 1206 and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
Chris@1706 1207 and extract_id id =
Chris@1706 1208 if is_modified id (* need to remove trailing "+" *)
Chris@1706 1209 then (implode o rev o tl o rev o explode) id
Chris@1706 1210 else id
Chris@1706 1211 and split_tags tags = String.tokens (fn c => c = #"/") tags
Chris@1706 1212 and state_for (id, branch, tags) =
Chris@1706 1213 OK { id = extract_id id,
Chris@1706 1214 modified = is_modified id,
Chris@1706 1215 branch = extract_branch branch,
Chris@1706 1216 tags = split_tags tags }
Chris@1706 1217 in
Chris@1706 1218 case hg_command_output context libname ["id"] of
Chris@1706 1219 ERROR e => ERROR e
Chris@1706 1220 | OK out =>
Chris@1706 1221 case String.tokens (fn x => x = #" ") out of
Chris@1706 1222 [id, branch, tags] => state_for (id, branch, tags)
Chris@1706 1223 | [id, other] => if is_branch other
Chris@1706 1224 then state_for (id, other, "")
Chris@1706 1225 else state_for (id, "", other)
Chris@1706 1226 | [id] => state_for (id, "", "")
Chris@1706 1227 | _ => ERROR ("Unexpected output from hg id: " ^ out)
Chris@1706 1228 end
Chris@1706 1229
Chris@1706 1230 fun branch_name branch = case branch of
Chris@1706 1231 DEFAULT_BRANCH => "default"
Chris@1706 1232 | BRANCH "" => "default"
Chris@1706 1233 | BRANCH b => b
Chris@1706 1234
Chris@1706 1235 fun id_of context libname =
Chris@1706 1236 case current_state context libname of
Chris@1706 1237 ERROR e => ERROR e
Chris@1706 1238 | OK { id, ... } => OK id
Chris@1706 1239
Chris@1706 1240 fun is_at context (libname, id_or_tag) =
Chris@1706 1241 case current_state context libname of
Chris@1706 1242 ERROR e => ERROR e
Chris@1706 1243 | OK { id, tags, ... } =>
Chris@1706 1244 OK (String.isPrefix id_or_tag id orelse
Chris@1706 1245 String.isPrefix id id_or_tag orelse
Chris@1706 1246 List.exists (fn t => t = id_or_tag) tags)
Chris@1706 1247
Chris@1706 1248 fun is_on_branch context (libname, b) =
Chris@1706 1249 case current_state context libname of
Chris@1706 1250 ERROR e => ERROR e
Chris@1706 1251 | OK { branch, ... } => OK (branch = branch_name b)
Chris@1706 1252
Chris@1706 1253 fun is_newest_locally context (libname, branch) =
Chris@1706 1254 case hg_command_output context libname
Chris@1706 1255 ["log", "-l1",
Chris@1706 1256 "-b", branch_name branch,
Chris@1706 1257 "--template", "{node}"] of
Chris@1752 1258 ERROR e => OK false (* desired branch does not exist *)
Chris@1706 1259 | OK newest_in_repo => is_at context (libname, newest_in_repo)
Chris@1706 1260
Chris@1752 1261 fun pull context (libname, source) =
Chris@1752 1262 let val url = remote_for context (libname, source)
Chris@1752 1263 in
Chris@1752 1264 hg_command context libname
Chris@1752 1265 (if FileBits.verbose ()
Chris@1752 1266 then ["pull", url]
Chris@1752 1267 else ["pull", "-q", url])
Chris@1752 1268 end
Chris@1706 1269
Chris@1752 1270 fun is_newest context (libname, source, branch) =
Chris@1706 1271 case is_newest_locally context (libname, branch) of
Chris@1706 1272 ERROR e => ERROR e
Chris@1706 1273 | OK false => OK false
Chris@1706 1274 | OK true =>
Chris@1752 1275 case pull context (libname, source) of
Chris@1706 1276 ERROR e => ERROR e
Chris@1706 1277 | _ => is_newest_locally context (libname, branch)
Chris@1706 1278
Chris@1706 1279 fun is_modified_locally context libname =
Chris@1706 1280 case current_state context libname of
Chris@1706 1281 ERROR e => ERROR e
Chris@1706 1282 | OK { modified, ... } => OK modified
Chris@1706 1283
Chris@1706 1284 fun checkout context (libname, source, branch) =
Chris@1706 1285 let val url = remote_for context (libname, source)
Chris@1706 1286 in
Chris@1747 1287 (* make the lib dir rather than just the ext dir, since
Chris@1747 1288 the lib dir might be nested and hg will happily check
Chris@1747 1289 out into an existing empty dir anyway *)
Chris@1747 1290 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1706 1291 ERROR e => ERROR e
Chris@1706 1292 | _ => hg_command context ""
Chris@1706 1293 ["clone", "-u", branch_name branch,
Chris@1706 1294 url, libname]
Chris@1706 1295 end
Chris@1706 1296
Chris@1752 1297 fun update context (libname, source, branch) =
Chris@1752 1298 let val pull_result = pull context (libname, source)
Chris@1706 1299 in
Chris@1706 1300 case hg_command context libname ["update", branch_name branch] of
Chris@1706 1301 ERROR e => ERROR e
Chris@1706 1302 | _ =>
Chris@1706 1303 case pull_result of
Chris@1706 1304 ERROR e => ERROR e
Chris@1758 1305 | _ => OK ()
Chris@1706 1306 end
Chris@1706 1307
Chris@1752 1308 fun update_to context (libname, _, "") =
Chris@1706 1309 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1752 1310 | update_to context (libname, source, id) =
Chris@1752 1311 let val pull_result = pull context (libname, source)
Chris@1723 1312 in
Chris@1723 1313 case hg_command context libname ["update", "-r", id] of
Chris@1758 1314 OK _ => OK ()
Chris@1723 1315 | ERROR e =>
Chris@1723 1316 case pull_result of
Chris@1723 1317 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@1723 1318 | _ => ERROR e
Chris@1723 1319 end
Chris@1756 1320
Chris@1756 1321 fun copy_url_for context libname =
Chris@1756 1322 OK (FileBits.file_url (FileBits.libpath context libname))
Chris@1756 1323
Chris@1706 1324 end
Chris@1706 1325
Chris@1706 1326 structure GitControl :> VCS_CONTROL = struct
Chris@1706 1327
Chris@1706 1328 (* With Git repos we always operate in detached HEAD state. Even
Chris@1752 1329 the master branch is checked out using a remote reference
Chris@1752 1330 (vext/master). The remote we use is always named vext, and we
Chris@1752 1331 update it to the expected URL each time we fetch, in order to
Chris@1752 1332 ensure we update properly if the location given in the project
Chris@1752 1333 file changes. The origin remote is unused. *)
Chris@1706 1334
Chris@1772 1335 val git_program = "git"
Chris@1772 1336
Chris@1706 1337 fun git_command context libname args =
Chris@1772 1338 FileBits.command context libname (git_program :: args)
Chris@1706 1339
Chris@1706 1340 fun git_command_output context libname args =
Chris@1772 1341 FileBits.command_output context libname (git_program :: args)
Chris@1772 1342
Chris@1772 1343 fun is_working context =
Chris@1772 1344 case git_command_output context "" ["--version"] of
Chris@1772 1345 OK "" => OK false
Chris@1772 1346 | OK _ => OK true
Chris@1772 1347 | ERROR e => ERROR e
Chris@1706 1348
Chris@1706 1349 fun exists context libname =
Chris@1706 1350 OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
Chris@1706 1351 handle _ => OK false
Chris@1706 1352
Chris@1706 1353 fun remote_for context (libname, source) =
Chris@1706 1354 Provider.remote_url context GIT source libname
Chris@1706 1355
Chris@1706 1356 fun branch_name branch = case branch of
Chris@1706 1357 DEFAULT_BRANCH => "master"
Chris@1706 1358 | BRANCH "" => "master"
Chris@1706 1359 | BRANCH b => b
Chris@1706 1360
Chris@1752 1361 val our_remote = "vext"
Chris@1752 1362
Chris@1752 1363 fun remote_branch_name branch = our_remote ^ "/" ^ branch_name branch
Chris@1706 1364
Chris@1706 1365 fun checkout context (libname, source, branch) =
Chris@1706 1366 let val url = remote_for context (libname, source)
Chris@1706 1367 in
Chris@1747 1368 (* make the lib dir rather than just the ext dir, since
Chris@1747 1369 the lib dir might be nested and git will happily check
Chris@1747 1370 out into an existing empty dir anyway *)
Chris@1747 1371 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1706 1372 OK () => git_command context ""
Chris@1752 1373 ["clone", "--origin", our_remote,
Chris@1752 1374 "--branch", branch_name branch,
Chris@1706 1375 url, libname]
Chris@1706 1376 | ERROR e => ERROR e
Chris@1706 1377 end
Chris@1706 1378
Chris@1752 1379 fun add_our_remote context (libname, source) =
Chris@1752 1380 (* When we do the checkout ourselves (above), we add the
Chris@1752 1381 remote at the same time. But if the repo was cloned by
Chris@1752 1382 someone else, we'll need to do it after the fact. Git
Chris@1752 1383 doesn't seem to have a means to add a remote or change its
Chris@1752 1384 url if it already exists; seems we have to do this: *)
Chris@1752 1385 let val url = remote_for context (libname, source)
Chris@1752 1386 in
Chris@1752 1387 case git_command context libname
Chris@1752 1388 ["remote", "set-url", our_remote, url] of
Chris@1752 1389 OK () => OK ()
Chris@1752 1390 | ERROR e => git_command context libname
Chris@1752 1391 ["remote", "add", "-f", our_remote, url]
Chris@1752 1392 end
Chris@1752 1393
Chris@1706 1394 (* NB git rev-parse HEAD shows revision id of current checkout;
Chris@1706 1395 git rev-list -1 <tag> shows revision id of revision with that tag *)
Chris@1706 1396
Chris@1706 1397 fun id_of context libname =
Chris@1706 1398 git_command_output context libname ["rev-parse", "HEAD"]
Chris@1706 1399
Chris@1706 1400 fun is_at context (libname, id_or_tag) =
Chris@1706 1401 case id_of context libname of
Chris@1752 1402 ERROR e => OK false (* HEAD nonexistent, expected in empty repo *)
Chris@1706 1403 | OK id =>
Chris@1706 1404 if String.isPrefix id_or_tag id orelse
Chris@1706 1405 String.isPrefix id id_or_tag
Chris@1706 1406 then OK true
Chris@1766 1407 else is_at_tag context (libname, id, id_or_tag)
Chris@1766 1408
Chris@1766 1409 and is_at_tag context (libname, id, tag) =
Chris@1766 1410 (* For annotated tags (with message) show-ref returns the tag
Chris@1766 1411 object ref rather than that of the revision being tagged;
Chris@1766 1412 we need the subsequent rev-list to chase that up. In fact
Chris@1766 1413 the rev-list on its own is enough to get us the id direct
Chris@1766 1414 from the tag name, but it fails with an error if the tag
Chris@1766 1415 doesn't exist, whereas we want to handle that quietly in
Chris@1766 1416 case the tag simply hasn't been pulled yet *)
Chris@1766 1417 case git_command_output context libname
Chris@1766 1418 ["show-ref", "refs/tags/" ^ tag, "--"] of
Chris@1766 1419 OK "" => OK false (* Not a tag *)
Chris@1766 1420 | ERROR _ => OK false
Chris@1766 1421 | OK s =>
Chris@1766 1422 let val tag_ref = hd (String.tokens (fn c => c = #" ") s)
Chris@1766 1423 in
Chris@1706 1424 case git_command_output context libname
Chris@1766 1425 ["rev-list", "-1", tag_ref] of
Chris@1766 1426 OK tagged => OK (id = tagged)
Chris@1723 1427 | ERROR _ => OK false
Chris@1766 1428 end
Chris@1766 1429
Chris@1706 1430 fun branch_tip context (libname, branch) =
Chris@1752 1431 (* We don't have access to the source info or the network
Chris@1752 1432 here, as this is used by status (e.g. via is_on_branch) as
Chris@1752 1433 well as review. It's possible the remote branch won't exist,
Chris@1752 1434 e.g. if the repo was checked out by something other than
Chris@1752 1435 Vext, and if that's the case, we can't add it here; we'll
Chris@1752 1436 just have to fail, since checking against local branches
Chris@1752 1437 instead could produce the wrong result. *)
Chris@1706 1438 git_command_output context libname
Chris@1706 1439 ["rev-list", "-1",
Chris@1752 1440 remote_branch_name branch, "--"]
Chris@1706 1441
Chris@1706 1442 fun is_newest_locally context (libname, branch) =
Chris@1706 1443 case branch_tip context (libname, branch) of
Chris@1752 1444 ERROR e => OK false
Chris@1706 1445 | OK rev => is_at context (libname, rev)
Chris@1706 1446
Chris@1706 1447 fun is_on_branch context (libname, branch) =
Chris@1706 1448 case branch_tip context (libname, branch) of
Chris@1752 1449 ERROR e => OK false
Chris@1706 1450 | OK rev =>
Chris@1706 1451 case is_at context (libname, rev) of
Chris@1706 1452 ERROR e => ERROR e
Chris@1706 1453 | OK true => OK true
Chris@1706 1454 | OK false =>
Chris@1706 1455 case git_command context libname
Chris@1706 1456 ["merge-base", "--is-ancestor",
Chris@1706 1457 "HEAD", remote_branch_name branch] of
Chris@1706 1458 ERROR e => OK false (* cmd returns non-zero for no *)
Chris@1706 1459 | _ => OK true
Chris@1706 1460
Chris@1752 1461 fun fetch context (libname, source) =
Chris@1752 1462 case add_our_remote context (libname, source) of
Chris@1706 1463 ERROR e => ERROR e
Chris@1752 1464 | _ => git_command context libname ["fetch", our_remote]
Chris@1752 1465
Chris@1752 1466 fun is_newest context (libname, source, branch) =
Chris@1752 1467 case add_our_remote context (libname, source) of
Chris@1752 1468 ERROR e => ERROR e
Chris@1752 1469 | OK () =>
Chris@1752 1470 case is_newest_locally context (libname, branch) of
Chris@1706 1471 ERROR e => ERROR e
Chris@1752 1472 | OK false => OK false
Chris@1752 1473 | OK true =>
Chris@1752 1474 case fetch context (libname, source) of
Chris@1752 1475 ERROR e => ERROR e
Chris@1752 1476 | _ => is_newest_locally context (libname, branch)
Chris@1706 1477
Chris@1706 1478 fun is_modified_locally context libname =
Chris@1706 1479 case git_command_output context libname ["status", "--porcelain"] of
Chris@1706 1480 ERROR e => ERROR e
Chris@1706 1481 | OK "" => OK false
Chris@1706 1482 | OK _ => OK true
Chris@1706 1483
Chris@1706 1484 (* This function updates to the latest revision on a branch rather
Chris@1706 1485 than to a specific id or tag. We can't just checkout the given
Chris@1706 1486 branch, as that will succeed even if the branch isn't up to
Chris@1706 1487 date. We could checkout the branch and then fetch and merge,
Chris@1706 1488 but it's perhaps cleaner not to maintain a local branch at all,
Chris@1706 1489 but instead checkout the remote branch as a detached head. *)
Chris@1706 1490
Chris@1752 1491 fun update context (libname, source, branch) =
Chris@1752 1492 case fetch context (libname, source) of
Chris@1706 1493 ERROR e => ERROR e
Chris@1706 1494 | _ =>
Chris@1706 1495 case git_command context libname ["checkout", "--detach",
Chris@1706 1496 remote_branch_name branch] of
Chris@1706 1497 ERROR e => ERROR e
Chris@1758 1498 | _ => OK ()
Chris@1706 1499
Chris@1706 1500 (* This function is dealing with a specific id or tag, so if we
Chris@1723 1501 can successfully check it out (detached) then that's all we
Chris@1723 1502 need to do, regardless of whether fetch succeeded or not. We do
Chris@1723 1503 attempt the fetch first, though, purely in order to avoid ugly
Chris@1723 1504 error messages in the common case where we're being asked to
Chris@1723 1505 update to a new pin (from the lock file) that hasn't been
Chris@1723 1506 fetched yet. *)
Chris@1706 1507
Chris@1752 1508 fun update_to context (libname, _, "") =
Chris@1706 1509 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1752 1510 | update_to context (libname, source, id) =
Chris@1752 1511 let val fetch_result = fetch context (libname, source)
Chris@1723 1512 in
Chris@1723 1513 case git_command context libname ["checkout", "--detach", id] of
Chris@1758 1514 OK _ => OK ()
Chris@1723 1515 | ERROR e =>
Chris@1723 1516 case fetch_result of
Chris@1723 1517 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@1723 1518 | _ => ERROR e
Chris@1723 1519 end
Chris@1756 1520
Chris@1756 1521 fun copy_url_for context libname =
Chris@1756 1522 OK (FileBits.file_url (FileBits.libpath context libname))
Chris@1723 1523
Chris@1706 1524 end
Chris@1706 1525
Chris@1761 1526 (* SubXml - A parser for a subset of XML
Chris@1772 1527 https://bitbucket.org/cannam/sml-subxml
Chris@1761 1528 Copyright 2018 Chris Cannam. BSD licence.
Chris@1761 1529 *)
Chris@1761 1530
Chris@1761 1531 signature SUBXML = sig
Chris@1761 1532
Chris@1761 1533 datatype node = ELEMENT of { name : string, children : node list }
Chris@1761 1534 | ATTRIBUTE of { name : string, value : string }
Chris@1761 1535 | TEXT of string
Chris@1761 1536 | CDATA of string
Chris@1761 1537 | COMMENT of string
Chris@1761 1538
Chris@1761 1539 datatype document = DOCUMENT of { name : string, children : node list }
Chris@1761 1540
Chris@1761 1541 datatype 'a result = OK of 'a
Chris@1761 1542 | ERROR of string
Chris@1761 1543
Chris@1761 1544 val parse : string -> document result
Chris@1761 1545 val serialise : document -> string
Chris@1761 1546
Chris@1761 1547 end
Chris@1761 1548
Chris@1761 1549 structure SubXml :> SUBXML = struct
Chris@1761 1550
Chris@1761 1551 datatype node = ELEMENT of { name : string, children : node list }
Chris@1761 1552 | ATTRIBUTE of { name : string, value : string }
Chris@1761 1553 | TEXT of string
Chris@1761 1554 | CDATA of string
Chris@1761 1555 | COMMENT of string
Chris@1761 1556
Chris@1761 1557 datatype document = DOCUMENT of { name : string, children : node list }
Chris@1761 1558
Chris@1761 1559 datatype 'a result = OK of 'a
Chris@1761 1560 | ERROR of string
Chris@1761 1561
Chris@1761 1562 structure T = struct
Chris@1761 1563 datatype token = ANGLE_L
Chris@1761 1564 | ANGLE_R
Chris@1761 1565 | ANGLE_SLASH_L
Chris@1761 1566 | SLASH_ANGLE_R
Chris@1761 1567 | EQUAL
Chris@1761 1568 | NAME of string
Chris@1761 1569 | TEXT of string
Chris@1761 1570 | CDATA of string
Chris@1761 1571 | COMMENT of string
Chris@1761 1572
Chris@1761 1573 fun name t =
Chris@1761 1574 case t of ANGLE_L => "<"
Chris@1761 1575 | ANGLE_R => ">"
Chris@1761 1576 | ANGLE_SLASH_L => "</"
Chris@1761 1577 | SLASH_ANGLE_R => "/>"
Chris@1761 1578 | EQUAL => "="
Chris@1761 1579 | NAME s => "name \"" ^ s ^ "\""
Chris@1761 1580 | TEXT s => "text"
Chris@1761 1581 | CDATA _ => "CDATA section"
Chris@1761 1582 | COMMENT _ => "comment"
Chris@1761 1583 end
Chris@1761 1584
Chris@1761 1585 structure Lex :> sig
Chris@1761 1586 val lex : string -> T.token list result
Chris@1761 1587 end = struct
Chris@1761 1588
Chris@1761 1589 fun error pos text =
Chris@1761 1590 ERROR (text ^ " at character position " ^ Int.toString (pos-1))
Chris@1761 1591 fun tokenError pos token =
Chris@1761 1592 error pos ("Unexpected token '" ^ Char.toString token ^ "'")
Chris@1761 1593
Chris@1761 1594 val nameEnd = explode " \t\n\r\"'</>!=?"
Chris@1761 1595
Chris@1761 1596 fun quoted quote pos acc cc =
Chris@1761 1597 let fun quoted' pos text [] =
Chris@1761 1598 error pos "Document ends during quoted string"
Chris@1761 1599 | quoted' pos text (x::xs) =
Chris@1761 1600 if x = quote
Chris@1761 1601 then OK (rev text, xs, pos+1)
Chris@1761 1602 else quoted' (pos+1) (x::text) xs
Chris@1761 1603 in
Chris@1761 1604 case quoted' pos [] cc of
Chris@1761 1605 ERROR e => ERROR e
Chris@1761 1606 | OK (text, rest, newpos) =>
Chris@1761 1607 inside newpos (T.TEXT (implode text) :: acc) rest
Chris@1761 1608 end
Chris@1761 1609
Chris@1761 1610 and name first pos acc cc =
Chris@1761 1611 let fun name' pos text [] =
Chris@1761 1612 error pos "Document ends during name"
Chris@1761 1613 | name' pos text (x::xs) =
Chris@1761 1614 if List.find (fn c => c = x) nameEnd <> NONE
Chris@1761 1615 then OK (rev text, (x::xs), pos)
Chris@1761 1616 else name' (pos+1) (x::text) xs
Chris@1761 1617 in
Chris@1761 1618 case name' (pos-1) [] (first::cc) of
Chris@1761 1619 ERROR e => ERROR e
Chris@1761 1620 | OK ([], [], pos) => error pos "Document ends before name"
Chris@1761 1621 | OK ([], (x::xs), pos) => tokenError pos x
Chris@1761 1622 | OK (text, rest, pos) =>
Chris@1761 1623 inside pos (T.NAME (implode text) :: acc) rest
Chris@1761 1624 end
Chris@1761 1625
Chris@1761 1626 and comment pos acc cc =
Chris@1761 1627 let fun comment' pos text cc =
Chris@1761 1628 case cc of
Chris@1761 1629 #"-" :: #"-" :: #">" :: xs => OK (rev text, xs, pos+3)
Chris@1761 1630 | x :: xs => comment' (pos+1) (x::text) xs
Chris@1761 1631 | [] => error pos "Document ends during comment"
Chris@1761 1632 in
Chris@1761 1633 case comment' pos [] cc of
Chris@1761 1634 ERROR e => ERROR e
Chris@1761 1635 | OK (text, rest, pos) =>
Chris@1761 1636 outside pos (T.COMMENT (implode text) :: acc) rest
Chris@1761 1637 end
Chris@1761 1638
Chris@1761 1639 and instruction pos acc cc =
Chris@1761 1640 case cc of
Chris@1761 1641 #"?" :: #">" :: xs => outside (pos+2) acc xs
Chris@1761 1642 | #">" :: _ => tokenError pos #">"
Chris@1761 1643 | x :: xs => instruction (pos+1) acc xs
Chris@1761 1644 | [] => error pos "Document ends during processing instruction"
Chris@1761 1645
Chris@1761 1646 and cdata pos acc cc =
Chris@1761 1647 let fun cdata' pos text cc =
Chris@1761 1648 case cc of
Chris@1761 1649 #"]" :: #"]" :: #">" :: xs => OK (rev text, xs, pos+3)
Chris@1761 1650 | x :: xs => cdata' (pos+1) (x::text) xs
Chris@1761 1651 | [] => error pos "Document ends during CDATA section"
Chris@1761 1652 in
Chris@1761 1653 case cdata' pos [] cc of
Chris@1761 1654 ERROR e => ERROR e
Chris@1761 1655 | OK (text, rest, pos) =>
Chris@1761 1656 outside pos (T.CDATA (implode text) :: acc) rest
Chris@1761 1657 end
Chris@1761 1658
Chris@1761 1659 and doctype pos acc cc =
Chris@1761 1660 case cc of
Chris@1761 1661 #">" :: xs => outside (pos+1) acc xs
Chris@1761 1662 | x :: xs => doctype (pos+1) acc xs
Chris@1761 1663 | [] => error pos "Document ends during DOCTYPE"
Chris@1761 1664
Chris@1761 1665 and declaration pos acc cc =
Chris@1761 1666 case cc of
Chris@1761 1667 #"-" :: #"-" :: xs =>
Chris@1761 1668 comment (pos+2) acc xs
Chris@1761 1669 | #"[" :: #"C" :: #"D" :: #"A" :: #"T" :: #"A" :: #"[" :: xs =>
Chris@1761 1670 cdata (pos+7) acc xs
Chris@1761 1671 | #"D" :: #"O" :: #"C" :: #"T" :: #"Y" :: #"P" :: #"E" :: xs =>
Chris@1761 1672 doctype (pos+7) acc xs
Chris@1761 1673 | [] => error pos "Document ends during declaration"
Chris@1761 1674 | _ => error pos "Unsupported declaration type"
Chris@1761 1675
Chris@1761 1676 and left pos acc cc =
Chris@1761 1677 case cc of
Chris@1761 1678 #"/" :: xs => inside (pos+1) (T.ANGLE_SLASH_L :: acc) xs
Chris@1761 1679 | #"!" :: xs => declaration (pos+1) acc xs
Chris@1761 1680 | #"?" :: xs => instruction (pos+1) acc xs
Chris@1761 1681 | xs => inside pos (T.ANGLE_L :: acc) xs
Chris@1761 1682
Chris@1761 1683 and slash pos acc cc =
Chris@1761 1684 case cc of
Chris@1761 1685 #">" :: xs => outside (pos+1) (T.SLASH_ANGLE_R :: acc) xs
Chris@1761 1686 | x :: _ => tokenError pos x
Chris@1761 1687 | [] => error pos "Document ends before element closed"
Chris@1761 1688
Chris@1761 1689 and close pos acc xs = outside pos (T.ANGLE_R :: acc) xs
Chris@1761 1690
Chris@1761 1691 and equal pos acc xs = inside pos (T.EQUAL :: acc) xs
Chris@1761 1692
Chris@1761 1693 and outside pos acc [] = OK acc
Chris@1761 1694 | outside pos acc cc =
Chris@1761 1695 let fun textOf text = T.TEXT (implode (rev text))
Chris@1761 1696 fun outside' pos [] acc [] = OK acc
Chris@1761 1697 | outside' pos text acc [] = OK (textOf text :: acc)
Chris@1761 1698 | outside' pos text acc (x::xs) =
Chris@1761 1699 case x of
Chris@1761 1700 #"<" => if text = []
Chris@1761 1701 then left (pos+1) acc xs
Chris@1761 1702 else left (pos+1) (textOf text :: acc) xs
Chris@1761 1703 | x => outside' (pos+1) (x::text) acc xs
Chris@1761 1704 in
Chris@1761 1705 outside' pos [] acc cc
Chris@1761 1706 end
Chris@1761 1707
Chris@1761 1708 and inside pos acc [] = error pos "Document ends within tag"
Chris@1761 1709 | inside pos acc (#"<"::_) = tokenError pos #"<"
Chris@1761 1710 | inside pos acc (x::xs) =
Chris@1761 1711 (case x of
Chris@1761 1712 #" " => inside | #"\t" => inside
Chris@1761 1713 | #"\n" => inside | #"\r" => inside
Chris@1761 1714 | #"\"" => quoted x | #"'" => quoted x
Chris@1761 1715 | #"/" => slash | #">" => close | #"=" => equal
Chris@1761 1716 | x => name x) (pos+1) acc xs
Chris@1761 1717
Chris@1761 1718 fun lex str =
Chris@1761 1719 case outside 1 [] (explode str) of
Chris@1761 1720 ERROR e => ERROR e
Chris@1761 1721 | OK tokens => OK (rev tokens)
Chris@1761 1722 end
Chris@1761 1723
Chris@1761 1724 structure Parse :> sig
Chris@1761 1725 val parse : string -> document result
Chris@1761 1726 end = struct
Chris@1761 1727
Chris@1761 1728 fun show [] = "end of input"
Chris@1761 1729 | show (tok :: _) = T.name tok
Chris@1761 1730
Chris@1761 1731 fun error toks text = ERROR (text ^ " before " ^ show toks)
Chris@1761 1732
Chris@1761 1733 fun attribute elt name toks =
Chris@1761 1734 case toks of
Chris@1761 1735 T.EQUAL :: T.TEXT value :: xs =>
Chris@1761 1736 namedElement {
Chris@1761 1737 name = #name elt,
Chris@1761 1738 children = ATTRIBUTE { name = name, value = value } ::
Chris@1761 1739 #children elt
Chris@1761 1740 } xs
Chris@1761 1741 | T.EQUAL :: xs => error xs "Expected attribute value"
Chris@1761 1742 | toks => error toks "Expected attribute assignment"
Chris@1761 1743
Chris@1761 1744 and content elt toks =
Chris@1761 1745 case toks of
Chris@1761 1746 T.ANGLE_SLASH_L :: T.NAME n :: T.ANGLE_R :: xs =>
Chris@1761 1747 if n = #name elt
Chris@1761 1748 then OK (elt, xs)
Chris@1761 1749 else ERROR ("Closing tag </" ^ n ^ "> " ^
Chris@1761 1750 "does not match opening <" ^ #name elt ^ ">")
Chris@1761 1751 | T.TEXT text :: xs =>
Chris@1761 1752 content {
Chris@1761 1753 name = #name elt,
Chris@1761 1754 children = TEXT text :: #children elt
Chris@1761 1755 } xs
Chris@1761 1756 | T.CDATA text :: xs =>
Chris@1761 1757 content {
Chris@1761 1758 name = #name elt,
Chris@1761 1759 children = CDATA text :: #children elt
Chris@1761 1760 } xs
Chris@1761 1761 | T.COMMENT text :: xs =>
Chris@1761 1762 content {
Chris@1761 1763 name = #name elt,
Chris@1761 1764 children = COMMENT text :: #children elt
Chris@1761 1765 } xs
Chris@1761 1766 | T.ANGLE_L :: xs =>
Chris@1761 1767 (case element xs of
Chris@1761 1768 ERROR e => ERROR e
Chris@1761 1769 | OK (child, xs) =>
Chris@1761 1770 content {
Chris@1761 1771 name = #name elt,
Chris@1761 1772 children = ELEMENT child :: #children elt
Chris@1761 1773 } xs)
Chris@1761 1774 | tok :: xs =>
Chris@1761 1775 error xs ("Unexpected token " ^ T.name tok)
Chris@1761 1776 | [] =>
Chris@1761 1777 ERROR ("Document ends within element \"" ^ #name elt ^ "\"")
Chris@1761 1778
Chris@1761 1779 and namedElement elt toks =
Chris@1761 1780 case toks of
Chris@1761 1781 T.SLASH_ANGLE_R :: xs => OK (elt, xs)
Chris@1761 1782 | T.NAME name :: xs => attribute elt name xs
Chris@1761 1783 | T.ANGLE_R :: xs => content elt xs
Chris@1761 1784 | x :: xs => error xs ("Unexpected token " ^ T.name x)
Chris@1761 1785 | [] => ERROR "Document ends within opening tag"
Chris@1761 1786
Chris@1761 1787 and element toks =
Chris@1761 1788 case toks of
Chris@1761 1789 T.NAME name :: xs =>
Chris@1761 1790 (case namedElement { name = name, children = [] } xs of
Chris@1761 1791 ERROR e => ERROR e
Chris@1761 1792 | OK ({ name, children }, xs) =>
Chris@1761 1793 OK ({ name = name, children = rev children }, xs))
Chris@1761 1794 | toks => error toks "Expected element name"
Chris@1761 1795
Chris@1761 1796 and document [] = ERROR "Empty document"
Chris@1761 1797 | document (tok :: xs) =
Chris@1761 1798 case tok of
Chris@1761 1799 T.TEXT _ => document xs
Chris@1761 1800 | T.COMMENT _ => document xs
Chris@1761 1801 | T.ANGLE_L =>
Chris@1761 1802 (case element xs of
Chris@1761 1803 ERROR e => ERROR e
Chris@1761 1804 | OK (elt, []) => OK (DOCUMENT elt)
Chris@1761 1805 | OK (elt, (T.TEXT _ :: xs)) => OK (DOCUMENT elt)
Chris@1761 1806 | OK (elt, xs) => error xs "Extra data after document")
Chris@1761 1807 | _ => error xs ("Unexpected token " ^ T.name tok)
Chris@1761 1808
Chris@1761 1809 fun parse str =
Chris@1761 1810 case Lex.lex str of
Chris@1761 1811 ERROR e => ERROR e
Chris@1761 1812 | OK tokens => document tokens
Chris@1761 1813 end
Chris@1761 1814
Chris@1761 1815 structure Serialise :> sig
Chris@1761 1816 val serialise : document -> string
Chris@1761 1817 end = struct
Chris@1761 1818
Chris@1761 1819 fun attributes nodes =
Chris@1761 1820 String.concatWith
Chris@1761 1821 " "
Chris@1761 1822 (map node (List.filter
Chris@1761 1823 (fn ATTRIBUTE _ => true | _ => false)
Chris@1761 1824 nodes))
Chris@1761 1825
Chris@1761 1826 and nonAttributes nodes =
Chris@1761 1827 String.concat
Chris@1761 1828 (map node (List.filter
Chris@1761 1829 (fn ATTRIBUTE _ => false | _ => true)
Chris@1761 1830 nodes))
Chris@1761 1831
Chris@1761 1832 and node n =
Chris@1761 1833 case n of
Chris@1761 1834 TEXT string =>
Chris@1761 1835 string
Chris@1761 1836 | CDATA string =>
Chris@1761 1837 "<![CDATA[" ^ string ^ "]]>"
Chris@1761 1838 | COMMENT string =>
Chris@1761 1839 "<!-- " ^ string ^ "-->"
Chris@1761 1840 | ATTRIBUTE { name, value } =>
Chris@1761 1841 name ^ "=" ^ "\"" ^ value ^ "\"" (*!!!*)
Chris@1761 1842 | ELEMENT { name, children } =>
Chris@1761 1843 "<" ^ name ^
Chris@1761 1844 (case (attributes children) of
Chris@1761 1845 "" => ""
Chris@1761 1846 | s => " " ^ s) ^
Chris@1761 1847 (case (nonAttributes children) of
Chris@1761 1848 "" => "/>"
Chris@1761 1849 | s => ">" ^ s ^ "</" ^ name ^ ">")
Chris@1761 1850
Chris@1761 1851 fun serialise (DOCUMENT { name, children }) =
Chris@1761 1852 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ^
Chris@1761 1853 node (ELEMENT { name = name, children = children })
Chris@1761 1854 end
Chris@1761 1855
Chris@1761 1856 val parse = Parse.parse
Chris@1761 1857 val serialise = Serialise.serialise
Chris@1761 1858
Chris@1761 1859 end
Chris@1761 1860
Chris@1761 1861
Chris@1756 1862 structure SvnControl :> VCS_CONTROL = struct
Chris@1756 1863
Chris@1772 1864 val svn_program = "svn"
Chris@1772 1865
Chris@1756 1866 fun svn_command context libname args =
Chris@1772 1867 FileBits.command context libname (svn_program :: args)
Chris@1756 1868
Chris@1756 1869 fun svn_command_output context libname args =
Chris@1772 1870 FileBits.command_output context libname (svn_program :: args)
Chris@1756 1871
Chris@1756 1872 fun svn_command_lines context libname args =
Chris@1756 1873 case svn_command_output context libname args of
Chris@1756 1874 ERROR e => ERROR e
Chris@1756 1875 | OK s => OK (String.tokens (fn c => c = #"\n" orelse c = #"\r") s)
Chris@1756 1876
Chris@1756 1877 fun split_line_pair line =
Chris@1756 1878 let fun strip_leading_ws str = case explode str of
Chris@1756 1879 #" "::rest => implode rest
Chris@1756 1880 | _ => str
Chris@1756 1881 in
Chris@1756 1882 case String.tokens (fn c => c = #":") line of
Chris@1756 1883 [] => ("", "")
Chris@1756 1884 | first::rest =>
Chris@1756 1885 (first, strip_leading_ws (String.concatWith ":" rest))
Chris@1756 1886 end
Chris@1761 1887
Chris@1772 1888 fun is_working context =
Chris@1772 1889 case svn_command_output context "" ["--version"] of
Chris@1772 1890 OK "" => OK false
Chris@1772 1891 | OK _ => OK true
Chris@1772 1892 | ERROR e => ERROR e
Chris@1772 1893
Chris@1761 1894 structure X = SubXml
Chris@1761 1895
Chris@1761 1896 fun svn_info context libname route =
Chris@1761 1897 (* SVN 1.9 has info --show-item which is just what we need,
Chris@1761 1898 but at this point we still have 1.8 on the CI boxes so we
Chris@1761 1899 might as well aim to support it. For that we really have to
Chris@1761 1900 use the XML output format, since the default info output is
Chris@1761 1901 localised. This is the only thing our mini-XML parser is
Chris@1761 1902 used for though, so it would be good to trim it at some
Chris@1761 1903 point *)
Chris@1761 1904 let fun find elt [] = OK elt
Chris@1761 1905 | find { children, ... } (first :: rest) =
Chris@1761 1906 case List.find (fn (X.ELEMENT { name, ... }) => name = first
Chris@1761 1907 | _ => false)
Chris@1761 1908 children of
Chris@1761 1909 NONE => ERROR ("No element \"" ^ first ^ "\" in SVN XML")
Chris@1761 1910 | SOME (X.ELEMENT e) => find e rest
Chris@1761 1911 | SOME _ => ERROR "Internal error"
Chris@1761 1912 in
Chris@1761 1913 case svn_command_output context libname ["info", "--xml"] of
Chris@1761 1914 ERROR e => ERROR e
Chris@1761 1915 | OK xml =>
Chris@1761 1916 case X.parse xml of
Chris@1761 1917 X.ERROR e => ERROR e
Chris@1761 1918 | X.OK (X.DOCUMENT doc) => find doc route
Chris@1761 1919 end
Chris@1756 1920
Chris@1756 1921 fun exists context libname =
Chris@1756 1922 OK (OS.FileSys.isDir (FileBits.subpath context libname ".svn"))
Chris@1756 1923 handle _ => OK false
Chris@1756 1924
Chris@1756 1925 fun remote_for context (libname, source) =
Chris@1756 1926 Provider.remote_url context SVN source libname
Chris@1756 1927
Chris@1761 1928 (* Remote the checkout came from, not necessarily the one we want *)
Chris@1761 1929 fun actual_remote_for context libname =
Chris@1761 1930 case svn_info context libname ["entry", "url"] of
Chris@1761 1931 ERROR e => ERROR e
Chris@1761 1932 | OK { children, ... } =>
Chris@1761 1933 case List.find (fn (X.TEXT _) => true | _ => false) children of
Chris@1761 1934 NONE => ERROR "No content for URL in SVN info XML"
Chris@1761 1935 | SOME (X.TEXT url) => OK url
Chris@1761 1936 | SOME _ => ERROR "Internal error"
Chris@1761 1937
Chris@1756 1938 fun id_of context libname =
Chris@1761 1939 case svn_info context libname ["entry"] of
Chris@1761 1940 ERROR e => ERROR e
Chris@1761 1941 | OK { children, ... } =>
Chris@1761 1942 case List.find
Chris@1761 1943 (fn (X.ATTRIBUTE { name = "revision", ... }) => true
Chris@1761 1944 | _ => false)
Chris@1761 1945 children of
Chris@1761 1946 NONE => ERROR "No revision for entry in SVN info XML"
Chris@1761 1947 | SOME (X.ATTRIBUTE { value, ... }) => OK value
Chris@1761 1948 | SOME _ => ERROR "Internal error"
Chris@1756 1949
Chris@1756 1950 fun is_at context (libname, id_or_tag) =
Chris@1756 1951 case id_of context libname of
Chris@1756 1952 ERROR e => ERROR e
Chris@1756 1953 | OK id => OK (id = id_or_tag)
Chris@1756 1954
Chris@1756 1955 fun is_on_branch context (libname, b) =
Chris@1756 1956 OK (b = DEFAULT_BRANCH)
Chris@1761 1957
Chris@1761 1958 fun check_remote context (libname, source) =
Chris@1761 1959 case (remote_for context (libname, source),
Chris@1761 1960 actual_remote_for context libname) of
Chris@1761 1961 (_, ERROR e) => ERROR e
Chris@1761 1962 | (url, OK actual) =>
Chris@1761 1963 if actual = url
Chris@1761 1964 then OK ()
Chris@1761 1965 else svn_command context libname ["relocate", url]
Chris@1756 1966
Chris@1756 1967 fun is_newest context (libname, source, branch) =
Chris@1761 1968 case check_remote context (libname, source) of
Chris@1756 1969 ERROR e => ERROR e
Chris@1761 1970 | OK () =>
Chris@1761 1971 case svn_command_lines context libname
Chris@1761 1972 ["status", "--show-updates"] of
Chris@1761 1973 ERROR e => ERROR e
Chris@1761 1974 | OK lines =>
Chris@1761 1975 case rev lines of
Chris@1761 1976 [] => ERROR "No result returned for server status"
Chris@1761 1977 | last_line::_ =>
Chris@1761 1978 case rev (String.tokens (fn c => c = #" ") last_line) of
Chris@1761 1979 [] => ERROR "No revision field found in server status"
Chris@1761 1980 | server_id::_ => is_at context (libname, server_id)
Chris@1756 1981
Chris@1756 1982 fun is_newest_locally context (libname, branch) =
Chris@1756 1983 OK true (* no local history *)
Chris@1756 1984
Chris@1756 1985 fun is_modified_locally context libname =
Chris@1756 1986 case svn_command_output context libname ["status"] of
Chris@1756 1987 ERROR e => ERROR e
Chris@1756 1988 | OK "" => OK false
Chris@1756 1989 | OK _ => OK true
Chris@1756 1990
Chris@1756 1991 fun checkout context (libname, source, branch) =
Chris@1756 1992 let val url = remote_for context (libname, source)
Chris@1756 1993 val path = FileBits.libpath context libname
Chris@1756 1994 in
Chris@1756 1995 if FileBits.nonempty_dir_exists path
Chris@1756 1996 then (* Surprisingly, SVN itself has no problem with
Chris@1756 1997 this. But for consistency with other VCSes we
Chris@1756 1998 don't allow it *)
Chris@1756 1999 ERROR ("Refusing checkout to nonempty dir \"" ^ path ^ "\"")
Chris@1756 2000 else
Chris@1756 2001 (* make the lib dir rather than just the ext dir, since
Chris@1756 2002 the lib dir might be nested and svn will happily check
Chris@1756 2003 out into an existing empty dir anyway *)
Chris@1756 2004 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1756 2005 ERROR e => ERROR e
Chris@1756 2006 | _ => svn_command context "" ["checkout", url, libname]
Chris@1756 2007 end
Chris@1756 2008
Chris@1756 2009 fun update context (libname, source, branch) =
Chris@1761 2010 case check_remote context (libname, source) of
Chris@1756 2011 ERROR e => ERROR e
Chris@1761 2012 | OK () =>
Chris@1761 2013 case svn_command context libname
Chris@1761 2014 ["update", "--accept", "postpone"] of
Chris@1761 2015 ERROR e => ERROR e
Chris@1761 2016 | _ => OK ()
Chris@1756 2017
Chris@1756 2018 fun update_to context (libname, _, "") =
Chris@1756 2019 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1756 2020 | update_to context (libname, source, id) =
Chris@1761 2021 case check_remote context (libname, source) of
Chris@1756 2022 ERROR e => ERROR e
Chris@1761 2023 | OK () =>
Chris@1761 2024 case svn_command context libname
Chris@1761 2025 ["update", "-r", id, "--accept", "postpone"] of
Chris@1761 2026 ERROR e => ERROR e
Chris@1761 2027 | OK _ => OK ()
Chris@1756 2028
Chris@1756 2029 fun copy_url_for context libname =
Chris@1761 2030 actual_remote_for context libname
Chris@1756 2031
Chris@1756 2032 end
Chris@1756 2033
Chris@1706 2034 structure AnyLibControl :> LIB_CONTROL = struct
Chris@1706 2035
Chris@1706 2036 structure H = LibControlFn(HgControl)
Chris@1706 2037 structure G = LibControlFn(GitControl)
Chris@1756 2038 structure S = LibControlFn(SvnControl)
Chris@1706 2039
Chris@1706 2040 fun review context (spec as { vcs, ... } : libspec) =
Chris@1756 2041 (fn HG => H.review | GIT => G.review | SVN => S.review) vcs context spec
Chris@1706 2042
Chris@1706 2043 fun status context (spec as { vcs, ... } : libspec) =
Chris@1756 2044 (fn HG => H.status | GIT => G.status | SVN => S.status) vcs context spec
Chris@1706 2045
Chris@1706 2046 fun update context (spec as { vcs, ... } : libspec) =
Chris@1756 2047 (fn HG => H.update | GIT => G.update | SVN => S.update) vcs context spec
Chris@1740 2048
Chris@1740 2049 fun id_of context (spec as { vcs, ... } : libspec) =
Chris@1756 2050 (fn HG => H.id_of | GIT => G.id_of | SVN => S.id_of) vcs context spec
Chris@1756 2051
Chris@1772 2052 fun is_working context vcs =
Chris@1772 2053 (fn HG => H.is_working | GIT => G.is_working | SVN => S.is_working)
Chris@1772 2054 vcs context vcs
Chris@1772 2055
Chris@1706 2056 end
Chris@1706 2057
Chris@1746 2058
Chris@1746 2059 type exclusions = string list
Chris@1746 2060
Chris@1746 2061 structure Archive :> sig
Chris@1746 2062
Chris@1746 2063 val archive : string * exclusions -> project -> OS.Process.status
Chris@1746 2064
Chris@1746 2065 end = struct
Chris@1746 2066
Chris@1746 2067 (* The idea of "archive" is to replace hg/git archive, which won't
Chris@1746 2068 include files, like the Vext-introduced external libraries,
Chris@1746 2069 that are not under version control with the main repo.
Chris@1746 2070
Chris@1746 2071 The process goes like this:
Chris@1746 2072
Chris@1746 2073 - Make sure we have a target filename from the user, and take
Chris@1746 2074 its basename as our archive directory name
Chris@1746 2075
Chris@1746 2076 - Make an "archive root" subdir of the project repo, named
Chris@1746 2077 typically .vext-archive
Chris@1746 2078
Chris@1746 2079 - Identify the VCS used for the project repo. Note that any
Chris@1746 2080 explicit references to VCS type in this structure are to
Chris@1746 2081 the VCS used for the project (something Vext doesn't
Chris@1746 2082 otherwise care about), not for an individual library
Chris@1746 2083
Chris@1746 2084 - Synthesise a Vext project with the archive root as its
Chris@1746 2085 root path, "." as its extdir, with one library whose
Chris@1746 2086 name is the user-supplied basename and whose explicit
Chris@1746 2087 source URL is the original project root; update that
Chris@1746 2088 project -- thus cloning the original project to a subdir
Chris@1746 2089 of the archive root
Chris@1746 2090
Chris@1746 2091 - Synthesise a Vext project identical to the original one for
Chris@1746 2092 this project, but with the newly-cloned copy as its root
Chris@1746 2093 path; update that project -- thus checking out clean copies
Chris@1746 2094 of the external library dirs
Chris@1746 2095
Chris@1746 2096 - Call out to an archive program to archive up the new copy,
Chris@1746 2097 running e.g.
Chris@1746 2098 tar cvzf project-release.tar.gz \
Chris@1746 2099 --exclude=.hg --exclude=.git project-release
Chris@1746 2100 in the archive root dir
Chris@1746 2101
Chris@1746 2102 - (We also omit the vext-project.json file and any trace of
Chris@1746 2103 Vext. It can't properly be run in a directory where the
Chris@1746 2104 external project folders already exist but their repo history
Chris@1746 2105 does not. End users shouldn't get to see Vext)
Chris@1746 2106
Chris@1746 2107 - Clean up by deleting the new copy
Chris@1746 2108 *)
Chris@1746 2109
Chris@1756 2110 fun project_vcs_id_and_url dir =
Chris@1746 2111 let val context = {
Chris@1746 2112 rootpath = dir,
Chris@1746 2113 extdir = ".",
Chris@1746 2114 providers = [],
Chris@1746 2115 accounts = []
Chris@1746 2116 }
Chris@1746 2117 val vcs_maybe =
Chris@1746 2118 case [HgControl.exists context ".",
Chris@1756 2119 GitControl.exists context ".",
Chris@1756 2120 SvnControl.exists context "."] of
Chris@1756 2121 [OK true, OK false, OK false] => OK HG
Chris@1756 2122 | [OK false, OK true, OK false] => OK GIT
Chris@1756 2123 | [OK false, OK false, OK true] => OK SVN
Chris@1746 2124 | _ => ERROR ("Unable to identify VCS for directory " ^ dir)
Chris@1746 2125 in
Chris@1746 2126 case vcs_maybe of
Chris@1746 2127 ERROR e => ERROR e
Chris@1746 2128 | OK vcs =>
Chris@1756 2129 case (fn HG => HgControl.id_of
Chris@1756 2130 | GIT => GitControl.id_of
Chris@1756 2131 | SVN => SvnControl.id_of)
Chris@1746 2132 vcs context "." of
Chris@1756 2133 ERROR e => ERROR ("Unable to find id of project repo: " ^ e)
Chris@1756 2134 | OK id =>
Chris@1756 2135 case (fn HG => HgControl.copy_url_for
Chris@1756 2136 | GIT => GitControl.copy_url_for
Chris@1756 2137 | SVN => SvnControl.copy_url_for)
Chris@1756 2138 vcs context "." of
Chris@1756 2139 ERROR e => ERROR ("Unable to find URL of project repo: "
Chris@1756 2140 ^ e)
Chris@1756 2141 | OK url => OK (vcs, id, url)
Chris@1746 2142 end
Chris@1746 2143
Chris@1746 2144 fun make_archive_root (context : context) =
Chris@1746 2145 let val path = OS.Path.joinDirFile {
Chris@1746 2146 dir = #rootpath context,
Chris@1746 2147 file = VextFilenames.archive_dir
Chris@1746 2148 }
Chris@1746 2149 in
Chris@1746 2150 case FileBits.mkpath path of
Chris@1746 2151 ERROR e => raise Fail ("Failed to create archive directory \""
Chris@1746 2152 ^ path ^ "\": " ^ e)
Chris@1746 2153 | OK () => path
Chris@1746 2154 end
Chris@1746 2155
Chris@1746 2156 fun archive_path archive_dir target_name =
Chris@1746 2157 OS.Path.joinDirFile {
Chris@1746 2158 dir = archive_dir,
Chris@1746 2159 file = target_name
Chris@1746 2160 }
Chris@1746 2161
Chris@1746 2162 fun check_nonexistent path =
Chris@1746 2163 case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
Chris@1746 2164 NONE => ()
Chris@1746 2165 | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
Chris@1746 2166
Chris@1756 2167 fun make_archive_copy target_name (vcs, project_id, source_url)
Chris@1746 2168 ({ context, ... } : project) =
Chris@1746 2169 let val archive_root = make_archive_root context
Chris@1746 2170 val synthetic_context = {
Chris@1746 2171 rootpath = archive_root,
Chris@1746 2172 extdir = ".",
Chris@1746 2173 providers = [],
Chris@1746 2174 accounts = []
Chris@1746 2175 }
Chris@1746 2176 val synthetic_library = {
Chris@1746 2177 libname = target_name,
Chris@1746 2178 vcs = vcs,
Chris@1756 2179 source = URL_SOURCE source_url,
Chris@1746 2180 branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
Chris@1746 2181 project_pin = PINNED project_id,
Chris@1746 2182 lock_pin = PINNED project_id
Chris@1746 2183 }
Chris@1746 2184 val path = archive_path archive_root target_name
Chris@1746 2185 val _ = print ("Cloning original project to " ^ path
Chris@1746 2186 ^ " at revision " ^ project_id ^ "...\n");
Chris@1746 2187 val _ = check_nonexistent path
Chris@1746 2188 in
Chris@1746 2189 case AnyLibControl.update synthetic_context synthetic_library of
Chris@1746 2190 ERROR e => ERROR ("Failed to clone original project to "
Chris@1746 2191 ^ path ^ ": " ^ e)
Chris@1746 2192 | OK _ => OK archive_root
Chris@1746 2193 end
Chris@1746 2194
Chris@1746 2195 fun update_archive archive_root target_name
Chris@1746 2196 (project as { context, ... } : project) =
Chris@1746 2197 let val synthetic_context = {
Chris@1746 2198 rootpath = archive_path archive_root target_name,
Chris@1746 2199 extdir = #extdir context,
Chris@1746 2200 providers = #providers context,
Chris@1746 2201 accounts = #accounts context
Chris@1746 2202 }
Chris@1746 2203 in
Chris@1746 2204 foldl (fn (lib, acc) =>
Chris@1746 2205 case acc of
Chris@1746 2206 ERROR e => ERROR e
Chris@1758 2207 | OK () => AnyLibControl.update synthetic_context lib)
Chris@1758 2208 (OK ())
Chris@1746 2209 (#libs project)
Chris@1746 2210 end
Chris@1746 2211
Chris@1746 2212 datatype packer = TAR
Chris@1746 2213 | TAR_GZ
Chris@1746 2214 | TAR_BZ2
Chris@1746 2215 | TAR_XZ
Chris@1746 2216 (* could add other packers, e.g. zip, if we knew how to
Chris@1746 2217 handle the file omissions etc properly in pack_archive *)
Chris@1746 2218
Chris@1746 2219 fun packer_and_basename path =
Chris@1746 2220 let val extensions = [ (".tar", TAR),
Chris@1746 2221 (".tar.gz", TAR_GZ),
Chris@1746 2222 (".tar.bz2", TAR_BZ2),
Chris@1746 2223 (".tar.xz", TAR_XZ)]
Chris@1746 2224 val filename = OS.Path.file path
Chris@1746 2225 in
Chris@1746 2226 foldl (fn ((ext, packer), acc) =>
Chris@1746 2227 if String.isSuffix ext filename
Chris@1746 2228 then SOME (packer,
Chris@1746 2229 String.substring (filename, 0,
Chris@1746 2230 String.size filename -
Chris@1746 2231 String.size ext))
Chris@1746 2232 else acc)
Chris@1746 2233 NONE
Chris@1746 2234 extensions
Chris@1746 2235 end
Chris@1746 2236
Chris@1746 2237 fun pack_archive archive_root target_name target_path packer exclusions =
Chris@1746 2238 case FileBits.command {
Chris@1746 2239 rootpath = archive_root,
Chris@1746 2240 extdir = ".",
Chris@1746 2241 providers = [],
Chris@1746 2242 accounts = []
Chris@1746 2243 } "" ([
Chris@1746 2244 "tar",
Chris@1746 2245 case packer of
Chris@1746 2246 TAR => "cf"
Chris@1746 2247 | TAR_GZ => "czf"
Chris@1746 2248 | TAR_BZ2 => "cjf"
Chris@1746 2249 | TAR_XZ => "cJf",
Chris@1746 2250 target_path,
Chris@1746 2251 "--exclude=.hg",
Chris@1746 2252 "--exclude=.git",
Chris@1756 2253 "--exclude=.svn",
Chris@1746 2254 "--exclude=vext",
Chris@1746 2255 "--exclude=vext.sml",
Chris@1746 2256 "--exclude=vext.ps1",
Chris@1746 2257 "--exclude=vext.bat",
Chris@1746 2258 "--exclude=vext-project.json",
Chris@1746 2259 "--exclude=vext-lock.json"
Chris@1746 2260 ] @ (map (fn e => "--exclude=" ^ e) exclusions) @
Chris@1746 2261 [ target_name ])
Chris@1746 2262 of
Chris@1746 2263 ERROR e => ERROR e
Chris@1746 2264 | OK _ => FileBits.rmpath (archive_path archive_root target_name)
Chris@1746 2265
Chris@1746 2266 fun archive (target_path, exclusions) (project : project) =
Chris@1746 2267 let val _ = check_nonexistent target_path
Chris@1746 2268 val (packer, name) =
Chris@1746 2269 case packer_and_basename target_path of
Chris@1746 2270 NONE => raise Fail ("Unsupported archive file extension in "
Chris@1746 2271 ^ target_path)
Chris@1746 2272 | SOME pn => pn
Chris@1746 2273 val details =
Chris@1756 2274 case project_vcs_id_and_url (#rootpath (#context project)) of
Chris@1746 2275 ERROR e => raise Fail e
Chris@1746 2276 | OK details => details
Chris@1746 2277 val archive_root =
Chris@1746 2278 case make_archive_copy name details project of
Chris@1746 2279 ERROR e => raise Fail e
Chris@1746 2280 | OK archive_root => archive_root
Chris@1746 2281 val outcome =
Chris@1746 2282 case update_archive archive_root name project of
Chris@1746 2283 ERROR e => ERROR e
Chris@1746 2284 | OK _ =>
Chris@1746 2285 case pack_archive archive_root name
Chris@1746 2286 target_path packer exclusions of
Chris@1746 2287 ERROR e => ERROR e
Chris@1746 2288 | OK _ => OK ()
Chris@1746 2289 in
Chris@1746 2290 case outcome of
Chris@1746 2291 ERROR e => raise Fail e
Chris@1746 2292 | OK () => OS.Process.success
Chris@1746 2293 end
Chris@1746 2294
Chris@1746 2295 end
Chris@1746 2296
Chris@1724 2297 val libobjname = "libraries"
Chris@1724 2298
Chris@1706 2299 fun load_libspec spec_json lock_json libname : libspec =
Chris@1706 2300 let open JsonBits
Chris@1724 2301 val libobj = lookup_mandatory spec_json [libobjname, libname]
Chris@1706 2302 val vcs = lookup_mandatory_string libobj ["vcs"]
Chris@1706 2303 val retrieve = lookup_optional_string libobj
Chris@1706 2304 val service = retrieve ["service"]
Chris@1706 2305 val owner = retrieve ["owner"]
Chris@1706 2306 val repo = retrieve ["repository"]
Chris@1706 2307 val url = retrieve ["url"]
Chris@1706 2308 val branch = retrieve ["branch"]
Chris@1740 2309 val project_pin = case retrieve ["pin"] of
Chris@1740 2310 NONE => UNPINNED
Chris@1740 2311 | SOME p => PINNED p
Chris@1724 2312 val lock_pin = case lookup_optional lock_json [libobjname, libname] of
Chris@1740 2313 NONE => UNPINNED
Chris@1740 2314 | SOME ll => case lookup_optional_string ll ["pin"] of
Chris@1740 2315 SOME p => PINNED p
Chris@1740 2316 | NONE => UNPINNED
Chris@1706 2317 in
Chris@1706 2318 {
Chris@1706 2319 libname = libname,
Chris@1706 2320 vcs = case vcs of
Chris@1706 2321 "hg" => HG
Chris@1706 2322 | "git" => GIT
Chris@1756 2323 | "svn" => SVN
Chris@1706 2324 | other => raise Fail ("Unknown version-control system \"" ^
Chris@1706 2325 other ^ "\""),
Chris@1706 2326 source = case (url, service, owner, repo) of
Chris@1721 2327 (SOME u, NONE, _, _) => URL_SOURCE u
Chris@1706 2328 | (NONE, SOME ss, owner, repo) =>
Chris@1721 2329 SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
Chris@1706 2330 | _ => raise Fail ("Must have exactly one of service " ^
Chris@1706 2331 "or url string"),
Chris@1740 2332 project_pin = project_pin,
Chris@1740 2333 lock_pin = lock_pin,
Chris@1706 2334 branch = case branch of
Chris@1756 2335 NONE => DEFAULT_BRANCH
Chris@1756 2336 | SOME b =>
Chris@1756 2337 case vcs of
Chris@1756 2338 "svn" => raise Fail ("Branches not supported for " ^
Chris@1756 2339 "svn repositories; change " ^
Chris@1756 2340 "URL instead")
Chris@1756 2341 | _ => BRANCH b
Chris@1706 2342 }
Chris@1706 2343 end
Chris@1706 2344
Chris@1706 2345 fun load_userconfig () : userconfig =
Chris@1706 2346 let val home = FileBits.homedir ()
Chris@1706 2347 val conf_json =
Chris@1706 2348 JsonBits.load_json_from
Chris@1706 2349 (OS.Path.joinDirFile {
Chris@1706 2350 dir = home,
Chris@1706 2351 file = VextFilenames.user_config_file })
Chris@1706 2352 handle IO.Io _ => Json.OBJECT []
Chris@1706 2353 in
Chris@1706 2354 {
Chris@1706 2355 accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
Chris@1706 2356 NONE => []
Chris@1706 2357 | SOME (Json.OBJECT aa) =>
Chris@1706 2358 map (fn (k, (Json.STRING v)) =>
Chris@1706 2359 { service = k, login = v }
Chris@1706 2360 | _ => raise Fail
Chris@1706 2361 "String expected for account name")
Chris@1706 2362 aa
Chris@1706 2363 | _ => raise Fail "Array expected for accounts",
Chris@1706 2364 providers = Provider.load_providers conf_json
Chris@1706 2365 }
Chris@1706 2366 end
Chris@1706 2367
Chris@1732 2368 datatype pintype =
Chris@1732 2369 NO_LOCKFILE |
Chris@1732 2370 USE_LOCKFILE
Chris@1732 2371
Chris@1732 2372 fun load_project (userconfig : userconfig) rootpath pintype : project =
Chris@1706 2373 let val spec_file = FileBits.project_spec_path rootpath
Chris@1706 2374 val lock_file = FileBits.project_lock_path rootpath
Chris@1706 2375 val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
Chris@1706 2376 handle OS.SysErr _ => false
Chris@1706 2377 then ()
Chris@1706 2378 else raise Fail ("Failed to open project spec file " ^
Chris@1706 2379 (VextFilenames.project_file) ^ " in " ^
Chris@1706 2380 rootpath ^
Chris@1706 2381 ".\nPlease ensure the spec file is in the " ^
Chris@1706 2382 "project root and run this from there.")
Chris@1706 2383 val spec_json = JsonBits.load_json_from spec_file
Chris@1732 2384 val lock_json = if pintype = USE_LOCKFILE
Chris@1706 2385 then JsonBits.load_json_from lock_file
Chris@1706 2386 handle IO.Io _ => Json.OBJECT []
Chris@1706 2387 else Json.OBJECT []
Chris@1706 2388 val extdir = JsonBits.lookup_mandatory_string spec_json
Chris@1706 2389 ["config", "extdir"]
Chris@1724 2390 val spec_libs = JsonBits.lookup_optional spec_json [libobjname]
Chris@1724 2391 val lock_libs = JsonBits.lookup_optional lock_json [libobjname]
Chris@1706 2392 val providers = Provider.load_more_providers
Chris@1706 2393 (#providers userconfig) spec_json
Chris@1706 2394 val libnames = case spec_libs of
Chris@1706 2395 NONE => []
Chris@1706 2396 | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
Chris@1706 2397 | _ => raise Fail "Object expected for libs"
Chris@1706 2398 in
Chris@1706 2399 {
Chris@1706 2400 context = {
Chris@1706 2401 rootpath = rootpath,
Chris@1706 2402 extdir = extdir,
Chris@1706 2403 providers = providers,
Chris@1706 2404 accounts = #accounts userconfig
Chris@1706 2405 },
Chris@1706 2406 libs = map (load_libspec spec_json lock_json) libnames
Chris@1706 2407 }
Chris@1706 2408 end
Chris@1706 2409
Chris@1706 2410 fun save_lock_file rootpath locks =
Chris@1706 2411 let val lock_file = FileBits.project_lock_path rootpath
Chris@1706 2412 open Json
Chris@1706 2413 val lock_json =
Chris@1706 2414 OBJECT [
Chris@1724 2415 (libobjname,
Chris@1724 2416 OBJECT (map (fn { libname, id_or_tag } =>
Chris@1724 2417 (libname,
Chris@1724 2418 OBJECT [ ("pin", STRING id_or_tag) ]))
Chris@1724 2419 locks))
Chris@1706 2420 ]
Chris@1706 2421 in
Chris@1706 2422 JsonBits.save_json_to lock_file lock_json
Chris@1706 2423 end
Chris@1706 2424
Chris@1706 2425 fun pad_to n str =
Chris@1706 2426 if n <= String.size str then str
Chris@1706 2427 else pad_to n (str ^ " ")
Chris@1706 2428
Chris@1706 2429 fun hline_to 0 = ""
Chris@1706 2430 | hline_to n = "-" ^ hline_to (n-1)
Chris@1706 2431
Chris@1766 2432 val libname_width = 28
Chris@1706 2433 val libstate_width = 11
Chris@1740 2434 val localstate_width = 17
Chris@1706 2435 val notes_width = 5
Chris@1706 2436 val divider = " | "
Chris@1740 2437 val clear_line = "\r" ^ pad_to 80 "";
Chris@1706 2438
Chris@1706 2439 fun print_status_header () =
Chris@1740 2440 print (clear_line ^ "\n " ^
Chris@1706 2441 pad_to libname_width "Library" ^ divider ^
Chris@1706 2442 pad_to libstate_width "State" ^ divider ^
Chris@1706 2443 pad_to localstate_width "Local" ^ divider ^
Chris@1706 2444 "Notes" ^ "\n " ^
Chris@1706 2445 hline_to libname_width ^ "-+-" ^
Chris@1706 2446 hline_to libstate_width ^ "-+-" ^
Chris@1706 2447 hline_to localstate_width ^ "-+-" ^
Chris@1706 2448 hline_to notes_width ^ "\n")
Chris@1706 2449
Chris@1706 2450 fun print_outcome_header () =
Chris@1740 2451 print (clear_line ^ "\n " ^
Chris@1706 2452 pad_to libname_width "Library" ^ divider ^
Chris@1706 2453 pad_to libstate_width "Outcome" ^ divider ^
Chris@1706 2454 "Notes" ^ "\n " ^
Chris@1706 2455 hline_to libname_width ^ "-+-" ^
Chris@1706 2456 hline_to libstate_width ^ "-+-" ^
Chris@1706 2457 hline_to notes_width ^ "\n")
Chris@1706 2458
Chris@1772 2459 fun print_status with_network (lib : libspec, status) =
Chris@1706 2460 let val libstate_str =
Chris@1706 2461 case status of
Chris@1706 2462 OK (ABSENT, _) => "Absent"
Chris@1706 2463 | OK (CORRECT, _) => if with_network then "Correct" else "Present"
Chris@1706 2464 | OK (SUPERSEDED, _) => "Superseded"
Chris@1706 2465 | OK (WRONG, _) => "Wrong"
Chris@1706 2466 | ERROR _ => "Error"
Chris@1706 2467 val localstate_str =
Chris@1706 2468 case status of
Chris@1706 2469 OK (_, MODIFIED) => "Modified"
Chris@1740 2470 | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
Chris@1740 2471 | OK (_, CLEAN) => "Clean"
Chris@1740 2472 | ERROR _ => ""
Chris@1706 2473 val error_str =
Chris@1706 2474 case status of
Chris@1706 2475 ERROR e => e
Chris@1706 2476 | _ => ""
Chris@1706 2477 in
Chris@1706 2478 print (" " ^
Chris@1772 2479 pad_to libname_width (#libname lib) ^ divider ^
Chris@1706 2480 pad_to libstate_width libstate_str ^ divider ^
Chris@1706 2481 pad_to localstate_width localstate_str ^ divider ^
Chris@1706 2482 error_str ^ "\n")
Chris@1706 2483 end
Chris@1706 2484
Chris@1772 2485 fun print_update_outcome (lib : libspec, outcome) =
Chris@1706 2486 let val outcome_str =
Chris@1706 2487 case outcome of
Chris@1706 2488 OK id => "Ok"
Chris@1706 2489 | ERROR e => "Failed"
Chris@1706 2490 val error_str =
Chris@1706 2491 case outcome of
Chris@1706 2492 ERROR e => e
Chris@1706 2493 | _ => ""
Chris@1706 2494 in
Chris@1706 2495 print (" " ^
Chris@1772 2496 pad_to libname_width (#libname lib) ^ divider ^
Chris@1706 2497 pad_to libstate_width outcome_str ^ divider ^
Chris@1706 2498 error_str ^ "\n")
Chris@1706 2499 end
Chris@1706 2500
Chris@1772 2501 fun vcs_name HG = ("Mercurial", "hg")
Chris@1772 2502 | vcs_name GIT = ("Git", "git")
Chris@1772 2503 | vcs_name SVN = ("Subversion", "svn")
Chris@1772 2504
Chris@1772 2505 fun print_problem_summary context lines =
Chris@1772 2506 let val failed_vcs =
Chris@1772 2507 foldl (fn (({ vcs, ... } : libspec, ERROR _), acc) => vcs::acc
Chris@1772 2508 | (_, acc) => acc) [] lines
Chris@1772 2509 fun report_nonworking vcs error =
Chris@1772 2510 print ((if error = "" then "" else error ^ "\n\n") ^
Chris@1772 2511 "Error: The project uses the " ^ (#1 (vcs_name vcs)) ^
Chris@1772 2512 " version control system, but its\n" ^
Chris@1772 2513 "executable program (" ^ (#2 (vcs_name vcs)) ^
Chris@1772 2514 ") does not appear to be installed in the program path\n\n")
Chris@1772 2515 fun check_working [] checked = ()
Chris@1772 2516 | check_working (vcs::rest) checked =
Chris@1772 2517 if List.exists (fn v => vcs = v) checked
Chris@1772 2518 then check_working rest checked
Chris@1772 2519 else
Chris@1772 2520 case AnyLibControl.is_working context vcs of
Chris@1772 2521 OK true => check_working rest checked
Chris@1772 2522 | OK false => (report_nonworking vcs "";
Chris@1772 2523 check_working rest (vcs::checked))
Chris@1772 2524 | ERROR e => (report_nonworking vcs e;
Chris@1772 2525 check_working rest (vcs::checked))
Chris@1772 2526 in
Chris@1772 2527 print "\nError: Some operations failed\n\n";
Chris@1772 2528 check_working failed_vcs []
Chris@1772 2529 end
Chris@1772 2530
Chris@1772 2531 fun act_and_print action print_header print_line context (libs : libspec list) =
Chris@1772 2532 let val lines = map (fn lib => (lib, action lib)) libs
Chris@1772 2533 val imperfect = List.exists (fn (_, ERROR _) => true | _ => false) lines
Chris@1706 2534 val _ = print_header ()
Chris@1706 2535 in
Chris@1706 2536 app print_line lines;
Chris@1772 2537 if imperfect then print_problem_summary context lines else ();
Chris@1706 2538 lines
Chris@1706 2539 end
Chris@1708 2540
Chris@1708 2541 fun return_code_for outcomes =
Chris@1708 2542 foldl (fn ((_, result), acc) =>
Chris@1708 2543 case result of
Chris@1708 2544 ERROR _ => OS.Process.failure
Chris@1708 2545 | _ => acc)
Chris@1708 2546 OS.Process.success
Chris@1708 2547 outcomes
Chris@1706 2548
Chris@1706 2549 fun status_of_project ({ context, libs } : project) =
Chris@1708 2550 return_code_for (act_and_print (AnyLibControl.status context)
Chris@1708 2551 print_status_header (print_status false)
Chris@1772 2552 context libs)
Chris@1706 2553
Chris@1706 2554 fun review_project ({ context, libs } : project) =
Chris@1708 2555 return_code_for (act_and_print (AnyLibControl.review context)
Chris@1708 2556 print_status_header (print_status true)
Chris@1772 2557 context libs)
Chris@1706 2558
Chris@1740 2559 fun lock_project ({ context, libs } : project) =
Chris@1756 2560 let val _ = if FileBits.verbose ()
Chris@1756 2561 then print ("Scanning IDs for lock file...\n")
Chris@1756 2562 else ()
Chris@1772 2563 val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib))
Chris@1740 2564 libs
Chris@1740 2565 val locks =
Chris@1740 2566 List.concat
Chris@1772 2567 (map (fn (lib : libspec, result) =>
Chris@1740 2568 case result of
Chris@1740 2569 ERROR _ => []
Chris@1772 2570 | OK id => [{ libname = #libname lib,
Chris@1772 2571 id_or_tag = id }])
Chris@1740 2572 outcomes)
Chris@1740 2573 val return_code = return_code_for outcomes
Chris@1740 2574 val _ = print clear_line
Chris@1740 2575 in
Chris@1740 2576 if OS.Process.isSuccess return_code
Chris@1740 2577 then save_lock_file (#rootpath context) locks
Chris@1740 2578 else ();
Chris@1740 2579 return_code
Chris@1740 2580 end
Chris@1756 2581
Chris@1756 2582 fun update_project (project as { context, libs }) =
Chris@1756 2583 let val outcomes = act_and_print
Chris@1756 2584 (AnyLibControl.update context)
Chris@1772 2585 print_outcome_header print_update_outcome
Chris@1772 2586 context libs
Chris@1756 2587 val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
Chris@1756 2588 then lock_project project
Chris@1756 2589 else OS.Process.success
Chris@1756 2590 in
Chris@1756 2591 return_code_for outcomes
Chris@1756 2592 end
Chris@1746 2593
Chris@1732 2594 fun load_local_project pintype =
Chris@1706 2595 let val userconfig = load_userconfig ()
Chris@1706 2596 val rootpath = OS.FileSys.getDir ()
Chris@1706 2597 in
Chris@1732 2598 load_project userconfig rootpath pintype
Chris@1706 2599 end
Chris@1706 2600
Chris@1732 2601 fun with_local_project pintype f =
Chris@1776 2602 let open OS.Process
Chris@1776 2603 val return_code =
Chris@1776 2604 f (load_local_project pintype)
Chris@1776 2605 handle Fail msg =>
Chris@1776 2606 failure before print ("Error: " ^ msg)
Chris@1776 2607 | JsonBits.Config msg =>
Chris@1776 2608 failure before print ("Error in configuration: " ^ msg)
Chris@1776 2609 | e =>
Chris@1776 2610 failure before print ("Error: " ^ exnMessage e)
Chris@1708 2611 val _ = print "\n";
Chris@1708 2612 in
Chris@1708 2613 return_code
Chris@1708 2614 end
Chris@1706 2615
Chris@1740 2616 fun review () = with_local_project USE_LOCKFILE review_project
Chris@1740 2617 fun status () = with_local_project USE_LOCKFILE status_of_project
Chris@1732 2618 fun update () = with_local_project NO_LOCKFILE update_project
Chris@1740 2619 fun lock () = with_local_project NO_LOCKFILE lock_project
Chris@1732 2620 fun install () = with_local_project USE_LOCKFILE update_project
Chris@1706 2621
Chris@1706 2622 fun version () =
Chris@1708 2623 (print ("v" ^ vext_version ^ "\n");
Chris@1708 2624 OS.Process.success)
Chris@1706 2625
Chris@1706 2626 fun usage () =
Chris@1706 2627 (print "\nVext ";
Chris@1706 2628 version ();
Chris@1706 2629 print ("\nA simple manager for third-party source code dependencies.\n\n"
Chris@1706 2630 ^ "Usage:\n\n"
Chris@1706 2631 ^ " vext <command>\n\n"
Chris@1706 2632 ^ "where <command> is one of:\n\n"
Chris@1716 2633 ^ " status print quick report on local status only, without using network\n"
Chris@1706 2634 ^ " review check configured libraries against their providers, and report\n"
Chris@1706 2635 ^ " install update configured libraries according to project specs and lock file\n"
Chris@1706 2636 ^ " update update configured libraries and lock file according to project specs\n"
Chris@1740 2637 ^ " lock update lock file to match local library status\n"
Chris@1746 2638 ^ " archive pack up project and all libraries into an archive file\n"
Chris@1746 2639 ^ " (invoke as 'vext archive target-file.tar.gz')\n"
Chris@1708 2640 ^ " version print the Vext version number and exit\n\n");
Chris@1708 2641 OS.Process.failure)
Chris@1706 2642
Chris@1746 2643 fun archive target args =
Chris@1746 2644 case args of
Chris@1746 2645 [] =>
Chris@1746 2646 with_local_project USE_LOCKFILE (Archive.archive (target, []))
Chris@1746 2647 | "--exclude"::xs =>
Chris@1746 2648 with_local_project USE_LOCKFILE (Archive.archive (target, xs))
Chris@1746 2649 | _ => usage ()
Chris@1746 2650
Chris@1706 2651 fun vext args =
Chris@1708 2652 let val return_code =
Chris@1708 2653 case args of
Chris@1708 2654 ["review"] => review ()
Chris@1708 2655 | ["status"] => status ()
Chris@1708 2656 | ["install"] => install ()
Chris@1708 2657 | ["update"] => update ()
Chris@1740 2658 | ["lock"] => lock ()
Chris@1708 2659 | ["version"] => version ()
Chris@1746 2660 | "archive"::target::args => archive target args
Chris@1772 2661 | arg::_ => (print ("Error: unknown argument \"" ^ arg ^ "\"\n");
Chris@1772 2662 usage ())
Chris@1708 2663 | _ => usage ()
Chris@1708 2664 in
Chris@1708 2665 OS.Process.exit return_code;
Chris@1708 2666 ()
Chris@1708 2667 end
Chris@1706 2668
Chris@1706 2669 fun main () =
Chris@1706 2670 vext (CommandLine.arguments ())