Annotation of /sml/trunk/src/cm/paths/srcpath.sml

Parent Directory | Revision Log

---

Revision 671 - (view) (download)

1 :	blume	354	(*
2 :	blume	666	* Operations over abstract names for CM source files.
3 :	blume	354	*
4 :	blume	666	* Copyright (c) 2000 by Lucent Technologies, Bell Laboratories
5 :	blume	354	*
6 :	blume	666	* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :	blume	354	*)
8 :			signature SRCPATH = sig
9 :	blume	367
10 :	blume	666	exception Format
11 :	blume	367
12 :	blume	666	type file
13 :			type dir
14 :			type env
15 :			type anchor = string
16 :			type prefile
17 :	blume	354
18 :	blume	666	type rebindings = { anchor: anchor, value: prefile } list
19 :	blume	354
20 :	blume	666	type ord_key = file
21 :
22 :			(* path comparison *)
23 :			val compare : file * file -> order
24 :
25 :			(* re-establish stability of ordering *)
26 :	blume	354	val sync : unit -> unit
27 :
28 :	blume	666	(* forget all known path names *)
29 :			val clear : unit -> unit
30 :
31 :			(* re-validate current working directory *)
32 :	blume	366	val revalidateCwd : unit -> unit
33 :
34 :	blume	666	(* make sure all servers get notified about cwd during next validation *)
35 :			val scheduleNotification : unit -> unit
36 :	blume	464
37 :	blume	666	(* new "empty" env *)
38 :			val newEnv : unit -> env
39 :	blume	354
40 :	blume	666	(* destructive updates to anchor settings (for configuration) *)
41 :			val set_anchor : env * anchor * string option -> unit (* native syntax! *)
42 :			val get_anchor : env * anchor -> string option
43 :			val reset_anchors : env -> unit
44 :	blume	366
45 :	blume	666	val processSpecFile : env * string -> unit
46 :	blume	354
47 :	blume	666	(* non-destructive bindings for anchors (for anchor scoping) *)
48 :			val bind: env -> rebindings -> env
49 :	blume	354
50 :	blume	666	(* make abstract paths *)
51 :			val native : { err: string -> unit } ->
52 :			{ context: dir, spec: string } -> prefile
53 :			val standard : { err: string -> unit, env: env } ->
54 :			{ context: dir, spec: string } -> prefile
55 :	blume	457
56 :	blume	666	(* check that there is at least one arc in after the path's context *)
57 :			val file : prefile -> file
58 :	blume	354
59 :	blume	666	(* To be able to pickle a file, turn it into a prefile first... *)
60 :			val pre : file -> prefile
61 :
62 :			(* directory paths (contexts) *)
63 :			val cwd : unit -> dir
64 :			val dir : file -> dir
65 :
66 :			(* get info out of abstract paths *)
67 :			val osstring : file -> string
68 :			val osstring' : file -> string (* use relative path if shorter *)
69 :
70 :			(* expand root anchors using given function *)
71 :			val osstring_reanchored : (anchor -> string) -> file -> string option
72 :
73 :			(* get path relative to the file's context; this will produce an
74 :			* absolute path if the original spec was not relative (i.e., if
75 :			* it was anchored or absolute) *)
76 :			val osstring_relative : file -> string
77 :
78 :			(* get name of dir *)
79 :			val osstring_dir : dir -> string
80 :
81 :			(* get a human-readable (well, sort of) description *)
82 :			val descr : file -> string
83 :
84 :			(* get a time stamp *)
85 :			val tstamp : file -> TStamp.t
86 :
87 :			(* portable encodings that avoid whitespace *)
88 :			val encode : file -> string
89 :			val decode : env -> string -> file
90 :
91 :			val pickle : { warn: bool * string -> unit } ->
92 :			{ file: prefile, relativeTo: file } -> string list
93 :
94 :			val unpickle : env -> { pickled: string list, relativeTo: file } -> prefile
95 :	blume	354	end
96 :
97 :			structure SrcPath :> SRCPATH = struct
98 :
99 :	blume	666	exception Format
100 :	blume	367
101 :	blume	666	structure P = OS.Path
102 :			structure F = OS.FileSys
103 :			structure I = FileId
104 :	blume	354
105 :	blume	666	fun impossible s = GenericVC.ErrorMsg.impossible ("SrcPath: " ^ s)
106 :	blume	354
107 :	blume	666	type anchor = string
108 :	blume	354
109 :	blume	666	type stableid = int
110 :	blume	354
111 :	blume	666	(* A pre-path is similar to the result of P.fromString except that
112 :			* we keep the list of arcs in reversed order. This makes adding
113 :			* and removing arcs at the end easier. *)
114 :			type prepath = { revarcs: string list, vol: string, isAbs: bool }
115 :	blume	354
116 :	blume	666	type elab = { pp: prepath, valid: unit -> bool }
117 :	blume	354
118 :	blume	666	type anchorval = unit -> elab
119 :
120 :			type env =
121 :			{ get_free: anchor -> elab,
122 :			set_free: anchor * prepath option -> unit,
123 :			is_set: anchor -> bool,
124 :			reset: unit -> unit,
125 :			bound: anchorval StringMap.map }
126 :			datatype dir =
127 :			CWD of { name: string, pp: prepath }
128 :			| ANCHOR of { name: anchor, look: unit -> elab }
129 :			| ROOT of string
130 :			| DIR of file0
131 :
132 :			and file0 =
133 :			PATH of { context: dir,
134 :			arcs: string list, (* at least one arc! *)
135 :			elab: elab ref,
136 :			id: I.id option ref }
137 :
138 :			type file = file0 * stableid
139 :
140 :			type prefile = { context: dir, arcs: string list, err: string -> unit }
141 :
142 :			type rebindings = { anchor: anchor, value: prefile } list
143 :
144 :			type ord_key = file
145 :
146 :			fun mk_look (e: env, a) () =
147 :			case StringMap.find (#bound e, a) of
148 :			SOME f => f ()
149 :			| NONE => #get_free e a
150 :
151 :			(* stable comparison *)
152 :			fun compare (f1: file, f2: file) = Int.compare (#2 f1, #2 f2)
153 :
154 :			val null_pp : prepath = { revarcs = [], vol = "", isAbs = false }
155 :			val bogus_elab : elab = { pp = null_pp, valid = fn _ => false }
156 :
157 :			fun string2pp n = let
158 :			val { arcs, vol, isAbs } = P.fromString n
159 :			in
160 :			{ revarcs = rev arcs, vol = vol, isAbs = isAbs }
161 :			end
162 :
163 :			val cwd_info =
164 :			let val n = F.getDir ()
165 :			in ref { name = n, pp = string2pp n }
166 :			end
167 :			val cwd_notify = ref true
168 :
169 :			fun absElab (arcs, vol) =
170 :			{ pp = { revarcs = rev arcs, vol = vol, isAbs = true },
171 :			valid = fn () => true }
172 :
173 :			fun unintern (f: file) = #1 f
174 :
175 :			fun encode0 bracket (p: file0) = let
176 :			fun needesc c = not (Char.isPrint c) orelse Char.contains "/:\\$%" c
177 :			fun esc c =
178 :			"\\" ^ StringCvt.padLeft #"0" 3 (Int.toString (Char.ord c))
179 :			fun tc c = if needesc c then esc c else String.str c
180 :			val ta = String.translate tc
181 :			val (dot, dotdot) = let
182 :			val ta' = String.translate esc
183 :			in
184 :			(ta' ".", ta' "..")
185 :			end
186 :			fun arc a =
187 :			if a = P.currentArc then "."
188 :			else if a = P.parentArc then ".."
189 :			else if a = "." then dot
190 :			else if a = ".." then dotdot
191 :			else ta a
192 :			fun e_p (PATH { arcs, context, ... }, ctxt, a) =
193 :			let val l = rev arcs
194 :			val l = if ctxt andalso bracket then
195 :			concat ["(", List.hd l, ")"] :: List.tl l
196 :			else l
197 :			val a = case l of
198 :			[] => a
199 :			| h :: t =>
200 :			foldl (fn (x, l) => arc x :: "/" :: l)
201 :			(arc h :: a) t
202 :			in e_c (context, a)
203 :			end
204 :			and e_c (ROOT "", a) = concat ("/" :: a)
205 :			| e_c (ROOT vol, a) = concat ("%" :: ta vol :: "/" :: a)
206 :			| e_c (CWD _, a) = concat a
207 :			| e_c (ANCHOR x, a) = concat ("$" :: ta (#name x) :: "/" :: a)
208 :			| e_c (DIR p, a) = e_p (p, true, ":" :: a)
209 :			in
210 :			e_p (p, false, [])
211 :			end
212 :
213 :			val encode = encode0 false o unintern
214 :
215 :			fun revalidateCwd () = let
216 :			val { name = n, pp } = !cwd_info
217 :			val n' = F.getDir ()
218 :			val pp' = string2pp n'
219 :			in
220 :			if n = n' then ()
221 :			else (cwd_info := { name = n', pp = pp' };
222 :			cwd_notify := true);
223 :			if !cwd_notify then
224 :			let val p = PATH { arcs = rev (#revarcs pp),
225 :			context = ROOT (#vol pp),
226 :			elab = ref bogus_elab, id = ref NONE }
227 :	blume	354	in
228 :	blume	666	Servers.cd (encode0 false p);
229 :			cwd_notify := false
230 :	blume	354	end
231 :	blume	666	else ()
232 :			end
233 :	blume	354
234 :	blume	666	fun scheduleNotification () = cwd_notify := true
235 :	blume	354
236 :	blume	666	fun dirPP { revarcs = _ :: revarcs, vol, isAbs } =
237 :			{ revarcs = revarcs, vol = vol, isAbs = isAbs }
238 :			| dirPP _ = impossible "dirPP"
239 :	blume	354
240 :	blume	666	fun dirElab { pp, valid } = { pp = dirPP pp, valid = valid }
241 :
242 :			fun augPP arcs { revarcs, vol, isAbs } =
243 :			{ revarcs = List.revAppend (arcs, revarcs), vol = vol, isAbs = isAbs }
244 :
245 :			fun augElab arcs { pp, valid } = { pp = augPP arcs pp, valid = valid }
246 :
247 :			fun elab_dir (CWD { name, pp }) =
248 :			let fun valid () = name = #name (!cwd_info)
249 :			in
250 :			if valid () then { pp = null_pp, valid = valid }
251 :			else { pp = pp, valid = fn () => true }
252 :			end
253 :			| elab_dir (ANCHOR { name, look }) = look ()
254 :			| elab_dir (ROOT vol) = absElab ([], vol)
255 :			| elab_dir (DIR p) = dirElab (elab_file p)
256 :
257 :			and elab_file (PATH { context, arcs, elab, id }) =
258 :			let val e as { pp, valid } = !elab
259 :			in
260 :			if valid () then e
261 :			else let val e' = augElab arcs (elab_dir context)
262 :			in elab := e'; id := NONE; e'
263 :			end
264 :			end
265 :
266 :			fun pp2name { revarcs, vol, isAbs } =
267 :			P.toString { arcs = rev revarcs, vol = vol, isAbs = isAbs }
268 :
269 :			fun idOf (p as PATH { id, ... }) =
270 :			let val { pp, ... } = elab_file p
271 :			in
272 :			case !id of
273 :			SOME i => i
274 :			| NONE => let
275 :			val i = I.fileId (pp2name pp)
276 :			in
277 :			id := SOME i; i
278 :			end
279 :			end
280 :
281 :			fun compare0 (f1, f2) = I.compare (idOf f1, idOf f2)
282 :
283 :			structure F0M = MapFn (type ord_key = file0 val compare = compare0)
284 :
285 :			local
286 :			val known = ref (F0M.empty: int F0M.map)
287 :			val next = ref 0
288 :			in
289 :			fun clear () = known := F0M.empty
290 :
291 :			fun intern f =
292 :			case F0M.find (!known, f) of
293 :			SOME i => (f, i)
294 :			| NONE => let
295 :			val i = !next
296 :			in
297 :			next := i + 1;
298 :			known := F0M.insert (!known, f, i);
299 :			(f, i)
300 :			end
301 :
302 :			fun sync () = let
303 :			val km = !known
304 :			fun inval (PATH { id, ... }, _) = id := NONE
305 :			fun reinsert (k, v, m) = F0M.insert (m, k, v)
306 :			in
307 :			F0M.appi inval km;
308 :			known := F0M.foldli reinsert F0M.empty km
309 :			end
310 :			end
311 :
312 :			val dir0 = DIR
313 :			val dir = dir0 o unintern
314 :
315 :			fun cwd () = (revalidateCwd (); CWD (!cwd_info))
316 :
317 :			val osstring = pp2name o #pp o elab_file o unintern
318 :
319 :			val descr = encode0 true o unintern
320 :
321 :	blume	671	fun osstring_dir d =
322 :			case pp2name (#pp (elab_dir d)) of
323 :			"" => P.currentArc
324 :			| s => s
325 :	blume	666
326 :			fun osstring' f = let
327 :			val oss = osstring f
328 :			in
329 :			if P.isAbsolute oss then
330 :			let val ross =
331 :			P.mkRelative { path = oss, relativeTo = #name (!cwd_info) }
332 :			in
333 :			if size ross < size oss then ross else oss
334 :			end
335 :			else oss
336 :			end
337 :
338 :			fun newEnv () = let
339 :			val freeMap = ref StringMap.empty
340 :			fun fetch a =
341 :			case StringMap.find (!freeMap, a) of
342 :			SOME x => x
343 :			| NONE => let
344 :			val validity = ref true
345 :			val pp = { revarcs = [concat ["$Undef<", a, ">"]],
346 :			vol = "", isAbs = false }
347 :			val x = (pp, validity)
348 :			in
349 :			freeMap := StringMap.insert (!freeMap, a, x);
350 :			x
351 :			end
352 :			fun get_free a = let
353 :			val (pp, validity) = fetch a
354 :			in
355 :			{ pp = pp, valid = fn () => !validity }
356 :			end
357 :			fun set_free (a, ppo) = let
358 :			val (_, validity) = fetch a
359 :			in
360 :			validity := false; (* invalidate earlier elabs *)
361 :			freeMap :=
362 :			(case ppo of
363 :			NONE => #1 (StringMap.remove (!freeMap, a))
364 :			| SOME pp => StringMap.insert (!freeMap, a, (pp, ref true)))
365 :			end
366 :			fun is_set a = StringMap.inDomain (!freeMap, a)
367 :			fun reset () = let
368 :			fun invalidate (_, validity) = validity := false
369 :			in
370 :			StringMap.app invalidate (!freeMap);
371 :			freeMap := StringMap.empty
372 :			end
373 :			in
374 :			{ get_free = get_free, set_free = set_free, is_set = is_set,
375 :			reset = reset, bound = StringMap.empty } : env
376 :			end
377 :
378 :			fun get_anchor (e: env, a) =
379 :			if #is_set e a then SOME (pp2name (#pp (#get_free e a))) else NONE
380 :
381 :			fun set0 mkAbsolute (e: env, a, so) = let
382 :			fun name2pp s = string2pp (if P.isAbsolute s then s else mkAbsolute s)
383 :			in
384 :			#set_free e (a, Option.map name2pp so);
385 :			sync ()
386 :			end
387 :
388 :			fun set_anchor x =
389 :			set0 (fn n => P.mkAbsolute { path = n, relativeTo = F.getDir () }) x
390 :
391 :			fun reset_anchors (e: env) = (#reset e (); sync ())
392 :
393 :			fun processSpecFile (e, f) = let
394 :			val d = P.dir (F.fullPath f)
395 :			fun set x = set0 (fn n => P.mkAbsolute { path = n, relativeTo = d }) x
396 :			fun work s = let
397 :			fun loop () = let
398 :			val line = TextIO.inputLine s
399 :			in
400 :			if line = "" then ()
401 :			else if String.sub (line, 0) = #"#" then loop ()
402 :			else case String.tokens Char.isSpace line of
403 :			[a, d] => (set (e, a, SOME d); loop ())
404 :			| ["-"] => (reset_anchors e; loop ())
405 :			| [a] => (set_anchor (e, a, NONE); loop ())
406 :			| [] => loop ()
407 :			| _ => (Say.say [f, ": malformed line (ignored)\n"];
408 :			loop ())
409 :			end
410 :			in
411 :			loop ()
412 :			end
413 :			in
414 :			SafeIO.perform { openIt = fn () => TextIO.openIn f,
415 :			closeIt = TextIO.closeIn,
416 :			work = work,
417 :			cleanup = fn _ => () }
418 :			end
419 :
420 :			datatype stdspec =
421 :			RELATIVE of string list
422 :			| ABSOLUTE of string list
423 :			| ANCHORED of anchor * string list
424 :
425 :			fun parseStdspec err s = let
426 :			fun delim #"/" = true
427 :			| delim #"\\" = true
428 :			| delim _ = false
429 :			fun transl ".." = P.parentArc
430 :			| transl "." = P.currentArc
431 :			| transl arc = arc
432 :			val impossible = fn s => impossible ("AbsPath.parseStdspec: " ^ s)
433 :			in
434 :			case map transl (String.fields delim s) of
435 :			[""] => impossible "zero-length name"
436 :			| [] => impossible "no fields"
437 :			| "" :: arcs => ABSOLUTE arcs
438 :			| arcs as (["$"] | "$" :: "" :: _) =>
439 :			(err (concat ["invalid zero-length anchor name in: `", s, "'"]);
440 :			RELATIVE arcs)
441 :			| "$" :: (arcs as (arc1 :: _)) => ANCHORED (arc1, arcs)
442 :			| arcs as (arc1 :: arcn) =>
443 :			if String.sub (arc1, 0) <> #"$" then RELATIVE arcs
444 :			else ANCHORED (String.extract (arc1, 1, NONE), arcn)
445 :			end
446 :
447 :			fun bind env l = let
448 :			fun b ({ anchor, value = { arcs, context, err } }, e: env) =
449 :			{ get_free = #get_free e, set_free = #set_free e,
450 :			reset = #reset e, is_set = #is_set e,
451 :			bound = StringMap.insert
452 :			(#bound e, anchor,
453 :			fn () => augElab arcs (elab_dir context)) }
454 :			in
455 :			foldl b env l
456 :			end
457 :
458 :			fun file0 ({ context, arcs, err }: prefile) =
459 :			PATH { context = context, elab = ref bogus_elab, id = ref NONE,
460 :			arcs = (case arcs of
461 :			[] => (err (concat
462 :			["path needs at least one arc relative to `",
463 :			pp2name (#pp (elab_dir context)), "'"]);
464 :			["<bogus>"])
465 :			| _ => arcs) }
466 :
467 :			val file = intern o file0
468 :			fun pre0 (PATH { arcs, context, ... }) =
469 :			{ arcs = arcs, context = context, err = fn (_: string) => () }
470 :			val pre = pre0 o unintern
471 :
472 :			fun prefile (c, l, e) = { context = c, arcs = l, err = e }
473 :
474 :			(* env argument is not used -- it's just there for uniformity *)
475 :			fun native { err } { context, spec } =
476 :			case P.fromString spec of
477 :			{ arcs, vol, isAbs = true } => prefile (ROOT vol, arcs, err)
478 :			| { arcs, ... } => prefile (context, arcs, err)
479 :
480 :			fun standard { env, err } { context, spec } =
481 :			case parseStdspec err spec of
482 :			RELATIVE l => prefile (context, l, err)
483 :			| ABSOLUTE l => prefile (ROOT "", l, err)
484 :			| ANCHORED (a, l) =>
485 :			prefile (ANCHOR { name = a, look = mk_look (env, a) }, l, err)
486 :
487 :			fun osstring_reanchored anchor f = let
488 :			fun path (PATH { context, arcs, ... }) =
489 :			Option.map (augPP arcs) (ctxt context)
490 :			and ctxt (CWD _) = NONE
491 :			| ctxt (ROOT _) = NONE
492 :			| ctxt (DIR p) = Option.map dirPP (path p)
493 :			| ctxt (ANCHOR { name, ... }) = SOME (string2pp (anchor name))
494 :			in
495 :			Option.map pp2name (path (unintern f))
496 :			end
497 :
498 :			fun osstring_relative (p as (PATH { arcs, context, ... }, _)) =
499 :			case context of
500 :			DIR _ => P.toString { arcs = arcs, vol = "", isAbs = false }
501 :			| _ => osstring p
502 :
503 :			fun tstamp f = TStamp.fmodTime (osstring f)
504 :
505 :			fun pickle { warn } { file = (f: prefile), relativeTo = (gf, _) } = let
506 :			val warn =
507 :			fn flag =>
508 :			warn (flag,
509 :			(* HACK! We are cheating here, turning the prefile into
510 :			* a file even when there are no arcs. This is ok
511 :			* because of (bracket = false) for encode0. *)
512 :			encode0 false (PATH { arcs = #arcs f,
513 :			context = #context f,
514 :			elab = ref bogus_elab,
515 :			id = ref NONE }))
516 :			fun p_p p = p_pf (pre0 p)
517 :			and p_pf { arcs, context, err } =
518 :			P.toString { arcs = arcs, vol = "", isAbs = false } :: p_c context
519 :			and p_c (ROOT vol) = (warn true; [vol, "r"])
520 :			| p_c (CWD _) = impossible "pickle: CWD"
521 :			| p_c (ANCHOR { name, ... }) = [name, "a"]
522 :			| p_c (DIR p) = if compare0 (p, gf) = EQUAL then (warn false; ["c"])
523 :			else p_p p
524 :			in
525 :			p_pf f
526 :			end
527 :
528 :			fun unpickle env { pickled, relativeTo } = let
529 :			fun u_pf (s :: l) =
530 :			(case P.fromString s of
531 :			{ arcs, vol = "", isAbs = false } =>
532 :			prefile (u_c l, arcs, fn _ => raise Format)
533 :			| _ => raise Format)
534 :			| u_pf _ = raise Format
535 :			and u_p l = file0 (u_pf l)
536 :			and u_c [vol, "r"] = ROOT vol
537 :			| u_c ["c"] = dir relativeTo
538 :			| u_c [n, "a"] = ANCHOR { name = n, look = mk_look (env, n) }
539 :			| u_c l = DIR (u_p l)
540 :			in
541 :			u_pf pickled
542 :			end
543 :
544 :			fun decode env s = let
545 :			fun isChar (c1: char) c2 = c1 = c2
546 :			fun unesc s = let
547 :			val dc = Char.chr o valOf o Int.fromString o implode
548 :			fun loop ([], r) = String.implode (rev r)
549 :			| loop (#"\\" :: d0 :: d1 :: d2 :: l, r) =
550 :			(loop (l, dc [d0, d1, d2] :: r)
551 :			handle _ => loop (l, d2 :: d1 :: d0 :: #"\\" :: r))
552 :			| loop (c :: l, r) = loop (l, c :: r)
553 :			in
554 :			loop (String.explode s, [])
555 :			end
556 :			fun arc "." = P.currentArc
557 :			| arc ".." = P.parentArc
558 :			| arc a = unesc a
559 :			fun file (c, l) =
560 :			file0 (prefile (c, l, fn s => raise Fail ("SrcPath.decode: " ^ s)))
561 :			fun addseg (seg, p) =
562 :			file (dir0 p, map arc (String.fields (isChar #"/") seg))
563 :			fun doseg0 s =
564 :			case String.fields (isChar #"/") s of
565 :			[] => impossible "decode: no fields in segment 0"
566 :			| arc0 :: arcs => let
567 :			val arcs = map arc arcs
568 :			fun xtr () = unesc (String.extract (arc0, 1, NONE))
569 :			in
570 :			if arc0 = "" then file (ROOT "", arcs)
571 :			else
572 :			case String.sub (arc0, 0) of
573 :			#"%" => file (ROOT (xtr ()), arcs)
574 :			| #"$" => let
575 :			val n = xtr ()
576 :			in
577 :			file (ANCHOR { name = n,
578 :			look = mk_look (env, n) }, arcs)
579 :			end
580 :			| _ => file (cwd (), arc arc0 :: arcs)
581 :			end
582 :			in
583 :			case String.fields (isChar #":") s of
584 :			[] => impossible "decode: no segments"
585 :			| seg0 :: segs => intern (foldl addseg (doseg0 seg0) segs)
586 :			end
587 :	blume	354	end

---

root@smlnj-gforge.cs.uchicago.edu	ViewVC Help
Powered by ViewVC 1.0.0