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/abspath.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 369 - (view) (download)

1 : blume 265 (*
2 : blume 267 * Operations over abstract path names.
3 : blume 265 *
4 : blume 267 * Copyright (c) 1999 by Lucent Technologies, Bell Laboratories
5 : blume 265 *
6 : blume 267 * Author: Matthias Blume (blume@cs.princeton.edu)
7 : blume 265 *)
8 :     signature ABSPATH = sig
9 :    
10 : blume 367 exception Format (* if something is seriously wrong with a pickle *)
11 :     exception BadAnchor of string (* if anchor cannot be resolved *)
12 :    
13 : blume 270 type context
14 : blume 265 type t
15 : blume 305 type ord_key = t
16 : blume 265
17 : blume 366 val newEra : unit -> unit
18 : blume 265 val revalidateCwd : unit -> unit
19 :    
20 : blume 270 val cwdContext: unit -> context
21 : blume 353 val sameDirContext: t -> context
22 : blume 270
23 : blume 354 val osstring : t -> string
24 :     val descr : t -> string
25 : blume 265 val compare : t * t -> order
26 : blume 353 val contextOf : t -> context
27 :     val specOf : t -> string
28 : blume 272 val contextName : context -> string
29 : blume 265
30 : blume 352 (* Replace the anchor context in the path argument with the
31 :     * given context. Returns NONE if there was no anchor context. *)
32 : blume 354 val reAnchoredName : t * string -> string option
33 : blume 352
34 : blume 270 val native : { context: context, spec: string } -> t
35 : blume 318 val standard : PathConfig.mode -> { context: context, spec: string } -> t
36 : blume 268
37 : blume 353 (* the second path argument is the path of the group spec that
38 :     * pickling is based upon. *)
39 : blume 340 val pickle : (bool -> unit) -> t * t -> string list
40 : blume 367 val unpickle : PathConfig.mode -> string list * t -> t
41 : blume 305
42 : blume 274 val tstamp : t -> TStamp.t
43 : blume 265 end
44 :    
45 :     structure AbsPath :> ABSPATH = struct
46 :    
47 :     structure P = OS.Path
48 :     structure F = OS.FileSys
49 : blume 340 val impossible = GenericVC.ErrorMsg.impossible
50 : blume 265
51 : blume 367 exception Format
52 :     exception BadAnchor of string
53 :    
54 : blume 265 (* unique file id that can handle absent files *)
55 :     datatype id =
56 :     PRESENT of F.file_id
57 :     | ABSENT of string
58 :    
59 :     (* comparison of unique file ids *)
60 :     fun compareId (PRESENT fid, PRESENT fid') = F.compare (fid, fid')
61 :     | compareId (ABSENT _, PRESENT _) = LESS
62 :     | compareId (PRESENT _, ABSENT _) = GREATER
63 :     | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
64 :    
65 : blume 270 fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f)
66 : blume 265
67 :     type elaboration = { stamp : unit ref,
68 :     name : string,
69 :     id : id option ref }
70 : blume 270
71 : blume 265 (* When a relative name is to be looked up wrt. CUR:
72 :     * - if the cwd hasn't changed since, then use relative path
73 :     * - if the cwd has changed, then make absolute path using name
74 :     * If we come back to the original dir, then ideally we should
75 :     * re-validate the stamp, but that would require having a cwd
76 :     * history -- and, thus, is probably not worth the effort.
77 :     *)
78 :    
79 :     type cwdinfo = { stamp: unit ref, name: string, id: id }
80 : blume 270
81 :     datatype context =
82 : blume 353 THEN_CWD of cwdinfo
83 : blume 265 | CONFIG_ANCHOR of { fetch: unit -> string,
84 : blume 304 cache: elaboration option ref,
85 :     config_name: string }
86 : blume 353 | DIR_OF of t
87 : blume 352 | ROOT
88 : blume 270
89 : blume 324 and t =
90 : blume 270 PATH of { context: context,
91 : blume 265 spec: string,
92 :     cache: elaboration option ref }
93 :    
94 : blume 305 type ord_key = t
95 :    
96 : blume 265 local
97 :     val cwdInfoCache : cwdinfo option ref = ref NONE
98 :     fun cwdInfo () =
99 :     case !cwdInfoCache of
100 :     SOME i => i
101 :     | NONE => let
102 :     val stamp = ref ()
103 :     val name = F.getDir ()
104 :     val id = PRESENT (F.fileId name)
105 :     val i = { stamp = stamp, name = name, id = id }
106 :     in
107 :     cwdInfoCache := SOME i;
108 :     i
109 :     end
110 :     val cwdStamp = #stamp o cwdInfo
111 :     val cwdName = #name o cwdInfo
112 :     val cwdId = #id o cwdInfo
113 :     in
114 :     (* start a new era (i.e., invalidate all previous elaborations) *)
115 : blume 369 val newEra = Era.newEra
116 : blume 265
117 :     (* make sure the cwd is consistent *)
118 :     fun revalidateCwd () =
119 :     case !cwdInfoCache of
120 :     NONE => ignore (cwdInfo ())
121 :     | SOME { name, id, ... } => let
122 :     val name' = F.getDir ()
123 :     val id' = PRESENT (F.fileId name')
124 :     in
125 :     if compareId (id, id') <> EQUAL then
126 :     (newEra ();
127 :     cwdInfoCache := SOME { stamp = ref (),
128 :     name = name', id = id' })
129 :     else ()
130 :     end
131 :    
132 : blume 270 fun cwdContext () =
133 : blume 366 (revalidateCwd ();
134 :     THEN_CWD { stamp = cwdStamp (),
135 :     name = cwdName (),
136 :     id = cwdId () })
137 : blume 270
138 : blume 353 fun sameDirContext p = DIR_OF p
139 : blume 270
140 :     fun mkElab (cache, name) = let
141 :     val e : elaboration =
142 : blume 369 { stamp = Era.thisEra (), name = name, id = ref NONE }
143 : blume 265 in
144 : blume 270 cache := SOME e; e
145 :     end
146 :    
147 :     fun validElab NONE = NONE
148 :     | validElab (SOME (e as { stamp, name, id })) =
149 : blume 369 if Era.isThisEra stamp then SOME e else NONE
150 : blume 270
151 : blume 352 val rootName = P.toString { isAbs = true, arcs = [], vol = "" }
152 : blume 353 val rootId = ref (NONE: id option)
153 : blume 352
154 : blume 270 fun elabContext c =
155 :     case c of
156 : blume 353 THEN_CWD { stamp, name, id } =>
157 : blume 369 { stamp = Era.thisEra (), id = ref (SOME id),
158 : blume 353 name = if stamp = cwdStamp () orelse name = cwdName ()
159 : blume 270 then P.currentArc else name }
160 : blume 304 | CONFIG_ANCHOR { fetch, cache, config_name } =>
161 : blume 270 (case validElab (!cache) of
162 :     SOME e => e
163 :     | NONE => mkElab (cache, fetch ()))
164 : blume 353 | DIR_OF p => let
165 :     val { name, stamp, ... } = elab p
166 :     in
167 :     { name = P.dir name, stamp = stamp, id = ref NONE }
168 :     end
169 : blume 369 | ROOT => { stamp = Era.thisEra (),
170 :     name = rootName, id = rootId }
171 : blume 265
172 : blume 305 and elab (PATH { context, spec, cache }) =
173 : blume 353 case validElab (!cache) of
174 :     SOME e => e
175 : blume 357 | NONE => mkElab (cache,
176 :     P.mkCanonical (P.concat
177 :     (#name (elabContext context), spec)))
178 : blume 270
179 : blume 265 (* get the file id (calls elab, so don't cache externally!) *)
180 :     fun id p = let
181 :     val { id, name, ... } = elab p
182 :     in
183 :     case !id of
184 :     NONE => let
185 :     val i = getId name
186 :     in
187 :     id := SOME i; i
188 :     end
189 :     | SOME i => i
190 :     end
191 :    
192 :     (* get the name as a string (calls elab, so don't cache externally!) *)
193 : blume 354 fun osstring p = #name (elab p)
194 : blume 265
195 : blume 272 (* get the context back *)
196 : blume 353 fun contextOf (PATH { context = c, ... }) = c
197 : blume 272 fun contextName c = #name (elabContext c)
198 :    
199 :     (* get the spec back *)
200 : blume 353 fun specOf (PATH { spec = s, ... }) = s
201 : blume 272
202 : blume 265 (* compare pathnames efficiently *)
203 :     fun compare (p1, p2) = compareId (id p1, id p2)
204 :    
205 : blume 305 fun fresh (context, spec) =
206 :     PATH { context = context, spec = spec, cache = ref NONE }
207 : blume 265
208 : blume 268 (* make an abstract path from a native string *)
209 : blume 352 fun native { spec, context } = let
210 :     val { isAbs, vol, arcs } = P.fromString spec
211 :     val relSpec = P.toString { isAbs = false, vol = vol, arcs = arcs }
212 :     in
213 :     if isAbs then fresh (ROOT, relSpec)
214 :     else fresh (context, relSpec)
215 :     end
216 : blume 268
217 : blume 265 (* make an abstract path from a standard string *)
218 : blume 318 fun standard mode { spec, context } = let
219 : blume 265 fun delim #"/" = true
220 :     | delim #"\\" = true (* accept DOS-style, too *)
221 :     | delim _ = false
222 :    
223 : blume 353 fun transl ".." = P.parentArc
224 :     | transl "." = P.currentArc
225 : blume 265 | transl arc = arc
226 :    
227 : blume 352 fun mk (arcs, context) =
228 : blume 268 fresh (context,
229 : blume 352 P.toString { isAbs = false, vol = "",
230 : blume 305 arcs = map transl arcs })
231 : blume 265 in
232 :     case String.fields delim spec of
233 : blume 353 [""] => impossible "AbsPath.standard: zero-length name"
234 :     | "" :: arcs => mk (arcs, ROOT)
235 :     | [] => impossible "AbsPath.standard: no fields"
236 : blume 304 | arcs as (arc1 :: _) =>
237 : blume 318 (case PathConfig.configAnchor mode arc1 of
238 : blume 352 NONE => mk (arcs, context)
239 : blume 265 | SOME fetch => let
240 :     val anchorcontext =
241 :     CONFIG_ANCHOR { fetch = fetch,
242 : blume 304 cache = ref NONE,
243 :     config_name = arc1 }
244 : blume 265 in
245 : blume 352 mk (arcs, anchorcontext)
246 : blume 265 end)
247 :     end
248 : blume 268
249 : blume 305 (* make a pickle-string *)
250 : blume 353 fun pickle warn (path, gpath) = let
251 :     fun p_p (PATH { spec, context, ... }) =
252 :     spec :: p_c context
253 :     and p_c ROOT = (warn true; ["r"])
254 :     | p_c (THEN_CWD _) = impossible "AbsPath.pickle: THEN_CWD"
255 :     | p_c (CONFIG_ANCHOR { config_name = n, ... }) = [n, "a"]
256 :     | p_c (DIR_OF p) =
257 :     if compare (p, gpath) = EQUAL then (warn false; ["c"])
258 :     else p_p p
259 : blume 305 in
260 : blume 340 p_p path
261 : blume 305 end
262 :    
263 : blume 353 fun unpickle mode (l, gpath) = let
264 :     fun u_p (s :: l) =
265 : blume 367 PATH { spec = s, context = u_c l, cache = ref NONE }
266 :     | u_p [] = raise Format
267 :     and u_c ["r"] = ROOT
268 :     | u_c ["c"] = DIR_OF gpath
269 : blume 353 | u_c [n, "a"] =
270 : blume 318 (case PathConfig.configAnchor mode n of
271 : blume 367 NONE => raise BadAnchor n
272 : blume 353 | SOME fetch =>
273 : blume 367 CONFIG_ANCHOR { config_name = n,
274 :     fetch = fetch,
275 :     cache = ref NONE })
276 :     | u_c l = DIR_OF (u_p l)
277 : blume 305 in
278 : blume 353 u_p l
279 : blume 305 end
280 :    
281 : blume 354 fun tstamp p = TStamp.fmodTime (osstring p)
282 : blume 268
283 : blume 354 fun descr (PATH { spec, context, ... }) = let
284 :     fun dir (x, l) =
285 : blume 357 case P.dir x of
286 : blume 354 "" => l
287 :     | d => d :: "/" :: l
288 :     fun d_c (CONFIG_ANCHOR { config_name = n, ... }, l) =
289 :     "$" :: n :: "/" :: l
290 :     | d_c (DIR_OF (PATH { spec, context, ... }), l) =
291 :     d_c (context, dir (spec, l))
292 :     | d_c (THEN_CWD _, l) = "./" :: l
293 :     | d_c (ROOT, l) = "/" :: l
294 : blume 274 in
295 : blume 354 concat (d_c (context, [spec]))
296 : blume 274 end
297 : blume 275
298 : blume 354 fun reAnchoredName (p, dirstring) = let
299 :     fun path (PATH { context, spec, ... }) = let
300 :     fun mk c = P.concat (c, spec)
301 :     in
302 :     Option.map mk (ctxt context)
303 :     end
304 :     and ctxt (CONFIG_ANCHOR { config_name = n, ... }) =
305 :     SOME (P.concat (dirstring, n))
306 :     | ctxt (DIR_OF p) = Option.map P.dir (path p)
307 :     | ctxt (THEN_CWD _) = (Say.say ["."]; NONE)
308 :     | ctxt ROOT = (Say.say ["/"]; NONE)
309 : blume 275 in
310 : blume 354 Option.map P.mkCanonical (path p)
311 : blume 275 end
312 : blume 265 end
313 :     end

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