Mercurial > hg > sonic-annotator
comparison vext.sml @ 314:d741e2c90eab
Update Vext and subrepos
author | Chris Cannam |
---|---|
date | Thu, 13 Jul 2017 17:10:13 +0100 |
parents | 523f8f1789b4 |
children | 9ebb9ac79bdf |
comparison
equal
deleted
inserted
replaced
313:cf863362a9df | 314:d741e2c90eab |
---|---|
31 Particular Programs Ltd shall not be used in advertising or | 31 Particular Programs Ltd shall not be used in advertising or |
32 otherwise to promote the sale, use or other dealings in this | 32 otherwise to promote the sale, use or other dealings in this |
33 Software without prior written authorization. | 33 Software without prior written authorization. |
34 *) | 34 *) |
35 | 35 |
36 val vext_version = "0.9.4" | 36 val vext_version = "0.9.6" |
37 | 37 |
38 | 38 |
39 datatype vcs = | 39 datatype vcs = |
40 HG | | 40 HG | |
41 GIT | 41 GIT |
46 service : string, | 46 service : string, |
47 owner : string option, | 47 owner : string option, |
48 repo : string option | 48 repo : string option |
49 } | 49 } |
50 | 50 |
51 type id_or_tag = string | |
52 | |
51 datatype pin = | 53 datatype pin = |
52 UNPINNED | | 54 UNPINNED | |
53 PINNED of string | 55 PINNED of id_or_tag |
54 | 56 |
55 datatype libstate = | 57 datatype libstate = |
56 ABSENT | | 58 ABSENT | |
57 CORRECT | | 59 CORRECT | |
58 SUPERSEDED | | 60 SUPERSEDED | |
59 WRONG | 61 WRONG |
60 | 62 |
61 datatype localstate = | 63 datatype localstate = |
62 MODIFIED | | 64 MODIFIED | |
63 UNMODIFIED | 65 LOCK_MISMATCHED | |
66 CLEAN | |
64 | 67 |
65 datatype branch = | 68 datatype branch = |
66 BRANCH of string | | 69 BRANCH of string | |
67 DEFAULT_BRANCH | 70 DEFAULT_BRANCH |
68 | 71 |
75 OK of 'a | | 78 OK of 'a | |
76 ERROR of string | 79 ERROR of string |
77 | 80 |
78 type libname = string | 81 type libname = string |
79 | 82 |
80 type id_or_tag = string | |
81 | |
82 type libspec = { | 83 type libspec = { |
83 libname : libname, | 84 libname : libname, |
84 vcs : vcs, | 85 vcs : vcs, |
85 source : source, | 86 source : source, |
86 branch : branch, | 87 branch : branch, |
87 pin : pin | 88 project_pin : pin, |
89 lock_pin : pin | |
88 } | 90 } |
89 | 91 |
90 type lock = { | 92 type lock = { |
91 libname : libname, | 93 libname : libname, |
92 id_or_tag : id_or_tag | 94 id_or_tag : id_or_tag |
93 } | 95 } |
94 | 96 |
95 type remote_spec = { | 97 type remote_spec = { |
96 anon : string option, | 98 anon : string option, |
97 auth : string option | 99 auth : string option |
98 } | 100 } |
99 | 101 |
175 | 177 |
176 signature LIB_CONTROL = sig | 178 signature LIB_CONTROL = sig |
177 val review : context -> libspec -> (libstate * localstate) result | 179 val review : context -> libspec -> (libstate * localstate) result |
178 val status : context -> libspec -> (libstate * localstate) result | 180 val status : context -> libspec -> (libstate * localstate) result |
179 val update : context -> libspec -> id_or_tag result | 181 val update : context -> libspec -> id_or_tag result |
182 val id_of : context -> libspec -> id_or_tag result | |
180 end | 183 end |
181 | 184 |
182 structure FileBits :> sig | 185 structure FileBits :> sig |
183 val extpath : context -> string | 186 val extpath : context -> string |
184 val libpath : context -> libname -> string | 187 val libpath : context -> libname -> string |
400 - WRONG: We are at any revision other than the pinned one. | 403 - WRONG: We are at any revision other than the pinned one. |
401 | 404 |
402 - ABSENT: Repo doesn't exist here at all. | 405 - ABSENT: Repo doesn't exist here at all. |
403 *) | 406 *) |
404 | 407 |
405 fun check with_network context ({ libname, branch, pin, ... } : libspec) = | 408 fun check with_network context |
409 ({ libname, branch, project_pin, lock_pin, ... } : libspec) = | |
406 let fun check_unpinned () = | 410 let fun check_unpinned () = |
407 let val is_newest = if with_network | 411 let val is_newest = if with_network |
408 then V.is_newest | 412 then V.is_newest |
409 else V.is_newest_locally | 413 else V.is_newest_locally |
410 in | 414 in |
420 fun check_pinned target = | 424 fun check_pinned target = |
421 case V.is_at context (libname, target) of | 425 case V.is_at context (libname, target) of |
422 ERROR e => ERROR e | 426 ERROR e => ERROR e |
423 | OK true => OK CORRECT | 427 | OK true => OK CORRECT |
424 | OK false => OK WRONG | 428 | OK false => OK WRONG |
425 fun check' () = | 429 fun check_remote () = |
426 case pin of | 430 case project_pin of |
427 UNPINNED => check_unpinned () | 431 UNPINNED => check_unpinned () |
428 | PINNED target => check_pinned target | 432 | PINNED target => check_pinned target |
433 fun check_local () = | |
434 case V.is_modified_locally context libname of | |
435 ERROR e => ERROR e | |
436 | OK true => OK MODIFIED | |
437 | OK false => | |
438 case lock_pin of | |
439 UNPINNED => OK CLEAN | |
440 | PINNED target => | |
441 case V.is_at context (libname, target) of | |
442 ERROR e => ERROR e | |
443 | OK true => OK CLEAN | |
444 | OK false => OK LOCK_MISMATCHED | |
429 in | 445 in |
430 case V.exists context libname of | 446 case V.exists context libname of |
431 ERROR e => ERROR e | 447 ERROR e => ERROR e |
432 | OK false => OK (ABSENT, UNMODIFIED) | 448 | OK false => OK (ABSENT, CLEAN) |
433 | OK true => | 449 | OK true => |
434 case (check' (), V.is_modified_locally context libname) of | 450 case (check_remote (), check_local ()) of |
435 (ERROR e, _) => ERROR e | 451 (ERROR e, _) => ERROR e |
436 | (_, ERROR e) => ERROR e | 452 | (_, ERROR e) => ERROR e |
437 | (OK state, OK true) => OK (state, MODIFIED) | 453 | (OK r, OK l) => OK (r, l) |
438 | (OK state, OK false) => OK (state, UNMODIFIED) | |
439 end | 454 end |
440 | 455 |
441 val review = check true | 456 val review = check true |
442 val status = check false | 457 val status = check false |
443 | 458 |
444 fun update context ({ libname, source, branch, pin, ... } : libspec) = | 459 fun update context |
460 ({ libname, source, branch, | |
461 project_pin, lock_pin, ... } : libspec) = | |
445 let fun update_unpinned () = | 462 let fun update_unpinned () = |
446 case V.is_newest context (libname, branch) of | 463 case V.is_newest context (libname, branch) of |
447 ERROR e => ERROR e | 464 ERROR e => ERROR e |
448 | OK true => V.id_of context libname | 465 | OK true => V.id_of context libname |
449 | OK false => V.update context (libname, branch) | 466 | OK false => V.update context (libname, branch) |
451 case V.is_at context (libname, target) of | 468 case V.is_at context (libname, target) of |
452 ERROR e => ERROR e | 469 ERROR e => ERROR e |
453 | OK true => OK target | 470 | OK true => OK target |
454 | OK false => V.update_to context (libname, target) | 471 | OK false => V.update_to context (libname, target) |
455 fun update' () = | 472 fun update' () = |
456 case pin of | 473 case lock_pin of |
457 UNPINNED => update_unpinned () | 474 PINNED target => update_pinned target |
458 | PINNED target => update_pinned target | 475 | UNPINNED => |
476 case project_pin of | |
477 PINNED target => update_pinned target | |
478 | UNPINNED => update_unpinned () | |
459 in | 479 in |
460 case V.exists context libname of | 480 case V.exists context libname of |
461 ERROR e => ERROR e | 481 ERROR e => ERROR e |
462 | OK true => update' () | 482 | OK true => update' () |
463 | OK false => | 483 | OK false => |
464 case V.checkout context (libname, source, branch) of | 484 case V.checkout context (libname, source, branch) of |
465 ERROR e => ERROR e | 485 ERROR e => ERROR e |
466 | OK () => update' () | 486 | OK () => update' () |
467 end | 487 end |
488 | |
489 fun id_of context ({ libname, ... } : libspec) = | |
490 V.id_of context libname | |
491 | |
468 end | 492 end |
469 | 493 |
470 (* Simple Standard ML JSON parser | 494 (* Simple Standard ML JSON parser |
471 ============================== | 495 ============================== |
472 | 496 |
1367 fun status context (spec as { vcs, ... } : libspec) = | 1391 fun status context (spec as { vcs, ... } : libspec) = |
1368 (fn HG => H.status | GIT => G.status) vcs context spec | 1392 (fn HG => H.status | GIT => G.status) vcs context spec |
1369 | 1393 |
1370 fun update context (spec as { vcs, ... } : libspec) = | 1394 fun update context (spec as { vcs, ... } : libspec) = |
1371 (fn HG => H.update | GIT => G.update) vcs context spec | 1395 (fn HG => H.update | GIT => G.update) vcs context spec |
1396 | |
1397 fun id_of context (spec as { vcs, ... } : libspec) = | |
1398 (fn HG => H.id_of | GIT => G.id_of) vcs context spec | |
1372 end | 1399 end |
1373 | 1400 |
1374 val libobjname = "libraries" | 1401 val libobjname = "libraries" |
1375 | 1402 |
1376 fun load_libspec spec_json lock_json libname : libspec = | 1403 fun load_libspec spec_json lock_json libname : libspec = |
1381 val service = retrieve ["service"] | 1408 val service = retrieve ["service"] |
1382 val owner = retrieve ["owner"] | 1409 val owner = retrieve ["owner"] |
1383 val repo = retrieve ["repository"] | 1410 val repo = retrieve ["repository"] |
1384 val url = retrieve ["url"] | 1411 val url = retrieve ["url"] |
1385 val branch = retrieve ["branch"] | 1412 val branch = retrieve ["branch"] |
1386 val user_pin = retrieve ["pin"] | 1413 val project_pin = case retrieve ["pin"] of |
1414 NONE => UNPINNED | |
1415 | SOME p => PINNED p | |
1387 val lock_pin = case lookup_optional lock_json [libobjname, libname] of | 1416 val lock_pin = case lookup_optional lock_json [libobjname, libname] of |
1388 SOME ll => lookup_optional_string ll ["pin"] | 1417 NONE => UNPINNED |
1389 | NONE => NONE | 1418 | SOME ll => case lookup_optional_string ll ["pin"] of |
1419 SOME p => PINNED p | |
1420 | NONE => UNPINNED | |
1390 in | 1421 in |
1391 { | 1422 { |
1392 libname = libname, | 1423 libname = libname, |
1393 vcs = case vcs of | 1424 vcs = case vcs of |
1394 "hg" => HG | 1425 "hg" => HG |
1399 (SOME u, NONE, _, _) => URL_SOURCE u | 1430 (SOME u, NONE, _, _) => URL_SOURCE u |
1400 | (NONE, SOME ss, owner, repo) => | 1431 | (NONE, SOME ss, owner, repo) => |
1401 SERVICE_SOURCE { service = ss, owner = owner, repo = repo } | 1432 SERVICE_SOURCE { service = ss, owner = owner, repo = repo } |
1402 | _ => raise Fail ("Must have exactly one of service " ^ | 1433 | _ => raise Fail ("Must have exactly one of service " ^ |
1403 "or url string"), | 1434 "or url string"), |
1404 pin = case lock_pin of | 1435 project_pin = project_pin, |
1405 SOME p => PINNED p | 1436 lock_pin = lock_pin, |
1406 | NONE => | |
1407 case user_pin of | |
1408 SOME p => PINNED p | |
1409 | NONE => UNPINNED, | |
1410 branch = case branch of | 1437 branch = case branch of |
1411 SOME b => BRANCH b | 1438 SOME b => BRANCH b |
1412 | NONE => DEFAULT_BRANCH | 1439 | NONE => DEFAULT_BRANCH |
1413 } | 1440 } |
1414 end | 1441 end |
1500 fun hline_to 0 = "" | 1527 fun hline_to 0 = "" |
1501 | hline_to n = "-" ^ hline_to (n-1) | 1528 | hline_to n = "-" ^ hline_to (n-1) |
1502 | 1529 |
1503 val libname_width = 25 | 1530 val libname_width = 25 |
1504 val libstate_width = 11 | 1531 val libstate_width = 11 |
1505 val localstate_width = 9 | 1532 val localstate_width = 17 |
1506 val notes_width = 5 | 1533 val notes_width = 5 |
1507 val divider = " | " | 1534 val divider = " | " |
1535 val clear_line = "\r" ^ pad_to 80 ""; | |
1508 | 1536 |
1509 fun print_status_header () = | 1537 fun print_status_header () = |
1510 print ("\r" ^ pad_to 80 "" ^ "\n " ^ | 1538 print (clear_line ^ "\n " ^ |
1511 pad_to libname_width "Library" ^ divider ^ | 1539 pad_to libname_width "Library" ^ divider ^ |
1512 pad_to libstate_width "State" ^ divider ^ | 1540 pad_to libstate_width "State" ^ divider ^ |
1513 pad_to localstate_width "Local" ^ divider ^ | 1541 pad_to localstate_width "Local" ^ divider ^ |
1514 "Notes" ^ "\n " ^ | 1542 "Notes" ^ "\n " ^ |
1515 hline_to libname_width ^ "-+-" ^ | 1543 hline_to libname_width ^ "-+-" ^ |
1516 hline_to libstate_width ^ "-+-" ^ | 1544 hline_to libstate_width ^ "-+-" ^ |
1517 hline_to localstate_width ^ "-+-" ^ | 1545 hline_to localstate_width ^ "-+-" ^ |
1518 hline_to notes_width ^ "\n") | 1546 hline_to notes_width ^ "\n") |
1519 | 1547 |
1520 fun print_outcome_header () = | 1548 fun print_outcome_header () = |
1521 print ("\r" ^ pad_to 80 "" ^ "\n " ^ | 1549 print (clear_line ^ "\n " ^ |
1522 pad_to libname_width "Library" ^ divider ^ | 1550 pad_to libname_width "Library" ^ divider ^ |
1523 pad_to libstate_width "Outcome" ^ divider ^ | 1551 pad_to libstate_width "Outcome" ^ divider ^ |
1524 "Notes" ^ "\n " ^ | 1552 "Notes" ^ "\n " ^ |
1525 hline_to libname_width ^ "-+-" ^ | 1553 hline_to libname_width ^ "-+-" ^ |
1526 hline_to libstate_width ^ "-+-" ^ | 1554 hline_to libstate_width ^ "-+-" ^ |
1535 | OK (WRONG, _) => "Wrong" | 1563 | OK (WRONG, _) => "Wrong" |
1536 | ERROR _ => "Error" | 1564 | ERROR _ => "Error" |
1537 val localstate_str = | 1565 val localstate_str = |
1538 case status of | 1566 case status of |
1539 OK (_, MODIFIED) => "Modified" | 1567 OK (_, MODIFIED) => "Modified" |
1540 | OK (_, UNMODIFIED) => "Clean" | 1568 | OK (_, LOCK_MISMATCHED) => "Differs from Lock" |
1541 | _ => "" | 1569 | OK (_, CLEAN) => "Clean" |
1570 | ERROR _ => "" | |
1542 val error_str = | 1571 val error_str = |
1543 case status of | 1572 case status of |
1544 ERROR e => e | 1573 ERROR e => e |
1545 | _ => "" | 1574 | _ => "" |
1546 in | 1575 in |
1610 then save_lock_file (#rootpath context) locks | 1639 then save_lock_file (#rootpath context) locks |
1611 else (); | 1640 else (); |
1612 return_code | 1641 return_code |
1613 end | 1642 end |
1614 | 1643 |
1644 fun lock_project ({ context, libs } : project) = | |
1645 let val outcomes = map (fn lib => | |
1646 (#libname lib, AnyLibControl.id_of context lib)) | |
1647 libs | |
1648 val locks = | |
1649 List.concat | |
1650 (map (fn (libname, result) => | |
1651 case result of | |
1652 ERROR _ => [] | |
1653 | OK id => [{ libname = libname, id_or_tag = id }]) | |
1654 outcomes) | |
1655 val return_code = return_code_for outcomes | |
1656 val _ = print clear_line | |
1657 in | |
1658 if OS.Process.isSuccess return_code | |
1659 then save_lock_file (#rootpath context) locks | |
1660 else (); | |
1661 return_code | |
1662 end | |
1663 | |
1615 fun load_local_project pintype = | 1664 fun load_local_project pintype = |
1616 let val userconfig = load_userconfig () | 1665 let val userconfig = load_userconfig () |
1617 val rootpath = OS.FileSys.getDir () | 1666 val rootpath = OS.FileSys.getDir () |
1618 in | 1667 in |
1619 load_project userconfig rootpath pintype | 1668 load_project userconfig rootpath pintype |
1628 val _ = print "\n"; | 1677 val _ = print "\n"; |
1629 in | 1678 in |
1630 return_code | 1679 return_code |
1631 end | 1680 end |
1632 | 1681 |
1633 fun review () = with_local_project NO_LOCKFILE review_project | 1682 fun review () = with_local_project USE_LOCKFILE review_project |
1634 fun status () = with_local_project NO_LOCKFILE status_of_project | 1683 fun status () = with_local_project USE_LOCKFILE status_of_project |
1635 fun update () = with_local_project NO_LOCKFILE update_project | 1684 fun update () = with_local_project NO_LOCKFILE update_project |
1685 fun lock () = with_local_project NO_LOCKFILE lock_project | |
1636 fun install () = with_local_project USE_LOCKFILE update_project | 1686 fun install () = with_local_project USE_LOCKFILE update_project |
1637 | 1687 |
1638 fun version () = | 1688 fun version () = |
1639 (print ("v" ^ vext_version ^ "\n"); | 1689 (print ("v" ^ vext_version ^ "\n"); |
1640 OS.Process.success) | 1690 OS.Process.success) |
1648 ^ "where <command> is one of:\n\n" | 1698 ^ "where <command> is one of:\n\n" |
1649 ^ " status print quick report on local status only, without using network\n" | 1699 ^ " status print quick report on local status only, without using network\n" |
1650 ^ " review check configured libraries against their providers, and report\n" | 1700 ^ " review check configured libraries against their providers, and report\n" |
1651 ^ " install update configured libraries according to project specs and lock file\n" | 1701 ^ " install update configured libraries according to project specs and lock file\n" |
1652 ^ " update update configured libraries and lock file according to project specs\n" | 1702 ^ " update update configured libraries and lock file according to project specs\n" |
1703 ^ " lock update lock file to match local library status\n" | |
1653 ^ " version print the Vext version number and exit\n\n"); | 1704 ^ " version print the Vext version number and exit\n\n"); |
1654 OS.Process.failure) | 1705 OS.Process.failure) |
1655 | 1706 |
1656 fun vext args = | 1707 fun vext args = |
1657 let val return_code = | 1708 let val return_code = |
1658 case args of | 1709 case args of |
1659 ["review"] => review () | 1710 ["review"] => review () |
1660 | ["status"] => status () | 1711 | ["status"] => status () |
1661 | ["install"] => install () | 1712 | ["install"] => install () |
1662 | ["update"] => update () | 1713 | ["update"] => update () |
1714 | ["lock"] => lock () | |
1663 | ["version"] => version () | 1715 | ["version"] => version () |
1664 | _ => usage () | 1716 | _ => usage () |
1665 in | 1717 in |
1666 OS.Process.exit return_code; | 1718 OS.Process.exit return_code; |
1667 () | 1719 () |