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