Annotation of /sml/trunk/src/cm/tools/tools.sml

Parent Directory | Revision Log

---

Revision 321 - (view) (download)

1 :	blume	274	(*
2 :			* Target expansion and CM tools.
3 :			*
4 :			* (C) 1999 Lucent Technologies, Bell Laboratories
5 :			*
6 :			* Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7 :			*)
8 :	blume	270	signature TOOLS = sig
9 :
10 :	blume	272	type fname = string
11 :			type class = string
12 :	blume	270
13 :	blume	272	exception ToolError of { tool: string, msg: string }
14 :
15 :			type item = fname * class option
16 :
17 :			(* A rule takes a file name (relative to the directory of the
18 :			* corresponding description file) and a rulecontext. In general,
19 :			* when coding a rule one would write a rule function and pass it to
20 :			* the context, which will temporarily change the current working
21 :			* directory to the one that holds the description file ("the context").
22 :			* If this is not necessary for the rule to work correctly, then
23 :			* one can simply ignore the context (this saves system call overhead
24 :			* during dependency analysis). *)
25 :			type rulefn = unit -> item list
26 :			type rulecontext = rulefn -> item list
27 :			type rule = fname * rulecontext -> item list
28 :
29 :			(* install a class *)
30 :			val registerClass : class * rule -> unit
31 :
32 :			(* install "ML Source" class *)
33 :			val registerSmlClass : class * bool option -> unit
34 :
35 :			(* install "CM Group" class *)
36 :			val registerGroupClass : class -> unit
37 :
38 :			(* classifiers are used when the class is not given explicitly *)
39 :			datatype classifier =
40 :			SFX_CLASSIFIER of string -> class option
41 :	blume	276	| GEN_CLASSIFIER of fname -> class option
42 :	blume	272
43 :			(* make a classifier which looks for a specific file name suffix *)
44 :			val stdSfxClassifier : { sfx: string, class: class } -> classifier
45 :
46 :	blume	276	(* two standard ways of dealing with filename extensions... *)
47 :			datatype extensionStyle =
48 :			EXTEND of string list
49 :			| REPLACE of string list * string list
50 :
51 :	blume	282	type cmdGetterSetter = string option -> string
52 :
53 :			val newCmdGetterSetter : string * string -> cmdGetterSetter
54 :
55 :			val registerStdShellCmdTool : { tool : string,
56 :			class : string,
57 :			suffixes : string list,
58 :			command : cmdGetterSetter,
59 :			extensionStyle : extensionStyle,
60 :			sml : bool } -> unit
61 :
62 :	blume	276	(* perform filename extension *)
63 :			val extend : extensionStyle -> fname -> fname list
64 :
65 :			(* check for outdated files *)
66 :			val outdated : string -> fname list * fname -> bool
67 :
68 :	blume	272	(* install a classifier *)
69 :			val registerClassifier : classifier -> unit
70 :
71 :			(* query default class *)
72 :			val defaultClassOf : fname -> class option
73 :			end
74 :
75 :			signature PRIVATETOOLS = sig
76 :
77 :			include TOOLS
78 :
79 :	blume	270	type smlsource =
80 :	blume	272	{ sourcepath: AbsPath.t, history: class list, share: bool option }
81 :	blume	270
82 :			datatype expansion =
83 :	blume	274	SMLSOURCE of smlsource
84 :	blume	270	| GROUP of AbsPath.t
85 :
86 :	blume	272	datatype private_rule =
87 :	blume	274	ISSML of bool option
88 :	blume	272	| ISGROUP
89 :			| ISTOOL of class * rule
90 :
91 :	blume	275	val expand : (string -> unit) -> AbsPath.t * class option -> expansion list
92 :	blume	270	end
93 :
94 :	blume	272	structure PrivateTools :> PRIVATETOOLS = struct
95 :	blume	270
96 :	blume	272	type fname = string
97 :			type class = string
98 :	blume	270
99 :	blume	272	exception ToolError of { tool: string, msg: string }
100 :
101 :			type item = fname * class option
102 :
103 :			type rulefn = unit -> item list
104 :			type rulecontext = rulefn -> item list
105 :			type rule = fname * rulecontext -> item list
106 :
107 :	blume	270	type smlsource =
108 :	blume	272	{ sourcepath: AbsPath.t, history: class list, share: bool option }
109 :	blume	270
110 :			datatype expansion =
111 :	blume	274	SMLSOURCE of smlsource
112 :	blume	270	| GROUP of AbsPath.t
113 :
114 :	blume	272	datatype private_rule =
115 :	blume	274	ISSML of bool option
116 :	blume	272	| ISGROUP
117 :			| ISTOOL of class * rule
118 :
119 :			val classes : private_rule StringMap.map ref = ref (StringMap.empty)
120 :
121 :			fun registerClass (class, rule) =
122 :			classes := StringMap.insert (!classes, class, ISTOOL (class, rule))
123 :
124 :			fun registerSmlClass (class, share) =
125 :			classes := StringMap.insert (!classes, class, ISSML share)
126 :
127 :			fun registerGroupClass class =
128 :			classes := StringMap.insert (!classes, class, ISGROUP)
129 :
130 :			(* classifiers are used when the class is not given explicitly *)
131 :			datatype classifier =
132 :			SFX_CLASSIFIER of string -> class option
133 :	blume	276	| GEN_CLASSIFIER of fname -> class option
134 :	blume	272
135 :			(* make a classifier which looks for a specific file name suffix *)
136 :			fun stdSfxClassifier { sfx, class } =
137 :			SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
138 :
139 :			(* install a classifier *)
140 :			val sfx_classifiers: (string -> class option) list ref = ref []
141 :			val gen_classifiers: (fname -> class option) list ref = ref []
142 :
143 :			local
144 :			fun add (x, r) = r := x :: (!r)
145 :			in
146 :			fun registerClassifier (SFX_CLASSIFIER c) = add (c, sfx_classifiers)
147 :			| registerClassifier (GEN_CLASSIFIER c) = add (c, gen_classifiers)
148 :			end
149 :
150 :			(* query default class *)
151 :			fun defaultClassOf p = let
152 :			fun gen_loop [] = NONE
153 :			| gen_loop (h :: t) =
154 :			(case h p of
155 :			NONE => gen_loop t
156 :			| SOME c => SOME c)
157 :
158 :			fun sfx_loop e = let
159 :			fun loop [] = gen_loop (!gen_classifiers)
160 :			| loop (h :: t) =
161 :			(case h e of
162 :			NONE => loop t
163 :			| SOME c => SOME c)
164 :			in
165 :			loop (!sfx_classifiers)
166 :			end
167 :			in
168 :			case OS.Path.ext p of
169 :			SOME e => sfx_loop e
170 :			| NONE => gen_loop (!gen_classifiers)
171 :			end
172 :
173 :	blume	275	fun expand error = let
174 :	blume	272
175 :	blume	275	(* get the rule corresponding to a given class *)
176 :			fun class2rule class =
177 :			case StringMap.find (!classes, class) of
178 :			SOME rule => rule
179 :			| NONE => (error (concat ["unknown class \"", class, "\""]);
180 :			ISSML NONE)
181 :
182 :			(* apply a rule to a path within a given context *)
183 :			fun apply (rule, p, c) = let
184 :			fun rctxt rf = let
185 :			val dir = AbsPath.contextName c
186 :			val cwd = OS.FileSys.getDir ()
187 :			fun doit () =
188 :			(OS.FileSys.chDir dir; rf () before OS.FileSys.chDir cwd)
189 :			in
190 :			(Interrupt.guarded doit)
191 :			handle ToolError { tool, msg } =>
192 :			(OS.FileSys.chDir cwd;
193 :			error (concat ["tool \"", tool, "\" failed: ",
194 :			msg]);
195 :			[])
196 :			| exn => (OS.FileSys.chDir cwd; raise exn)
197 :			end
198 :	blume	272	in
199 :	blume	275	rule (p, rctxt)
200 :	blume	272	end
201 :
202 :	blume	275	fun expand' context = let
203 :			fun loop (acc, []) = rev acc
204 :			| loop (acc, ((p, c), history) :: t) = let
205 :			fun step (ISSML share) =
206 :			let
207 :			val ap = AbsPath.native { context = context,
208 :			spec = p }
209 :			val src = { sourcepath = ap,
210 :			history = rev history,
211 :			share = share }
212 :			in
213 :			loop (SMLSOURCE src :: acc, t)
214 :			end
215 :			| step ISGROUP = let
216 :			val ap = AbsPath.native { context = context,
217 :			spec = p }
218 :			in
219 :			loop (GROUP ap :: acc, t)
220 :			end
221 :			| step (ISTOOL (class, rule)) = let
222 :			val l = apply (rule, p, context)
223 :			val l' = map (fn i => (i, class :: history)) l
224 :			in
225 :			loop (acc, l' @ t)
226 :			end
227 :			in
228 :			case c of
229 :			SOME class => step (class2rule class)
230 :			| NONE =>
231 :			(case defaultClassOf p of
232 :			SOME class => step (class2rule class)
233 :			| NONE => step (ISSML NONE))
234 :			end
235 :			in
236 :			fn l => loop ([], l)
237 :			end
238 :
239 :	blume	276	fun expand0 (ap, NONE) =
240 :			expand' (AbsPath.context ap) [((AbsPath.spec ap, NONE), [])]
241 :			| expand0 (ap, SOME class0) = let
242 :			(* classes are case-insensitive, internally we use lowercase *)
243 :			val class = String.map Char.toLower class0
244 :			in
245 :			case class2rule class of
246 :			ISSML share =>
247 :			[SMLSOURCE { sourcepath = ap, history = [],
248 :			share = share }]
249 :			| ISGROUP =>
250 :			[GROUP ap]
251 :			| ISTOOL (class, rule) => let
252 :			val c = AbsPath.context ap
253 :			val l = apply (rule, AbsPath.spec ap, c)
254 :			val l' = map (fn i => (i, [class])) l
255 :			in
256 :			expand' (AbsPath.context ap) l'
257 :			end
258 :			end
259 :	blume	272	in
260 :	blume	275	expand0
261 :	blume	272	end
262 :
263 :	blume	276	datatype extensionStyle =
264 :			EXTEND of string list
265 :			| REPLACE of string list * string list
266 :
267 :			fun extend (EXTEND l) f = map (fn s => concat [f, ".", s]) l
268 :			| extend (REPLACE (ol, nl)) f = let
269 :			val { base, ext } = OS.Path.splitBaseExt f
270 :			fun join b e = OS.Path.joinBaseExt { base = b, ext = SOME e }
271 :			fun gen b = map (join b) nl
272 :			fun sameExt (e1: string) (e2: string) = e1 = e2
273 :			in
274 :			case ext of
275 :			NONE => gen base
276 :			| SOME e =>
277 :			if List.exists (sameExt e) ol then gen base else gen f
278 :			end
279 :
280 :			fun outdated tool (l, f) = let
281 :			val (ftime, fexists) =
282 :			(OS.FileSys.modTime f, true)
283 :			handle _ => (Time.zeroTime, false)
284 :			fun olderThan t f = Time.< (OS.FileSys.modTime f, t)
285 :			in
286 :			(List.exists (olderThan ftime) l)
287 :			handle _ => if fexists then true
288 :			else raise ToolError { tool = tool,
289 :			msg = "cannot access " ^ f }
290 :			end
291 :
292 :	blume	282	type cmdGetterSetter = string option -> string
293 :
294 :	blume	321	fun newCmdGetterSetter sp = EnvConfig.getSet (EnvConfig.new SOME sp)
295 :	blume	282
296 :			fun registerStdShellCmdTool arg = let
297 :			val { tool, class, suffixes, command, extensionStyle, sml } = arg
298 :			fun rule (f, ctxt) = let
299 :			val targetfiles = extend extensionStyle f
300 :			val mkTarget =
301 :			if sml then (fn tf => (tf, SOME "sml"))
302 :			else (fn tf => (tf, NONE))
303 :			val targets = map mkTarget targetfiles
304 :			fun runcmd () = let
305 :			val cmd = concat [command NONE, " ", f]
306 :	blume	310	val _ = Say.vsay ["[", cmd, "]\n"]
307 :	blume	282	in
308 :			if OS.Process.system cmd = OS.Process.success then ()
309 :			else raise ToolError { tool = tool, msg = cmd }
310 :			end
311 :			fun rfun () =
312 :			(if outdated tool (targetfiles, f) then runcmd ()
313 :			else ();
314 :			targets)
315 :			in
316 :			ctxt rfun
317 :			end
318 :
319 :			fun sfx s =
320 :			registerClassifier (stdSfxClassifier { sfx = s, class = class })
321 :			in
322 :			registerClass (class, rule);
323 :			app sfx suffixes
324 :			end
325 :
326 :	blume	274	(* registering standard classes and classifiers *)
327 :			local
328 :			fun sfx (s, c) =
329 :			registerClassifier (stdSfxClassifier { sfx = s, class = c })
330 :			in
331 :			val _ = registerSmlClass ("sml", NONE)
332 :			val _ = registerSmlClass ("shared", SOME true)
333 :			val _ = registerSmlClass ("private", SOME false)
334 :			val _ = registerGroupClass "cm"
335 :
336 :			val _ = sfx ("sml", "sml")
337 :			val _ = sfx ("sig", "sml")
338 :			val _ = sfx ("cm", "cm")
339 :			end
340 :	blume	270	end
341 :	blume	272
342 :	blume	276	structure Tools : TOOLS = PrivateTools

---

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