7 |
*) |
*) |
8 |
signature ABSPATH = sig |
signature ABSPATH = sig |
9 |
|
|
10 |
|
type context |
11 |
type t |
type t |
12 |
|
|
13 |
val revalidateCwd : unit -> unit |
val revalidateCwd : unit -> unit |
14 |
|
|
15 |
|
val cwdContext: unit -> context |
16 |
|
val configContext: (unit -> string) -> context |
17 |
|
val relativeContext: t -> context |
18 |
|
|
19 |
val name : t -> string |
val name : t -> string |
20 |
val compare : t * t -> order |
val compare : t * t -> order |
21 |
|
|
22 |
val native : { context: t, spec: string } -> t |
val native : { context: context, spec: string } -> t |
23 |
val standard : { context: t, spec: string } -> t |
val standard : { context: context, spec: string } -> t |
24 |
|
|
25 |
val joinDirFile : { dir: t, file: string } -> t |
val joinDirFile : { dir: t, file: string } -> t |
26 |
val splitDirFile : t -> { dir: t, file: string } |
val splitDirFile : t -> { dir: t, file: string } |
44 |
| compareId (PRESENT _, ABSENT _) = GREATER |
| compareId (PRESENT _, ABSENT _) = GREATER |
45 |
| compareId (ABSENT s, ABSENT s') = String.compare (s, s') |
| compareId (ABSENT s, ABSENT s') = String.compare (s, s') |
46 |
|
|
47 |
fun getId f = PRESENT (F.fileId f) handle _ => ABSENT f |
fun getId f = (PRESENT (F.fileId f) handle _ => ABSENT f) |
48 |
|
|
49 |
type elaboration = { stamp : unit ref, |
type elaboration = { stamp : unit ref, |
50 |
name : string, |
name : string, |
59 |
*) |
*) |
60 |
|
|
61 |
type cwdinfo = { stamp: unit ref, name: string, id: id } |
type cwdinfo = { stamp: unit ref, name: string, id: id } |
62 |
datatype t = |
|
63 |
|
datatype context = |
64 |
CUR of cwdinfo |
CUR of cwdinfo |
65 |
| CONFIG_ANCHOR of { fetch: unit -> string, |
| CONFIG_ANCHOR of { fetch: unit -> string, |
66 |
cache: elaboration option ref } |
cache: elaboration option ref } |
67 |
| SPEC of { context: t, |
| RELATIVE of t |
68 |
|
|
69 |
|
and t = |
70 |
|
PATH of { context: context, |
71 |
spec: string, |
spec: string, |
72 |
cache: elaboration option ref } |
cache: elaboration option ref } |
73 |
|
|
109 |
else () |
else () |
110 |
end |
end |
111 |
|
|
112 |
(* elaborate a path -- uses internal caching, don't cache |
fun cwdContext () = |
113 |
* results externally! *) |
CUR { stamp = cwdStamp (), name = cwdName (), id = cwdId () } |
114 |
fun elab p = let |
|
115 |
|
fun configContext fetch = |
116 |
|
CONFIG_ANCHOR { fetch = fetch, cache = ref NONE } |
117 |
|
|
118 |
|
fun relativeContext p = RELATIVE p |
119 |
|
|
120 |
fun mkElab (cache, name) = let |
fun mkElab (cache, name) = let |
121 |
val e = { stamp = !elabStamp, name = name, id = ref NONE } |
val e : elaboration = |
122 |
|
{ stamp = !elabStamp, name = name, id = ref NONE } |
123 |
in |
in |
124 |
cache := SOME e; e |
cache := SOME e; e |
125 |
end |
end |
126 |
fun resolve_anchor { fetch, cache } = mkElab (cache, fetch ()) |
|
127 |
fun resolve_spec { context, spec, cache } = let |
fun validElab NONE = NONE |
128 |
|
| validElab (SOME (e as { stamp, name, id })) = |
129 |
|
if stamp = !elabStamp then SOME e else NONE |
130 |
|
|
131 |
|
fun elabContext c = |
132 |
|
case c of |
133 |
|
CUR { stamp, name, id } => |
134 |
|
{ stamp = !elabStamp, id = ref (SOME id), |
135 |
|
name = if stamp = cwdStamp () orelse |
136 |
|
name = cwdName () |
137 |
|
then P.currentArc else name } |
138 |
|
| CONFIG_ANCHOR { fetch, cache } => |
139 |
|
(case validElab (!cache) of |
140 |
|
SOME e => e |
141 |
|
| NONE => mkElab (cache, fetch ())) |
142 |
|
| RELATIVE p => elab p |
143 |
|
|
144 |
|
and elab (PATH { context, spec, cache }) = |
145 |
|
(case validElab (!cache) of |
146 |
|
SOME e => e |
147 |
|
| NONE => let |
148 |
val name = |
val name = |
149 |
if P.isAbsolute spec then spec |
if P.isAbsolute spec then spec |
150 |
else P.mkCanonical (P.concat (#name (elab context), spec)) |
else P.mkCanonical |
151 |
|
(P.concat (#name (elabContext context), |
152 |
|
spec)) |
153 |
in |
in |
154 |
mkElab (cache, name) |
mkElab (cache, name) |
155 |
end |
end) |
|
in |
|
|
case p of |
|
|
CUR { stamp, name, id } => |
|
|
{ stamp = !elabStamp, id = ref (SOME id), |
|
|
name = if stamp = cwdStamp () |
|
|
orelse name = cwdName () then |
|
|
P.currentArc |
|
|
else name } |
|
|
| CONFIG_ANCHOR (a as { cache = ref NONE, ... }) => |
|
|
resolve_anchor a |
|
|
| CONFIG_ANCHOR (a as { cache = ref (SOME (e as { stamp, ... })), |
|
|
... }) => |
|
|
if stamp = !elabStamp then e else resolve_anchor a |
|
|
| SPEC (s as { cache = ref NONE, ... }) => |
|
|
resolve_spec s |
|
|
| SPEC (s as { cache = ref (SOME (e as { stamp, ... })), ...}) => |
|
|
if stamp = !elabStamp then e else resolve_spec s |
|
|
end |
|
156 |
|
|
157 |
(* get the file id (calls elab, so don't cache externally!) *) |
(* get the file id (calls elab, so don't cache externally!) *) |
158 |
fun id p = let |
fun id p = let |
174 |
fun compare (p1, p2) = compareId (id p1, id p2) |
fun compare (p1, p2) = compareId (id p1, id p2) |
175 |
|
|
176 |
fun fresh (context, spec) = |
fun fresh (context, spec) = |
177 |
SPEC { context = context, spec = spec, cache = ref NONE } |
PATH { context = context, spec = spec, cache = ref NONE } |
178 |
|
|
179 |
(* make an abstract path from a native string *) |
(* make an abstract path from a native string *) |
180 |
fun native { spec, context } = fresh (context, spec) |
fun native { spec, context } = fresh (context, spec) |
210 |
end |
end |
211 |
|
|
212 |
(* . and .. are not permitted as file parameter *) |
(* . and .. are not permitted as file parameter *) |
213 |
fun joinDirFile { dir, file } = |
fun joinDirFile { dir = PATH { context, spec, ... }, file } = |
214 |
if file = P.currentArc orelse file = P.parentArc then |
if file = P.currentArc orelse file = P.parentArc then |
215 |
raise Fail "AbsPath.joinDirFile: . or .." |
raise Fail "AbsPath.joinDirFile: . or .." |
216 |
else case dir of |
else fresh (context, P.joinDirFile { dir = spec, file = file }) |
|
(CUR _ | CONFIG_ANCHOR _) => fresh (dir, file) |
|
|
| SPEC { context, spec, ... } => |
|
|
fresh (context, P.joinDirFile { dir = spec, file = file }) |
|
217 |
|
|
218 |
(* splitDirFile never walks past a context. |
(* splitDirFile never walks past a context. |
219 |
* Moreover, it is an error to split something that ends in "..". *) |
* Moreover, it is an error to split something that ends in "..". *) |
220 |
fun splitDirFile (x as (CUR _ | CONFIG_ANCHOR _)) = |
fun splitDirFile (PATH { context, spec, ... }) = let |
|
raise Fail "AbsPath.splitDirFile: CUR or CONFIG_ANCHOR" |
|
|
| splitDirFile (SPEC { context, spec, ... }) = let |
|
221 |
fun loop "" = |
fun loop "" = |
222 |
raise Fail "AbsPath.splitDirFile: tried to split context" |
raise Fail "AbsPath.splitDirFile: tried to split a context" |
223 |
| loop spec = let |
| loop spec = let |
224 |
val { dir, file } = P.splitDirFile spec |
val { dir, file } = P.splitDirFile spec |
225 |
in |
in |
229 |
else (dir, file) |
else (dir, file) |
230 |
end |
end |
231 |
val (dir, file) = loop spec |
val (dir, file) = loop spec |
232 |
val dir = if dir = "" then context else fresh (context, dir) |
val dir = if dir = "" then P.currentArc else dir |
233 |
in |
in |
234 |
{ dir = dir, file = file } |
{ dir = fresh (context, dir), file = file } |
235 |
end |
end |
236 |
|
|
237 |
val dir = #dir o splitDirFile |
val dir = #dir o splitDirFile |