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

Parent Directory | Revision Log

---

Revision 634 - (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	518	signature CORETOOLS = sig
9 :	blume	270
10 :	blume	493	(* We don't make classes abstract. It doesn't look like there
11 :			* would be much point to it. *)
12 :	blume	272	type class = string
13 :	blume	270
14 :	blume	493	(* We keep source paths abstract. Tool writers should not mess
15 :			* with their internals.
16 :			* The function that makes a srcpath from a string is passed as
17 :			* part of the input specification (type "spec"). Which function
18 :			* is originally being passed depends on which syntax was used for
19 :			* this member in its .cm-file. Most tools will want to work on
20 :			* native pathname syntax (function "outdated" -- see below -- depends
21 :			* on native syntax!). In these cases the tool should first convert
22 :			* the name to a srcpath and then get the native string back by
23 :			* applying "nativeSpec". *)
24 :			type srcpath
25 :
26 :			val nativeSpec : srcpath -> string
27 :
28 :	blume	272	exception ToolError of { tool: string, msg: string }
29 :
30 :	blume	493	type pathmaker = string -> srcpath
31 :	blume	272
32 :	blume	587	(* case-by-case parameters that can be passed to tools... *)
33 :	blume	588	datatype toolopt =
34 :	blume	634	STRING of { name: string, mkpath: pathmaker }
35 :	blume	588	| SUBOPTS of { name: string, opts: toolopts }
36 :			withtype toolopts = toolopt list
37 :	blume	587
38 :	blume	588	type tooloptcvt = toolopts option -> toolopts option
39 :	blume	587
40 :	blume	493	(* A member specification consists of the actual string, an optional
41 :	blume	587	* class name, (optional) tool options, and a function to convert a
42 :			* string to its correspondin gsrcpath. *)
43 :	blume	588	type spec = string * pathmaker * class option * toolopts option
44 :	blume	493
45 :			(* The goal of applying tools to members is to obtain an "expansion",
46 :			* i.e., a list of ML-files and a list of .cm-files. *)
47 :			type expansion = { smlfiles: (srcpath * Sharing.request) list,
48 :	blume	632	cmfiles: (srcpath * Version.t option) list }
49 :	blume	493
50 :			(* A partial expansion is an expansion with a list of things yet to be
51 :			* expanded... *)
52 :			type partial_expansion = expansion * spec list
53 :
54 :	blume	518	(* A rule takes a spec and a rulecontext where the name contained
55 :	blume	493	* in the spec -- if relative -- is considered relative to the directory
56 :			* of the corresponding description file. In general,
57 :	blume	272	* when coding a rule one would write a rule function and pass it to
58 :			* the context, which will temporarily change the current working
59 :			* directory to the one that holds the description file ("the context").
60 :			* If this is not necessary for the rule to work correctly, then
61 :			* one can simply ignore the context (this saves system call overhead
62 :	blume	493	* during dependency analysis).
63 :			* If the rule yields a genuine partial expansion (where the resulting
64 :			* spec list is not empty), then it must pass the proper "path maker"
65 :			* along with each new name. For most cases this will be the given
66 :			* "native path maker" because most rules work on native path names.
67 :			* Some rules, however, might want to use the same convention for
68 :			* derived specs that was used for the original spec. *)
69 :			type rulefn = unit -> partial_expansion
70 :			type rulecontext = rulefn -> partial_expansion
71 :			type rule =
72 :			{ spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
73 :			partial_expansion
74 :	blume	272
75 :			(* install a class *)
76 :			val registerClass : class * rule -> unit
77 :
78 :			(* classifiers are used when the class is not given explicitly *)
79 :			datatype classifier =
80 :			SFX_CLASSIFIER of string -> class option
81 :	blume	493	| GEN_CLASSIFIER of string -> class option
82 :	blume	272
83 :			(* make a classifier which looks for a specific file name suffix *)
84 :	blume	493	val stdSfxClassifier : { sfx: string , class: class } -> classifier
85 :	blume	272
86 :	blume	587	(* two standard ways of dealing with filename extensions...
87 :			* (Tool options can be calculated from the options that we have.) *)
88 :	blume	276	datatype extensionStyle =
89 :	blume	587	EXTEND of (string * class option * tooloptcvt) list
90 :			| REPLACE of string list * (string * class option * tooloptcvt) list
91 :	blume	276
92 :			(* perform filename extension *)
93 :	blume	587	val extend : extensionStyle ->
94 :	blume	588	(string * toolopts option) ->
95 :			(string * class option * toolopts option) list
96 :	blume	276
97 :	blume	493	(* check for outdated files; the pathname strings must be in
98 :			* native syntax! *)
99 :			val outdated : string -> string list * string -> bool
100 :	blume	276
101 :	blume	272	(* install a classifier *)
102 :			val registerClassifier : classifier -> unit
103 :			end
104 :
105 :			signature PRIVATETOOLS = sig
106 :	blume	518	include CORETOOLS where type srcpath = SrcPath.t
107 :
108 :	blume	493	val expand : { error: string -> unit,
109 :			spec: spec,
110 :	blume	518	context: SrcPath.context,
111 :	blume	578	load_plugin: SrcPath.context -> string -> bool }
112 :	blume	493	-> expansion
113 :	blume	518
114 :			val defaultClassOf : (string -> bool) -> string -> class option
115 :	blume	270	end
116 :
117 :	blume	518	signature TOOLS = sig
118 :			include CORETOOLS
119 :
120 :	blume	587	(* CM's say and vsay functions *)
121 :			val say : string list -> unit
122 :			val vsay : string list -> unit
123 :
124 :			(* Get an anchor-configurable command name. *)
125 :			val mkCmdName : string -> string
126 :
127 :	blume	525	(* Register a "standard" tool based on some shell command. *)
128 :			val registerStdShellCmdTool : { tool: string,
129 :			class: string,
130 :			suffixes: string list,
131 :			cmdStdPath: string,
132 :	blume	578	extensionStyle: extensionStyle,
133 :	blume	587	template: string option,
134 :			dflopts: toolopts } -> unit
135 :	blume	525
136 :	blume	518	(* query default class *)
137 :			val defaultClassOf : string -> class option
138 :	blume	587
139 :	blume	588	(* grab all named options... *)
140 :	blume	587	val parseOptions :
141 :	blume	588	{ tool : string, keywords : string list, options : toolopts } ->
142 :			{ matches : string -> toolopts option, restoptions : string list }
143 :	blume	518	end
144 :
145 :	blume	272	structure PrivateTools :> PRIVATETOOLS = struct
146 :	blume	270
147 :	blume	272	type class = string
148 :	blume	270
149 :	blume	493	type srcpath = SrcPath.t
150 :
151 :			val nativeSpec = SrcPath.specOf
152 :
153 :	blume	272	exception ToolError of { tool: string, msg: string }
154 :
155 :	blume	493	type pathmaker = string -> srcpath
156 :	blume	272
157 :	blume	588	datatype toolopt =
158 :	blume	634	STRING of { name: string, mkpath: pathmaker }
159 :	blume	588	| SUBOPTS of { name: string, opts: toolopts }
160 :			withtype toolopts = toolopt list
161 :	blume	272
162 :	blume	588	type tooloptcvt = toolopts option -> toolopts option
163 :	blume	587
164 :	blume	588	type spec = string * pathmaker * class option * toolopts option
165 :	blume	587
166 :	blume	493	type expansion = { smlfiles: (srcpath * Sharing.request) list,
167 :	blume	632	cmfiles: (srcpath * Version.t option) list }
168 :	blume	270
169 :	blume	493	type partial_expansion = expansion * spec list
170 :	blume	270
171 :	blume	493	type rulefn = unit -> partial_expansion
172 :			type rulecontext = rulefn -> partial_expansion
173 :			type rule =
174 :			{ spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
175 :			partial_expansion
176 :	blume	272
177 :	blume	493	val classes : rule StringMap.map ref = ref StringMap.empty
178 :	blume	424
179 :	blume	272	fun registerClass (class, rule) =
180 :	blume	493	classes := StringMap.insert (!classes, class, rule)
181 :	blume	272
182 :			datatype classifier =
183 :			SFX_CLASSIFIER of string -> class option
184 :	blume	493	| GEN_CLASSIFIER of string -> class option
185 :	blume	272
186 :			fun stdSfxClassifier { sfx, class } =
187 :			SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
188 :
189 :	blume	493	datatype extensionStyle =
190 :	blume	587	EXTEND of (string * class option * tooloptcvt) list
191 :			| REPLACE of string list * (string * class option * tooloptcvt) list
192 :	blume	272
193 :	blume	587	fun extend (EXTEND l) (f, too) =
194 :			map (fn (s, co, toc) => (concat [f, ".", s], co, toc too)) l
195 :			| extend (REPLACE (ol, nl)) (f, too) = let
196 :	blume	493	val { base, ext } = OS.Path.splitBaseExt f
197 :	blume	587	fun join b (e, co, toc) =
198 :			(OS.Path.joinBaseExt { base = b, ext = SOME e }, co, toc too)
199 :	blume	493	fun gen b = map (join b) nl
200 :			fun sameExt (e1: string) (e2: string) = e1 = e2
201 :			in
202 :			case ext of
203 :			NONE => gen base
204 :			| SOME e =>
205 :			if List.exists (sameExt e) ol then gen base else gen f
206 :			end
207 :
208 :			fun outdated tool (l, f) = let
209 :			val (ftime, fexists) =
210 :			(OS.FileSys.modTime f, true)
211 :			handle _ => (Time.zeroTime, false)
212 :			fun olderThan t f = Time.< (OS.FileSys.modTime f, t)
213 :			in
214 :			(List.exists (olderThan ftime) l)
215 :			handle _ => if fexists then true
216 :			else raise ToolError { tool = tool,
217 :			msg = "cannot access " ^ f }
218 :			end
219 :
220 :			val sfx_classifiers : (string -> class option) list ref = ref []
221 :			val gen_classifiers : (string -> class option) list ref = ref []
222 :
223 :	blume	272	local
224 :			fun add (x, r) = r := x :: (!r)
225 :			in
226 :			fun registerClassifier (SFX_CLASSIFIER c) = add (c, sfx_classifiers)
227 :			| registerClassifier (GEN_CLASSIFIER c) = add (c, gen_classifiers)
228 :			end
229 :
230 :			(* query default class *)
231 :	blume	518	fun defaultClassOf load_plugin p = let
232 :	blume	272	fun gen_loop [] = NONE
233 :			| gen_loop (h :: t) =
234 :			(case h p of
235 :			NONE => gen_loop t
236 :			| SOME c => SOME c)
237 :
238 :			fun sfx_loop e = let
239 :			fun loop [] = gen_loop (!gen_classifiers)
240 :			| loop (h :: t) =
241 :			(case h e of
242 :			NONE => loop t
243 :			| SOME c => SOME c)
244 :			in
245 :			loop (!sfx_classifiers)
246 :			end
247 :			in
248 :			case OS.Path.ext p of
249 :	blume	518	SOME e =>
250 :			(case sfx_loop e of
251 :			SOME c => SOME c
252 :			| NONE => let
253 :			val plugin = OS.Path.joinBaseExt { base = e ^ "-ext",
254 :			ext = SOME "cm" }
255 :			in
256 :	blume	578	if load_plugin plugin then sfx_loop e
257 :			else NONE
258 :	blume	518	end)
259 :	blume	272	| NONE => gen_loop (!gen_classifiers)
260 :			end
261 :
262 :	blume	587	fun smlrule { spec, context, mkNativePath } = let
263 :			val (name, mkpath, _, oto) = spec
264 :			val srq = case oto of
265 :			NONE => Sharing.DONTCARE
266 :			| SOME [] => Sharing.DONTCARE
267 :	blume	588	| SOME [STRING { name = "shared", ... }] => Sharing.SHARED
268 :			| SOME [STRING { name = "private",... }] => Sharing.PRIVATE
269 :			| SOME l => raise ToolError { tool = "sml",
270 :			msg = "invalid option(s)" }
271 :	blume	587	in
272 :	blume	493	({ smlfiles = [(mkpath name, srq)], cmfiles = [] }, [])
273 :	blume	587	end
274 :	blume	632	fun cmrule { spec = (name, mkpath, _, oto), context, mkNativePath } =
275 :			let fun err m = raise ToolError { tool = "cm", msg = m }
276 :			val vrq =
277 :			case oto of
278 :			NONE => NONE
279 :			| SOME [] => NONE
280 :			| SOME [SUBOPTS { name = "version",
281 :			opts = [STRING { name, ... }] }] =>
282 :			(case Version.fromString name of
283 :			NONE => err "ill-formed version specification"
284 :			| SOME v => SOME v)
285 :			| _ => err "unknown option"
286 :			in
287 :			({ smlfiles = [], cmfiles = [(mkpath name, vrq)] }, [])
288 :			end
289 :	blume	272
290 :	blume	518	fun expand { error, spec, context, load_plugin } = let
291 :	blume	493	fun mkNativePath s = SrcPath.native { context = context, spec = s }
292 :	blume	275	fun class2rule class =
293 :			case StringMap.find (!classes, class) of
294 :			SOME rule => rule
295 :	blume	518	| NONE => let
296 :			val plugin = OS.Path.joinBaseExt { base = class ^ "-tool",
297 :			ext = SOME "cm" }
298 :			fun complain () =
299 :			(error (concat ["unknown class \"", class, "\""]);
300 :	blume	587	smlrule)
301 :	blume	518	in
302 :	blume	578	if load_plugin context plugin then
303 :	blume	518	case StringMap.find (!classes, class) of
304 :			SOME rule => rule
305 :			| NONE => complain ()
306 :			else complain ()
307 :			end
308 :
309 :	blume	587	fun expand1 (spec as (name, _, co, _)) = let
310 :	blume	493	val rule =
311 :			case co of
312 :			SOME c0 => class2rule (String.map Char.toLower c0)
313 :			| NONE =>
314 :	blume	578	(case defaultClassOf (load_plugin context) name of
315 :	blume	493	SOME c => class2rule c
316 :	blume	587	| NONE => smlrule)
317 :	blume	493	fun rcontext rf = let
318 :			val dir = SrcPath.contextName context
319 :	blume	275	val cwd = OS.FileSys.getDir ()
320 :			in
321 :	blume	345	SafeIO.perform { openIt = fn () => OS.FileSys.chDir dir,
322 :			closeIt = fn () => OS.FileSys.chDir cwd,
323 :			work = rf,
324 :	blume	459	cleanup = fn _ => () }
325 :	blume	275	end
326 :	blume	272	in
327 :	blume	493	rule { spec = spec, context = rcontext,
328 :			mkNativePath = mkNativePath }
329 :	blume	587	handle ToolError { tool, msg } =>
330 :			(error (concat ["tool \"", tool, "\" failed: ", msg]);
331 :			({ smlfiles = [], cmfiles = [] }, []))
332 :	blume	272	end
333 :	blume	493	fun loop (expansion, []) = expansion
334 :			| loop ({ smlfiles, cmfiles }, item :: items) = let
335 :			val ({ smlfiles = sfl, cmfiles = cfl }, il) = expand1 item
336 :	blume	276	in
337 :	blume	493	loop ({ smlfiles = smlfiles @ sfl, cmfiles = cmfiles @ cfl},
338 :			il @ items)
339 :	blume	276	end
340 :	blume	272	in
341 :	blume	493	loop ({ smlfiles = [], cmfiles = [] }, [spec])
342 :	blume	272	end
343 :
344 :	blume	274	local
345 :			fun sfx (s, c) =
346 :			registerClassifier (stdSfxClassifier { sfx = s, class = c })
347 :			in
348 :	blume	587	val _ = registerClass ("sml", smlrule)
349 :	blume	493	val _ = registerClass ("cm", cmrule)
350 :
351 :	blume	274	val _ = sfx ("sml", "sml")
352 :			val _ = sfx ("sig", "sml")
353 :	blume	629	val _ = sfx ("fun", "sml")
354 :	blume	274	val _ = sfx ("cm", "cm")
355 :			end
356 :	blume	270	end
357 :	blume	272
358 :	blume	525	functor ToolsFn (val load_plugin : string -> bool
359 :			val mkStdSrcPath : string -> SrcPath.t) : TOOLS = struct
360 :	blume	587
361 :	blume	518	open PrivateTools
362 :			val defaultClassOf = defaultClassOf load_plugin
363 :	blume	525
364 :	blume	587	val say = Say.say
365 :			val vsay = Say.vsay
366 :
367 :			fun mkCmdName cmdStdPath = let
368 :			(* It is not enough to turn the string into a SrcPath.t
369 :			* once. This is because if there was no anchor in the
370 :			* beginning, later additions of an anchor will go unnoticed.
371 :			* This is different from how other files (ML source files)
372 :			* behave: They, once the are found to be unanchored, should
373 :			* never become anchored later (although an existing anchor
374 :			* is allowed to change). *)
375 :			val p = mkStdSrcPath cmdStdPath
376 :			val n = SrcPath.osstring p
377 :			in
378 :			(* If the resulting path is not absolute, then it cannot have
379 :			* been anchored (configured). In this case we just use the
380 :			* given string as-is. *)
381 :			if OS.Path.isAbsolute n then n else cmdStdPath
382 :			end
383 :
384 :	blume	525	fun registerStdShellCmdTool args = let
385 :	blume	587	val { tool, class, suffixes, cmdStdPath,
386 :			extensionStyle, template, dflopts } = args
387 :	blume	578	val template = getOpt (template, "%c %s")
388 :	blume	587	fun rule { spec = (name, mkpath, _, oto), context, mkNativePath } = let
389 :			val opts = getOpt (oto, dflopts)
390 :	blume	595	val sol = let (* only use STRING options for %o *)
391 :	blume	588	fun so (SUBOPTS _) = NONE
392 :			| so (STRING { name, mkpath }) =
393 :			SOME (nativeSpec (mkpath name))
394 :			in
395 :			List.mapPartial so opts
396 :			end
397 :	blume	525	val nativename = nativeSpec (mkpath name)
398 :	blume	587	val tfiles = extend extensionStyle (nativename, oto)
399 :	blume	525	val partial_expansion =
400 :			({ smlfiles = [], cmfiles = [] },
401 :	blume	587	map (fn (f, co, too) => (f, mkNativePath, co, too)) tfiles)
402 :	blume	525	fun runcmd () = let
403 :	blume	587	val cmdname = mkCmdName cmdStdPath
404 :	blume	578	fun fill ([], sl) = concat (rev sl)
405 :			| fill (#"%" :: #"%" :: t, sl) = fill (t, "%" :: sl)
406 :			| fill (#"%" :: #"c" :: t, sl) = fill (t, cmdname :: sl)
407 :			| fill (#"%" :: #"s" :: t, sl) = fill (t, nativename :: sl)
408 :	blume	587	| fill (#"%" :: t, sl0) = let
409 :			val o0 = Char.ord #"0"
410 :			fun select (0, cl, sl, ol, sel) =
411 :			fill (cl, foldl (fn (x, l) => sel x :: " " :: l)
412 :			sl0 ol)
413 :			| select (n, cl, sl, ol, sel) =
414 :			(fill (cl, sel (List.nth (ol, n-1)) :: sl0)
415 :			handle General.Subscript => fill (cl, sl))
416 :			fun loop (n, [], sl) = fill ([], sl)
417 :			| loop (n, t as (c :: t'), sl) =
418 :			if c >= #"0" andalso c <= #"9" then
419 :			loop (n * 10 + Char.ord c - o0,
420 :			t', String.str c :: sl)
421 :			else let
422 :			val sl = String.str c :: sl
423 :			in
424 :			case c of
425 :	blume	588	#"o" => select (n, t', sl, sol, fn x => x)
426 :	blume	587	| #"t" => select (n, t', sl, tfiles, #1)
427 :			| _ => fill (t', sl)
428 :			end
429 :	blume	578	in
430 :	blume	587	loop (0, t, "%" :: sl0)
431 :	blume	578	end
432 :			| fill (c :: t, sl) = fill (t, String.str c :: sl)
433 :			val cmd = fill (String.explode template, [])
434 :	blume	525	in
435 :	blume	587	Say.vsay ["[", cmd, "]\n"];
436 :	blume	525	if OS.Process.system cmd = OS.Process.success then ()
437 :			else raise ToolError { tool = tool, msg = cmd }
438 :			end
439 :			fun rulefn () =
440 :	blume	587	(if outdated tool (map #1 tfiles, nativename) then runcmd ()
441 :	blume	525	else ();
442 :			partial_expansion)
443 :			in
444 :			context rulefn
445 :			end
446 :			fun sfx s =
447 :			registerClassifier (stdSfxClassifier { sfx = s, class = class })
448 :			in
449 :			registerClass (class, rule);
450 :			app sfx suffixes
451 :			end
452 :	blume	587
453 :			fun parseOptions { tool, keywords, options } = let
454 :	blume	588	fun err m = raise ToolError { tool = tool, msg = m }
455 :			fun isKW kw = List.exists (fn kw' => kw = kw') keywords
456 :			fun loop ([], m, ro) = { matches = fn kw => StringMap.find (m, kw),
457 :			restoptions = rev ro }
458 :			| loop (STRING { name, ... } :: t, m, ro) = loop (t, m, name :: ro)
459 :			| loop (SUBOPTS { name, opts } :: t, m, ro) =
460 :			if not (isKW name) then
461 :			raise err (concat ["keyword option `", name,
462 :			"' not recognized"])
463 :			else (case StringMap.find (m, name) of
464 :			SOME _ => err (concat ["keyword option `", name,
465 :			"' specified more than once"])
466 :			| NONE => loop (t, StringMap.insert (m, name, opts), ro))
467 :	blume	587	in
468 :	blume	588	loop (options, StringMap.empty, [])
469 :	blume	587	end
470 :	blume	518	end

---

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