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 ()