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/branches/SMLNJ/src/compiler/PervEnv/OS/os-path-fn.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/PervEnv/OS/os-path-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 167 - (view) (download)

1 : monnier 16 (* os-path-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * A functorized implementation of the OS.Path structure.
6 :     *
7 :     * NOTE: these operations are currently not very efficient, since they
8 :     * explode the path into its volume and arcs. A better implementation
9 :     * would work "in situ."
10 :     *
11 :     *)
12 :    
13 :     functor OS_PathFn (OSPathBase : sig
14 :    
15 :     exception Path
16 :    
17 :     datatype arc_kind = Null | Parent | Current | Arc of string
18 :     val classify : string -> arc_kind
19 :     val parentArc : string
20 :     val currentArc : string
21 :     val validVolume : (bool * Substring.substring) -> bool
22 :     val splitVolPath : string -> (bool * Substring.substring * Substring.substring)
23 :     (* Split a string into the volume part and arcs part and note whether it
24 :     * is absolute.
25 :     * Note: it is guaranteed that this is never called with "".
26 :     *)
27 :     val joinVolPath : (bool * string * string) -> string
28 :     (* join a volume and path; raise Path on invalid volumes *)
29 :     val arcSepChar : char
30 :     (* the character used to separate arcs (e.g., #"/" on UNIX) *)
31 :    
32 :     end) : OS_PATH = struct
33 :    
34 :     structure P = OSPathBase
35 :     structure SS = Substring
36 :    
37 :     exception Path = P.Path
38 :    
39 :     val arcSepStr = String.str P.arcSepChar
40 :    
41 :     val parentArc = P.parentArc
42 :     val currentArc = P.currentArc
43 :    
44 :     (* concatArcs is like List.@, except that a trailing empty arc in the
45 :     * first argument is dropped.
46 :     *)
47 :     fun concatArcs ([], al2) = al2
48 :     | concatArcs ([""], al2) = al2
49 :     | concatArcs (a::al1, al2) = a :: concatArcs(al1, al2)
50 :    
51 :     fun validVolume {isAbs, vol} = P.validVolume(isAbs, SS.all vol)
52 :    
53 :     fun fromString "" = {isAbs = false, vol = "", arcs = []}
54 :     | fromString p = let
55 :     val fields = SS.fields (fn c => (c = P.arcSepChar))
56 :     val (isAbs, vol, rest) = P.splitVolPath p
57 :     in
58 :     { isAbs = isAbs,
59 :     vol = SS.string vol,
60 :     arcs = List.map SS.string (fields rest)
61 :     }
62 :     end
63 :    
64 :     fun toString {isAbs=false, vol, arcs="" :: _} = raise Path
65 :     | toString {isAbs, vol, arcs} = let
66 :     fun f [] = [""]
67 :     | f [a] = [a]
68 :     | f (a :: al) = a :: arcSepStr :: (f al)
69 :     in
70 :     String.concat(P.joinVolPath(isAbs, vol, "") :: f arcs)
71 :     end
72 :    
73 :     fun getVolume p = #vol(fromString p)
74 :     fun getParent p = let
75 :     fun getParent' [] = [parentArc]
76 :     | getParent' [a] = (case (P.classify a)
77 :     of P.Current => [parentArc]
78 :     | P.Parent => [parentArc, parentArc]
79 :     | P.Null => [parentArc]
80 :     | _ => []
81 :     (* end case *))
82 :     | getParent' (a :: al) = a :: getParent' al
83 :     in
84 :     case (fromString p)
85 :     of {isAbs=true, vol, arcs=[""]} => p
86 :     | {isAbs=true, vol, arcs} =>
87 :     toString{isAbs = true, vol = vol, arcs = getParent' arcs}
88 :     | {isAbs=false, vol, arcs} => (case (getParent' arcs)
89 :     of [] => toString{isAbs=false, vol=vol, arcs=[currentArc]}
90 :     | al' => toString{isAbs=false, vol=vol, arcs=al'}
91 :     (* end case *))
92 :     (* end case *)
93 :     end
94 :    
95 :     fun splitDirFile p = let
96 :     val {isAbs, vol, arcs} = fromString p
97 :     fun split [] = ([], "")
98 :     | split [f] = ([], f)
99 :     | split (a :: al) = let val (d, f) = split al
100 :     in
101 :     (a :: d, f)
102 :     end
103 :     fun split' p = let val (d, f) = split p
104 :     in
105 :     {dir=toString{isAbs=isAbs, vol=vol, arcs=d}, file=f}
106 :     end
107 :     in
108 :     split' arcs
109 :     end
110 :     fun joinDirFile {dir="", file} = file
111 :     | joinDirFile {dir, file} = let
112 :     val {isAbs, vol, arcs} = fromString dir
113 :     in
114 :     toString {isAbs=isAbs, vol=vol, arcs = concatArcs(arcs, [file])}
115 :     end
116 :     fun dir p = #dir(splitDirFile p)
117 :     fun file p = #file(splitDirFile p)
118 :    
119 :     fun splitBaseExt p = let
120 :     val {dir, file} = splitDirFile p
121 :     val (file', ext') = SS.splitr (fn c => c <> #".") (SS.all file)
122 :     val fileLen = SS.size file'
123 :     val (file, ext) =
124 :     if (fileLen <= 1) orelse (SS.isEmpty ext')
125 :     then (file, NONE)
126 :     else (SS.string(SS.trimr 1 file'), SOME(SS.string ext'))
127 :     in
128 :     {base = joinDirFile{dir=dir, file=file}, ext = ext}
129 :     end
130 :     fun joinBaseExt {base, ext=NONE} = base
131 :     | joinBaseExt {base, ext=SOME ""} = base
132 :     | joinBaseExt {base, ext=SOME ext} = let
133 :     val {dir, file} = splitDirFile base
134 :     in
135 :     joinDirFile{dir=dir, file=String.concat[file, ".", ext]}
136 :     end
137 :     fun base p = #base(splitBaseExt p)
138 :     fun ext p = #ext(splitBaseExt p)
139 :    
140 :     fun mkCanonical "" = currentArc
141 :     | mkCanonical p = let
142 :     fun scanArcs ([], []) = [P.Current]
143 :     | scanArcs (l, []) = List.rev l
144 :     | scanArcs ([], [""]) = [P.Null]
145 :     | scanArcs (l, a::al) = (case (P.classify a)
146 :     of P.Null => scanArcs(l, al)
147 :     | P.Current => scanArcs(l, al)
148 :     | P.Parent => (case l
149 :     of (P.Arc _ :: r) => scanArcs(r, al)
150 :     | _ => scanArcs(P.Parent::l, al)
151 :     (* end case *))
152 :     | a' => scanArcs(a' :: l, al)
153 :     (* end case *))
154 :     fun scanPath relPath = scanArcs([], relPath)
155 :     fun mkArc (P.Arc a) = a
156 :     | mkArc (P.Parent) = parentArc
157 :     | mkArc _ = raise Fail "mkCanonical: impossible"
158 :     fun filterArcs (true, P.Parent::r) = filterArcs (true, r)
159 :     | filterArcs (true, []) = [""]
160 :     | filterArcs (true, [P.Null]) = [""]
161 :     | filterArcs (true, [P.Current]) = [""]
162 :     | filterArcs (false, [P.Current]) = [currentArc]
163 :     | filterArcs (_, al) = List.map mkArc al
164 :     val {isAbs, vol, arcs} = fromString p
165 :     in
166 :     toString{
167 :     isAbs=isAbs, vol=vol, arcs=filterArcs(isAbs, scanPath arcs)
168 :     }
169 :     end
170 :    
171 :     fun isCanonical p = (p = mkCanonical p)
172 :    
173 :     fun isAbsolute p = #isAbs(fromString p)
174 :     fun isRelative p = Bool.not(#isAbs(fromString p))
175 :    
176 : monnier 143 fun mkAbsolute {path, relativeTo} = (
177 :     case (fromString path, fromString relativeTo)
178 : monnier 16 of (_, {isAbs=false, ...}) => raise Path
179 : monnier 143 | ({isAbs=true, ...}, _) => path
180 : monnier 16 | ({vol=v1, arcs=al1, ...}, {vol=v2, arcs=al2, ...}) => let
181 :     fun mkCanon vol = mkCanonical(toString{
182 :     isAbs=true, vol=vol, arcs=List.@(al2, al1)
183 :     })
184 :     in
185 :     if (v1 = v2) then mkCanon v1
186 :     else if (v1 = "") then mkCanon v2
187 :     else if (v2 = "") then mkCanon v1
188 :     else raise Path
189 :     end
190 :     (* end case *))
191 : monnier 143 fun mkRelative {path, relativeTo} =
192 :     if (isAbsolute relativeTo)
193 :     then if (isRelative path)
194 :     then path
195 : monnier 16 else let
196 : monnier 143 val {vol=v1, arcs=al1, ...} = fromString path
197 :     val {vol=v2, arcs=al2, ...} = fromString(mkCanonical relativeTo)
198 : monnier 16 fun strip (l, []) = mkArcs l
199 :     | strip ([], l) = dotDot([], l)
200 :     | strip (l1 as (x1::r1), l2 as (x2::r2)) = if (x1 = x2)
201 :     then strip (r1, r2)
202 :     else dotDot (l1, l2)
203 :     and dotDot (al, []) = al
204 :     | dotDot (al, _::r) = dotDot(parentArc :: al, r)
205 :     and mkArcs [] = [currentArc]
206 :     | mkArcs al = al
207 :     in
208 :     if (v1 <> v2)
209 :     then raise Path
210 :     else (case (al1, al2)
211 :     of ([""], [""]) => currentArc
212 :     | ([""], _) =>
213 :     toString{isAbs=false, vol="", arcs=dotDot([], al2)}
214 :     | _ =>
215 :     toString{isAbs=false, vol="", arcs=strip(al1, al2)}
216 :     (* end case *))
217 :     end
218 :     else raise Path
219 :    
220 :     fun isRoot path = (case (fromString path)
221 :     of {isAbs=true, arcs=[""], ...} => true
222 :     | _ => false
223 :     (* end case *))
224 :    
225 :     fun concat (p1, p2) = (case (fromString p1, fromString p2)
226 :     of (_, {isAbs=true, ...}) => raise Path
227 :     | ({isAbs, vol=v1, arcs=al1}, {vol=v2, arcs=al2, ...}) =>
228 :     if ((v2 = "") orelse (v1 = v2))
229 :     then toString{isAbs=isAbs, vol=v1, arcs=concatArcs(al1, al2)}
230 :     else raise Path
231 :     (* end case *))
232 :    
233 :     end;
234 :    
235 :    
236 : monnier 167 (*
237 :     * $Log: os-path-fn.sml,v $
238 :     * Revision 1.1.1.1 1998/04/08 18:39:56 george
239 :     * Version 110.5
240 :     *
241 :     *)

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