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 268 - (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 :     type t
11 :    
12 :     val revalidateCwd : unit -> unit
13 :    
14 :     val name : t -> string
15 :     val compare : t * t -> order
16 :    
17 :     val native : { context: t, spec: string } -> t
18 :     val standard : { context: t, spec: string } -> t
19 : blume 268
20 :     val joinDirFile : { dir: t, file: string } -> t
21 :     val splitDirFile : t -> { dir: t, file: string }
22 :     val dir : t -> t
23 :     val file : t -> string
24 : blume 265 end
25 :    
26 :     structure AbsPath :> ABSPATH = struct
27 :    
28 :     structure P = OS.Path
29 :     structure F = OS.FileSys
30 :    
31 :     (* unique file id that can handle absent files *)
32 :     datatype id =
33 :     PRESENT of F.file_id
34 :     | ABSENT of string
35 :    
36 :     (* comparison of unique file ids *)
37 :     fun compareId (PRESENT fid, PRESENT fid') = F.compare (fid, fid')
38 :     | compareId (ABSENT _, PRESENT _) = LESS
39 :     | compareId (PRESENT _, ABSENT _) = GREATER
40 :     | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
41 :    
42 :     fun getId f = PRESENT (F.fileId f) handle _ => ABSENT f
43 :    
44 :     type elaboration = { stamp : unit ref,
45 :     name : string,
46 :     id : id option ref }
47 :    
48 :     (* When a relative name is to be looked up wrt. CUR:
49 :     * - if the cwd hasn't changed since, then use relative path
50 :     * - if the cwd has changed, then make absolute path using name
51 :     * If we come back to the original dir, then ideally we should
52 :     * re-validate the stamp, but that would require having a cwd
53 :     * history -- and, thus, is probably not worth the effort.
54 :     *)
55 :    
56 :     type cwdinfo = { stamp: unit ref, name: string, id: id }
57 :     datatype t =
58 :     CUR of cwdinfo
59 :     | CONFIG_ANCHOR of { fetch: unit -> string,
60 :     cache: elaboration option ref }
61 :     | SPEC of { context: t,
62 :     spec: string,
63 :     cache: elaboration option ref }
64 :    
65 :     local
66 :     val elabStamp = ref (ref ())
67 :     val cwdInfoCache : cwdinfo option ref = ref NONE
68 :     fun cwdInfo () =
69 :     case !cwdInfoCache of
70 :     SOME i => i
71 :     | NONE => let
72 :     val stamp = ref ()
73 :     val name = F.getDir ()
74 :     val id = PRESENT (F.fileId name)
75 :     val i = { stamp = stamp, name = name, id = id }
76 :     in
77 :     cwdInfoCache := SOME i;
78 :     i
79 :     end
80 :     val cwdStamp = #stamp o cwdInfo
81 :     val cwdName = #name o cwdInfo
82 :     val cwdId = #id o cwdInfo
83 :     fun invalidateCwdInfo () = cwdInfoCache := NONE
84 :     in
85 :     (* start a new era (i.e., invalidate all previous elaborations) *)
86 :     fun newEra () = elabStamp := ref ()
87 :    
88 :     (* make sure the cwd is consistent *)
89 :     fun revalidateCwd () =
90 :     case !cwdInfoCache of
91 :     NONE => ignore (cwdInfo ())
92 :     | SOME { name, id, ... } => let
93 :     val name' = F.getDir ()
94 :     val id' = PRESENT (F.fileId name')
95 :     in
96 :     if compareId (id, id') <> EQUAL then
97 :     (newEra ();
98 :     cwdInfoCache := SOME { stamp = ref (),
99 :     name = name', id = id' })
100 :     else ()
101 :     end
102 :    
103 :     (* elaborate a path -- uses internal caching, don't cache
104 :     * results externally! *)
105 :     fun elab p = let
106 :     fun mkElab (cache, name) = let
107 :     val e = { stamp = !elabStamp, name = name, id = ref NONE }
108 :     in
109 :     cache := SOME e; e
110 :     end
111 :     fun resolve_anchor { fetch, cache } = mkElab (cache, fetch ())
112 :     fun resolve_spec { context, spec, cache } = let
113 :     val name =
114 :     if P.isAbsolute spec then spec
115 :     else P.mkCanonical (P.concat (#name (elab context), spec))
116 :     in
117 :     mkElab (cache, name)
118 :     end
119 :     in
120 :     case p of
121 :     CUR { stamp, name, id } =>
122 :     { stamp = !elabStamp, id = ref (SOME id),
123 :     name = if stamp = cwdStamp ()
124 :     orelse name = cwdName () then
125 :     P.currentArc
126 :     else name }
127 :     | CONFIG_ANCHOR (a as { cache = ref NONE, ... }) =>
128 :     resolve_anchor a
129 :     | CONFIG_ANCHOR (a as { cache = ref (SOME (e as { stamp, ... })),
130 :     ... }) =>
131 :     if stamp = !elabStamp then e else resolve_anchor a
132 :     | SPEC (s as { cache = ref NONE, ... }) =>
133 :     resolve_spec s
134 :     | SPEC (s as { cache = ref (SOME (e as { stamp, ... })), ...}) =>
135 :     if stamp = !elabStamp then e else resolve_spec s
136 :     end
137 :    
138 :     (* get the file id (calls elab, so don't cache externally!) *)
139 :     fun id p = let
140 :     val { id, name, ... } = elab p
141 :     in
142 :     case !id of
143 :     NONE => let
144 :     val i = getId name
145 :     in
146 :     id := SOME i; i
147 :     end
148 :     | SOME i => i
149 :     end
150 :    
151 :     (* get the name as a string (calls elab, so don't cache externally!) *)
152 :     fun name p = #name (elab p)
153 :    
154 :     (* compare pathnames efficiently *)
155 :     fun compare (p1, p2) = compareId (id p1, id p2)
156 :    
157 : blume 268 fun fresh (context, spec) =
158 : blume 265 SPEC { context = context, spec = spec, cache = ref NONE }
159 :    
160 : blume 268 (* make an abstract path from a native string *)
161 :     fun native { spec, context } = fresh (context, spec)
162 :    
163 : blume 265 (* make an abstract path from a standard string *)
164 :     fun standard { spec, context } = let
165 :     fun delim #"/" = true
166 :     | delim #"\\" = true (* accept DOS-style, too *)
167 :     | delim _ = false
168 :    
169 :     fun transl ".." = OS.Path.parentArc
170 :     | transl "." = OS.Path.currentArc
171 :     | transl arc = arc
172 :    
173 :     fun mk (isAbs, arcs, context) =
174 : blume 268 fresh (context,
175 :     P.toString { isAbs = isAbs, vol = "",
176 :     arcs = map transl arcs })
177 : blume 265 in
178 :     case String.fields delim spec of
179 :     "" :: arcs => mk (true, arcs, context)
180 :     | [] => mk (false, [], context)
181 :     | arcs as (arc1 :: arcn) =>
182 :     (case PathConfig.configAnchor arc1 of
183 :     NONE => mk (false, arcs, context)
184 :     | SOME fetch => let
185 :     val anchorcontext =
186 :     CONFIG_ANCHOR { fetch = fetch,
187 :     cache = ref NONE }
188 :     in
189 :     mk (false, arcn, anchorcontext)
190 :     end)
191 :     end
192 : blume 268
193 :     fun joinDirFile { dir as (CUR _ | CONFIG_ANCHOR _), file } =
194 :     fresh (dir, file)
195 :     | joinDirFile { dir = SPEC { context, spec, ... }, file } = let
196 :     val j =
197 :     P.mkCanonical (P.joinDirFile { dir = spec, file = file })
198 :     in
199 :     fresh (context, j)
200 :     end
201 :    
202 :     (* The cases where we try to split CUR, CONFIG_ANCHOR, ".",
203 :     * or any path ending in ".." should never occur in practice.
204 :     * It would perhaps be better to put error-handling here... *)
205 :     fun splitDirFile (x as (CUR _ | CONFIG_ANCHOR _)) =
206 :     { dir = x, file = P.currentArc }
207 :     | splitDirFile (SPEC { context, spec, ... }) = let
208 :     val { dir, file } = P.splitDirFile spec
209 :     val dir = if dir = "" then P.currentArc else dir
210 :     in
211 :     { dir = fresh (context, dir), file = file }
212 :     end
213 :    
214 :     val dir = #dir o splitDirFile
215 :     val file = #file o splitDirFile
216 : blume 265 end
217 :     end

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