annotate vext.sml @ 1747:ffe59b457557

Update vext
author Chris Cannam
date Mon, 09 Oct 2017 11:09:34 +0100
parents bf4a7015033e
children 716e13004b19
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@1746 12 Copyright 2017 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@1747 41 val vext_version = "0.9.9"
Chris@1706 42
Chris@1706 43
Chris@1706 44 datatype vcs =
Chris@1706 45 HG |
Chris@1706 46 GIT
Chris@1706 47
Chris@1706 48 datatype source =
Chris@1721 49 URL_SOURCE of string |
Chris@1721 50 SERVICE_SOURCE of {
Chris@1706 51 service : string,
Chris@1706 52 owner : string option,
Chris@1706 53 repo : string option
Chris@1706 54 }
Chris@1706 55
Chris@1740 56 type id_or_tag = string
Chris@1740 57
Chris@1706 58 datatype pin =
Chris@1706 59 UNPINNED |
Chris@1740 60 PINNED of id_or_tag
Chris@1706 61
Chris@1706 62 datatype libstate =
Chris@1706 63 ABSENT |
Chris@1706 64 CORRECT |
Chris@1706 65 SUPERSEDED |
Chris@1706 66 WRONG
Chris@1706 67
Chris@1706 68 datatype localstate =
Chris@1706 69 MODIFIED |
Chris@1740 70 LOCK_MISMATCHED |
Chris@1740 71 CLEAN
Chris@1706 72
Chris@1706 73 datatype branch =
Chris@1706 74 BRANCH of string |
Chris@1706 75 DEFAULT_BRANCH
Chris@1706 76
Chris@1706 77 (* If we can recover from an error, for example by reporting failure
Chris@1706 78 for this one thing and going on to the next thing, then the error
Chris@1706 79 should usually be returned through a result type rather than an
Chris@1706 80 exception. *)
Chris@1706 81
Chris@1706 82 datatype 'a result =
Chris@1706 83 OK of 'a |
Chris@1706 84 ERROR of string
Chris@1706 85
Chris@1706 86 type libname = string
Chris@1706 87
Chris@1706 88 type libspec = {
Chris@1706 89 libname : libname,
Chris@1706 90 vcs : vcs,
Chris@1706 91 source : source,
Chris@1706 92 branch : branch,
Chris@1740 93 project_pin : pin,
Chris@1740 94 lock_pin : pin
Chris@1706 95 }
Chris@1706 96
Chris@1706 97 type lock = {
Chris@1706 98 libname : libname,
Chris@1706 99 id_or_tag : id_or_tag
Chris@1706 100 }
Chris@1740 101
Chris@1706 102 type remote_spec = {
Chris@1706 103 anon : string option,
Chris@1706 104 auth : string option
Chris@1706 105 }
Chris@1706 106
Chris@1706 107 type provider = {
Chris@1706 108 service : string,
Chris@1706 109 supports : vcs list,
Chris@1706 110 remote_spec : remote_spec
Chris@1706 111 }
Chris@1706 112
Chris@1706 113 type account = {
Chris@1706 114 service : string,
Chris@1706 115 login : string
Chris@1706 116 }
Chris@1706 117
Chris@1706 118 type context = {
Chris@1706 119 rootpath : string,
Chris@1706 120 extdir : string,
Chris@1706 121 providers : provider list,
Chris@1706 122 accounts : account list
Chris@1706 123 }
Chris@1706 124
Chris@1706 125 type userconfig = {
Chris@1706 126 providers : provider list,
Chris@1706 127 accounts : account list
Chris@1706 128 }
Chris@1706 129
Chris@1706 130 type project = {
Chris@1706 131 context : context,
Chris@1706 132 libs : libspec list
Chris@1706 133 }
Chris@1706 134
Chris@1706 135 structure VextFilenames = struct
Chris@1706 136 val project_file = "vext-project.json"
Chris@1706 137 val project_lock_file = "vext-lock.json"
Chris@1706 138 val user_config_file = ".vext.json"
Chris@1746 139 val archive_dir = ".vext-archive"
Chris@1706 140 end
Chris@1706 141
Chris@1706 142 signature VCS_CONTROL = sig
Chris@1706 143
Chris@1706 144 (** Test whether the library is present locally at all *)
Chris@1706 145 val exists : context -> libname -> bool result
Chris@1706 146
Chris@1706 147 (** Return the id (hash) of the current revision for the library *)
Chris@1706 148 val id_of : context -> libname -> id_or_tag result
Chris@1706 149
Chris@1706 150 (** Test whether the library is at the given id *)
Chris@1706 151 val is_at : context -> libname * id_or_tag -> bool result
Chris@1706 152
Chris@1706 153 (** Test whether the library is on the given branch, i.e. is at
Chris@1706 154 the branch tip or an ancestor of it *)
Chris@1706 155 val is_on_branch : context -> libname * branch -> bool result
Chris@1706 156
Chris@1706 157 (** Test whether the library is at the newest revision for the
Chris@1706 158 given branch. False may indicate that the branch has advanced
Chris@1706 159 or that the library is not on the branch at all. This function
Chris@1706 160 may use the network to check for new revisions *)
Chris@1706 161 val is_newest : context -> libname * branch -> bool result
Chris@1706 162
Chris@1706 163 (** Test whether the library is at the newest revision available
Chris@1706 164 locally for the given branch. False may indicate that the
Chris@1706 165 branch has advanced or that the library is not on the branch
Chris@1706 166 at all. This function must not use the network *)
Chris@1706 167 val is_newest_locally : context -> libname * branch -> bool result
Chris@1706 168
Chris@1706 169 (** Test whether the library has been modified in the local
Chris@1706 170 working copy *)
Chris@1706 171 val is_modified_locally : context -> libname -> bool result
Chris@1706 172
Chris@1706 173 (** Check out, i.e. clone a fresh copy of, the repo for the given
Chris@1706 174 library on the given branch *)
Chris@1706 175 val checkout : context -> libname * source * branch -> unit result
Chris@1706 176
Chris@1706 177 (** Update the library to the given branch tip *)
Chris@1706 178 val update : context -> libname * branch -> id_or_tag result
Chris@1706 179
Chris@1706 180 (** Update the library to the given specific id or tag *)
Chris@1706 181 val update_to : context -> libname * id_or_tag -> id_or_tag result
Chris@1706 182 end
Chris@1706 183
Chris@1706 184 signature LIB_CONTROL = sig
Chris@1706 185 val review : context -> libspec -> (libstate * localstate) result
Chris@1706 186 val status : context -> libspec -> (libstate * localstate) result
Chris@1706 187 val update : context -> libspec -> id_or_tag result
Chris@1740 188 val id_of : context -> libspec -> id_or_tag result
Chris@1706 189 end
Chris@1706 190
Chris@1706 191 structure FileBits :> sig
Chris@1706 192 val extpath : context -> string
Chris@1706 193 val libpath : context -> libname -> string
Chris@1706 194 val subpath : context -> libname -> string -> string
Chris@1706 195 val command_output : context -> libname -> string list -> string result
Chris@1706 196 val command : context -> libname -> string list -> unit result
Chris@1706 197 val file_contents : string -> string
Chris@1706 198 val mydir : unit -> string
Chris@1706 199 val homedir : unit -> string
Chris@1706 200 val mkpath : string -> unit result
Chris@1746 201 val rmpath : string -> unit result
Chris@1706 202 val project_spec_path : string -> string
Chris@1706 203 val project_lock_path : string -> string
Chris@1706 204 val verbose : unit -> bool
Chris@1706 205 end = struct
Chris@1706 206
Chris@1706 207 fun verbose () =
Chris@1706 208 case OS.Process.getEnv "VEXT_VERBOSE" of
Chris@1706 209 SOME "0" => false
Chris@1706 210 | SOME _ => true
Chris@1706 211 | NONE => false
Chris@1706 212
Chris@1706 213 fun extpath ({ rootpath, extdir, ... } : context) =
Chris@1706 214 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1706 215 in OS.Path.toString {
Chris@1706 216 isAbs = isAbs,
Chris@1706 217 vol = vol,
Chris@1706 218 arcs = arcs @ [ extdir ]
Chris@1706 219 }
Chris@1706 220 end
Chris@1706 221
Chris@1706 222 fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
Chris@1706 223 (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
Chris@1706 224 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1706 225 val split = String.fields (fn c => c = #"/")
Chris@1706 226 in OS.Path.toString {
Chris@1706 227 isAbs = isAbs,
Chris@1706 228 vol = vol,
Chris@1706 229 arcs = arcs @ [ extdir ] @ split libname @ split remainder
Chris@1706 230 }
Chris@1706 231 end
Chris@1706 232
Chris@1706 233 fun libpath context "" =
Chris@1706 234 extpath context
Chris@1706 235 | libpath context libname =
Chris@1706 236 subpath context libname ""
Chris@1706 237
Chris@1706 238 fun project_file_path rootpath filename =
Chris@1706 239 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
Chris@1706 240 in OS.Path.toString {
Chris@1706 241 isAbs = isAbs,
Chris@1706 242 vol = vol,
Chris@1706 243 arcs = arcs @ [ filename ]
Chris@1706 244 }
Chris@1706 245 end
Chris@1706 246
Chris@1706 247 fun project_spec_path rootpath =
Chris@1706 248 project_file_path rootpath (VextFilenames.project_file)
Chris@1706 249
Chris@1706 250 fun project_lock_path rootpath =
Chris@1706 251 project_file_path rootpath (VextFilenames.project_lock_file)
Chris@1706 252
Chris@1706 253 fun trim str =
Chris@1706 254 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
Chris@1706 255
Chris@1706 256 fun file_contents filename =
Chris@1706 257 let val stream = TextIO.openIn filename
Chris@1706 258 fun read_all str acc =
Chris@1706 259 case TextIO.inputLine str of
Chris@1706 260 SOME line => read_all str (trim line :: acc)
Chris@1706 261 | NONE => rev acc
Chris@1706 262 val contents = read_all stream []
Chris@1706 263 val _ = TextIO.closeIn stream
Chris@1706 264 in
Chris@1706 265 String.concatWith "\n" contents
Chris@1706 266 end
Chris@1706 267
Chris@1706 268 fun expand_commandline cmdlist =
Chris@1706 269 (* We are quite [too] strict about what we accept here, except
Chris@1706 270 for the first element in cmdlist which is assumed to be a
Chris@1706 271 known command location rather than arbitrary user input. NB
Chris@1706 272 only ASCII accepted at this point. *)
Chris@1706 273 let open Char
Chris@1706 274 fun quote arg =
Chris@1706 275 if List.all
Chris@1706 276 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
Chris@1706 277 (explode arg)
Chris@1706 278 then arg
Chris@1706 279 else "\"" ^ arg ^ "\""
Chris@1706 280 fun check arg =
Chris@1706 281 let val valid = explode " /#:;?,._-{}@="
Chris@1706 282 in
Chris@1706 283 app (fn c =>
Chris@1706 284 if isAlphaNum c orelse
Chris@1706 285 List.exists (fn v => v = c) valid
Chris@1706 286 then ()
Chris@1706 287 else raise Fail ("Invalid character '" ^
Chris@1706 288 (Char.toString c) ^
Chris@1706 289 "' in command list"))
Chris@1706 290 (explode arg);
Chris@1706 291 arg
Chris@1706 292 end
Chris@1706 293 in
Chris@1706 294 String.concatWith " "
Chris@1706 295 (map quote
Chris@1706 296 (hd cmdlist :: map check (tl cmdlist)))
Chris@1706 297 end
Chris@1706 298
Chris@1706 299 val tick_cycle = ref 0
Chris@1706 300 val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
Chris@1706 301
Chris@1716 302 fun tick libname cmdlist =
Chris@1706 303 let val n = Vector.length tick_chars
Chris@1706 304 fun pad_to n str =
Chris@1716 305 if n <= String.size str then str
Chris@1716 306 else pad_to n (str ^ " ")
Chris@1716 307 val name = if libname <> "" then libname
Chris@1716 308 else if cmdlist = nil then ""
Chris@1716 309 else hd (rev cmdlist)
Chris@1706 310 in
Chris@1716 311 print (" " ^
Chris@1706 312 Vector.sub(tick_chars, !tick_cycle) ^ " " ^
Chris@1716 313 pad_to 24 name ^
Chris@1716 314 "\r");
Chris@1706 315 tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
Chris@1706 316 end
Chris@1706 317
Chris@1706 318 fun run_command context libname cmdlist redirect =
Chris@1706 319 let open OS
Chris@1706 320 val dir = libpath context libname
Chris@1706 321 val cmd = expand_commandline cmdlist
Chris@1706 322 val _ = if verbose ()
Chris@1706 323 then print ("Running: " ^ cmd ^
Chris@1706 324 " (in dir " ^ dir ^ ")...\n")
Chris@1716 325 else tick libname cmdlist
Chris@1706 326 val _ = FileSys.chDir dir
Chris@1706 327 val status = case redirect of
Chris@1706 328 NONE => Process.system cmd
Chris@1706 329 | SOME file => Process.system (cmd ^ ">" ^ file)
Chris@1706 330 in
Chris@1706 331 if Process.isSuccess status
Chris@1706 332 then OK ()
Chris@1706 333 else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
Chris@1706 334 end
Chris@1706 335 handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
Chris@1706 336
Chris@1706 337 fun command context libname cmdlist =
Chris@1706 338 run_command context libname cmdlist NONE
Chris@1706 339
Chris@1706 340 fun command_output context libname cmdlist =
Chris@1706 341 let open OS
Chris@1706 342 val tmpFile = FileSys.tmpName ()
Chris@1706 343 val result = run_command context libname cmdlist (SOME tmpFile)
Chris@1706 344 val contents = file_contents tmpFile
Chris@1706 345 in
Chris@1706 346 FileSys.remove tmpFile handle _ => ();
Chris@1706 347 case result of
Chris@1706 348 OK () => OK contents
Chris@1706 349 | ERROR e => ERROR e
Chris@1706 350 end
Chris@1706 351
Chris@1706 352 fun mydir () =
Chris@1706 353 let open OS
Chris@1706 354 val { dir, file } = Path.splitDirFile (CommandLine.name ())
Chris@1706 355 in
Chris@1706 356 FileSys.realPath
Chris@1706 357 (if Path.isAbsolute dir
Chris@1706 358 then dir
Chris@1706 359 else Path.concat (FileSys.getDir (), dir))
Chris@1706 360 end
Chris@1706 361
Chris@1706 362 fun homedir () =
Chris@1706 363 (* Failure is not routine, so we use an exception here *)
Chris@1706 364 case (OS.Process.getEnv "HOME",
Chris@1706 365 OS.Process.getEnv "HOMEPATH") of
Chris@1706 366 (SOME home, _) => home
Chris@1706 367 | (NONE, SOME home) => home
Chris@1706 368 | (NONE, NONE) =>
Chris@1706 369 raise Fail "Failed to look up home directory from environment"
Chris@1706 370
Chris@1747 371 fun mkpath' path =
Chris@1706 372 if OS.FileSys.isDir path handle _ => false
Chris@1706 373 then OK ()
Chris@1706 374 else case OS.Path.fromString path of
Chris@1706 375 { arcs = nil, ... } => OK ()
Chris@1706 376 | { isAbs = false, ... } => ERROR "mkpath requires absolute path"
Chris@1706 377 | { isAbs, vol, arcs } =>
Chris@1747 378 case mkpath' (OS.Path.toString { (* parent *)
Chris@1747 379 isAbs = isAbs,
Chris@1747 380 vol = vol,
Chris@1747 381 arcs = rev (tl (rev arcs)) }) of
Chris@1706 382 ERROR e => ERROR e
Chris@1706 383 | OK () => ((OS.FileSys.mkDir path; OK ())
Chris@1706 384 handle OS.SysErr (e, _) =>
Chris@1706 385 ERROR ("Directory creation failed: " ^ e))
Chris@1746 386
Chris@1747 387 fun mkpath path =
Chris@1747 388 (* strip any trailing '/', something isDir doesn't always handle *)
Chris@1747 389 case rev (explode path) of
Chris@1747 390 #"/"::rest => mkpath (implode (rev rest))
Chris@1747 391 | _ => mkpath' path
Chris@1747 392
Chris@1746 393 fun rmpath path =
Chris@1746 394 let open OS
Chris@1746 395 fun files_from dirstream =
Chris@1746 396 case FileSys.readDir dirstream of
Chris@1746 397 NONE => []
Chris@1746 398 | SOME file =>
Chris@1746 399 (* readDir is supposed to filter these,
Chris@1746 400 but let's be extra cautious: *)
Chris@1746 401 if file = Path.parentArc orelse file = Path.currentArc
Chris@1746 402 then files_from dirstream
Chris@1746 403 else file :: files_from dirstream
Chris@1746 404 fun contents dir =
Chris@1746 405 let val stream = FileSys.openDir dir
Chris@1746 406 val files = map (fn f => Path.joinDirFile
Chris@1746 407 { dir = dir, file = f })
Chris@1746 408 (files_from stream)
Chris@1746 409 val _ = FileSys.closeDir stream
Chris@1746 410 in files
Chris@1746 411 end
Chris@1746 412 fun remove path =
Chris@1746 413 if FileSys.isLink path (* dangling links bother isDir *)
Chris@1746 414 then FileSys.remove path
Chris@1746 415 else if FileSys.isDir path
Chris@1746 416 then (app remove (contents path); FileSys.rmDir path)
Chris@1746 417 else FileSys.remove path
Chris@1746 418 in
Chris@1746 419 (remove path; OK ())
Chris@1746 420 handle SysErr (e, _) => ERROR ("Path removal failed: " ^ e)
Chris@1746 421 end
Chris@1706 422 end
Chris@1706 423
Chris@1706 424 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
Chris@1706 425
Chris@1706 426 (* Valid states for unpinned libraries:
Chris@1706 427
Chris@1706 428 - CORRECT: We are on the right branch and are up-to-date with
Chris@1706 429 it as far as we can tell. (If not using the network, this
Chris@1706 430 should be reported to user as "Present" rather than "Correct"
Chris@1706 431 as the remote repo may have advanced without us knowing.)
Chris@1706 432
Chris@1706 433 - SUPERSEDED: We are on the right branch but we can see that
Chris@1706 434 there is a newer revision either locally or on the remote (in
Chris@1706 435 Git terms, we are at an ancestor of the desired branch tip).
Chris@1706 436
Chris@1706 437 - WRONG: We are on the wrong branch (in Git terms, we are not
Chris@1706 438 at the desired branch tip or any ancestor of it).
Chris@1706 439
Chris@1706 440 - ABSENT: Repo doesn't exist here at all.
Chris@1706 441
Chris@1706 442 Valid states for pinned libraries:
Chris@1706 443
Chris@1706 444 - CORRECT: We are at the pinned revision.
Chris@1706 445
Chris@1706 446 - WRONG: We are at any revision other than the pinned one.
Chris@1706 447
Chris@1706 448 - ABSENT: Repo doesn't exist here at all.
Chris@1706 449 *)
Chris@1706 450
Chris@1740 451 fun check with_network context
Chris@1740 452 ({ libname, branch, project_pin, lock_pin, ... } : libspec) =
Chris@1706 453 let fun check_unpinned () =
Chris@1706 454 let val is_newest = if with_network
Chris@1706 455 then V.is_newest
Chris@1706 456 else V.is_newest_locally
Chris@1706 457 in
Chris@1706 458 case is_newest context (libname, branch) of
Chris@1706 459 ERROR e => ERROR e
Chris@1706 460 | OK true => OK CORRECT
Chris@1706 461 | OK false =>
Chris@1706 462 case V.is_on_branch context (libname, branch) of
Chris@1706 463 ERROR e => ERROR e
Chris@1706 464 | OK true => OK SUPERSEDED
Chris@1706 465 | OK false => OK WRONG
Chris@1706 466 end
Chris@1706 467 fun check_pinned target =
Chris@1706 468 case V.is_at context (libname, target) of
Chris@1706 469 ERROR e => ERROR e
Chris@1706 470 | OK true => OK CORRECT
Chris@1706 471 | OK false => OK WRONG
Chris@1740 472 fun check_remote () =
Chris@1740 473 case project_pin of
Chris@1706 474 UNPINNED => check_unpinned ()
Chris@1706 475 | PINNED target => check_pinned target
Chris@1740 476 fun check_local () =
Chris@1740 477 case V.is_modified_locally context libname of
Chris@1740 478 ERROR e => ERROR e
Chris@1740 479 | OK true => OK MODIFIED
Chris@1740 480 | OK false =>
Chris@1740 481 case lock_pin of
Chris@1740 482 UNPINNED => OK CLEAN
Chris@1740 483 | PINNED target =>
Chris@1740 484 case V.is_at context (libname, target) of
Chris@1740 485 ERROR e => ERROR e
Chris@1740 486 | OK true => OK CLEAN
Chris@1740 487 | OK false => OK LOCK_MISMATCHED
Chris@1706 488 in
Chris@1706 489 case V.exists context libname of
Chris@1706 490 ERROR e => ERROR e
Chris@1740 491 | OK false => OK (ABSENT, CLEAN)
Chris@1706 492 | OK true =>
Chris@1740 493 case (check_remote (), check_local ()) of
Chris@1706 494 (ERROR e, _) => ERROR e
Chris@1706 495 | (_, ERROR e) => ERROR e
Chris@1740 496 | (OK r, OK l) => OK (r, l)
Chris@1706 497 end
Chris@1706 498
Chris@1706 499 val review = check true
Chris@1706 500 val status = check false
Chris@1740 501
Chris@1740 502 fun update context
Chris@1740 503 ({ libname, source, branch,
Chris@1740 504 project_pin, lock_pin, ... } : libspec) =
Chris@1706 505 let fun update_unpinned () =
Chris@1706 506 case V.is_newest context (libname, branch) of
Chris@1706 507 ERROR e => ERROR e
Chris@1706 508 | OK true => V.id_of context libname
Chris@1706 509 | OK false => V.update context (libname, branch)
Chris@1706 510 fun update_pinned target =
Chris@1706 511 case V.is_at context (libname, target) of
Chris@1706 512 ERROR e => ERROR e
Chris@1706 513 | OK true => OK target
Chris@1706 514 | OK false => V.update_to context (libname, target)
Chris@1706 515 fun update' () =
Chris@1740 516 case lock_pin of
Chris@1740 517 PINNED target => update_pinned target
Chris@1740 518 | UNPINNED =>
Chris@1740 519 case project_pin of
Chris@1740 520 PINNED target => update_pinned target
Chris@1740 521 | UNPINNED => update_unpinned ()
Chris@1706 522 in
Chris@1706 523 case V.exists context libname of
Chris@1706 524 ERROR e => ERROR e
Chris@1706 525 | OK true => update' ()
Chris@1706 526 | OK false =>
Chris@1706 527 case V.checkout context (libname, source, branch) of
Chris@1706 528 ERROR e => ERROR e
Chris@1706 529 | OK () => update' ()
Chris@1706 530 end
Chris@1740 531
Chris@1740 532 fun id_of context ({ libname, ... } : libspec) =
Chris@1740 533 V.id_of context libname
Chris@1740 534
Chris@1706 535 end
Chris@1706 536
Chris@1706 537 (* Simple Standard ML JSON parser
Chris@1706 538 ==============================
Chris@1706 539
Chris@1706 540 https://bitbucket.org/cannam/sml-simplejson
Chris@1706 541
Chris@1706 542 An RFC-compliant JSON parser in one SML file with no dependency
Chris@1706 543 on anything outside the Basis library. Also includes a simple
Chris@1706 544 serialiser.
Chris@1706 545
Chris@1706 546 Tested with MLton, Poly/ML, and SML/NJ compilers.
Chris@1706 547
Chris@1706 548 Parser notes:
Chris@1706 549
Chris@1706 550 * Complies with RFC 7159, The JavaScript Object Notation (JSON)
Chris@1706 551 Data Interchange Format
Chris@1706 552
Chris@1706 553 * Passes all of the JSONTestSuite parser accept/reject tests that
Chris@1706 554 exist at the time of writing, as listed in "Parsing JSON is a
Chris@1706 555 Minefield" (http://seriot.ch/parsing_json.php)
Chris@1706 556
Chris@1706 557 * Two-pass parser using naive exploded strings, therefore not
Chris@1706 558 particularly fast and not suitable for large input files
Chris@1706 559
Chris@1706 560 * Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check
Chris@1706 561 that JSON strings are valid UTF-8 -- the caller must do that --
Chris@1706 562 but does handle \u escapes
Chris@1706 563
Chris@1706 564 * Converts all numbers to type "real". If that is a 64-bit IEEE
Chris@1706 565 float type (common but not guaranteed in SML) then we're pretty
Chris@1706 566 standard for a JSON parser
Chris@1706 567
Chris@1706 568 Copyright 2017 Chris Cannam.
Chris@1706 569 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
Chris@1706 570
Chris@1706 571 Permission is hereby granted, free of charge, to any person
Chris@1706 572 obtaining a copy of this software and associated documentation
Chris@1706 573 files (the "Software"), to deal in the Software without
Chris@1706 574 restriction, including without limitation the rights to use, copy,
Chris@1706 575 modify, merge, publish, distribute, sublicense, and/or sell copies
Chris@1706 576 of the Software, and to permit persons to whom the Software is
Chris@1706 577 furnished to do so, subject to the following conditions:
Chris@1706 578
Chris@1706 579 The above copyright notice and this permission notice shall be
Chris@1706 580 included in all copies or substantial portions of the Software.
Chris@1706 581
Chris@1706 582 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
Chris@1706 583 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
Chris@1706 584 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
Chris@1706 585 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
Chris@1706 586 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
Chris@1706 587 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
Chris@1706 588 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Chris@1706 589
Chris@1706 590 Except as contained in this notice, the names of Chris Cannam and
Chris@1706 591 Particular Programs Ltd shall not be used in advertising or
Chris@1706 592 otherwise to promote the sale, use or other dealings in this
Chris@1706 593 Software without prior written authorization.
Chris@1706 594 *)
Chris@1706 595
Chris@1706 596 signature JSON = sig
Chris@1706 597
Chris@1706 598 datatype json = OBJECT of (string * json) list
Chris@1706 599 | ARRAY of json list
Chris@1706 600 | NUMBER of real
Chris@1706 601 | STRING of string
Chris@1706 602 | BOOL of bool
Chris@1706 603 | NULL
Chris@1706 604
Chris@1706 605 datatype 'a result = OK of 'a
Chris@1706 606 | ERROR of string
Chris@1706 607
Chris@1706 608 val parse : string -> json result
Chris@1706 609 val serialise : json -> string
Chris@1706 610 val serialiseIndented : json -> string
Chris@1706 611
Chris@1706 612 end
Chris@1706 613
Chris@1706 614 structure Json :> JSON = struct
Chris@1706 615
Chris@1706 616 datatype json = OBJECT of (string * json) list
Chris@1706 617 | ARRAY of json list
Chris@1706 618 | NUMBER of real
Chris@1706 619 | STRING of string
Chris@1706 620 | BOOL of bool
Chris@1706 621 | NULL
Chris@1706 622
Chris@1706 623 datatype 'a result = OK of 'a
Chris@1706 624 | ERROR of string
Chris@1706 625
Chris@1706 626 structure T = struct
Chris@1706 627 datatype token = NUMBER of char list
Chris@1706 628 | STRING of string
Chris@1706 629 | BOOL of bool
Chris@1706 630 | NULL
Chris@1706 631 | CURLY_L
Chris@1706 632 | CURLY_R
Chris@1706 633 | SQUARE_L
Chris@1706 634 | SQUARE_R
Chris@1706 635 | COLON
Chris@1706 636 | COMMA
Chris@1706 637
Chris@1706 638 fun toString t =
Chris@1706 639 case t of NUMBER digits => implode digits
Chris@1706 640 | STRING s => s
Chris@1706 641 | BOOL b => Bool.toString b
Chris@1706 642 | NULL => "null"
Chris@1706 643 | CURLY_L => "{"
Chris@1706 644 | CURLY_R => "}"
Chris@1706 645 | SQUARE_L => "["
Chris@1706 646 | SQUARE_R => "]"
Chris@1706 647 | COLON => ":"
Chris@1706 648 | COMMA => ","
Chris@1706 649 end
Chris@1706 650
Chris@1706 651 fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *)
Chris@1706 652 let open Word
Chris@1706 653 infix 6 orb andb >>
Chris@1706 654 in
Chris@1706 655 map (Char.chr o toInt)
Chris@1706 656 (if cp < 0wx80 then
Chris@1706 657 [cp]
Chris@1706 658 else if cp < 0wx800 then
Chris@1706 659 [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
Chris@1706 660 else if cp < 0wx10000 then
Chris@1706 661 [0wxe0 orb (cp >> 0w12),
Chris@1706 662 0wx80 orb ((cp >> 0w6) andb 0wx3f),
Chris@1706 663 0wx80 orb (cp andb 0wx3f)]
Chris@1706 664 else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
Chris@1706 665 end
Chris@1706 666
Chris@1706 667 fun error pos text = ERROR (text ^ " at character position " ^
Chris@1706 668 Int.toString (pos - 1))
Chris@1706 669 fun token_error pos = error pos ("Unexpected token")
Chris@1706 670
Chris@1706 671 fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
Chris@1706 672 lex (pos + 3) (T.NULL :: acc) xs
Chris@1706 673 | lexNull pos acc _ = token_error pos
Chris@1706 674
Chris@1706 675 and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
Chris@1706 676 lex (pos + 3) (T.BOOL true :: acc) xs
Chris@1706 677 | lexTrue pos acc _ = token_error pos
Chris@1706 678
Chris@1706 679 and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
Chris@1706 680 lex (pos + 4) (T.BOOL false :: acc) xs
Chris@1706 681 | lexFalse pos acc _ = token_error pos
Chris@1706 682
Chris@1706 683 and lexChar tok pos acc xs =
Chris@1706 684 lex pos (tok :: acc) xs
Chris@1706 685
Chris@1706 686 and lexString pos acc cc =
Chris@1706 687 let datatype escaped = ESCAPED | NORMAL
Chris@1706 688 fun lexString' pos text ESCAPED [] =
Chris@1706 689 error pos "End of input during escape sequence"
Chris@1706 690 | lexString' pos text NORMAL [] =
Chris@1706 691 error pos "End of input during string"
Chris@1706 692 | lexString' pos text ESCAPED (x :: xs) =
Chris@1706 693 let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
Chris@1706 694 in case x of
Chris@1706 695 #"\"" => esc x
Chris@1706 696 | #"\\" => esc x
Chris@1706 697 | #"/" => esc x
Chris@1706 698 | #"b" => esc #"\b"
Chris@1706 699 | #"f" => esc #"\f"
Chris@1706 700 | #"n" => esc #"\n"
Chris@1706 701 | #"r" => esc #"\r"
Chris@1706 702 | #"t" => esc #"\t"
Chris@1706 703 | _ => error pos ("Invalid escape \\" ^
Chris@1706 704 Char.toString x)
Chris@1706 705 end
Chris@1706 706 | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
Chris@1706 707 if List.all Char.isHexDigit [a,b,c,d]
Chris@1706 708 then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
Chris@1706 709 SOME w => (let val utf = rev (bmpToUtf8 w) in
Chris@1706 710 lexString' (pos + 6) (utf @ text)
Chris@1706 711 NORMAL xs
Chris@1706 712 end
Chris@1706 713 handle Fail err => error pos err)
Chris@1706 714 | NONE => error pos "Invalid Unicode BMP escape sequence"
Chris@1706 715 else error pos "Invalid Unicode BMP escape sequence"
Chris@1706 716 | lexString' pos text NORMAL (x :: xs) =
Chris@1706 717 if Char.ord x < 0x20
Chris@1706 718 then error pos "Invalid unescaped control character"
Chris@1706 719 else
Chris@1706 720 case x of
Chris@1706 721 #"\"" => OK (rev text, xs, pos + 1)
Chris@1706 722 | #"\\" => lexString' (pos + 1) text ESCAPED xs
Chris@1706 723 | _ => lexString' (pos + 1) (x :: text) NORMAL xs
Chris@1706 724 in
Chris@1706 725 case lexString' pos [] NORMAL cc of
Chris@1706 726 OK (text, rest, newpos) =>
Chris@1706 727 lex newpos (T.STRING (implode text) :: acc) rest
Chris@1706 728 | ERROR e => ERROR e
Chris@1706 729 end
Chris@1706 730
Chris@1706 731 and lexNumber firstChar pos acc cc =
Chris@1706 732 let val valid = explode ".+-e"
Chris@1706 733 fun lexNumber' pos digits [] = (rev digits, [], pos)
Chris@1706 734 | lexNumber' pos digits (x :: xs) =
Chris@1706 735 if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
Chris@1706 736 else if Char.isDigit x orelse List.exists (fn c => x = c) valid
Chris@1706 737 then lexNumber' (pos + 1) (x :: digits) xs
Chris@1706 738 else (rev digits, x :: xs, pos)
Chris@1706 739 val (digits, rest, newpos) =
Chris@1706 740 lexNumber' (pos - 1) [] (firstChar :: cc)
Chris@1706 741 in
Chris@1706 742 case digits of
Chris@1706 743 [] => token_error pos
Chris@1706 744 | _ => lex newpos (T.NUMBER digits :: acc) rest
Chris@1706 745 end
Chris@1706 746
Chris@1706 747 and lex pos acc [] = OK (rev acc)
Chris@1706 748 | lex pos acc (x::xs) =
Chris@1706 749 (case x of
Chris@1706 750 #" " => lex
Chris@1706 751 | #"\t" => lex
Chris@1706 752 | #"\n" => lex
Chris@1706 753 | #"\r" => lex
Chris@1706 754 | #"{" => lexChar T.CURLY_L
Chris@1706 755 | #"}" => lexChar T.CURLY_R
Chris@1706 756 | #"[" => lexChar T.SQUARE_L
Chris@1706 757 | #"]" => lexChar T.SQUARE_R
Chris@1706 758 | #":" => lexChar T.COLON
Chris@1706 759 | #"," => lexChar T.COMMA
Chris@1706 760 | #"\"" => lexString
Chris@1706 761 | #"t" => lexTrue
Chris@1706 762 | #"f" => lexFalse
Chris@1706 763 | #"n" => lexNull
Chris@1706 764 | x => lexNumber x) (pos + 1) acc xs
Chris@1706 765
Chris@1706 766 fun show [] = "end of input"
Chris@1706 767 | show (tok :: _) = T.toString tok
Chris@1706 768
Chris@1706 769 fun parseNumber digits =
Chris@1706 770 (* Note lexNumber already case-insensitised the E for us *)
Chris@1706 771 let open Char
Chris@1706 772
Chris@1706 773 fun okExpDigits [] = false
Chris@1706 774 | okExpDigits (c :: []) = isDigit c
Chris@1706 775 | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
Chris@1706 776
Chris@1706 777 fun okExponent [] = false
Chris@1706 778 | okExponent (#"+" :: cs) = okExpDigits cs
Chris@1706 779 | okExponent (#"-" :: cs) = okExpDigits cs
Chris@1706 780 | okExponent cc = okExpDigits cc
Chris@1706 781
Chris@1706 782 fun okFracTrailing [] = true
Chris@1706 783 | okFracTrailing (c :: cs) =
Chris@1706 784 (isDigit c andalso okFracTrailing cs) orelse
Chris@1706 785 (c = #"e" andalso okExponent cs)
Chris@1706 786
Chris@1706 787 fun okFraction [] = false
Chris@1706 788 | okFraction (c :: cs) =
Chris@1706 789 isDigit c andalso okFracTrailing cs
Chris@1706 790
Chris@1706 791 fun okPosTrailing [] = true
Chris@1706 792 | okPosTrailing (#"." :: cs) = okFraction cs
Chris@1706 793 | okPosTrailing (#"e" :: cs) = okExponent cs
Chris@1706 794 | okPosTrailing (c :: cs) =
Chris@1706 795 isDigit c andalso okPosTrailing cs
Chris@1706 796
Chris@1706 797 fun okPositive [] = false
Chris@1706 798 | okPositive (#"0" :: []) = true
Chris@1706 799 | okPositive (#"0" :: #"." :: cs) = okFraction cs
Chris@1706 800 | okPositive (#"0" :: #"e" :: cs) = okExponent cs
Chris@1706 801 | okPositive (#"0" :: cs) = false
Chris@1706 802 | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
Chris@1706 803
Chris@1706 804 fun okNumber (#"-" :: cs) = okPositive cs
Chris@1706 805 | okNumber cc = okPositive cc
Chris@1706 806 in
Chris@1706 807 if okNumber digits
Chris@1706 808 then case Real.fromString (implode digits) of
Chris@1706 809 NONE => ERROR "Number out of range"
Chris@1706 810 | SOME r => OK r
Chris@1706 811 else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
Chris@1706 812 end
Chris@1706 813
Chris@1706 814 fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
Chris@1706 815 | parseObject tokens =
Chris@1706 816 let fun parsePair (T.STRING key :: T.COLON :: xs) =
Chris@1706 817 (case parseTokens xs of
Chris@1706 818 ERROR e => ERROR e
Chris@1706 819 | OK (j, xs) => OK ((key, j), xs))
Chris@1706 820 | parsePair other =
Chris@1706 821 ERROR ("Object key/value pair expected around \"" ^
Chris@1706 822 show other ^ "\"")
Chris@1706 823 fun parseObject' acc [] = ERROR "End of input during object"
Chris@1706 824 | parseObject' acc tokens =
Chris@1706 825 case parsePair tokens of
Chris@1706 826 ERROR e => ERROR e
Chris@1706 827 | OK (pair, T.COMMA :: xs) =>
Chris@1706 828 parseObject' (pair :: acc) xs
Chris@1706 829 | OK (pair, T.CURLY_R :: xs) =>
Chris@1706 830 OK (OBJECT (rev (pair :: acc)), xs)
Chris@1706 831 | OK (_, _) => ERROR "Expected , or } after object element"
Chris@1706 832 in
Chris@1706 833 parseObject' [] tokens
Chris@1706 834 end
Chris@1706 835
Chris@1706 836 and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
Chris@1706 837 | parseArray tokens =
Chris@1706 838 let fun parseArray' acc [] = ERROR "End of input during array"
Chris@1706 839 | parseArray' acc tokens =
Chris@1706 840 case parseTokens tokens of
Chris@1706 841 ERROR e => ERROR e
Chris@1706 842 | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
Chris@1706 843 | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
Chris@1706 844 | OK (_, _) => ERROR "Expected , or ] after array element"
Chris@1706 845 in
Chris@1706 846 parseArray' [] tokens
Chris@1706 847 end
Chris@1706 848
Chris@1706 849 and parseTokens [] = ERROR "Value expected"
Chris@1706 850 | parseTokens (tok :: xs) =
Chris@1706 851 (case tok of
Chris@1706 852 T.NUMBER d => (case parseNumber d of
Chris@1706 853 OK r => OK (NUMBER r, xs)
Chris@1706 854 | ERROR e => ERROR e)
Chris@1706 855 | T.STRING s => OK (STRING s, xs)
Chris@1706 856 | T.BOOL b => OK (BOOL b, xs)
Chris@1706 857 | T.NULL => OK (NULL, xs)
Chris@1706 858 | T.CURLY_L => parseObject xs
Chris@1706 859 | T.SQUARE_L => parseArray xs
Chris@1706 860 | _ => ERROR ("Unexpected token " ^ T.toString tok ^
Chris@1706 861 " before " ^ show xs))
Chris@1706 862
Chris@1706 863 fun parse str =
Chris@1706 864 case lex 1 [] (explode str) of
Chris@1706 865 ERROR e => ERROR e
Chris@1706 866 | OK tokens => case parseTokens tokens of
Chris@1706 867 OK (value, []) => OK value
Chris@1706 868 | OK (_, _) => ERROR "Extra data after input"
Chris@1706 869 | ERROR e => ERROR e
Chris@1706 870
Chris@1706 871 fun stringEscape s =
Chris@1706 872 let fun esc x = [x, #"\\"]
Chris@1706 873 fun escape' acc [] = rev acc
Chris@1706 874 | escape' acc (x :: xs) =
Chris@1706 875 escape' (case x of
Chris@1706 876 #"\"" => esc x @ acc
Chris@1706 877 | #"\\" => esc x @ acc
Chris@1706 878 | #"\b" => esc #"b" @ acc
Chris@1706 879 | #"\f" => esc #"f" @ acc
Chris@1706 880 | #"\n" => esc #"n" @ acc
Chris@1706 881 | #"\r" => esc #"r" @ acc
Chris@1706 882 | #"\t" => esc #"t" @ acc
Chris@1706 883 | _ =>
Chris@1706 884 let val c = Char.ord x
Chris@1706 885 in
Chris@1706 886 if c < 0x20
Chris@1706 887 then let val hex = Word.toString (Word.fromInt c)
Chris@1706 888 in (rev o explode) (if c < 0x10
Chris@1706 889 then ("\\u000" ^ hex)
Chris@1706 890 else ("\\u00" ^ hex))
Chris@1706 891 end @ acc
Chris@1706 892 else
Chris@1706 893 x :: acc
Chris@1706 894 end)
Chris@1706 895 xs
Chris@1706 896 in
Chris@1706 897 implode (escape' [] (explode s))
Chris@1706 898 end
Chris@1706 899
Chris@1706 900 fun serialise json =
Chris@1706 901 case json of
Chris@1706 902 OBJECT pp => "{" ^ String.concatWith
Chris@1706 903 "," (map (fn (key, value) =>
Chris@1706 904 serialise (STRING key) ^ ":" ^
Chris@1706 905 serialise value) pp) ^
Chris@1706 906 "}"
Chris@1706 907 | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
Chris@1706 908 | NUMBER n => implode (map (fn #"~" => #"-" | c => c)
Chris@1706 909 (explode (Real.toString n)))
Chris@1706 910 | STRING s => "\"" ^ stringEscape s ^ "\""
Chris@1706 911 | BOOL b => Bool.toString b
Chris@1706 912 | NULL => "null"
Chris@1706 913
Chris@1706 914 fun serialiseIndented json =
Chris@1706 915 let fun indent 0 = ""
Chris@1706 916 | indent i = " " ^ indent (i - 1)
Chris@1706 917 fun serialiseIndented' i json =
Chris@1706 918 let val ser = serialiseIndented' (i + 1)
Chris@1706 919 in
Chris@1706 920 case json of
Chris@1706 921 OBJECT [] => "{}"
Chris@1706 922 | ARRAY [] => "[]"
Chris@1706 923 | OBJECT pp => "{\n" ^ indent (i + 1) ^
Chris@1706 924 String.concatWith
Chris@1706 925 (",\n" ^ indent (i + 1))
Chris@1706 926 (map (fn (key, value) =>
Chris@1706 927 ser (STRING key) ^ ": " ^
Chris@1706 928 ser value) pp) ^
Chris@1706 929 "\n" ^ indent i ^ "}"
Chris@1706 930 | ARRAY arr => "[\n" ^ indent (i + 1) ^
Chris@1706 931 String.concatWith
Chris@1706 932 (",\n" ^ indent (i + 1))
Chris@1706 933 (map ser arr) ^
Chris@1706 934 "\n" ^ indent i ^ "]"
Chris@1706 935 | other => serialise other
Chris@1706 936 end
Chris@1706 937 in
Chris@1706 938 serialiseIndented' 0 json ^ "\n"
Chris@1706 939 end
Chris@1706 940
Chris@1706 941 end
Chris@1706 942
Chris@1706 943
Chris@1706 944 structure JsonBits :> sig
Chris@1706 945 val load_json_from : string -> Json.json (* filename -> json *)
Chris@1706 946 val save_json_to : string -> Json.json -> unit
Chris@1706 947 val lookup_optional : Json.json -> string list -> Json.json option
Chris@1706 948 val lookup_optional_string : Json.json -> string list -> string option
Chris@1706 949 val lookup_mandatory : Json.json -> string list -> Json.json
Chris@1706 950 val lookup_mandatory_string : Json.json -> string list -> string
Chris@1706 951 end = struct
Chris@1706 952
Chris@1706 953 fun load_json_from filename =
Chris@1706 954 case Json.parse (FileBits.file_contents filename) of
Chris@1706 955 Json.OK json => json
Chris@1706 956 | Json.ERROR e => raise Fail ("Failed to parse file: " ^ e)
Chris@1706 957
Chris@1706 958 fun save_json_to filename json =
Chris@1732 959 (* using binary I/O to avoid ever writing CR/LF line endings *)
Chris@1706 960 let val jstr = Json.serialiseIndented json
Chris@1732 961 val stream = BinIO.openOut filename
Chris@1706 962 in
Chris@1732 963 BinIO.output (stream, Byte.stringToBytes jstr);
Chris@1732 964 BinIO.closeOut stream
Chris@1706 965 end
Chris@1706 966
Chris@1706 967 fun lookup_optional json kk =
Chris@1706 968 let fun lookup key =
Chris@1706 969 case json of
Chris@1706 970 Json.OBJECT kvs =>
Chris@1706 971 (case List.find (fn (k, v) => k = key) kvs of
Chris@1706 972 SOME (k, v) => SOME v
Chris@1706 973 | NONE => NONE)
Chris@1706 974 | _ => raise Fail "Object expected"
Chris@1706 975 in
Chris@1706 976 case kk of
Chris@1706 977 [] => NONE
Chris@1706 978 | key::[] => lookup key
Chris@1706 979 | key::kk => case lookup key of
Chris@1706 980 NONE => NONE
Chris@1706 981 | SOME j => lookup_optional j kk
Chris@1706 982 end
Chris@1706 983
Chris@1706 984 fun lookup_optional_string json kk =
Chris@1706 985 case lookup_optional json kk of
Chris@1706 986 SOME (Json.STRING s) => SOME s
Chris@1706 987 | SOME _ => raise Fail ("Value (if present) must be string: " ^
Chris@1706 988 (String.concatWith " -> " kk))
Chris@1706 989 | NONE => NONE
Chris@1706 990
Chris@1706 991 fun lookup_mandatory json kk =
Chris@1706 992 case lookup_optional json kk of
Chris@1706 993 SOME v => v
Chris@1706 994 | NONE => raise Fail ("Value is mandatory: " ^
Chris@1706 995 (String.concatWith " -> " kk) ^ " in json: " ^
Chris@1706 996 (Json.serialise json))
Chris@1706 997
Chris@1706 998 fun lookup_mandatory_string json kk =
Chris@1706 999 case lookup_optional json kk of
Chris@1706 1000 SOME (Json.STRING s) => s
Chris@1706 1001 | _ => raise Fail ("Value must be string: " ^
Chris@1706 1002 (String.concatWith " -> " kk))
Chris@1706 1003 end
Chris@1706 1004
Chris@1706 1005 structure Provider :> sig
Chris@1706 1006 val load_providers : Json.json -> provider list
Chris@1706 1007 val load_more_providers : provider list -> Json.json -> provider list
Chris@1706 1008 val remote_url : context -> vcs -> source -> libname -> string
Chris@1706 1009 end = struct
Chris@1706 1010
Chris@1706 1011 val known_providers : provider list =
Chris@1706 1012 [ {
Chris@1706 1013 service = "bitbucket",
Chris@1706 1014 supports = [HG, GIT],
Chris@1706 1015 remote_spec = {
Chris@1724 1016 anon = SOME "https://bitbucket.org/{owner}/{repository}",
Chris@1724 1017 auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repository}"
Chris@1706 1018 }
Chris@1706 1019 },
Chris@1706 1020 {
Chris@1706 1021 service = "github",
Chris@1706 1022 supports = [GIT],
Chris@1706 1023 remote_spec = {
Chris@1724 1024 anon = SOME "https://github.com/{owner}/{repository}",
Chris@1724 1025 auth = SOME "ssh://{vcs}@github.com/{owner}/{repository}"
Chris@1706 1026 }
Chris@1706 1027 }
Chris@1706 1028 ]
Chris@1706 1029
Chris@1706 1030 fun vcs_name vcs =
Chris@1706 1031 case vcs of GIT => "git" |
Chris@1706 1032 HG => "hg"
Chris@1706 1033
Chris@1706 1034 fun vcs_from_name name =
Chris@1706 1035 case name of "git" => GIT
Chris@1706 1036 | "hg" => HG
Chris@1706 1037 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
Chris@1706 1038
Chris@1706 1039 fun load_more_providers previously_loaded json =
Chris@1706 1040 let open JsonBits
Chris@1706 1041 fun load pjson pname : provider =
Chris@1706 1042 {
Chris@1706 1043 service = pname,
Chris@1706 1044 supports =
Chris@1706 1045 case lookup_mandatory pjson ["vcs"] of
Chris@1706 1046 Json.ARRAY vv =>
Chris@1706 1047 map (fn (Json.STRING v) => vcs_from_name v
Chris@1706 1048 | _ => raise Fail "Strings expected in vcs array")
Chris@1706 1049 vv
Chris@1706 1050 | _ => raise Fail "Array expected for vcs",
Chris@1706 1051 remote_spec = {
Chris@1724 1052 anon = lookup_optional_string pjson ["anonymous"],
Chris@1724 1053 auth = lookup_optional_string pjson ["authenticated"]
Chris@1706 1054 }
Chris@1706 1055 }
Chris@1706 1056 val loaded =
Chris@1721 1057 case lookup_optional json ["services"] of
Chris@1706 1058 NONE => []
Chris@1706 1059 | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
Chris@1721 1060 | _ => raise Fail "Object expected for services in config"
Chris@1706 1061 val newly_loaded =
Chris@1706 1062 List.filter (fn p => not (List.exists (fn pp => #service p =
Chris@1706 1063 #service pp)
Chris@1706 1064 previously_loaded))
Chris@1706 1065 loaded
Chris@1706 1066 in
Chris@1706 1067 previously_loaded @ newly_loaded
Chris@1706 1068 end
Chris@1706 1069
Chris@1706 1070 fun load_providers json =
Chris@1706 1071 load_more_providers known_providers json
Chris@1706 1072
Chris@1706 1073 fun expand_spec spec { vcs, service, owner, repo } login =
Chris@1706 1074 (* ugly *)
Chris@1706 1075 let fun replace str =
Chris@1706 1076 case str of
Chris@1706 1077 "vcs" => vcs_name vcs
Chris@1706 1078 | "service" => service
Chris@1706 1079 | "owner" =>
Chris@1706 1080 (case owner of
Chris@1706 1081 SOME ostr => ostr
Chris@1706 1082 | NONE => raise Fail ("Owner not specified for service " ^
Chris@1706 1083 service))
Chris@1724 1084 | "repository" => repo
Chris@1706 1085 | "account" =>
Chris@1706 1086 (case login of
Chris@1706 1087 SOME acc => acc
Chris@1706 1088 | NONE => raise Fail ("Account not given for service " ^
Chris@1706 1089 service))
Chris@1706 1090 | other => raise Fail ("Unknown variable \"" ^ other ^
Chris@1706 1091 "\" in spec for service " ^ service)
Chris@1706 1092 fun expand' acc sstr =
Chris@1706 1093 case Substring.splitl (fn c => c <> #"{") sstr of
Chris@1706 1094 (pfx, sfx) =>
Chris@1706 1095 if Substring.isEmpty sfx
Chris@1706 1096 then rev (pfx :: acc)
Chris@1706 1097 else
Chris@1706 1098 case Substring.splitl (fn c => c <> #"}") sfx of
Chris@1706 1099 (tok, remainder) =>
Chris@1706 1100 if Substring.isEmpty remainder
Chris@1706 1101 then rev (tok :: pfx :: acc)
Chris@1706 1102 else let val replacement =
Chris@1706 1103 replace
Chris@1706 1104 (* tok begins with "{": *)
Chris@1706 1105 (Substring.string
Chris@1706 1106 (Substring.triml 1 tok))
Chris@1706 1107 in
Chris@1706 1108 expand' (Substring.full replacement ::
Chris@1706 1109 pfx :: acc)
Chris@1706 1110 (* remainder begins with "}": *)
Chris@1706 1111 (Substring.triml 1 remainder)
Chris@1706 1112 end
Chris@1706 1113 in
Chris@1706 1114 Substring.concat (expand' [] (Substring.full spec))
Chris@1706 1115 end
Chris@1706 1116
Chris@1706 1117 fun provider_url req login providers =
Chris@1706 1118 case providers of
Chris@1706 1119 [] => raise Fail ("Unknown service \"" ^ (#service req) ^
Chris@1706 1120 "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
Chris@1706 1121 | ({ service, supports, remote_spec : remote_spec } :: rest) =>
Chris@1706 1122 if service <> (#service req) orelse
Chris@1706 1123 not (List.exists (fn v => v = (#vcs req)) supports)
Chris@1706 1124 then provider_url req login rest
Chris@1706 1125 else
Chris@1706 1126 case (login, #auth remote_spec, #anon remote_spec) of
Chris@1706 1127 (SOME _, SOME auth, _) => expand_spec auth req login
Chris@1706 1128 | (SOME _, _, SOME anon) => expand_spec anon req NONE
Chris@1706 1129 | (NONE, _, SOME anon) => expand_spec anon req NONE
Chris@1724 1130 | _ => raise Fail ("No suitable anonymous or authenticated " ^
Chris@1724 1131 "URL spec provided for service \"" ^
Chris@1724 1132 service ^ "\"")
Chris@1706 1133
Chris@1706 1134 fun login_for ({ accounts, ... } : context) service =
Chris@1706 1135 case List.find (fn a => service = #service a) accounts of
Chris@1706 1136 SOME { login, ... } => SOME login
Chris@1706 1137 | NONE => NONE
Chris@1747 1138
Chris@1747 1139 fun reponame_for path =
Chris@1747 1140 case String.tokens (fn c => c = #"/") path of
Chris@1747 1141 [] => raise Fail "Non-empty library path required"
Chris@1747 1142 | toks => hd (rev toks)
Chris@1747 1143
Chris@1706 1144 fun remote_url (context : context) vcs source libname =
Chris@1706 1145 case source of
Chris@1721 1146 URL_SOURCE u => u
Chris@1721 1147 | SERVICE_SOURCE { service, owner, repo } =>
Chris@1706 1148 provider_url { vcs = vcs,
Chris@1706 1149 service = service,
Chris@1706 1150 owner = owner,
Chris@1706 1151 repo = case repo of
Chris@1706 1152 SOME r => r
Chris@1747 1153 | NONE => reponame_for libname }
Chris@1706 1154 (login_for context service)
Chris@1706 1155 (#providers context)
Chris@1706 1156 end
Chris@1706 1157
Chris@1706 1158 structure HgControl :> VCS_CONTROL = struct
Chris@1706 1159
Chris@1706 1160 type vcsstate = { id: string, modified: bool,
Chris@1706 1161 branch: string, tags: string list }
Chris@1706 1162
Chris@1706 1163 val hg_args = [ "--config", "ui.interactive=true" ]
Chris@1706 1164
Chris@1706 1165 fun hg_command context libname args =
Chris@1706 1166 FileBits.command context libname ("hg" :: hg_args @ args)
Chris@1706 1167
Chris@1706 1168 fun hg_command_output context libname args =
Chris@1706 1169 FileBits.command_output context libname ("hg" :: hg_args @ args)
Chris@1706 1170
Chris@1706 1171 fun exists context libname =
Chris@1706 1172 OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
Chris@1706 1173 handle _ => OK false
Chris@1706 1174
Chris@1706 1175 fun remote_for context (libname, source) =
Chris@1706 1176 Provider.remote_url context HG source libname
Chris@1706 1177
Chris@1706 1178 fun current_state context libname : vcsstate result =
Chris@1706 1179 let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
Chris@1706 1180 and extract_branch b =
Chris@1706 1181 if is_branch b (* need to remove enclosing parens *)
Chris@1706 1182 then (implode o rev o tl o rev o tl o explode) b
Chris@1706 1183 else "default"
Chris@1706 1184 and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
Chris@1706 1185 and extract_id id =
Chris@1706 1186 if is_modified id (* need to remove trailing "+" *)
Chris@1706 1187 then (implode o rev o tl o rev o explode) id
Chris@1706 1188 else id
Chris@1706 1189 and split_tags tags = String.tokens (fn c => c = #"/") tags
Chris@1706 1190 and state_for (id, branch, tags) =
Chris@1706 1191 OK { id = extract_id id,
Chris@1706 1192 modified = is_modified id,
Chris@1706 1193 branch = extract_branch branch,
Chris@1706 1194 tags = split_tags tags }
Chris@1706 1195 in
Chris@1706 1196 case hg_command_output context libname ["id"] of
Chris@1706 1197 ERROR e => ERROR e
Chris@1706 1198 | OK out =>
Chris@1706 1199 case String.tokens (fn x => x = #" ") out of
Chris@1706 1200 [id, branch, tags] => state_for (id, branch, tags)
Chris@1706 1201 | [id, other] => if is_branch other
Chris@1706 1202 then state_for (id, other, "")
Chris@1706 1203 else state_for (id, "", other)
Chris@1706 1204 | [id] => state_for (id, "", "")
Chris@1706 1205 | _ => ERROR ("Unexpected output from hg id: " ^ out)
Chris@1706 1206 end
Chris@1706 1207
Chris@1706 1208 fun branch_name branch = case branch of
Chris@1706 1209 DEFAULT_BRANCH => "default"
Chris@1706 1210 | BRANCH "" => "default"
Chris@1706 1211 | BRANCH b => b
Chris@1706 1212
Chris@1706 1213 fun id_of context libname =
Chris@1706 1214 case current_state context libname of
Chris@1706 1215 ERROR e => ERROR e
Chris@1706 1216 | OK { id, ... } => OK id
Chris@1706 1217
Chris@1706 1218 fun is_at context (libname, id_or_tag) =
Chris@1706 1219 case current_state context libname of
Chris@1706 1220 ERROR e => ERROR e
Chris@1706 1221 | OK { id, tags, ... } =>
Chris@1706 1222 OK (String.isPrefix id_or_tag id orelse
Chris@1706 1223 String.isPrefix id id_or_tag orelse
Chris@1706 1224 List.exists (fn t => t = id_or_tag) tags)
Chris@1706 1225
Chris@1706 1226 fun is_on_branch context (libname, b) =
Chris@1706 1227 case current_state context libname of
Chris@1706 1228 ERROR e => ERROR e
Chris@1706 1229 | OK { branch, ... } => OK (branch = branch_name b)
Chris@1706 1230
Chris@1706 1231 fun is_newest_locally context (libname, branch) =
Chris@1706 1232 case hg_command_output context libname
Chris@1706 1233 ["log", "-l1",
Chris@1706 1234 "-b", branch_name branch,
Chris@1706 1235 "--template", "{node}"] of
Chris@1706 1236 ERROR e => ERROR e
Chris@1706 1237 | OK newest_in_repo => is_at context (libname, newest_in_repo)
Chris@1706 1238
Chris@1706 1239 fun pull context libname =
Chris@1706 1240 hg_command context libname
Chris@1706 1241 (if FileBits.verbose ()
Chris@1706 1242 then ["pull"]
Chris@1706 1243 else ["pull", "-q"])
Chris@1706 1244
Chris@1706 1245 fun is_newest context (libname, branch) =
Chris@1706 1246 case is_newest_locally context (libname, branch) of
Chris@1706 1247 ERROR e => ERROR e
Chris@1706 1248 | OK false => OK false
Chris@1706 1249 | OK true =>
Chris@1706 1250 case pull context libname of
Chris@1706 1251 ERROR e => ERROR e
Chris@1706 1252 | _ => is_newest_locally context (libname, branch)
Chris@1706 1253
Chris@1706 1254 fun is_modified_locally context libname =
Chris@1706 1255 case current_state context libname of
Chris@1706 1256 ERROR e => ERROR e
Chris@1706 1257 | OK { modified, ... } => OK modified
Chris@1706 1258
Chris@1706 1259 fun checkout context (libname, source, branch) =
Chris@1706 1260 let val url = remote_for context (libname, source)
Chris@1706 1261 in
Chris@1747 1262 (* make the lib dir rather than just the ext dir, since
Chris@1747 1263 the lib dir might be nested and hg will happily check
Chris@1747 1264 out into an existing empty dir anyway *)
Chris@1747 1265 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1706 1266 ERROR e => ERROR e
Chris@1706 1267 | _ => hg_command context ""
Chris@1706 1268 ["clone", "-u", branch_name branch,
Chris@1706 1269 url, libname]
Chris@1706 1270 end
Chris@1706 1271
Chris@1706 1272 fun update context (libname, branch) =
Chris@1706 1273 let val pull_result = pull context libname
Chris@1706 1274 in
Chris@1706 1275 case hg_command context libname ["update", branch_name branch] of
Chris@1706 1276 ERROR e => ERROR e
Chris@1706 1277 | _ =>
Chris@1706 1278 case pull_result of
Chris@1706 1279 ERROR e => ERROR e
Chris@1706 1280 | _ => id_of context libname
Chris@1706 1281 end
Chris@1706 1282
Chris@1706 1283 fun update_to context (libname, "") =
Chris@1706 1284 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1706 1285 | update_to context (libname, id) =
Chris@1723 1286 let val pull_result = pull context libname
Chris@1723 1287 in
Chris@1723 1288 case hg_command context libname ["update", "-r", id] of
Chris@1723 1289 OK _ => id_of context libname
Chris@1723 1290 | ERROR e =>
Chris@1723 1291 case pull_result of
Chris@1723 1292 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@1723 1293 | _ => ERROR e
Chris@1723 1294 end
Chris@1706 1295
Chris@1706 1296 end
Chris@1706 1297
Chris@1706 1298 structure GitControl :> VCS_CONTROL = struct
Chris@1706 1299
Chris@1706 1300 (* With Git repos we always operate in detached HEAD state. Even
Chris@1706 1301 the master branch is checked out using the remote reference,
Chris@1706 1302 origin/master. *)
Chris@1706 1303
Chris@1706 1304 fun git_command context libname args =
Chris@1706 1305 FileBits.command context libname ("git" :: args)
Chris@1706 1306
Chris@1706 1307 fun git_command_output context libname args =
Chris@1706 1308 FileBits.command_output context libname ("git" :: args)
Chris@1706 1309
Chris@1706 1310 fun exists context libname =
Chris@1706 1311 OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
Chris@1706 1312 handle _ => OK false
Chris@1706 1313
Chris@1706 1314 fun remote_for context (libname, source) =
Chris@1706 1315 Provider.remote_url context GIT source libname
Chris@1706 1316
Chris@1706 1317 fun branch_name branch = case branch of
Chris@1706 1318 DEFAULT_BRANCH => "master"
Chris@1706 1319 | BRANCH "" => "master"
Chris@1706 1320 | BRANCH b => b
Chris@1706 1321
Chris@1706 1322 fun remote_branch_name branch = "origin/" ^ branch_name branch
Chris@1706 1323
Chris@1706 1324 fun checkout context (libname, source, branch) =
Chris@1706 1325 let val url = remote_for context (libname, source)
Chris@1706 1326 in
Chris@1747 1327 (* make the lib dir rather than just the ext dir, since
Chris@1747 1328 the lib dir might be nested and git will happily check
Chris@1747 1329 out into an existing empty dir anyway *)
Chris@1747 1330 case FileBits.mkpath (FileBits.libpath context libname) of
Chris@1706 1331 OK () => git_command context ""
Chris@1706 1332 ["clone", "-b",
Chris@1706 1333 branch_name branch,
Chris@1706 1334 url, libname]
Chris@1706 1335 | ERROR e => ERROR e
Chris@1706 1336 end
Chris@1706 1337
Chris@1706 1338 (* NB git rev-parse HEAD shows revision id of current checkout;
Chris@1706 1339 git rev-list -1 <tag> shows revision id of revision with that tag *)
Chris@1706 1340
Chris@1706 1341 fun id_of context libname =
Chris@1706 1342 git_command_output context libname ["rev-parse", "HEAD"]
Chris@1706 1343
Chris@1706 1344 fun is_at context (libname, id_or_tag) =
Chris@1706 1345 case id_of context libname of
Chris@1706 1346 ERROR e => ERROR e
Chris@1706 1347 | OK id =>
Chris@1706 1348 if String.isPrefix id_or_tag id orelse
Chris@1706 1349 String.isPrefix id id_or_tag
Chris@1706 1350 then OK true
Chris@1706 1351 else
Chris@1706 1352 case git_command_output context libname
Chris@1723 1353 ["show-ref",
Chris@1723 1354 "refs/tags/" ^ id_or_tag] of
Chris@1723 1355 OK "" => OK false
Chris@1723 1356 | ERROR _ => OK false
Chris@1723 1357 | OK s => OK (id = hd (String.tokens (fn c => c = #" ") s))
Chris@1706 1358
Chris@1706 1359 fun branch_tip context (libname, branch) =
Chris@1706 1360 git_command_output context libname
Chris@1706 1361 ["rev-list", "-1",
Chris@1706 1362 remote_branch_name branch]
Chris@1706 1363
Chris@1706 1364 fun is_newest_locally context (libname, branch) =
Chris@1706 1365 case branch_tip context (libname, branch) of
Chris@1706 1366 ERROR e => ERROR e
Chris@1706 1367 | OK rev => is_at context (libname, rev)
Chris@1706 1368
Chris@1706 1369 fun is_on_branch context (libname, branch) =
Chris@1706 1370 case branch_tip context (libname, branch) of
Chris@1706 1371 ERROR e => ERROR e
Chris@1706 1372 | OK rev =>
Chris@1706 1373 case is_at context (libname, rev) of
Chris@1706 1374 ERROR e => ERROR e
Chris@1706 1375 | OK true => OK true
Chris@1706 1376 | OK false =>
Chris@1706 1377 case git_command context libname
Chris@1706 1378 ["merge-base", "--is-ancestor",
Chris@1706 1379 "HEAD", remote_branch_name branch] of
Chris@1706 1380 ERROR e => OK false (* cmd returns non-zero for no *)
Chris@1706 1381 | _ => OK true
Chris@1706 1382
Chris@1706 1383 fun is_newest context (libname, branch) =
Chris@1706 1384 case is_newest_locally context (libname, branch) of
Chris@1706 1385 ERROR e => ERROR e
Chris@1706 1386 | OK false => OK false
Chris@1706 1387 | OK true =>
Chris@1706 1388 case git_command context libname ["fetch"] of
Chris@1706 1389 ERROR e => ERROR e
Chris@1706 1390 | _ => is_newest_locally context (libname, branch)
Chris@1706 1391
Chris@1706 1392 fun is_modified_locally context libname =
Chris@1706 1393 case git_command_output context libname ["status", "--porcelain"] of
Chris@1706 1394 ERROR e => ERROR e
Chris@1706 1395 | OK "" => OK false
Chris@1706 1396 | OK _ => OK true
Chris@1706 1397
Chris@1706 1398 (* This function updates to the latest revision on a branch rather
Chris@1706 1399 than to a specific id or tag. We can't just checkout the given
Chris@1706 1400 branch, as that will succeed even if the branch isn't up to
Chris@1706 1401 date. We could checkout the branch and then fetch and merge,
Chris@1706 1402 but it's perhaps cleaner not to maintain a local branch at all,
Chris@1706 1403 but instead checkout the remote branch as a detached head. *)
Chris@1706 1404
Chris@1706 1405 fun update context (libname, branch) =
Chris@1706 1406 case git_command context libname ["fetch"] of
Chris@1706 1407 ERROR e => ERROR e
Chris@1706 1408 | _ =>
Chris@1706 1409 case git_command context libname ["checkout", "--detach",
Chris@1706 1410 remote_branch_name branch] of
Chris@1706 1411 ERROR e => ERROR e
Chris@1706 1412 | _ => id_of context libname
Chris@1706 1413
Chris@1706 1414 (* This function is dealing with a specific id or tag, so if we
Chris@1723 1415 can successfully check it out (detached) then that's all we
Chris@1723 1416 need to do, regardless of whether fetch succeeded or not. We do
Chris@1723 1417 attempt the fetch first, though, purely in order to avoid ugly
Chris@1723 1418 error messages in the common case where we're being asked to
Chris@1723 1419 update to a new pin (from the lock file) that hasn't been
Chris@1723 1420 fetched yet. *)
Chris@1706 1421
Chris@1706 1422 fun update_to context (libname, "") =
Chris@1706 1423 ERROR "Non-empty id (tag or revision id) required for update_to"
Chris@1706 1424 | update_to context (libname, id) =
Chris@1723 1425 let val fetch_result = git_command context libname ["fetch"]
Chris@1723 1426 in
Chris@1723 1427 case git_command context libname ["checkout", "--detach", id] of
Chris@1723 1428 OK _ => id_of context libname
Chris@1723 1429 | ERROR e =>
Chris@1723 1430 case fetch_result of
Chris@1723 1431 ERROR e' => ERROR e' (* this was the ur-error *)
Chris@1723 1432 | _ => ERROR e
Chris@1723 1433 end
Chris@1723 1434
Chris@1706 1435 end
Chris@1706 1436
Chris@1706 1437 structure AnyLibControl :> LIB_CONTROL = struct
Chris@1706 1438
Chris@1706 1439 structure H = LibControlFn(HgControl)
Chris@1706 1440 structure G = LibControlFn(GitControl)
Chris@1706 1441
Chris@1706 1442 fun review context (spec as { vcs, ... } : libspec) =
Chris@1706 1443 (fn HG => H.review | GIT => G.review) vcs context spec
Chris@1706 1444
Chris@1706 1445 fun status context (spec as { vcs, ... } : libspec) =
Chris@1706 1446 (fn HG => H.status | GIT => G.status) vcs context spec
Chris@1706 1447
Chris@1706 1448 fun update context (spec as { vcs, ... } : libspec) =
Chris@1706 1449 (fn HG => H.update | GIT => G.update) vcs context spec
Chris@1740 1450
Chris@1740 1451 fun id_of context (spec as { vcs, ... } : libspec) =
Chris@1740 1452 (fn HG => H.id_of | GIT => G.id_of) vcs context spec
Chris@1706 1453 end
Chris@1706 1454
Chris@1746 1455
Chris@1746 1456 type exclusions = string list
Chris@1746 1457
Chris@1746 1458 structure Archive :> sig
Chris@1746 1459
Chris@1746 1460 val archive : string * exclusions -> project -> OS.Process.status
Chris@1746 1461
Chris@1746 1462 end = struct
Chris@1746 1463
Chris@1746 1464 (* The idea of "archive" is to replace hg/git archive, which won't
Chris@1746 1465 include files, like the Vext-introduced external libraries,
Chris@1746 1466 that are not under version control with the main repo.
Chris@1746 1467
Chris@1746 1468 The process goes like this:
Chris@1746 1469
Chris@1746 1470 - Make sure we have a target filename from the user, and take
Chris@1746 1471 its basename as our archive directory name
Chris@1746 1472
Chris@1746 1473 - Make an "archive root" subdir of the project repo, named
Chris@1746 1474 typically .vext-archive
Chris@1746 1475
Chris@1746 1476 - Identify the VCS used for the project repo. Note that any
Chris@1746 1477 explicit references to VCS type in this structure are to
Chris@1746 1478 the VCS used for the project (something Vext doesn't
Chris@1746 1479 otherwise care about), not for an individual library
Chris@1746 1480
Chris@1746 1481 - Synthesise a Vext project with the archive root as its
Chris@1746 1482 root path, "." as its extdir, with one library whose
Chris@1746 1483 name is the user-supplied basename and whose explicit
Chris@1746 1484 source URL is the original project root; update that
Chris@1746 1485 project -- thus cloning the original project to a subdir
Chris@1746 1486 of the archive root
Chris@1746 1487
Chris@1746 1488 - Synthesise a Vext project identical to the original one for
Chris@1746 1489 this project, but with the newly-cloned copy as its root
Chris@1746 1490 path; update that project -- thus checking out clean copies
Chris@1746 1491 of the external library dirs
Chris@1746 1492
Chris@1746 1493 - Call out to an archive program to archive up the new copy,
Chris@1746 1494 running e.g.
Chris@1746 1495 tar cvzf project-release.tar.gz \
Chris@1746 1496 --exclude=.hg --exclude=.git project-release
Chris@1746 1497 in the archive root dir
Chris@1746 1498
Chris@1746 1499 - (We also omit the vext-project.json file and any trace of
Chris@1746 1500 Vext. It can't properly be run in a directory where the
Chris@1746 1501 external project folders already exist but their repo history
Chris@1746 1502 does not. End users shouldn't get to see Vext)
Chris@1746 1503
Chris@1746 1504 - Clean up by deleting the new copy
Chris@1746 1505 *)
Chris@1746 1506
Chris@1746 1507 fun project_vcs_and_id dir =
Chris@1746 1508 let val context = {
Chris@1746 1509 rootpath = dir,
Chris@1746 1510 extdir = ".",
Chris@1746 1511 providers = [],
Chris@1746 1512 accounts = []
Chris@1746 1513 }
Chris@1746 1514 val vcs_maybe =
Chris@1746 1515 case [HgControl.exists context ".",
Chris@1746 1516 GitControl.exists context "."] of
Chris@1746 1517 [OK true, OK false] => OK HG
Chris@1746 1518 | [OK false, OK true] => OK GIT
Chris@1746 1519 | _ => ERROR ("Unable to identify VCS for directory " ^ dir)
Chris@1746 1520 in
Chris@1746 1521 case vcs_maybe of
Chris@1746 1522 ERROR e => ERROR e
Chris@1746 1523 | OK vcs =>
Chris@1746 1524 case (fn HG => HgControl.id_of | GIT => GitControl.id_of)
Chris@1746 1525 vcs context "." of
Chris@1746 1526 ERROR e => ERROR ("Unable to obtain id of project repo: "
Chris@1746 1527 ^ e)
Chris@1746 1528 | OK id => OK (vcs, id)
Chris@1746 1529 end
Chris@1746 1530
Chris@1746 1531 fun make_archive_root (context : context) =
Chris@1746 1532 let val path = OS.Path.joinDirFile {
Chris@1746 1533 dir = #rootpath context,
Chris@1746 1534 file = VextFilenames.archive_dir
Chris@1746 1535 }
Chris@1746 1536 in
Chris@1746 1537 case FileBits.mkpath path of
Chris@1746 1538 ERROR e => raise Fail ("Failed to create archive directory \""
Chris@1746 1539 ^ path ^ "\": " ^ e)
Chris@1746 1540 | OK () => path
Chris@1746 1541 end
Chris@1746 1542
Chris@1746 1543 fun archive_path archive_dir target_name =
Chris@1746 1544 OS.Path.joinDirFile {
Chris@1746 1545 dir = archive_dir,
Chris@1746 1546 file = target_name
Chris@1746 1547 }
Chris@1746 1548
Chris@1746 1549 fun check_nonexistent path =
Chris@1746 1550 case SOME (OS.FileSys.fileSize path) handle OS.SysErr _ => NONE of
Chris@1746 1551 NONE => ()
Chris@1746 1552 | _ => raise Fail ("Path " ^ path ^ " exists, not overwriting")
Chris@1746 1553
Chris@1746 1554 fun file_url path =
Chris@1746 1555 let val forward_path =
Chris@1746 1556 String.translate (fn #"\\" => "/" |
Chris@1746 1557 c => Char.toString c) path
Chris@1746 1558 in
Chris@1746 1559 (* Path is expected to be absolute already, but if it
Chris@1746 1560 starts with a drive letter, we'll need an extra slash *)
Chris@1746 1561 case explode forward_path of
Chris@1746 1562 #"/"::rest => "file:///" ^ implode rest
Chris@1746 1563 | _ => "file:///" ^ forward_path
Chris@1746 1564 end
Chris@1746 1565
Chris@1746 1566 fun make_archive_copy target_name (vcs, project_id)
Chris@1746 1567 ({ context, ... } : project) =
Chris@1746 1568 let val archive_root = make_archive_root context
Chris@1746 1569 val synthetic_context = {
Chris@1746 1570 rootpath = archive_root,
Chris@1746 1571 extdir = ".",
Chris@1746 1572 providers = [],
Chris@1746 1573 accounts = []
Chris@1746 1574 }
Chris@1746 1575 val synthetic_library = {
Chris@1746 1576 libname = target_name,
Chris@1746 1577 vcs = vcs,
Chris@1746 1578 source = URL_SOURCE (file_url (#rootpath context)),
Chris@1746 1579 branch = DEFAULT_BRANCH, (* overridden by pinned id below *)
Chris@1746 1580 project_pin = PINNED project_id,
Chris@1746 1581 lock_pin = PINNED project_id
Chris@1746 1582 }
Chris@1746 1583 val path = archive_path archive_root target_name
Chris@1746 1584 val _ = print ("Cloning original project to " ^ path
Chris@1746 1585 ^ " at revision " ^ project_id ^ "...\n");
Chris@1746 1586 val _ = check_nonexistent path
Chris@1746 1587 in
Chris@1746 1588 case AnyLibControl.update synthetic_context synthetic_library of
Chris@1746 1589 ERROR e => ERROR ("Failed to clone original project to "
Chris@1746 1590 ^ path ^ ": " ^ e)
Chris@1746 1591 | OK _ => OK archive_root
Chris@1746 1592 end
Chris@1746 1593
Chris@1746 1594 fun update_archive archive_root target_name
Chris@1746 1595 (project as { context, ... } : project) =
Chris@1746 1596 let val synthetic_context = {
Chris@1746 1597 rootpath = archive_path archive_root target_name,
Chris@1746 1598 extdir = #extdir context,
Chris@1746 1599 providers = #providers context,
Chris@1746 1600 accounts = #accounts context
Chris@1746 1601 }
Chris@1746 1602 in
Chris@1746 1603 foldl (fn (lib, acc) =>
Chris@1746 1604 case acc of
Chris@1746 1605 ERROR e => ERROR e
Chris@1746 1606 | OK _ => AnyLibControl.update synthetic_context lib)
Chris@1746 1607 (OK "")
Chris@1746 1608 (#libs project)
Chris@1746 1609 end
Chris@1746 1610
Chris@1746 1611 datatype packer = TAR
Chris@1746 1612 | TAR_GZ
Chris@1746 1613 | TAR_BZ2
Chris@1746 1614 | TAR_XZ
Chris@1746 1615 (* could add other packers, e.g. zip, if we knew how to
Chris@1746 1616 handle the file omissions etc properly in pack_archive *)
Chris@1746 1617
Chris@1746 1618 fun packer_and_basename path =
Chris@1746 1619 let val extensions = [ (".tar", TAR),
Chris@1746 1620 (".tar.gz", TAR_GZ),
Chris@1746 1621 (".tar.bz2", TAR_BZ2),
Chris@1746 1622 (".tar.xz", TAR_XZ)]
Chris@1746 1623 val filename = OS.Path.file path
Chris@1746 1624 in
Chris@1746 1625 foldl (fn ((ext, packer), acc) =>
Chris@1746 1626 if String.isSuffix ext filename
Chris@1746 1627 then SOME (packer,
Chris@1746 1628 String.substring (filename, 0,
Chris@1746 1629 String.size filename -
Chris@1746 1630 String.size ext))
Chris@1746 1631 else acc)
Chris@1746 1632 NONE
Chris@1746 1633 extensions
Chris@1746 1634 end
Chris@1746 1635
Chris@1746 1636 fun pack_archive archive_root target_name target_path packer exclusions =
Chris@1746 1637 case FileBits.command {
Chris@1746 1638 rootpath = archive_root,
Chris@1746 1639 extdir = ".",
Chris@1746 1640 providers = [],
Chris@1746 1641 accounts = []
Chris@1746 1642 } "" ([
Chris@1746 1643 "tar",
Chris@1746 1644 case packer of
Chris@1746 1645 TAR => "cf"
Chris@1746 1646 | TAR_GZ => "czf"
Chris@1746 1647 | TAR_BZ2 => "cjf"
Chris@1746 1648 | TAR_XZ => "cJf",
Chris@1746 1649 target_path,
Chris@1746 1650 "--exclude=.hg",
Chris@1746 1651 "--exclude=.git",
Chris@1746 1652 "--exclude=vext",
Chris@1746 1653 "--exclude=vext.sml",
Chris@1746 1654 "--exclude=vext.ps1",
Chris@1746 1655 "--exclude=vext.bat",
Chris@1746 1656 "--exclude=vext-project.json",
Chris@1746 1657 "--exclude=vext-lock.json"
Chris@1746 1658 ] @ (map (fn e => "--exclude=" ^ e) exclusions) @
Chris@1746 1659 [ target_name ])
Chris@1746 1660 of
Chris@1746 1661 ERROR e => ERROR e
Chris@1746 1662 | OK _ => FileBits.rmpath (archive_path archive_root target_name)
Chris@1746 1663
Chris@1746 1664 fun archive (target_path, exclusions) (project : project) =
Chris@1746 1665 let val _ = check_nonexistent target_path
Chris@1746 1666 val (packer, name) =
Chris@1746 1667 case packer_and_basename target_path of
Chris@1746 1668 NONE => raise Fail ("Unsupported archive file extension in "
Chris@1746 1669 ^ target_path)
Chris@1746 1670 | SOME pn => pn
Chris@1746 1671 val details =
Chris@1746 1672 case project_vcs_and_id (#rootpath (#context project)) of
Chris@1746 1673 ERROR e => raise Fail e
Chris@1746 1674 | OK details => details
Chris@1746 1675 val archive_root =
Chris@1746 1676 case make_archive_copy name details project of
Chris@1746 1677 ERROR e => raise Fail e
Chris@1746 1678 | OK archive_root => archive_root
Chris@1746 1679 val outcome =
Chris@1746 1680 case update_archive archive_root name project of
Chris@1746 1681 ERROR e => ERROR e
Chris@1746 1682 | OK _ =>
Chris@1746 1683 case pack_archive archive_root name
Chris@1746 1684 target_path packer exclusions of
Chris@1746 1685 ERROR e => ERROR e
Chris@1746 1686 | OK _ => OK ()
Chris@1746 1687 in
Chris@1746 1688 case outcome of
Chris@1746 1689 ERROR e => raise Fail e
Chris@1746 1690 | OK () => OS.Process.success
Chris@1746 1691 end
Chris@1746 1692
Chris@1746 1693 end
Chris@1746 1694
Chris@1724 1695 val libobjname = "libraries"
Chris@1724 1696
Chris@1706 1697 fun load_libspec spec_json lock_json libname : libspec =
Chris@1706 1698 let open JsonBits
Chris@1724 1699 val libobj = lookup_mandatory spec_json [libobjname, libname]
Chris@1706 1700 val vcs = lookup_mandatory_string libobj ["vcs"]
Chris@1706 1701 val retrieve = lookup_optional_string libobj
Chris@1706 1702 val service = retrieve ["service"]
Chris@1706 1703 val owner = retrieve ["owner"]
Chris@1706 1704 val repo = retrieve ["repository"]
Chris@1706 1705 val url = retrieve ["url"]
Chris@1706 1706 val branch = retrieve ["branch"]
Chris@1740 1707 val project_pin = case retrieve ["pin"] of
Chris@1740 1708 NONE => UNPINNED
Chris@1740 1709 | SOME p => PINNED p
Chris@1724 1710 val lock_pin = case lookup_optional lock_json [libobjname, libname] of
Chris@1740 1711 NONE => UNPINNED
Chris@1740 1712 | SOME ll => case lookup_optional_string ll ["pin"] of
Chris@1740 1713 SOME p => PINNED p
Chris@1740 1714 | NONE => UNPINNED
Chris@1706 1715 in
Chris@1706 1716 {
Chris@1706 1717 libname = libname,
Chris@1706 1718 vcs = case vcs of
Chris@1706 1719 "hg" => HG
Chris@1706 1720 | "git" => GIT
Chris@1706 1721 | other => raise Fail ("Unknown version-control system \"" ^
Chris@1706 1722 other ^ "\""),
Chris@1706 1723 source = case (url, service, owner, repo) of
Chris@1721 1724 (SOME u, NONE, _, _) => URL_SOURCE u
Chris@1706 1725 | (NONE, SOME ss, owner, repo) =>
Chris@1721 1726 SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
Chris@1706 1727 | _ => raise Fail ("Must have exactly one of service " ^
Chris@1706 1728 "or url string"),
Chris@1740 1729 project_pin = project_pin,
Chris@1740 1730 lock_pin = lock_pin,
Chris@1706 1731 branch = case branch of
Chris@1706 1732 SOME b => BRANCH b
Chris@1706 1733 | NONE => DEFAULT_BRANCH
Chris@1706 1734 }
Chris@1706 1735 end
Chris@1706 1736
Chris@1706 1737 fun load_userconfig () : userconfig =
Chris@1706 1738 let val home = FileBits.homedir ()
Chris@1706 1739 val conf_json =
Chris@1706 1740 JsonBits.load_json_from
Chris@1706 1741 (OS.Path.joinDirFile {
Chris@1706 1742 dir = home,
Chris@1706 1743 file = VextFilenames.user_config_file })
Chris@1706 1744 handle IO.Io _ => Json.OBJECT []
Chris@1706 1745 in
Chris@1706 1746 {
Chris@1706 1747 accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
Chris@1706 1748 NONE => []
Chris@1706 1749 | SOME (Json.OBJECT aa) =>
Chris@1706 1750 map (fn (k, (Json.STRING v)) =>
Chris@1706 1751 { service = k, login = v }
Chris@1706 1752 | _ => raise Fail
Chris@1706 1753 "String expected for account name")
Chris@1706 1754 aa
Chris@1706 1755 | _ => raise Fail "Array expected for accounts",
Chris@1706 1756 providers = Provider.load_providers conf_json
Chris@1706 1757 }
Chris@1706 1758 end
Chris@1706 1759
Chris@1732 1760 datatype pintype =
Chris@1732 1761 NO_LOCKFILE |
Chris@1732 1762 USE_LOCKFILE
Chris@1732 1763
Chris@1732 1764 fun load_project (userconfig : userconfig) rootpath pintype : project =
Chris@1706 1765 let val spec_file = FileBits.project_spec_path rootpath
Chris@1706 1766 val lock_file = FileBits.project_lock_path rootpath
Chris@1706 1767 val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
Chris@1706 1768 handle OS.SysErr _ => false
Chris@1706 1769 then ()
Chris@1706 1770 else raise Fail ("Failed to open project spec file " ^
Chris@1706 1771 (VextFilenames.project_file) ^ " in " ^
Chris@1706 1772 rootpath ^
Chris@1706 1773 ".\nPlease ensure the spec file is in the " ^
Chris@1706 1774 "project root and run this from there.")
Chris@1706 1775 val spec_json = JsonBits.load_json_from spec_file
Chris@1732 1776 val lock_json = if pintype = USE_LOCKFILE
Chris@1706 1777 then JsonBits.load_json_from lock_file
Chris@1706 1778 handle IO.Io _ => Json.OBJECT []
Chris@1706 1779 else Json.OBJECT []
Chris@1706 1780 val extdir = JsonBits.lookup_mandatory_string spec_json
Chris@1706 1781 ["config", "extdir"]
Chris@1724 1782 val spec_libs = JsonBits.lookup_optional spec_json [libobjname]
Chris@1724 1783 val lock_libs = JsonBits.lookup_optional lock_json [libobjname]
Chris@1706 1784 val providers = Provider.load_more_providers
Chris@1706 1785 (#providers userconfig) spec_json
Chris@1706 1786 val libnames = case spec_libs of
Chris@1706 1787 NONE => []
Chris@1706 1788 | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
Chris@1706 1789 | _ => raise Fail "Object expected for libs"
Chris@1706 1790 in
Chris@1706 1791 {
Chris@1706 1792 context = {
Chris@1706 1793 rootpath = rootpath,
Chris@1706 1794 extdir = extdir,
Chris@1706 1795 providers = providers,
Chris@1706 1796 accounts = #accounts userconfig
Chris@1706 1797 },
Chris@1706 1798 libs = map (load_libspec spec_json lock_json) libnames
Chris@1706 1799 }
Chris@1706 1800 end
Chris@1706 1801
Chris@1706 1802 fun save_lock_file rootpath locks =
Chris@1706 1803 let val lock_file = FileBits.project_lock_path rootpath
Chris@1706 1804 open Json
Chris@1706 1805 val lock_json =
Chris@1706 1806 OBJECT [
Chris@1724 1807 (libobjname,
Chris@1724 1808 OBJECT (map (fn { libname, id_or_tag } =>
Chris@1724 1809 (libname,
Chris@1724 1810 OBJECT [ ("pin", STRING id_or_tag) ]))
Chris@1724 1811 locks))
Chris@1706 1812 ]
Chris@1706 1813 in
Chris@1706 1814 JsonBits.save_json_to lock_file lock_json
Chris@1706 1815 end
Chris@1706 1816
Chris@1706 1817 fun pad_to n str =
Chris@1706 1818 if n <= String.size str then str
Chris@1706 1819 else pad_to n (str ^ " ")
Chris@1706 1820
Chris@1706 1821 fun hline_to 0 = ""
Chris@1706 1822 | hline_to n = "-" ^ hline_to (n-1)
Chris@1706 1823
Chris@1706 1824 val libname_width = 25
Chris@1706 1825 val libstate_width = 11
Chris@1740 1826 val localstate_width = 17
Chris@1706 1827 val notes_width = 5
Chris@1706 1828 val divider = " | "
Chris@1740 1829 val clear_line = "\r" ^ pad_to 80 "";
Chris@1706 1830
Chris@1706 1831 fun print_status_header () =
Chris@1740 1832 print (clear_line ^ "\n " ^
Chris@1706 1833 pad_to libname_width "Library" ^ divider ^
Chris@1706 1834 pad_to libstate_width "State" ^ divider ^
Chris@1706 1835 pad_to localstate_width "Local" ^ divider ^
Chris@1706 1836 "Notes" ^ "\n " ^
Chris@1706 1837 hline_to libname_width ^ "-+-" ^
Chris@1706 1838 hline_to libstate_width ^ "-+-" ^
Chris@1706 1839 hline_to localstate_width ^ "-+-" ^
Chris@1706 1840 hline_to notes_width ^ "\n")
Chris@1706 1841
Chris@1706 1842 fun print_outcome_header () =
Chris@1740 1843 print (clear_line ^ "\n " ^
Chris@1706 1844 pad_to libname_width "Library" ^ divider ^
Chris@1706 1845 pad_to libstate_width "Outcome" ^ divider ^
Chris@1706 1846 "Notes" ^ "\n " ^
Chris@1706 1847 hline_to libname_width ^ "-+-" ^
Chris@1706 1848 hline_to libstate_width ^ "-+-" ^
Chris@1706 1849 hline_to notes_width ^ "\n")
Chris@1706 1850
Chris@1706 1851 fun print_status with_network (libname, status) =
Chris@1706 1852 let val libstate_str =
Chris@1706 1853 case status of
Chris@1706 1854 OK (ABSENT, _) => "Absent"
Chris@1706 1855 | OK (CORRECT, _) => if with_network then "Correct" else "Present"
Chris@1706 1856 | OK (SUPERSEDED, _) => "Superseded"
Chris@1706 1857 | OK (WRONG, _) => "Wrong"
Chris@1706 1858 | ERROR _ => "Error"
Chris@1706 1859 val localstate_str =
Chris@1706 1860 case status of
Chris@1706 1861 OK (_, MODIFIED) => "Modified"
Chris@1740 1862 | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
Chris@1740 1863 | OK (_, CLEAN) => "Clean"
Chris@1740 1864 | ERROR _ => ""
Chris@1706 1865 val error_str =
Chris@1706 1866 case status of
Chris@1706 1867 ERROR e => e
Chris@1706 1868 | _ => ""
Chris@1706 1869 in
Chris@1706 1870 print (" " ^
Chris@1706 1871 pad_to libname_width libname ^ divider ^
Chris@1706 1872 pad_to libstate_width libstate_str ^ divider ^
Chris@1706 1873 pad_to localstate_width localstate_str ^ divider ^
Chris@1706 1874 error_str ^ "\n")
Chris@1706 1875 end
Chris@1706 1876
Chris@1706 1877 fun print_update_outcome (libname, outcome) =
Chris@1706 1878 let val outcome_str =
Chris@1706 1879 case outcome of
Chris@1706 1880 OK id => "Ok"
Chris@1706 1881 | ERROR e => "Failed"
Chris@1706 1882 val error_str =
Chris@1706 1883 case outcome of
Chris@1706 1884 ERROR e => e
Chris@1706 1885 | _ => ""
Chris@1706 1886 in
Chris@1706 1887 print (" " ^
Chris@1706 1888 pad_to libname_width libname ^ divider ^
Chris@1706 1889 pad_to libstate_width outcome_str ^ divider ^
Chris@1706 1890 error_str ^ "\n")
Chris@1706 1891 end
Chris@1706 1892
Chris@1706 1893 fun act_and_print action print_header print_line (libs : libspec list) =
Chris@1706 1894 let val lines = map (fn lib => (#libname lib, action lib)) libs
Chris@1706 1895 val _ = print_header ()
Chris@1706 1896 in
Chris@1706 1897 app print_line lines;
Chris@1706 1898 lines
Chris@1706 1899 end
Chris@1708 1900
Chris@1708 1901 fun return_code_for outcomes =
Chris@1708 1902 foldl (fn ((_, result), acc) =>
Chris@1708 1903 case result of
Chris@1708 1904 ERROR _ => OS.Process.failure
Chris@1708 1905 | _ => acc)
Chris@1708 1906 OS.Process.success
Chris@1708 1907 outcomes
Chris@1706 1908
Chris@1706 1909 fun status_of_project ({ context, libs } : project) =
Chris@1708 1910 return_code_for (act_and_print (AnyLibControl.status context)
Chris@1708 1911 print_status_header (print_status false)
Chris@1708 1912 libs)
Chris@1706 1913
Chris@1706 1914 fun review_project ({ context, libs } : project) =
Chris@1708 1915 return_code_for (act_and_print (AnyLibControl.review context)
Chris@1708 1916 print_status_header (print_status true)
Chris@1708 1917 libs)
Chris@1706 1918
Chris@1706 1919 fun update_project ({ context, libs } : project) =
Chris@1706 1920 let val outcomes = act_and_print
Chris@1706 1921 (AnyLibControl.update context)
Chris@1706 1922 print_outcome_header print_update_outcome libs
Chris@1708 1923 val locks =
Chris@1708 1924 List.concat
Chris@1708 1925 (map (fn (libname, result) =>
Chris@1708 1926 case result of
Chris@1708 1927 ERROR _ => []
Chris@1708 1928 | OK id => [{ libname = libname, id_or_tag = id }])
Chris@1708 1929 outcomes)
Chris@1708 1930 val return_code = return_code_for outcomes
Chris@1706 1931 in
Chris@1708 1932 if OS.Process.isSuccess return_code
Chris@1708 1933 then save_lock_file (#rootpath context) locks
Chris@1708 1934 else ();
Chris@1708 1935 return_code
Chris@1706 1936 end
Chris@1706 1937
Chris@1740 1938 fun lock_project ({ context, libs } : project) =
Chris@1740 1939 let val outcomes = map (fn lib =>
Chris@1740 1940 (#libname lib, AnyLibControl.id_of context lib))
Chris@1740 1941 libs
Chris@1740 1942 val locks =
Chris@1740 1943 List.concat
Chris@1740 1944 (map (fn (libname, result) =>
Chris@1740 1945 case result of
Chris@1740 1946 ERROR _ => []
Chris@1740 1947 | OK id => [{ libname = libname, id_or_tag = id }])
Chris@1740 1948 outcomes)
Chris@1740 1949 val return_code = return_code_for outcomes
Chris@1740 1950 val _ = print clear_line
Chris@1740 1951 in
Chris@1740 1952 if OS.Process.isSuccess return_code
Chris@1740 1953 then save_lock_file (#rootpath context) locks
Chris@1740 1954 else ();
Chris@1740 1955 return_code
Chris@1740 1956 end
Chris@1746 1957
Chris@1732 1958 fun load_local_project pintype =
Chris@1706 1959 let val userconfig = load_userconfig ()
Chris@1706 1960 val rootpath = OS.FileSys.getDir ()
Chris@1706 1961 in
Chris@1732 1962 load_project userconfig rootpath pintype
Chris@1706 1963 end
Chris@1706 1964
Chris@1732 1965 fun with_local_project pintype f =
Chris@1732 1966 let val return_code = f (load_local_project pintype)
Chris@1746 1967 handle e => (print ("Error: " ^ exnMessage e);
Chris@1746 1968 OS.Process.failure)
Chris@1708 1969 val _ = print "\n";
Chris@1708 1970 in
Chris@1708 1971 return_code
Chris@1708 1972 end
Chris@1706 1973
Chris@1740 1974 fun review () = with_local_project USE_LOCKFILE review_project
Chris@1740 1975 fun status () = with_local_project USE_LOCKFILE status_of_project
Chris@1732 1976 fun update () = with_local_project NO_LOCKFILE update_project
Chris@1740 1977 fun lock () = with_local_project NO_LOCKFILE lock_project
Chris@1732 1978 fun install () = with_local_project USE_LOCKFILE update_project
Chris@1706 1979
Chris@1706 1980 fun version () =
Chris@1708 1981 (print ("v" ^ vext_version ^ "\n");
Chris@1708 1982 OS.Process.success)
Chris@1706 1983
Chris@1706 1984 fun usage () =
Chris@1706 1985 (print "\nVext ";
Chris@1706 1986 version ();
Chris@1706 1987 print ("\nA simple manager for third-party source code dependencies.\n\n"
Chris@1706 1988 ^ "Usage:\n\n"
Chris@1706 1989 ^ " vext <command>\n\n"
Chris@1706 1990 ^ "where <command> is one of:\n\n"
Chris@1716 1991 ^ " status print quick report on local status only, without using network\n"
Chris@1706 1992 ^ " review check configured libraries against their providers, and report\n"
Chris@1706 1993 ^ " install update configured libraries according to project specs and lock file\n"
Chris@1706 1994 ^ " update update configured libraries and lock file according to project specs\n"
Chris@1740 1995 ^ " lock update lock file to match local library status\n"
Chris@1746 1996 ^ " archive pack up project and all libraries into an archive file\n"
Chris@1746 1997 ^ " (invoke as 'vext archive target-file.tar.gz')\n"
Chris@1708 1998 ^ " version print the Vext version number and exit\n\n");
Chris@1708 1999 OS.Process.failure)
Chris@1706 2000
Chris@1746 2001 fun archive target args =
Chris@1746 2002 case args of
Chris@1746 2003 [] =>
Chris@1746 2004 with_local_project USE_LOCKFILE (Archive.archive (target, []))
Chris@1746 2005 | "--exclude"::xs =>
Chris@1746 2006 with_local_project USE_LOCKFILE (Archive.archive (target, xs))
Chris@1746 2007 | _ => usage ()
Chris@1746 2008
Chris@1706 2009 fun vext args =
Chris@1708 2010 let val return_code =
Chris@1708 2011 case args of
Chris@1708 2012 ["review"] => review ()
Chris@1708 2013 | ["status"] => status ()
Chris@1708 2014 | ["install"] => install ()
Chris@1708 2015 | ["update"] => update ()
Chris@1740 2016 | ["lock"] => lock ()
Chris@1708 2017 | ["version"] => version ()
Chris@1746 2018 | "archive"::target::args => archive target args
Chris@1708 2019 | _ => usage ()
Chris@1708 2020 in
Chris@1708 2021 OS.Process.exit return_code;
Chris@1708 2022 ()
Chris@1708 2023 end
Chris@1706 2024
Chris@1706 2025 fun main () =
Chris@1706 2026 vext (CommandLine.arguments ())