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

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