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