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/trunk/src/cm/tools/tools.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 632 - (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 :     STRING of { name: string, mkpath: string -> srcpath }
35 :     | 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 :     STRING of { name: string, mkpath: string -> srcpath }
159 :     | 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