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

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