10 |
type fname = string |
type fname = string |
11 |
type class = string |
type class = string |
12 |
|
|
|
exception UnknownClass of class |
|
13 |
exception ToolError of { tool: string, msg: string } |
exception ToolError of { tool: string, msg: string } |
14 |
|
|
15 |
type item = fname * class option |
type item = fname * class option |
66 |
| ISGROUP |
| ISGROUP |
67 |
| ISTOOL of class * rule |
| ISTOOL of class * rule |
68 |
|
|
69 |
val expand : AbsPath.t * class option -> expansion list |
val expand : (string -> unit) -> AbsPath.t * class option -> expansion list |
70 |
end |
end |
71 |
|
|
72 |
structure PrivateTools :> PRIVATETOOLS = struct |
structure PrivateTools :> PRIVATETOOLS = struct |
74 |
type fname = string |
type fname = string |
75 |
type class = string |
type class = string |
76 |
|
|
|
exception UnknownClass of class |
|
77 |
exception ToolError of { tool: string, msg: string } |
exception ToolError of { tool: string, msg: string } |
78 |
|
|
79 |
type item = fname * class option |
type item = fname * class option |
148 |
| NONE => gen_loop (!gen_classifiers) |
| NONE => gen_loop (!gen_classifiers) |
149 |
end |
end |
150 |
|
|
151 |
|
fun expand error = let |
152 |
|
|
153 |
(* get the rule corresponding to a given class *) |
(* get the rule corresponding to a given class *) |
154 |
fun class2rule class = |
fun class2rule class = |
155 |
case StringMap.find (!classes, class) of |
case StringMap.find (!classes, class) of |
156 |
SOME rule => rule |
SOME rule => rule |
157 |
| NONE => raise UnknownClass class |
| NONE => (error (concat ["unknown class \"", class, "\""]); |
158 |
|
ISSML NONE) |
159 |
|
|
160 |
(* apply a rule to a path within a given context *) |
(* apply a rule to a path within a given context *) |
161 |
fun apply (rule, p, c) = let |
fun apply (rule, p, c) = let |
166 |
(OS.FileSys.chDir dir; rf () before OS.FileSys.chDir cwd) |
(OS.FileSys.chDir dir; rf () before OS.FileSys.chDir cwd) |
167 |
in |
in |
168 |
(Interrupt.guarded doit) |
(Interrupt.guarded doit) |
169 |
handle exn => (OS.FileSys.chDir cwd; raise exn) |
handle ToolError { tool, msg } => |
170 |
|
(OS.FileSys.chDir cwd; |
171 |
|
error (concat ["tool \"", tool, "\" failed: ", |
172 |
|
msg]); |
173 |
|
[]) |
174 |
|
| exn => (OS.FileSys.chDir cwd; raise exn) |
175 |
end |
end |
176 |
in |
in |
177 |
rule (p, rctxt) |
rule (p, rctxt) |
182 |
| loop (acc, ((p, c), history) :: t) = let |
| loop (acc, ((p, c), history) :: t) = let |
183 |
fun step (ISSML share) = |
fun step (ISSML share) = |
184 |
let |
let |
185 |
val ap = AbsPath.native { context = context, spec = p } |
val ap = AbsPath.native { context = context, |
186 |
|
spec = p } |
187 |
val src = { sourcepath = ap, |
val src = { sourcepath = ap, |
188 |
history = rev history, |
history = rev history, |
189 |
share = share } |
share = share } |
191 |
loop (SMLSOURCE src :: acc, t) |
loop (SMLSOURCE src :: acc, t) |
192 |
end |
end |
193 |
| step ISGROUP = let |
| step ISGROUP = let |
194 |
val ap = AbsPath.native { context = context, spec = p } |
val ap = AbsPath.native { context = context, |
195 |
|
spec = p } |
196 |
in |
in |
197 |
loop (GROUP ap :: acc, t) |
loop (GROUP ap :: acc, t) |
198 |
end |
end |
214 |
fn l => loop ([], l) |
fn l => loop ([], l) |
215 |
end |
end |
216 |
|
|
217 |
fun expand (ap, SOME class) = |
fun expand0 (ap, SOME class) = |
218 |
(case class2rule class of |
(case class2rule class of |
219 |
ISSML share => |
ISSML share => |
220 |
[SMLSOURCE { sourcepath = ap, history = [], share = share }] |
[SMLSOURCE { sourcepath = ap, history = [], |
221 |
|
share = share }] |
222 |
| ISGROUP => |
| ISGROUP => |
223 |
[GROUP ap] |
[GROUP ap] |
224 |
| ISTOOL (class, rule) => let |
| ISTOOL (class, rule) => let |
228 |
in |
in |
229 |
expand' (AbsPath.context ap) l' |
expand' (AbsPath.context ap) l' |
230 |
end) |
end) |
231 |
| expand (ap, NONE) = |
| expand0 (ap, NONE) = |
232 |
expand' (AbsPath.context ap) [((AbsPath.spec ap, NONE), [])] |
expand' (AbsPath.context ap) [((AbsPath.spec ap, NONE), [])] |
233 |
|
in |
234 |
|
expand0 |
235 |
|
end |
236 |
|
|
237 |
(* registering standard classes and classifiers *) |
(* registering standard classes and classifiers *) |
238 |
local |
local |