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

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