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
[smlnj] / 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 351, Wed Jun 23 06:44:27 1999 UTC revision 352, Wed Jun 23 09:27:27 1999 UTC
# Line 23  Line 23 
23      val spec : t -> string      val spec : t -> string
24      val contextName : context -> string      val contextName : context -> string
25    
26        (* Replace the anchor context in the path argument with the
27         * given context. Returns NONE if there was no anchor context. *)
28        val reAnchor : t * context -> t option
29    
30      val native : { context: context, spec: string } -> t      val native : { context: context, spec: string } -> t
31      val standard : PathConfig.mode -> { context: context, spec: string } -> t      val standard : PathConfig.mode -> { context: context, spec: string } -> t
32    
# Line 40  Line 44 
44      val delete : t -> unit      val delete : t -> unit
45    
46      (* The open?Out functions automagically create any necessary directories      (* The open?Out functions automagically create any necessary directories
47       * and announce this activity via their string consumer argument. *)       * and announce this activity. *)
48      val openTextIn : t -> TextIO.instream      val openTextIn : t -> TextIO.instream
49      val openTextOut : t -> TextIO.outstream      val openTextOut : t -> TextIO.outstream
50      val openBinIn : t -> BinIO.instream      val openBinIn : t -> BinIO.instream
# Line 86  Line 90 
90                             cache: elaboration option ref,                             cache: elaboration option ref,
91                             config_name: string }                             config_name: string }
92        | RELATIVE of t        | RELATIVE of t
93          | ROOT
94    
95      and t =      and t =
96          PATH of { context: context,          PATH of { context: context,
# Line 149  Line 154 
154            | validElab (SOME (e as { stamp, name, id })) =            | validElab (SOME (e as { stamp, name, id })) =
155              if stamp = !elabStamp then SOME e else NONE              if stamp = !elabStamp then SOME e else NONE
156    
157            val rootName = P.toString { isAbs = true, arcs = [], vol = "" }
158    
159          fun elabContext c =          fun elabContext c =
160              case c of              case c of
161                  CUR { stamp, name, id } =>                  CUR { stamp, name, id } =>
# Line 161  Line 168 
168                           SOME e => e                           SOME e => e
169                         | NONE => mkElab (cache, fetch ()))                         | NONE => mkElab (cache, fetch ()))
170                | RELATIVE p => elab p                | RELATIVE p => elab p
171                  | ROOT => mkElab (ref NONE, rootName)
172    
173          and elab (PATH { context, spec, cache }) =          and elab (PATH { context, spec, cache }) =
174              (case validElab (!cache) of              (case validElab (!cache) of
# Line 205  Line 213 
213              PATH { context = context, spec = spec, cache = ref NONE }              PATH { context = context, spec = spec, cache = ref NONE }
214    
215          (* make an abstract path from a native string *)          (* make an abstract path from a native string *)
216          fun native { spec, context } = fresh (context, spec)          fun native { spec, context } = let
217                val { isAbs, vol, arcs } = P.fromString spec
218                val relSpec = P.toString { isAbs = false, vol = vol, arcs = arcs }
219            in
220                if isAbs then fresh (ROOT, relSpec)
221                else fresh (context, relSpec)
222            end
223    
224          (* make an abstract path from a standard string *)          (* make an abstract path from a standard string *)
225          fun standard mode { spec, context } = let          fun standard mode { spec, context } = let
# Line 217  Line 231 
231                | transl "." = OS.Path.currentArc                | transl "." = OS.Path.currentArc
232                | transl arc = arc                | transl arc = arc
233    
234              fun mk (isAbs, arcs, context) =              fun mk (arcs, context) =
235                  fresh (context,                  fresh (context,
236                         P.toString { isAbs = isAbs, vol = "",                         P.toString { isAbs = false, vol = "",
237                                      arcs = map transl arcs })                                      arcs = map transl arcs })
238          in          in
239              case String.fields delim spec of              case String.fields delim spec of
240                  "" :: arcs => mk (true, arcs, context)                  "" :: arcs => mk (arcs, ROOT)
241                | [] => mk (false, [], context) (* shouldn't happen *)                | [] => mk ([], context) (* shouldn't happen *)
242                | arcs as (arc1 :: _) =>                | arcs as (arc1 :: _) =>
243                      (case PathConfig.configAnchor mode arc1 of                      (case PathConfig.configAnchor mode arc1 of
244                           NONE => mk (false, arcs, context)                           NONE => mk (arcs, context)
245                         | SOME fetch => let                         | SOME fetch => let
246                               val anchorcontext =                               val anchorcontext =
247                                   CONFIG_ANCHOR { fetch = fetch,                                   CONFIG_ANCHOR { fetch = fetch,
248                                                   cache = ref NONE,                                                   cache = ref NONE,
249                                                   config_name = arc1 }                                                   config_name = arc1 }
250                           in                           in
251                               mk (false, arcs, anchorcontext)                               mk (arcs, anchorcontext)
252                           end)                           end)
253          end          end
254    
# Line 340  Line 354 
354          val openTextOut = openOut TextIO.openOut          val openTextOut = openOut TextIO.openOut
355          val openBinOut = openOut BinIO.openOut          val openBinOut = openOut BinIO.openOut
356      end      end
357    
358        fun reAnchor (p, c) = let
359            fun ctxt (CONFIG_ANCHOR { config_name, ... }) =
360                SOME (relativeContext (native { context = c, spec = config_name }))
361              | ctxt (RELATIVE t) = Option.map RELATIVE (path t)
362              | ctxt (CUR _) = NONE
363              | ctxt ROOT = NONE
364            and path (PATH { context, spec, ... }) = let
365                fun p c = PATH { context = c, spec = spec, cache = ref NONE }
366            in
367                Option.map p (ctxt context)
368            end
369        in
370            path p
371        end
372  end  end
Legend:
Removed from v.351  
changed lines
  Added in v.352
root@smlnj-gforge.cs.uchicago.edu
 ViewVC Help
Powered by ViewVC 1.0.0  
Powered By FusionForge