annotate repoint.sml @ 2202:e1adac799317 bqaudiostream

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