Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/paths/abspath.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 265, Fri May 7 08:42:54 1999 UTC revision 369, Sun Jul 4 12:55:20 1999 UTC
# Line 1  Line 1 
1  (*  (*
2   * util/abspath.sml: Operations over abstract path names.   * Operations over abstract path names.
3   *   *
4   *   Copyright (c) 1999 by Lucent Bell Laboratories   * Copyright (c) 1999 by Lucent Technologies, Bell Laboratories
5   *   *
6   * author: Matthias Blume (blume@cs.princeton.edu)   * Author: Matthias Blume (blume@cs.princeton.edu)
7   *)   *)
8  signature ABSPATH = sig  signature ABSPATH = sig
9    
10        exception Format        (* if something is seriously wrong with a pickle *)
11        exception BadAnchor of string       (* if anchor cannot be resolved *)
12    
13        type context
14      type t      type t
15        type ord_key = t
16    
17        val newEra : unit -> unit
18      val revalidateCwd : unit -> unit      val revalidateCwd : unit -> unit
19    
20      val name : t -> string      val cwdContext: unit -> context
21        val sameDirContext: t -> context
22    
23        val osstring : t -> string
24        val descr : t -> string
25      val compare : t * t -> order      val compare : t * t -> order
26        val contextOf : t -> context
27        val specOf : t -> string
28        val contextName : context -> string
29    
30        (* Replace the anchor context in the path argument with the
31         * given context. Returns NONE if there was no anchor context. *)
32        val reAnchoredName : t * string -> string option
33    
34        val native : { context: context, spec: string } -> t
35        val standard : PathConfig.mode -> { context: context, spec: string } -> t
36    
37        (* the second path argument is the path of the group spec that
38         * pickling is based upon. *)
39        val pickle : (bool -> unit) -> t * t -> string list
40        val unpickle : PathConfig.mode -> string list * t -> t
41    
42      val native : { context: t, spec: string } -> t      val tstamp : t -> TStamp.t
     val standard : { context: t, spec: string } -> t  
43  end  end
44    
45  structure AbsPath :> ABSPATH = struct  structure AbsPath :> ABSPATH = struct
46    
47      structure P = OS.Path      structure P = OS.Path
48      structure F = OS.FileSys      structure F = OS.FileSys
49        val impossible = GenericVC.ErrorMsg.impossible
50    
51        exception Format
52        exception BadAnchor of string
53    
54      (* unique file id that can handle absent files *)      (* unique file id that can handle absent files *)
55      datatype id =      datatype id =
# Line 34  Line 62 
62        | compareId (PRESENT _, ABSENT _) = GREATER        | compareId (PRESENT _, ABSENT _) = GREATER
63        | compareId (ABSENT s, ABSENT s') = String.compare (s, s')        | compareId (ABSENT s, ABSENT s') = String.compare (s, s')
64    
65      fun getId f = PRESENT (F.fileId f) handle _ => ABSENT f      fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f)
66    
67      type elaboration = { stamp : unit ref,      type elaboration = { stamp : unit ref,
68                           name : string,                           name : string,
# Line 49  Line 77 
77       *)       *)
78    
79      type cwdinfo = { stamp: unit ref, name: string, id: id }      type cwdinfo = { stamp: unit ref, name: string, id: id }
80      datatype t =  
81          CUR of cwdinfo      datatype context =
82            THEN_CWD of cwdinfo
83        | CONFIG_ANCHOR of { fetch: unit -> string,        | CONFIG_ANCHOR of { fetch: unit -> string,
84                             cache: elaboration option ref }                             cache: elaboration option ref,
85        | SPEC of { context: t,                             config_name: string }
86          | DIR_OF of t
87          | ROOT
88    
89        and t =
90            PATH of { context: context,
91                    spec: string,                    spec: string,
92                    cache: elaboration option ref }                    cache: elaboration option ref }
93    
94        type ord_key = t
95    
96      local      local
         val elabStamp = ref (ref ())  
97          val cwdInfoCache : cwdinfo option ref = ref NONE          val cwdInfoCache : cwdinfo option ref = ref NONE
98          fun cwdInfo () =          fun cwdInfo () =
99              case !cwdInfoCache of              case !cwdInfoCache of
# Line 75  Line 110 
110          val cwdStamp = #stamp o cwdInfo          val cwdStamp = #stamp o cwdInfo
111          val cwdName = #name o cwdInfo          val cwdName = #name o cwdInfo
112          val cwdId = #id o cwdInfo          val cwdId = #id o cwdInfo
         fun invalidateCwdInfo () = cwdInfoCache := NONE  
113      in      in
114          (* start a new era (i.e., invalidate all previous elaborations) *)          (* start a new era (i.e., invalidate all previous elaborations) *)
115          fun newEra () = elabStamp := ref ()          val newEra = Era.newEra
116    
117          (* make sure the cwd is consistent *)          (* make sure the cwd is consistent *)
118          fun revalidateCwd () =          fun revalidateCwd () =
# Line 95  Line 129 
129                      else ()                      else ()
130                  end                  end
131    
132          (* elaborate a path -- uses internal caching, don't cache          fun cwdContext () =
133           * results externally! *)              (revalidateCwd ();
134          fun elab p = let               THEN_CWD { stamp = cwdStamp (),
135                            name = cwdName (),
136                            id = cwdId () })
137    
138            fun sameDirContext p = DIR_OF p
139    
140              fun mkElab (cache, name) = let              fun mkElab (cache, name) = let
141                  val e = { stamp = !elabStamp, name = name, id = ref NONE }              val e : elaboration =
142                    { stamp = Era.thisEra (), name = name, id = ref NONE }
143              in              in
144                  cache := SOME e; e                  cache := SOME e; e
145              end              end
146              fun resolve_anchor { fetch, cache } = mkElab (cache, fetch ())  
147              fun resolve_spec { context, spec, cache } = let          fun validElab NONE = NONE
148                  val name =            | validElab (SOME (e as { stamp, name, id })) =
149                      if P.isAbsolute spec then spec              if Era.isThisEra stamp then SOME e else NONE
150                      else P.mkCanonical (P.concat (#name (elab context), spec))  
151              in          val rootName = P.toString { isAbs = true, arcs = [], vol = "" }
152                  mkElab (cache, name)          val rootId = ref (NONE: id option)
153              end  
154          in          fun elabContext c =
155              case p of              case c of
156                  CUR { stamp, name, id } =>                  THEN_CWD { stamp, name, id } =>
157                      { stamp = !elabStamp, id = ref (SOME id),                      { stamp = Era.thisEra (), id = ref (SOME id),
158                        name = if stamp = cwdStamp ()                        name = if stamp = cwdStamp () orelse name = cwdName ()
159                                     orelse name = cwdName () then                               then P.currentArc else name }
160                                   P.currentArc                | CONFIG_ANCHOR { fetch, cache, config_name } =>
161                              else name }                      (case validElab (!cache) of
162                | CONFIG_ANCHOR (a as { cache = ref NONE, ... }) =>                           SOME e => e
163                      resolve_anchor a                         | NONE => mkElab (cache, fetch ()))
164                | CONFIG_ANCHOR (a as { cache = ref (SOME (e as { stamp, ... })),                | DIR_OF p => let
165                                        ... }) =>                      val { name, stamp, ... } = elab p
166                      if stamp = !elabStamp then e else resolve_anchor a                  in
167                | SPEC (s as { cache = ref NONE, ... }) =>                      { name = P.dir name, stamp = stamp, id = ref NONE }
                     resolve_spec s  
               | SPEC (s as { cache = ref (SOME (e as { stamp, ... })), ...}) =>  
                     if stamp = !elabStamp then e else resolve_spec s  
168          end          end
169                  | ROOT => { stamp = Era.thisEra (),
170                              name = rootName, id = rootId }
171    
172            and elab (PATH { context, spec, cache }) =
173                case validElab (!cache) of
174                    SOME e => e
175                  | NONE => mkElab (cache,
176                                    P.mkCanonical (P.concat
177                                             (#name (elabContext context), spec)))
178    
179          (* get the file id (calls elab, so don't cache externally!) *)          (* get the file id (calls elab, so don't cache externally!) *)
180          fun id p = let          fun id p = let
# Line 144  Line 190 
190          end          end
191    
192          (* get the name as a string (calls elab, so don't cache externally!) *)          (* get the name as a string (calls elab, so don't cache externally!) *)
193          fun name p = #name (elab p)          fun osstring p = #name (elab p)
194    
195            (* get the context back *)
196            fun contextOf (PATH { context = c, ... }) = c
197            fun contextName c = #name (elabContext c)
198    
199            (* get the spec back *)
200            fun specOf (PATH { spec = s, ... }) = s
201    
202          (* compare pathnames efficiently *)          (* compare pathnames efficiently *)
203          fun compare (p1, p2) = compareId (id p1, id p2)          fun compare (p1, p2) = compareId (id p1, id p2)
204    
205            fun fresh (context, spec) =
206                PATH { context = context, spec = spec, cache = ref NONE }
207    
208          (* make an abstract path from a native string *)          (* make an abstract path from a native string *)
209          fun native { spec, context } =          fun native { spec, context } = let
210              SPEC { context = context, spec = spec, cache = ref NONE }              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    
217          (* make an abstract path from a standard string *)          (* make an abstract path from a standard string *)
218          fun standard { spec, context } = let          fun standard mode { spec, context } = let
219              fun delim #"/" = true              fun delim #"/" = true
220                | delim #"\\" = true              (* accept DOS-style, too *)                | delim #"\\" = true              (* accept DOS-style, too *)
221                | delim _ = false                | delim _ = false
222    
223              fun transl ".." = OS.Path.parentArc              fun transl ".." = P.parentArc
224                | transl "." = OS.Path.currentArc                | transl "." = P.currentArc
225                | transl arc = arc                | transl arc = arc
226    
227              fun mk (isAbs, arcs, context) =              fun mk (arcs, context) =
228                  SPEC { context = context,                  fresh (context,
229                         spec = P.toString { isAbs = isAbs, vol = "",                         P.toString { isAbs = false, vol = "",
230                                             arcs = map transl arcs },                                      arcs = map transl arcs })
                        cache = ref NONE }  
231          in          in
232              case String.fields delim spec of              case String.fields delim spec of
233                  "" :: arcs => mk (true, arcs, context)                  [""] => impossible "AbsPath.standard: zero-length name"
234                | [] => mk (false, [], context)                | "" :: arcs => mk (arcs, ROOT)
235                | arcs as (arc1 :: arcn) =>                | [] => impossible "AbsPath.standard: no fields"
236                      (case PathConfig.configAnchor arc1 of                | arcs as (arc1 :: _) =>
237                           NONE => mk (false, arcs, context)                      (case PathConfig.configAnchor mode arc1 of
238                             NONE => mk (arcs, context)
239                         | SOME fetch => let                         | SOME fetch => let
240                               val anchorcontext =                               val anchorcontext =
241                                   CONFIG_ANCHOR { fetch = fetch,                                   CONFIG_ANCHOR { fetch = fetch,
242                                                   cache = ref NONE }                                                   cache = ref NONE,
243                                                     config_name = arc1 }
244                           in                           in
245                               mk (false, arcn, anchorcontext)                               mk (arcs, anchorcontext)
246                           end)                           end)
247          end          end
248    
249            (* make a pickle-string *)
250            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            in
260                p_p path
261            end
262    
263            fun unpickle mode (l, gpath) = let
264                fun u_p (s :: l) =
265                    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                  | u_c [n, "a"] =
270                    (case PathConfig.configAnchor mode n of
271                         NONE => raise BadAnchor n
272                       | SOME fetch =>
273                             CONFIG_ANCHOR { config_name = n,
274                                             fetch = fetch,
275                                             cache = ref NONE })
276                  | u_c l = DIR_OF (u_p l)
277            in
278                u_p l
279            end
280    
281            fun tstamp p = TStamp.fmodTime (osstring p)
282    
283            fun descr (PATH { spec, context, ... }) = let
284                fun dir (x, l) =
285                    case P.dir x of
286                        "" => 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            in
295                concat (d_c (context, [spec]))
296            end
297    
298            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            in
310                Option.map P.mkCanonical (path p)
311            end
312      end      end
313  end  end

Legend:
Removed from v.265  
changed lines
  Added in v.369

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