Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/cm/paths/srcpath.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log 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