Mercurial > hg > sonic-visualiser

comparison vext.sml @ 1706:d60b30ea9b80 vext

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make configure use vext
author Chris Cannam
date Wed, 07 Jun 2017 09:00:47 +0100
parents
children 975dee07ff5c
comparison
equal deleted inserted replaced
1705:c737c43d64af 1706:d60b30ea9b80
1 (* This file is automatically generated from the individual
2 source files in the Vext repository. *)
3
4 (*
5 Vext
6
7 A simple manager for third-party source code dependencies
8
9 Copyright 2017 Chris Cannam.
10
11 Permission is hereby granted, free of charge, to any person
12 obtaining a copy of this software and associated documentation
13 files (the "Software"), to deal in the Software without
14 restriction, including without limitation the rights to use, copy,
15 modify, merge, publish, distribute, sublicense, and/or sell copies
16 of the Software, and to permit persons to whom the Software is
17 furnished to do so, subject to the following conditions:
18
19 The above copyright notice and this permission notice shall be
20 included in all copies or substantial portions of the Software.
21
22 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
23 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
24 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
25 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
26 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
27 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
28 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
29
30 Except as contained in this notice, the names of Chris Cannam and
31 Particular Programs Ltd shall not be used in advertising or
32 otherwise to promote the sale, use or other dealings in this
33 Software without prior written authorization.
34 *)
35
36 val vext_version = "0.0.1"
37
38
39 datatype vcs =
40 HG |
41 GIT
42
43 datatype source =
44 URL of string |
45 PROVIDER of {
46 service : string,
47 owner : string option,
48 repo : string option
49 }
50
51 datatype pin =
52 UNPINNED |
53 PINNED of string
54
55 datatype libstate =
56 ABSENT |
57 CORRECT |
58 SUPERSEDED |
59 WRONG
60
61 datatype localstate =
62 MODIFIED |
63 UNMODIFIED
64
65 datatype branch =
66 BRANCH of string |
67 DEFAULT_BRANCH
68
69 (* If we can recover from an error, for example by reporting failure
70 for this one thing and going on to the next thing, then the error
71 should usually be returned through a result type rather than an
72 exception. *)
73
74 datatype 'a result =
75 OK of 'a |
76 ERROR of string
77
78 type libname = string
79
80 type id_or_tag = string
81
82 type libspec = {
83 libname : libname,
84 vcs : vcs,
85 source : source,
86 branch : branch,
87 pin : pin
88 }
89
90 type lock = {
91 libname : libname,
92 id_or_tag : id_or_tag
93 }
94
95 type remote_spec = {
96 anon : string option,
97 auth : string option
98 }
99
100 type provider = {
101 service : string,
102 supports : vcs list,
103 remote_spec : remote_spec
104 }
105
106 type account = {
107 service : string,
108 login : string
109 }
110
111 type context = {
112 rootpath : string,
113 extdir : string,
114 providers : provider list,
115 accounts : account list
116 }
117
118 type userconfig = {
119 providers : provider list,
120 accounts : account list
121 }
122
123 type project = {
124 context : context,
125 libs : libspec list
126 }
127
128 structure VextFilenames = struct
129 val project_file = "vext-project.json"
130 val project_lock_file = "vext-lock.json"
131 val user_config_file = ".vext.json"
132 end
133
134 signature VCS_CONTROL = sig
135
136 (** Test whether the library is present locally at all *)
137 val exists : context -> libname -> bool result
138
139 (** Return the id (hash) of the current revision for the library *)
140 val id_of : context -> libname -> id_or_tag result
141
142 (** Test whether the library is at the given id *)
143 val is_at : context -> libname * id_or_tag -> bool result
144
145 (** Test whether the library is on the given branch, i.e. is at
146 the branch tip or an ancestor of it *)
147 val is_on_branch : context -> libname * branch -> bool result
148
149 (** Test whether the library is at the newest revision for the
150 given branch. False may indicate that the branch has advanced
151 or that the library is not on the branch at all. This function
152 may use the network to check for new revisions *)
153 val is_newest : context -> libname * branch -> bool result
154
155 (** Test whether the library is at the newest revision available
156 locally for the given branch. False may indicate that the
157 branch has advanced or that the library is not on the branch
158 at all. This function must not use the network *)
159 val is_newest_locally : context -> libname * branch -> bool result
160
161 (** Test whether the library has been modified in the local
162 working copy *)
163 val is_modified_locally : context -> libname -> bool result
164
165 (** Check out, i.e. clone a fresh copy of, the repo for the given
166 library on the given branch *)
167 val checkout : context -> libname * source * branch -> unit result
168
169 (** Update the library to the given branch tip *)
170 val update : context -> libname * branch -> id_or_tag result
171
172 (** Update the library to the given specific id or tag *)
173 val update_to : context -> libname * id_or_tag -> id_or_tag result
174 end
175
176 signature LIB_CONTROL = sig
177 val review : context -> libspec -> (libstate * localstate) result
178 val status : context -> libspec -> (libstate * localstate) result
179 val update : context -> libspec -> id_or_tag result
180 end
181
182 structure FileBits :> sig
183 val extpath : context -> string
184 val libpath : context -> libname -> string
185 val subpath : context -> libname -> string -> string
186 val command_output : context -> libname -> string list -> string result
187 val command : context -> libname -> string list -> unit result
188 val file_contents : string -> string
189 val mydir : unit -> string
190 val homedir : unit -> string
191 val mkpath : string -> unit result
192 val project_spec_path : string -> string
193 val project_lock_path : string -> string
194 val verbose : unit -> bool
195 end = struct
196
197 fun verbose () =
198 case OS.Process.getEnv "VEXT_VERBOSE" of
199 SOME "0" => false
200 | SOME _ => true
201 | NONE => false
202
203 fun extpath ({ rootpath, extdir, ... } : context) =
204 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
205 in OS.Path.toString {
206 isAbs = isAbs,
207 vol = vol,
208 arcs = arcs @ [ extdir ]
209 }
210 end
211
212 fun subpath ({ rootpath, extdir, ... } : context) libname remainder =
213 (* NB libname is allowed to be a path fragment, e.g. foo/bar *)
214 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
215 val split = String.fields (fn c => c = #"/")
216 in OS.Path.toString {
217 isAbs = isAbs,
218 vol = vol,
219 arcs = arcs @ [ extdir ] @ split libname @ split remainder
220 }
221 end
222
223 fun libpath context "" =
224 extpath context
225 | libpath context libname =
226 subpath context libname ""
227
228 fun project_file_path rootpath filename =
229 let val { isAbs, vol, arcs } = OS.Path.fromString rootpath
230 in OS.Path.toString {
231 isAbs = isAbs,
232 vol = vol,
233 arcs = arcs @ [ filename ]
234 }
235 end
236
237 fun project_spec_path rootpath =
238 project_file_path rootpath (VextFilenames.project_file)
239
240 fun project_lock_path rootpath =
241 project_file_path rootpath (VextFilenames.project_lock_file)
242
243 fun trim str =
244 hd (String.fields (fn x => x = #"\n" orelse x = #"\r") str)
245
246 fun file_contents filename =
247 let val stream = TextIO.openIn filename
248 fun read_all str acc =
249 case TextIO.inputLine str of
250 SOME line => read_all str (trim line :: acc)
251 | NONE => rev acc
252 val contents = read_all stream []
253 val _ = TextIO.closeIn stream
254 in
255 String.concatWith "\n" contents
256 end
257
258 fun expand_commandline cmdlist =
259 (* We are quite [too] strict about what we accept here, except
260 for the first element in cmdlist which is assumed to be a
261 known command location rather than arbitrary user input. NB
262 only ASCII accepted at this point. *)
263 let open Char
264 fun quote arg =
265 if List.all
266 (fn c => isAlphaNum c orelse c = #"-" orelse c = #"_")
267 (explode arg)
268 then arg
269 else "\"" ^ arg ^ "\""
270 fun check arg =
271 let val valid = explode " /#:;?,._-{}@="
272 in
273 app (fn c =>
274 if isAlphaNum c orelse
275 List.exists (fn v => v = c) valid
276 then ()
277 else raise Fail ("Invalid character '" ^
278 (Char.toString c) ^
279 "' in command list"))
280 (explode arg);
281 arg
282 end
283 in
284 String.concatWith " "
285 (map quote
286 (hd cmdlist :: map check (tl cmdlist)))
287 end
288
289 val tick_cycle = ref 0
290 val tick_chars = Vector.fromList (map String.str (explode "|/-\\"))
291
292 fun tick name =
293 let val n = Vector.length tick_chars
294 fun pad_to n str =
295 if n <= String.size str then str
296 else pad_to n (str ^ " ")
297 in
298 print ("\r " ^
299 Vector.sub(tick_chars, !tick_cycle) ^ " " ^
300 pad_to 50 name);
301 tick_cycle := (if !tick_cycle = n - 1 then 0 else 1 + !tick_cycle)
302 end
303
304 fun run_command context libname cmdlist redirect =
305 let open OS
306 val dir = libpath context libname
307 val cmd = expand_commandline cmdlist
308 val _ = if verbose ()
309 then print ("Running: " ^ cmd ^
310 " (in dir " ^ dir ^ ")...\n")
311 else tick libname
312 val _ = FileSys.chDir dir
313 val status = case redirect of
314 NONE => Process.system cmd
315 | SOME file => Process.system (cmd ^ ">" ^ file)
316 in
317 if Process.isSuccess status
318 then OK ()
319 else ERROR ("Command failed: " ^ cmd ^ " (in dir " ^ dir ^ ")")
320 end
321 handle ex => ERROR ("Unable to run command: " ^ exnMessage ex)
322
323 fun command context libname cmdlist =
324 run_command context libname cmdlist NONE
325
326 fun command_output context libname cmdlist =
327 let open OS
328 val tmpFile = FileSys.tmpName ()
329 val result = run_command context libname cmdlist (SOME tmpFile)
330 val contents = file_contents tmpFile
331 in
332 FileSys.remove tmpFile handle _ => ();
333 case result of
334 OK () => OK contents
335 | ERROR e => ERROR e
336 end
337
338 fun mydir () =
339 let open OS
340 val { dir, file } = Path.splitDirFile (CommandLine.name ())
341 in
342 FileSys.realPath
343 (if Path.isAbsolute dir
344 then dir
345 else Path.concat (FileSys.getDir (), dir))
346 end
347
348 fun homedir () =
349 (* Failure is not routine, so we use an exception here *)
350 case (OS.Process.getEnv "HOME",
351 OS.Process.getEnv "HOMEPATH") of
352 (SOME home, _) => home
353 | (NONE, SOME home) => home
354 | (NONE, NONE) =>
355 raise Fail "Failed to look up home directory from environment"
356
357 fun mkpath path =
358 if OS.FileSys.isDir path handle _ => false
359 then OK ()
360 else case OS.Path.fromString path of
361 { arcs = nil, ... } => OK ()
362 | { isAbs = false, ... } => ERROR "mkpath requires absolute path"
363 | { isAbs, vol, arcs } =>
364 case mkpath (OS.Path.toString { (* parent *)
365 isAbs = isAbs,
366 vol = vol,
367 arcs = rev (tl (rev arcs)) }) of
368 ERROR e => ERROR e
369 | OK () => ((OS.FileSys.mkDir path; OK ())
370 handle OS.SysErr (e, _) =>
371 ERROR ("Directory creation failed: " ^ e))
372 end
373
374 functor LibControlFn (V: VCS_CONTROL) :> LIB_CONTROL = struct
375
376 (* Valid states for unpinned libraries:
377
378 - CORRECT: We are on the right branch and are up-to-date with
379 it as far as we can tell. (If not using the network, this
380 should be reported to user as "Present" rather than "Correct"
381 as the remote repo may have advanced without us knowing.)
382
383 - SUPERSEDED: We are on the right branch but we can see that
384 there is a newer revision either locally or on the remote (in
385 Git terms, we are at an ancestor of the desired branch tip).
386
387 - WRONG: We are on the wrong branch (in Git terms, we are not
388 at the desired branch tip or any ancestor of it).
389
390 - ABSENT: Repo doesn't exist here at all.
391
392 Valid states for pinned libraries:
393
394 - CORRECT: We are at the pinned revision.
395
396 - WRONG: We are at any revision other than the pinned one.
397
398 - ABSENT: Repo doesn't exist here at all.
399 *)
400
401 fun check with_network context ({ libname, branch, pin, ... } : libspec) =
402 let fun check_unpinned () =
403 let val is_newest = if with_network
404 then V.is_newest
405 else V.is_newest_locally
406 in
407 case is_newest context (libname, branch) of
408 ERROR e => ERROR e
409 | OK true => OK CORRECT
410 | OK false =>
411 case V.is_on_branch context (libname, branch) of
412 ERROR e => ERROR e
413 | OK true => OK SUPERSEDED
414 | OK false => OK WRONG
415 end
416 fun check_pinned target =
417 case V.is_at context (libname, target) of
418 ERROR e => ERROR e
419 | OK true => OK CORRECT
420 | OK false => OK WRONG
421 fun check' () =
422 case pin of
423 UNPINNED => check_unpinned ()
424 | PINNED target => check_pinned target
425 in
426 case V.exists context libname of
427 ERROR e => ERROR e
428 | OK false => OK (ABSENT, UNMODIFIED)
429 | OK true =>
430 case (check' (), V.is_modified_locally context libname) of
431 (ERROR e, _) => ERROR e
432 | (_, ERROR e) => ERROR e
433 | (OK state, OK true) => OK (state, MODIFIED)
434 | (OK state, OK false) => OK (state, UNMODIFIED)
435 end
436
437 val review = check true
438 val status = check false
439
440 fun update context ({ libname, source, branch, pin, ... } : libspec) =
441 let fun update_unpinned () =
442 case V.is_newest context (libname, branch) of
443 ERROR e => ERROR e
444 | OK true => V.id_of context libname
445 | OK false => V.update context (libname, branch)
446 fun update_pinned target =
447 case V.is_at context (libname, target) of
448 ERROR e => ERROR e
449 | OK true => OK target
450 | OK false => V.update_to context (libname, target)
451 fun update' () =
452 case pin of
453 UNPINNED => update_unpinned ()
454 | PINNED target => update_pinned target
455 in
456 case V.exists context libname of
457 ERROR e => ERROR e
458 | OK true => update' ()
459 | OK false =>
460 case V.checkout context (libname, source, branch) of
461 ERROR e => ERROR e
462 | OK () => update' ()
463 end
464 end
465
466 (* Simple Standard ML JSON parser
467 ==============================
468
469 https://bitbucket.org/cannam/sml-simplejson
470
471 An RFC-compliant JSON parser in one SML file with no dependency
472 on anything outside the Basis library. Also includes a simple
473 serialiser.
474
475 Tested with MLton, Poly/ML, and SML/NJ compilers.
476
477 Parser notes:
478
479 * Complies with RFC 7159, The JavaScript Object Notation (JSON)
480 Data Interchange Format
481
482 * Passes all of the JSONTestSuite parser accept/reject tests that
483 exist at the time of writing, as listed in "Parsing JSON is a
484 Minefield" (http://seriot.ch/parsing_json.php)
485
486 * Two-pass parser using naive exploded strings, therefore not
487 particularly fast and not suitable for large input files
488
489 * Only supports UTF-8 input, not UTF-16 or UTF-32. Doesn't check
490 that JSON strings are valid UTF-8 -- the caller must do that --
491 but does handle \u escapes
492
493 * Converts all numbers to type "real". If that is a 64-bit IEEE
494 float type (common but not guaranteed in SML) then we're pretty
495 standard for a JSON parser
496
497 Copyright 2017 Chris Cannam.
498 Parts based on the JSON parser in the Ponyo library by Phil Eaton.
499
500 Permission is hereby granted, free of charge, to any person
501 obtaining a copy of this software and associated documentation
502 files (the "Software"), to deal in the Software without
503 restriction, including without limitation the rights to use, copy,
504 modify, merge, publish, distribute, sublicense, and/or sell copies
505 of the Software, and to permit persons to whom the Software is
506 furnished to do so, subject to the following conditions:
507
508 The above copyright notice and this permission notice shall be
509 included in all copies or substantial portions of the Software.
510
511 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
512 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
513 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
514 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR
515 ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
516 CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
517 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
518
519 Except as contained in this notice, the names of Chris Cannam and
520 Particular Programs Ltd shall not be used in advertising or
521 otherwise to promote the sale, use or other dealings in this
522 Software without prior written authorization.
523 *)
524
525 signature JSON = sig
526
527 datatype json = OBJECT of (string * json) list
528 | ARRAY of json list
529 | NUMBER of real
530 | STRING of string
531 | BOOL of bool
532 | NULL
533
534 datatype 'a result = OK of 'a
535 | ERROR of string
536
537 val parse : string -> json result
538 val serialise : json -> string
539 val serialiseIndented : json -> string
540
541 end
542
543 structure Json :> JSON = struct
544
545 datatype json = OBJECT of (string * json) list
546 | ARRAY of json list
547 | NUMBER of real
548 | STRING of string
549 | BOOL of bool
550 | NULL
551
552 datatype 'a result = OK of 'a
553 | ERROR of string
554
555 structure T = struct
556 datatype token = NUMBER of char list
557 | STRING of string
558 | BOOL of bool
559 | NULL
560 | CURLY_L
561 | CURLY_R
562 | SQUARE_L
563 | SQUARE_R
564 | COLON
565 | COMMA
566
567 fun toString t =
568 case t of NUMBER digits => implode digits
569 | STRING s => s
570 | BOOL b => Bool.toString b
571 | NULL => "null"
572 | CURLY_L => "{"
573 | CURLY_R => "}"
574 | SQUARE_L => "["
575 | SQUARE_R => "]"
576 | COLON => ":"
577 | COMMA => ","
578 end
579
580 fun bmpToUtf8 cp = (* convert a codepoint in Unicode BMP to utf8 bytes *)
581 let open Word
582 infix 6 orb andb >>
583 in
584 map (Char.chr o toInt)
585 (if cp < 0wx80 then
586 [cp]
587 else if cp < 0wx800 then
588 [0wxc0 orb (cp >> 0w6), 0wx80 orb (cp andb 0wx3f)]
589 else if cp < 0wx10000 then
590 [0wxe0 orb (cp >> 0w12),
591 0wx80 orb ((cp >> 0w6) andb 0wx3f),
592 0wx80 orb (cp andb 0wx3f)]
593 else raise Fail ("Invalid BMP point " ^ (Word.toString cp)))
594 end
595
596 fun error pos text = ERROR (text ^ " at character position " ^
597 Int.toString (pos - 1))
598 fun token_error pos = error pos ("Unexpected token")
599
600 fun lexNull pos acc (#"u" :: #"l" :: #"l" :: xs) =
601 lex (pos + 3) (T.NULL :: acc) xs
602 | lexNull pos acc _ = token_error pos
603
604 and lexTrue pos acc (#"r" :: #"u" :: #"e" :: xs) =
605 lex (pos + 3) (T.BOOL true :: acc) xs
606 | lexTrue pos acc _ = token_error pos
607
608 and lexFalse pos acc (#"a" :: #"l" :: #"s" :: #"e" :: xs) =
609 lex (pos + 4) (T.BOOL false :: acc) xs
610 | lexFalse pos acc _ = token_error pos
611
612 and lexChar tok pos acc xs =
613 lex pos (tok :: acc) xs
614
615 and lexString pos acc cc =
616 let datatype escaped = ESCAPED | NORMAL
617 fun lexString' pos text ESCAPED [] =
618 error pos "End of input during escape sequence"
619 | lexString' pos text NORMAL [] =
620 error pos "End of input during string"
621 | lexString' pos text ESCAPED (x :: xs) =
622 let fun esc c = lexString' (pos + 1) (c :: text) NORMAL xs
623 in case x of
624 #"\"" => esc x
625 | #"\\" => esc x
626 | #"/" => esc x
627 | #"b" => esc #"\b"
628 | #"f" => esc #"\f"
629 | #"n" => esc #"\n"
630 | #"r" => esc #"\r"
631 | #"t" => esc #"\t"
632 | _ => error pos ("Invalid escape \\" ^
633 Char.toString x)
634 end
635 | lexString' pos text NORMAL (#"\\" :: #"u" ::a::b::c::d:: xs) =
636 if List.all Char.isHexDigit [a,b,c,d]
637 then case Word.fromString ("0wx" ^ (implode [a,b,c,d])) of
638 SOME w => (let val utf = rev (bmpToUtf8 w) in
639 lexString' (pos + 6) (utf @ text)
640 NORMAL xs
641 end
642 handle Fail err => error pos err)
643 | NONE => error pos "Invalid Unicode BMP escape sequence"
644 else error pos "Invalid Unicode BMP escape sequence"
645 | lexString' pos text NORMAL (x :: xs) =
646 if Char.ord x < 0x20
647 then error pos "Invalid unescaped control character"
648 else
649 case x of
650 #"\"" => OK (rev text, xs, pos + 1)
651 | #"\\" => lexString' (pos + 1) text ESCAPED xs
652 | _ => lexString' (pos + 1) (x :: text) NORMAL xs
653 in
654 case lexString' pos [] NORMAL cc of
655 OK (text, rest, newpos) =>
656 lex newpos (T.STRING (implode text) :: acc) rest
657 | ERROR e => ERROR e
658 end
659
660 and lexNumber firstChar pos acc cc =
661 let val valid = explode ".+-e"
662 fun lexNumber' pos digits [] = (rev digits, [], pos)
663 | lexNumber' pos digits (x :: xs) =
664 if x = #"E" then lexNumber' (pos + 1) (#"e" :: digits) xs
665 else if Char.isDigit x orelse List.exists (fn c => x = c) valid
666 then lexNumber' (pos + 1) (x :: digits) xs
667 else (rev digits, x :: xs, pos)
668 val (digits, rest, newpos) =
669 lexNumber' (pos - 1) [] (firstChar :: cc)
670 in
671 case digits of
672 [] => token_error pos
673 | _ => lex newpos (T.NUMBER digits :: acc) rest
674 end
675
676 and lex pos acc [] = OK (rev acc)
677 | lex pos acc (x::xs) =
678 (case x of
679 #" " => lex
680 | #"\t" => lex
681 | #"\n" => lex
682 | #"\r" => lex
683 | #"{" => lexChar T.CURLY_L
684 | #"}" => lexChar T.CURLY_R
685 | #"[" => lexChar T.SQUARE_L
686 | #"]" => lexChar T.SQUARE_R
687 | #":" => lexChar T.COLON
688 | #"," => lexChar T.COMMA
689 | #"\"" => lexString
690 | #"t" => lexTrue
691 | #"f" => lexFalse
692 | #"n" => lexNull
693 | x => lexNumber x) (pos + 1) acc xs
694
695 fun show [] = "end of input"
696 | show (tok :: _) = T.toString tok
697
698 fun parseNumber digits =
699 (* Note lexNumber already case-insensitised the E for us *)
700 let open Char
701
702 fun okExpDigits [] = false
703 | okExpDigits (c :: []) = isDigit c
704 | okExpDigits (c :: cs) = isDigit c andalso okExpDigits cs
705
706 fun okExponent [] = false
707 | okExponent (#"+" :: cs) = okExpDigits cs
708 | okExponent (#"-" :: cs) = okExpDigits cs
709 | okExponent cc = okExpDigits cc
710
711 fun okFracTrailing [] = true
712 | okFracTrailing (c :: cs) =
713 (isDigit c andalso okFracTrailing cs) orelse
714 (c = #"e" andalso okExponent cs)
715
716 fun okFraction [] = false
717 | okFraction (c :: cs) =
718 isDigit c andalso okFracTrailing cs
719
720 fun okPosTrailing [] = true
721 | okPosTrailing (#"." :: cs) = okFraction cs
722 | okPosTrailing (#"e" :: cs) = okExponent cs
723 | okPosTrailing (c :: cs) =
724 isDigit c andalso okPosTrailing cs
725
726 fun okPositive [] = false
727 | okPositive (#"0" :: []) = true
728 | okPositive (#"0" :: #"." :: cs) = okFraction cs
729 | okPositive (#"0" :: #"e" :: cs) = okExponent cs
730 | okPositive (#"0" :: cs) = false
731 | okPositive (c :: cs) = isDigit c andalso okPosTrailing cs
732
733 fun okNumber (#"-" :: cs) = okPositive cs
734 | okNumber cc = okPositive cc
735 in
736 if okNumber digits
737 then case Real.fromString (implode digits) of
738 NONE => ERROR "Number out of range"
739 | SOME r => OK r
740 else ERROR ("Invalid number \"" ^ (implode digits) ^ "\"")
741 end
742
743 fun parseObject (T.CURLY_R :: xs) = OK (OBJECT [], xs)
744 | parseObject tokens =
745 let fun parsePair (T.STRING key :: T.COLON :: xs) =
746 (case parseTokens xs of
747 ERROR e => ERROR e
748 | OK (j, xs) => OK ((key, j), xs))
749 | parsePair other =
750 ERROR ("Object key/value pair expected around \"" ^
751 show other ^ "\"")
752 fun parseObject' acc [] = ERROR "End of input during object"
753 | parseObject' acc tokens =
754 case parsePair tokens of
755 ERROR e => ERROR e
756 | OK (pair, T.COMMA :: xs) =>
757 parseObject' (pair :: acc) xs
758 | OK (pair, T.CURLY_R :: xs) =>
759 OK (OBJECT (rev (pair :: acc)), xs)
760 | OK (_, _) => ERROR "Expected , or } after object element"
761 in
762 parseObject' [] tokens
763 end
764
765 and parseArray (T.SQUARE_R :: xs) = OK (ARRAY [], xs)
766 | parseArray tokens =
767 let fun parseArray' acc [] = ERROR "End of input during array"
768 | parseArray' acc tokens =
769 case parseTokens tokens of
770 ERROR e => ERROR e
771 | OK (j, T.COMMA :: xs) => parseArray' (j :: acc) xs
772 | OK (j, T.SQUARE_R :: xs) => OK (ARRAY (rev (j :: acc)), xs)
773 | OK (_, _) => ERROR "Expected , or ] after array element"
774 in
775 parseArray' [] tokens
776 end
777
778 and parseTokens [] = ERROR "Value expected"
779 | parseTokens (tok :: xs) =
780 (case tok of
781 T.NUMBER d => (case parseNumber d of
782 OK r => OK (NUMBER r, xs)
783 | ERROR e => ERROR e)
784 | T.STRING s => OK (STRING s, xs)
785 | T.BOOL b => OK (BOOL b, xs)
786 | T.NULL => OK (NULL, xs)
787 | T.CURLY_L => parseObject xs
788 | T.SQUARE_L => parseArray xs
789 | _ => ERROR ("Unexpected token " ^ T.toString tok ^
790 " before " ^ show xs))
791
792 fun parse str =
793 case lex 1 [] (explode str) of
794 ERROR e => ERROR e
795 | OK tokens => case parseTokens tokens of
796 OK (value, []) => OK value
797 | OK (_, _) => ERROR "Extra data after input"
798 | ERROR e => ERROR e
799
800 fun stringEscape s =
801 let fun esc x = [x, #"\\"]
802 fun escape' acc [] = rev acc
803 | escape' acc (x :: xs) =
804 escape' (case x of
805 #"\"" => esc x @ acc
806 | #"\\" => esc x @ acc
807 | #"\b" => esc #"b" @ acc
808 | #"\f" => esc #"f" @ acc
809 | #"\n" => esc #"n" @ acc
810 | #"\r" => esc #"r" @ acc
811 | #"\t" => esc #"t" @ acc
812 | _ =>
813 let val c = Char.ord x
814 in
815 if c < 0x20
816 then let val hex = Word.toString (Word.fromInt c)
817 in (rev o explode) (if c < 0x10
818 then ("\\u000" ^ hex)
819 else ("\\u00" ^ hex))
820 end @ acc
821 else
822 x :: acc
823 end)
824 xs
825 in
826 implode (escape' [] (explode s))
827 end
828
829 fun serialise json =
830 case json of
831 OBJECT pp => "{" ^ String.concatWith
832 "," (map (fn (key, value) =>
833 serialise (STRING key) ^ ":" ^
834 serialise value) pp) ^
835 "}"
836 | ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
837 | NUMBER n => implode (map (fn #"~" => #"-" | c => c)
838 (explode (Real.toString n)))
839 | STRING s => "\"" ^ stringEscape s ^ "\""
840 | BOOL b => Bool.toString b
841 | NULL => "null"
842
843 fun serialiseIndented json =
844 let fun indent 0 = ""
845 | indent i = " " ^ indent (i - 1)
846 fun serialiseIndented' i json =
847 let val ser = serialiseIndented' (i + 1)
848 in
849 case json of
850 OBJECT [] => "{}"
851 | ARRAY [] => "[]"
852 | OBJECT pp => "{\n" ^ indent (i + 1) ^
853 String.concatWith
854 (",\n" ^ indent (i + 1))
855 (map (fn (key, value) =>
856 ser (STRING key) ^ ": " ^
857 ser value) pp) ^
858 "\n" ^ indent i ^ "}"
859 | ARRAY arr => "[\n" ^ indent (i + 1) ^
860 String.concatWith
861 (",\n" ^ indent (i + 1))
862 (map ser arr) ^
863 "\n" ^ indent i ^ "]"
864 | other => serialise other
865 end
866 in
867 serialiseIndented' 0 json ^ "\n"
868 end
869
870 end
871
872
873 structure JsonBits :> sig
874 val load_json_from : string -> Json.json (* filename -> json *)
875 val save_json_to : string -> Json.json -> unit
876 val lookup_optional : Json.json -> string list -> Json.json option
877 val lookup_optional_string : Json.json -> string list -> string option
878 val lookup_mandatory : Json.json -> string list -> Json.json
879 val lookup_mandatory_string : Json.json -> string list -> string
880 end = struct
881
882 fun load_json_from filename =
883 case Json.parse (FileBits.file_contents filename) of
884 Json.OK json => json
885 | Json.ERROR e => raise Fail ("Failed to parse file: " ^ e)
886
887 fun save_json_to filename json =
888 let val jstr = Json.serialiseIndented json
889 val stream = TextIO.openOut filename
890 in
891 TextIO.output (stream, jstr);
892 TextIO.closeOut stream
893 end
894
895 fun lookup_optional json kk =
896 let fun lookup key =
897 case json of
898 Json.OBJECT kvs =>
899 (case List.find (fn (k, v) => k = key) kvs of
900 SOME (k, v) => SOME v
901 | NONE => NONE)
902 | _ => raise Fail "Object expected"
903 in
904 case kk of
905 [] => NONE
906 | key::[] => lookup key
907 | key::kk => case lookup key of
908 NONE => NONE
909 | SOME j => lookup_optional j kk
910 end
911
912 fun lookup_optional_string json kk =
913 case lookup_optional json kk of
914 SOME (Json.STRING s) => SOME s
915 | SOME _ => raise Fail ("Value (if present) must be string: " ^
916 (String.concatWith " -> " kk))
917 | NONE => NONE
918
919 fun lookup_mandatory json kk =
920 case lookup_optional json kk of
921 SOME v => v
922 | NONE => raise Fail ("Value is mandatory: " ^
923 (String.concatWith " -> " kk) ^ " in json: " ^
924 (Json.serialise json))
925
926 fun lookup_mandatory_string json kk =
927 case lookup_optional json kk of
928 SOME (Json.STRING s) => s
929 | _ => raise Fail ("Value must be string: " ^
930 (String.concatWith " -> " kk))
931 end
932
933 structure Provider :> sig
934 val load_providers : Json.json -> provider list
935 val load_more_providers : provider list -> Json.json -> provider list
936 val remote_url : context -> vcs -> source -> libname -> string
937 end = struct
938
939 val known_providers : provider list =
940 [ {
941 service = "bitbucket",
942 supports = [HG, GIT],
943 remote_spec = {
944 anon = SOME "https://bitbucket.org/{owner}/{repo}",
945 auth = SOME "ssh://{vcs}@bitbucket.org/{owner}/{repo}"
946 }
947 },
948 {
949 service = "github",
950 supports = [GIT],
951 remote_spec = {
952 anon = SOME "https://github.com/{owner}/{repo}",
953 auth = SOME "ssh://{vcs}@github.com/{owner}/{repo}"
954 }
955 }
956 ]
957
958 fun vcs_name vcs =
959 case vcs of GIT => "git" |
960 HG => "hg"
961
962 fun vcs_from_name name =
963 case name of "git" => GIT
964 | "hg" => HG
965 | other => raise Fail ("Unknown vcs name \"" ^ name ^ "\"")
966
967 fun load_more_providers previously_loaded json =
968 let open JsonBits
969 fun load pjson pname : provider =
970 {
971 service = pname,
972 supports =
973 case lookup_mandatory pjson ["vcs"] of
974 Json.ARRAY vv =>
975 map (fn (Json.STRING v) => vcs_from_name v
976 | _ => raise Fail "Strings expected in vcs array")
977 vv
978 | _ => raise Fail "Array expected for vcs",
979 remote_spec = {
980 anon = lookup_optional_string pjson ["anon"],
981 auth = lookup_optional_string pjson ["auth"]
982 }
983 }
984 val loaded =
985 case lookup_optional json ["providers"] of
986 NONE => []
987 | SOME (Json.OBJECT pl) => map (fn (k, v) => load v k) pl
988 | _ => raise Fail "Object expected for providers in config"
989 val newly_loaded =
990 List.filter (fn p => not (List.exists (fn pp => #service p =
991 #service pp)
992 previously_loaded))
993 loaded
994 in
995 previously_loaded @ newly_loaded
996 end
997
998 fun load_providers json =
999 load_more_providers known_providers json
1000
1001 fun expand_spec spec { vcs, service, owner, repo } login =
1002 (* ugly *)
1003 let fun replace str =
1004 case str of
1005 "vcs" => vcs_name vcs
1006 | "service" => service
1007 | "owner" =>
1008 (case owner of
1009 SOME ostr => ostr
1010 | NONE => raise Fail ("Owner not specified for service " ^
1011 service))
1012 | "repo" => repo
1013 | "account" =>
1014 (case login of
1015 SOME acc => acc
1016 | NONE => raise Fail ("Account not given for service " ^
1017 service))
1018 | other => raise Fail ("Unknown variable \"" ^ other ^
1019 "\" in spec for service " ^ service)
1020 fun expand' acc sstr =
1021 case Substring.splitl (fn c => c <> #"{") sstr of
1022 (pfx, sfx) =>
1023 if Substring.isEmpty sfx
1024 then rev (pfx :: acc)
1025 else
1026 case Substring.splitl (fn c => c <> #"}") sfx of
1027 (tok, remainder) =>
1028 if Substring.isEmpty remainder
1029 then rev (tok :: pfx :: acc)
1030 else let val replacement =
1031 replace
1032 (* tok begins with "{": *)
1033 (Substring.string
1034 (Substring.triml 1 tok))
1035 in
1036 expand' (Substring.full replacement ::
1037 pfx :: acc)
1038 (* remainder begins with "}": *)
1039 (Substring.triml 1 remainder)
1040 end
1041 in
1042 Substring.concat (expand' [] (Substring.full spec))
1043 end
1044
1045 fun provider_url req login providers =
1046 case providers of
1047 [] => raise Fail ("Unknown service \"" ^ (#service req) ^
1048 "\" for vcs \"" ^ (vcs_name (#vcs req)) ^ "\"")
1049 | ({ service, supports, remote_spec : remote_spec } :: rest) =>
1050 if service <> (#service req) orelse
1051 not (List.exists (fn v => v = (#vcs req)) supports)
1052 then provider_url req login rest
1053 else
1054 case (login, #auth remote_spec, #anon remote_spec) of
1055 (SOME _, SOME auth, _) => expand_spec auth req login
1056 | (SOME _, _, SOME anon) => expand_spec anon req NONE
1057 | (NONE, _, SOME anon) => expand_spec anon req NONE
1058 | _ => raise Fail ("No suitable anon/auth URL spec " ^
1059 "provided for service \"" ^ service ^ "\"")
1060
1061 fun login_for ({ accounts, ... } : context) service =
1062 case List.find (fn a => service = #service a) accounts of
1063 SOME { login, ... } => SOME login
1064 | NONE => NONE
1065
1066 fun remote_url (context : context) vcs source libname =
1067 case source of
1068 URL u => u
1069 | PROVIDER { service, owner, repo } =>
1070 provider_url { vcs = vcs,
1071 service = service,
1072 owner = owner,
1073 repo = case repo of
1074 SOME r => r
1075 | NONE => libname }
1076 (login_for context service)
1077 (#providers context)
1078 end
1079
1080 structure HgControl :> VCS_CONTROL = struct
1081
1082 type vcsstate = { id: string, modified: bool,
1083 branch: string, tags: string list }
1084
1085 val hg_args = [ "--config", "ui.interactive=true" ]
1086
1087 fun hg_command context libname args =
1088 FileBits.command context libname ("hg" :: hg_args @ args)
1089
1090 fun hg_command_output context libname args =
1091 FileBits.command_output context libname ("hg" :: hg_args @ args)
1092
1093 fun exists context libname =
1094 OK (OS.FileSys.isDir (FileBits.subpath context libname ".hg"))
1095 handle _ => OK false
1096
1097 fun remote_for context (libname, source) =
1098 Provider.remote_url context HG source libname
1099
1100 fun current_state context libname : vcsstate result =
1101 let fun is_branch text = text <> "" andalso #"(" = hd (explode text)
1102 and extract_branch b =
1103 if is_branch b (* need to remove enclosing parens *)
1104 then (implode o rev o tl o rev o tl o explode) b
1105 else "default"
1106 and is_modified id = id <> "" andalso #"+" = hd (rev (explode id))
1107 and extract_id id =
1108 if is_modified id (* need to remove trailing "+" *)
1109 then (implode o rev o tl o rev o explode) id
1110 else id
1111 and split_tags tags = String.tokens (fn c => c = #"/") tags
1112 and state_for (id, branch, tags) =
1113 OK { id = extract_id id,
1114 modified = is_modified id,
1115 branch = extract_branch branch,
1116 tags = split_tags tags }
1117 in
1118 case hg_command_output context libname ["id"] of
1119 ERROR e => ERROR e
1120 | OK out =>
1121 case String.tokens (fn x => x = #" ") out of
1122 [id, branch, tags] => state_for (id, branch, tags)
1123 | [id, other] => if is_branch other
1124 then state_for (id, other, "")
1125 else state_for (id, "", other)
1126 | [id] => state_for (id, "", "")
1127 | _ => ERROR ("Unexpected output from hg id: " ^ out)
1128 end
1129
1130 fun branch_name branch = case branch of
1131 DEFAULT_BRANCH => "default"
1132 | BRANCH "" => "default"
1133 | BRANCH b => b
1134
1135 fun id_of context libname =
1136 case current_state context libname of
1137 ERROR e => ERROR e
1138 | OK { id, ... } => OK id
1139
1140 fun is_at context (libname, id_or_tag) =
1141 case current_state context libname of
1142 ERROR e => ERROR e
1143 | OK { id, tags, ... } =>
1144 OK (String.isPrefix id_or_tag id orelse
1145 String.isPrefix id id_or_tag orelse
1146 List.exists (fn t => t = id_or_tag) tags)
1147
1148 fun is_on_branch context (libname, b) =
1149 case current_state context libname of
1150 ERROR e => ERROR e
1151 | OK { branch, ... } => OK (branch = branch_name b)
1152
1153 fun is_newest_locally context (libname, branch) =
1154 case hg_command_output context libname
1155 ["log", "-l1",
1156 "-b", branch_name branch,
1157 "--template", "{node}"] of
1158 ERROR e => ERROR e
1159 | OK newest_in_repo => is_at context (libname, newest_in_repo)
1160
1161 fun pull context libname =
1162 hg_command context libname
1163 (if FileBits.verbose ()
1164 then ["pull"]
1165 else ["pull", "-q"])
1166
1167 fun is_newest context (libname, branch) =
1168 case is_newest_locally context (libname, branch) of
1169 ERROR e => ERROR e
1170 | OK false => OK false
1171 | OK true =>
1172 case pull context libname of
1173 ERROR e => ERROR e
1174 | _ => is_newest_locally context (libname, branch)
1175
1176 fun is_modified_locally context libname =
1177 case current_state context libname of
1178 ERROR e => ERROR e
1179 | OK { modified, ... } => OK modified
1180
1181 fun checkout context (libname, source, branch) =
1182 let val url = remote_for context (libname, source)
1183 in
1184 case FileBits.mkpath (FileBits.extpath context) of
1185 ERROR e => ERROR e
1186 | _ => hg_command context ""
1187 ["clone", "-u", branch_name branch,
1188 url, libname]
1189 end
1190
1191 fun update context (libname, branch) =
1192 let val pull_result = pull context libname
1193 in
1194 case hg_command context libname ["update", branch_name branch] of
1195 ERROR e => ERROR e
1196 | _ =>
1197 case pull_result of
1198 ERROR e => ERROR e
1199 | _ => id_of context libname
1200 end
1201
1202 fun update_to context (libname, "") =
1203 ERROR "Non-empty id (tag or revision id) required for update_to"
1204 | update_to context (libname, id) =
1205 case hg_command context libname ["update", "-r" ^ id] of
1206 OK () => id_of context libname
1207 | ERROR _ =>
1208 case pull context libname of
1209 ERROR e => ERROR e
1210 | _ =>
1211 case hg_command context libname ["update", "-r" ^ id] of
1212 ERROR e => ERROR e
1213 | _ => id_of context libname
1214
1215 end
1216
1217 structure GitControl :> VCS_CONTROL = struct
1218
1219 (* With Git repos we always operate in detached HEAD state. Even
1220 the master branch is checked out using the remote reference,
1221 origin/master. *)
1222
1223 fun git_command context libname args =
1224 FileBits.command context libname ("git" :: args)
1225
1226 fun git_command_output context libname args =
1227 FileBits.command_output context libname ("git" :: args)
1228
1229 fun exists context libname =
1230 OK (OS.FileSys.isDir (FileBits.subpath context libname ".git"))
1231 handle _ => OK false
1232
1233 fun remote_for context (libname, source) =
1234 Provider.remote_url context GIT source libname
1235
1236 fun branch_name branch = case branch of
1237 DEFAULT_BRANCH => "master"
1238 | BRANCH "" => "master"
1239 | BRANCH b => b
1240
1241 fun remote_branch_name branch = "origin/" ^ branch_name branch
1242
1243 fun checkout context (libname, source, branch) =
1244 let val url = remote_for context (libname, source)
1245 in
1246 case FileBits.mkpath (FileBits.extpath context) of
1247 OK () => git_command context ""
1248 ["clone", "-b",
1249 branch_name branch,
1250 url, libname]
1251 | ERROR e => ERROR e
1252 end
1253
1254 (* NB git rev-parse HEAD shows revision id of current checkout;
1255 git rev-list -1 <tag> shows revision id of revision with that tag *)
1256
1257 fun id_of context libname =
1258 git_command_output context libname ["rev-parse", "HEAD"]
1259
1260 fun is_at context (libname, id_or_tag) =
1261 case id_of context libname of
1262 ERROR e => ERROR e
1263 | OK id =>
1264 if String.isPrefix id_or_tag id orelse
1265 String.isPrefix id id_or_tag
1266 then OK true
1267 else
1268 case git_command_output context libname
1269 ["rev-list", "-1", id_or_tag] of
1270 ERROR e => ERROR e
1271 | OK tid =>
1272 OK (tid = id andalso
1273 tid <> id_or_tag) (* else id_or_tag was id not tag *)
1274
1275 fun branch_tip context (libname, branch) =
1276 git_command_output context libname
1277 ["rev-list", "-1",
1278 remote_branch_name branch]
1279
1280 fun is_newest_locally context (libname, branch) =
1281 case branch_tip context (libname, branch) of
1282 ERROR e => ERROR e
1283 | OK rev => is_at context (libname, rev)
1284
1285 fun is_on_branch context (libname, branch) =
1286 case branch_tip context (libname, branch) of
1287 ERROR e => ERROR e
1288 | OK rev =>
1289 case is_at context (libname, rev) of
1290 ERROR e => ERROR e
1291 | OK true => OK true
1292 | OK false =>
1293 case git_command context libname
1294 ["merge-base", "--is-ancestor",
1295 "HEAD", remote_branch_name branch] of
1296 ERROR e => OK false (* cmd returns non-zero for no *)
1297 | _ => OK true
1298
1299 fun is_newest context (libname, branch) =
1300 case is_newest_locally context (libname, branch) of
1301 ERROR e => ERROR e
1302 | OK false => OK false
1303 | OK true =>
1304 case git_command context libname ["fetch"] of
1305 ERROR e => ERROR e
1306 | _ => is_newest_locally context (libname, branch)
1307
1308 fun is_modified_locally context libname =
1309 case git_command_output context libname ["status", "--porcelain"] of
1310 ERROR e => ERROR e
1311 | OK "" => OK false
1312 | OK _ => OK true
1313
1314 (* This function updates to the latest revision on a branch rather
1315 than to a specific id or tag. We can't just checkout the given
1316 branch, as that will succeed even if the branch isn't up to
1317 date. We could checkout the branch and then fetch and merge,
1318 but it's perhaps cleaner not to maintain a local branch at all,
1319 but instead checkout the remote branch as a detached head. *)
1320
1321 fun update context (libname, branch) =
1322 case git_command context libname ["fetch"] of
1323 ERROR e => ERROR e
1324 | _ =>
1325 case git_command context libname ["checkout", "--detach",
1326 remote_branch_name branch] of
1327 ERROR e => ERROR e
1328 | _ => id_of context libname
1329
1330 (* This function is dealing with a specific id or tag, so if we
1331 can successfully check it out (detached) then that's all we need
1332 to do. Otherwise we need to fetch and try again *)
1333
1334 fun update_to context (libname, "") =
1335 ERROR "Non-empty id (tag or revision id) required for update_to"
1336 | update_to context (libname, id) =
1337 case git_command context libname ["checkout", "--detach", id] of
1338 OK () => id_of context libname
1339 | ERROR _ =>
1340 case git_command context libname ["fetch"] of
1341 ERROR e => ERROR e
1342 | _ =>
1343 case git_command context libname ["checkout", "--detach", id] of
1344 ERROR e => ERROR e
1345 | _ => id_of context libname
1346 end
1347
1348 structure AnyLibControl :> LIB_CONTROL = struct
1349
1350 structure H = LibControlFn(HgControl)
1351 structure G = LibControlFn(GitControl)
1352
1353 fun review context (spec as { vcs, ... } : libspec) =
1354 (fn HG => H.review | GIT => G.review) vcs context spec
1355
1356 fun status context (spec as { vcs, ... } : libspec) =
1357 (fn HG => H.status | GIT => G.status) vcs context spec
1358
1359 fun update context (spec as { vcs, ... } : libspec) =
1360 (fn HG => H.update | GIT => G.update) vcs context spec
1361 end
1362
1363 fun load_libspec spec_json lock_json libname : libspec =
1364 let open JsonBits
1365 val libobj = lookup_mandatory spec_json ["libs", libname]
1366 val vcs = lookup_mandatory_string libobj ["vcs"]
1367 val retrieve = lookup_optional_string libobj
1368 val service = retrieve ["service"]
1369 val owner = retrieve ["owner"]
1370 val repo = retrieve ["repository"]
1371 val url = retrieve ["url"]
1372 val branch = retrieve ["branch"]
1373 val user_pin = retrieve ["pin"]
1374 val lock_pin = case lookup_optional lock_json ["libs", libname] of
1375 SOME ll => lookup_optional_string ll ["pin"]
1376 | NONE => NONE
1377 in
1378 {
1379 libname = libname,
1380 vcs = case vcs of
1381 "hg" => HG
1382 | "git" => GIT
1383 | other => raise Fail ("Unknown version-control system \"" ^
1384 other ^ "\""),
1385 source = case (url, service, owner, repo) of
1386 (SOME u, NONE, _, _) => URL u
1387 | (NONE, SOME ss, owner, repo) =>
1388 PROVIDER { service = ss, owner = owner, repo = repo }
1389 | _ => raise Fail ("Must have exactly one of service " ^
1390 "or url string"),
1391 pin = case lock_pin of
1392 SOME p => PINNED p
1393 | NONE =>
1394 case user_pin of
1395 SOME p => PINNED p
1396 | NONE => UNPINNED,
1397 branch = case branch of
1398 SOME b => BRANCH b
1399 | NONE => DEFAULT_BRANCH
1400 }
1401 end
1402
1403 fun load_userconfig () : userconfig =
1404 let val home = FileBits.homedir ()
1405 val conf_json =
1406 JsonBits.load_json_from
1407 (OS.Path.joinDirFile {
1408 dir = home,
1409 file = VextFilenames.user_config_file })
1410 handle IO.Io _ => Json.OBJECT []
1411 in
1412 {
1413 accounts = case JsonBits.lookup_optional conf_json ["accounts"] of
1414 NONE => []
1415 | SOME (Json.OBJECT aa) =>
1416 map (fn (k, (Json.STRING v)) =>
1417 { service = k, login = v }
1418 | _ => raise Fail
1419 "String expected for account name")
1420 aa
1421 | _ => raise Fail "Array expected for accounts",
1422 providers = Provider.load_providers conf_json
1423 }
1424 end
1425
1426 fun load_project (userconfig : userconfig) rootpath use_locks : project =
1427 let val spec_file = FileBits.project_spec_path rootpath
1428 val lock_file = FileBits.project_lock_path rootpath
1429 val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ])
1430 handle OS.SysErr _ => false
1431 then ()
1432 else raise Fail ("Failed to open project spec file " ^
1433 (VextFilenames.project_file) ^ " in " ^
1434 rootpath ^
1435 ".\nPlease ensure the spec file is in the " ^
1436 "project root and run this from there.")
1437 val spec_json = JsonBits.load_json_from spec_file
1438 val lock_json = if use_locks
1439 then JsonBits.load_json_from lock_file
1440 handle IO.Io _ => Json.OBJECT []
1441 else Json.OBJECT []
1442 val extdir = JsonBits.lookup_mandatory_string spec_json
1443 ["config", "extdir"]
1444 val spec_libs = JsonBits.lookup_optional spec_json ["libs"]
1445 val lock_libs = JsonBits.lookup_optional lock_json ["libs"]
1446 val providers = Provider.load_more_providers
1447 (#providers userconfig) spec_json
1448 val libnames = case spec_libs of
1449 NONE => []
1450 | SOME (Json.OBJECT ll) => map (fn (k, v) => k) ll
1451 | _ => raise Fail "Object expected for libs"
1452 in
1453 {
1454 context = {
1455 rootpath = rootpath,
1456 extdir = extdir,
1457 providers = providers,
1458 accounts = #accounts userconfig
1459 },
1460 libs = map (load_libspec spec_json lock_json) libnames
1461 }
1462 end
1463
1464 fun save_lock_file rootpath locks =
1465 let val lock_file = FileBits.project_lock_path rootpath
1466 open Json
1467 val lock_json =
1468 OBJECT [
1469 ("libs", OBJECT
1470 (map (fn { libname, id_or_tag } =>
1471 (libname,
1472 OBJECT [ ("pin", STRING id_or_tag) ]))
1473 locks))
1474 ]
1475 in
1476 JsonBits.save_json_to lock_file lock_json
1477 end
1478
1479 fun pad_to n str =
1480 if n <= String.size str then str
1481 else pad_to n (str ^ " ")
1482
1483 fun hline_to 0 = ""
1484 | hline_to n = "-" ^ hline_to (n-1)
1485
1486 val libname_width = 25
1487 val libstate_width = 11
1488 val localstate_width = 9
1489 val notes_width = 5
1490 val divider = " | "
1491
1492 fun print_status_header () =
1493 print ("\r" ^ pad_to 80 "" ^ "\n " ^
1494 pad_to libname_width "Library" ^ divider ^
1495 pad_to libstate_width "State" ^ divider ^
1496 pad_to localstate_width "Local" ^ divider ^
1497 "Notes" ^ "\n " ^
1498 hline_to libname_width ^ "-+-" ^
1499 hline_to libstate_width ^ "-+-" ^
1500 hline_to localstate_width ^ "-+-" ^
1501 hline_to notes_width ^ "\n")
1502
1503 fun print_outcome_header () =
1504 print ("\r" ^ pad_to 80 "" ^ "\n " ^
1505 pad_to libname_width "Library" ^ divider ^
1506 pad_to libstate_width "Outcome" ^ divider ^
1507 "Notes" ^ "\n " ^
1508 hline_to libname_width ^ "-+-" ^
1509 hline_to libstate_width ^ "-+-" ^
1510 hline_to notes_width ^ "\n")
1511
1512 fun print_status with_network (libname, status) =
1513 let val libstate_str =
1514 case status of
1515 OK (ABSENT, _) => "Absent"
1516 | OK (CORRECT, _) => if with_network then "Correct" else "Present"
1517 | OK (SUPERSEDED, _) => "Superseded"
1518 | OK (WRONG, _) => "Wrong"
1519 | ERROR _ => "Error"
1520 val localstate_str =
1521 case status of
1522 OK (_, MODIFIED) => "Modified"
1523 | OK (_, UNMODIFIED) => "Clean"
1524 | _ => ""
1525 val error_str =
1526 case status of
1527 ERROR e => e
1528 | _ => ""
1529 in
1530 print (" " ^
1531 pad_to libname_width libname ^ divider ^
1532 pad_to libstate_width libstate_str ^ divider ^
1533 pad_to localstate_width localstate_str ^ divider ^
1534 error_str ^ "\n")
1535 end
1536
1537 fun print_update_outcome (libname, outcome) =
1538 let val outcome_str =
1539 case outcome of
1540 OK id => "Ok"
1541 | ERROR e => "Failed"
1542 val error_str =
1543 case outcome of
1544 ERROR e => e
1545 | _ => ""
1546 in
1547 print (" " ^
1548 pad_to libname_width libname ^ divider ^
1549 pad_to libstate_width outcome_str ^ divider ^
1550 error_str ^ "\n")
1551 end
1552
1553 fun act_and_print action print_header print_line (libs : libspec list) =
1554 let val lines = map (fn lib => (#libname lib, action lib)) libs
1555 val _ = print_header ()
1556 in
1557 app print_line lines;
1558 lines
1559 end
1560
1561 fun status_of_project ({ context, libs } : project) =
1562 ignore (act_and_print (AnyLibControl.status context)
1563 print_status_header (print_status false) libs)
1564
1565 fun review_project ({ context, libs } : project) =
1566 ignore (act_and_print (AnyLibControl.review context)
1567 print_status_header (print_status true) libs)
1568
1569 fun update_project ({ context, libs } : project) =
1570 let val outcomes = act_and_print
1571 (AnyLibControl.update context)
1572 print_outcome_header print_update_outcome libs
1573 val locks = List.concat
1574 (map (fn (libname, result) =>
1575 case result of
1576 ERROR _ => []
1577 | OK id => [{ libname = libname,
1578 id_or_tag = id
1579 }]
1580 )
1581 outcomes)
1582 in
1583 save_lock_file (#rootpath context) locks
1584 end
1585
1586 fun load_local_project use_locks =
1587 let val userconfig = load_userconfig ()
1588 val rootpath = OS.FileSys.getDir ()
1589 in
1590 load_project userconfig rootpath use_locks
1591 end
1592
1593 fun with_local_project use_locks f =
1594 (f (load_local_project use_locks); print "\n")
1595 handle Fail err => print ("ERROR: " ^ err ^ "\n")
1596 | e => print ("Failed with exception: " ^ (exnMessage e) ^ "\n")
1597
1598 fun review () = with_local_project false review_project
1599 fun status () = with_local_project false status_of_project
1600 fun update () = with_local_project false update_project
1601 fun install () = with_local_project true update_project
1602
1603 fun version () =
1604 print ("v" ^ vext_version ^ "\n");
1605
1606 fun usage () =
1607 (print "\nVext ";
1608 version ();
1609 print ("\nA simple manager for third-party source code dependencies.\n\n"
1610 ^ "Usage:\n\n"
1611 ^ " vext <command>\n\n"
1612 ^ "where <command> is one of:\n\n"
1613 ^ " review check configured libraries against their providers, and report\n"
1614 ^ " status print quick report on local status only, without using network\n"
1615 ^ " install update configured libraries according to project specs and lock file\n"
1616 ^ " update update configured libraries and lock file according to project specs\n"
1617 ^ " version print the Vext version number and exit\n\n"))
1618
1619 fun vext args =
1620 case args of
1621 ["review"] => review ()
1622 | ["status"] => status ()
1623 | ["install"] => install ()
1624 | ["update"] => update ()
1625 | ["version"] => version ()
1626 | _ => usage ()
1627
1628 fun main () =
1629 vext (CommandLine.arguments ())