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 735 - (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 : blume 666 type presrcpath
26 : blume 493
27 : blume 666 type rebindings = { anchor: string, value: presrcpath } list
28 :    
29 : blume 493 val nativeSpec : srcpath -> string
30 :    
31 : blume 678 val nativePre : presrcpath -> string
32 :    
33 : blume 666 val srcpath : presrcpath -> srcpath
34 :    
35 : blume 272 exception ToolError of { tool: string, msg: string }
36 :    
37 : blume 666 type pathmaker = string -> presrcpath
38 : blume 272
39 : blume 587 (* case-by-case parameters that can be passed to tools... *)
40 : blume 588 datatype toolopt =
41 : blume 634 STRING of { name: string, mkpath: pathmaker }
42 : blume 588 | SUBOPTS of { name: string, opts: toolopts }
43 :     withtype toolopts = toolopt list
44 : blume 587
45 : blume 588 type tooloptcvt = toolopts option -> toolopts option
46 : blume 587
47 : blume 493 (* A member specification consists of the actual string, an optional
48 : blume 642 * class name, (optional) tool options, a function to convert a
49 : blume 735 * string to its corresponding srcpath, and information about whether
50 : blume 642 * or not this source is an "original" source or a derived source
51 :     * (i.e., output of some tool). *)
52 :     type spec = { name: string,
53 :     mkpath: pathmaker,
54 :     class: class option,
55 :     opts: toolopts option,
56 :     derived: bool }
57 : blume 493
58 : blume 677 type setup = string option * string option (* (pre, post) *)
59 :    
60 : blume 493 (* The goal of applying tools to members is to obtain an "expansion",
61 : blume 642 * i.e., a list of ML-files and a list of .cm-files. We also
62 :     * obtain a list of "sources". This is used to implement CM.sources,
63 :     * i.e., to generate dependency information etc. *)
64 :     type expansion =
65 : blume 677 { smlfiles: (srcpath * Sharing.request * setup) list,
66 : blume 666 cmfiles: (srcpath * Version.t option * rebindings) list,
67 : blume 642 sources: (srcpath * { class: string, derived: bool}) list }
68 : blume 493
69 :     (* A partial expansion is an expansion with a list of things yet to be
70 :     * expanded... *)
71 :     type partial_expansion = expansion * spec list
72 :    
73 : blume 518 (* A rule takes a spec and a rulecontext where the name contained
74 : blume 493 * in the spec -- if relative -- is considered relative to the directory
75 :     * of the corresponding description file. In general,
76 : blume 272 * when coding a rule one would write a rule function and pass it to
77 :     * the context, which will temporarily change the current working
78 :     * directory to the one that holds the description file ("the context").
79 :     * If this is not necessary for the rule to work correctly, then
80 :     * one can simply ignore the context (this saves system call overhead
81 : blume 493 * during dependency analysis).
82 :     * If the rule yields a genuine partial expansion (where the resulting
83 :     * spec list is not empty), then it must pass the proper "path maker"
84 :     * along with each new name. For most cases this will be the given
85 :     * "native path maker" because most rules work on native path names.
86 :     * Some rules, however, might want to use the same convention for
87 :     * derived specs that was used for the original spec. *)
88 :     type rulefn = unit -> partial_expansion
89 :     type rulecontext = rulefn -> partial_expansion
90 :     type rule =
91 :     { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
92 :     partial_expansion
93 : blume 272
94 :     (* install a class *)
95 :     val registerClass : class * rule -> unit
96 :    
97 :     (* classifiers are used when the class is not given explicitly *)
98 :     datatype classifier =
99 :     SFX_CLASSIFIER of string -> class option
100 : blume 493 | GEN_CLASSIFIER of string -> class option
101 : blume 272
102 :     (* make a classifier which looks for a specific file name suffix *)
103 : blume 493 val stdSfxClassifier : { sfx: string , class: class } -> classifier
104 : blume 272
105 : blume 587 (* two standard ways of dealing with filename extensions...
106 :     * (Tool options can be calculated from the options that we have.) *)
107 : blume 276 datatype extensionStyle =
108 : blume 587 EXTEND of (string * class option * tooloptcvt) list
109 :     | REPLACE of string list * (string * class option * tooloptcvt) list
110 : blume 276
111 :     (* perform filename extension *)
112 : blume 587 val extend : extensionStyle ->
113 : blume 588 (string * toolopts option) ->
114 :     (string * class option * toolopts option) list
115 : blume 276
116 : blume 493 (* check for outdated files; the pathname strings must be in
117 :     * native syntax! *)
118 :     val outdated : string -> string list * string -> bool
119 : blume 276
120 : blume 678 (* Alternative way of checking for outdated-ness using a "witness"
121 :     * file. The idea is that if both tgt (target) and wtn (witness)
122 :     * exist, then tgt is considered outdated if wtn is older than src.
123 :     * Otherwise, if tgt exists but wtn does not, then tgt is considered
124 :     * outdated if it is older than src. If tgt does not exist, it is
125 :     * always considered outdated. *)
126 :     val outdated' : string ->
127 :     { src: string, wtn: string, tgt: string } -> bool
128 :    
129 :     (* open output file; make all necessary directories for it *)
130 :     val openTextOut : string -> TextIO.outstream
131 :    
132 :     (* make all directories leading up to a given file; the file itself
133 :     * is to be left alone *)
134 :     val makeDirs : string -> unit
135 :    
136 : blume 272 (* install a classifier *)
137 :     val registerClassifier : classifier -> unit
138 : blume 677
139 :     (* grab all named options... *)
140 :     val parseOptions :
141 :     { tool : string, keywords : string list, options : toolopts } ->
142 :     { matches : string -> toolopts option, restoptions : string list }
143 : blume 272 end
144 :    
145 :     signature PRIVATETOOLS = sig
146 : blume 666 include CORETOOLS where type srcpath = SrcPath.file
147 :     where type presrcpath = SrcPath.prefile
148 : blume 518
149 : blume 735 type registry
150 :    
151 :     val newRegistry : unit -> registry
152 :    
153 : blume 493 val expand : { error: string -> unit,
154 : blume 735 local_registry : registry,
155 : blume 493 spec: spec,
156 : blume 666 context: SrcPath.dir,
157 :     load_plugin: SrcPath.dir -> string -> bool }
158 : blume 493 -> expansion
159 : blume 518
160 :     val defaultClassOf : (string -> bool) -> string -> class option
161 : blume 270 end
162 :    
163 : blume 518 signature TOOLS = sig
164 :     include CORETOOLS
165 :    
166 : blume 587 (* CM's say and vsay functions *)
167 :     val say : string list -> unit
168 :     val vsay : string list -> unit
169 :    
170 :     (* Get an anchor-configurable command name. *)
171 :     val mkCmdName : string -> string
172 :    
173 : blume 525 (* Register a "standard" tool based on some shell command. *)
174 :     val registerStdShellCmdTool : { tool: string,
175 :     class: string,
176 :     suffixes: string list,
177 :     cmdStdPath: string,
178 : blume 578 extensionStyle: extensionStyle,
179 : blume 587 template: string option,
180 :     dflopts: toolopts } -> unit
181 : blume 525
182 : blume 518 (* query default class *)
183 :     val defaultClassOf : string -> class option
184 :     end
185 :    
186 : blume 272 structure PrivateTools :> PRIVATETOOLS = struct
187 : blume 270
188 : blume 272 type class = string
189 : blume 270
190 : blume 666 type srcpath = SrcPath.file
191 :     type presrcpath = SrcPath.prefile
192 :     type rebindings = SrcPath.rebindings
193 : blume 493
194 : blume 666 val nativeSpec = SrcPath.osstring_relative
195 : blume 493
196 : blume 678 val nativePre = SrcPath.osstring_prefile
197 :    
198 : blume 666 val srcpath = SrcPath.file
199 :    
200 : blume 272 exception ToolError of { tool: string, msg: string }
201 :    
202 : blume 666 type pathmaker = string -> presrcpath
203 : blume 272
204 : blume 588 datatype toolopt =
205 : blume 634 STRING of { name: string, mkpath: pathmaker }
206 : blume 588 | SUBOPTS of { name: string, opts: toolopts }
207 :     withtype toolopts = toolopt list
208 : blume 272
209 : blume 588 type tooloptcvt = toolopts option -> toolopts option
210 : blume 587
211 : blume 642 type spec = { name: string,
212 :     mkpath: pathmaker,
213 :     class: class option,
214 :     opts: toolopts option,
215 :     derived: bool }
216 : blume 587
217 : blume 677 type setup = string option * string option
218 :    
219 : blume 642 type expansion =
220 : blume 677 { smlfiles: (srcpath * Sharing.request * setup) list,
221 : blume 666 cmfiles: (srcpath * Version.t option * rebindings) list,
222 : blume 642 sources: (srcpath * { class: string, derived: bool}) list }
223 : blume 270
224 : blume 493 type partial_expansion = expansion * spec list
225 : blume 270
226 : blume 493 type rulefn = unit -> partial_expansion
227 :     type rulecontext = rulefn -> partial_expansion
228 :     type rule =
229 :     { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
230 :     partial_expansion
231 : blume 272
232 : blume 735 type registry = { classes : rule StringMap.map ref,
233 :     sfx_classifiers : (string -> class option) list ref,
234 :     gen_classifiers : (string -> class option) list ref }
235 : blume 424
236 : blume 735 fun newRegistry () = { classes = ref StringMap.empty,
237 :     sfx_classifiers = ref [],
238 :     gen_classifiers = ref [] } : registry
239 : blume 272
240 : blume 735 val global_registry = newRegistry ()
241 :    
242 :     val local_registry : registry option ref = ref NONE
243 :    
244 :     local
245 :     fun registry join sel () = let
246 :     val get = ! o sel
247 :     in
248 :     case !local_registry of
249 :     NONE => get global_registry
250 :     | SOME rg => join (get rg, get global_registry)
251 :     end
252 :     in
253 :     val classes = registry (StringMap.unionWith #1) #classes
254 :     val sfx_classifiers = registry (op @) #sfx_classifiers
255 :     val gen_classifiers = registry (op @) #gen_classifiers
256 :     end
257 :    
258 : blume 272 datatype classifier =
259 :     SFX_CLASSIFIER of string -> class option
260 : blume 493 | GEN_CLASSIFIER of string -> class option
261 : blume 272
262 :     fun stdSfxClassifier { sfx, class } =
263 :     SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
264 :    
265 : blume 735 local
266 :     fun upd sel f = let
267 :     val rf = sel (case !local_registry of
268 :     SOME rg => rg
269 :     | NONE => global_registry)
270 :     in
271 :     rf := f (!rf)
272 :     end
273 :     in
274 :     fun registerClass (class, rule) =
275 :     upd #classes (fn m => StringMap.insert (m, class, rule))
276 :     fun registerClassifier (SFX_CLASSIFIER c) =
277 :     upd #sfx_classifiers (fn l => c :: l)
278 :     | registerClassifier (GEN_CLASSIFIER c) =
279 :     upd #gen_classifiers (fn l => c :: l)
280 :     end
281 :    
282 : blume 493 datatype extensionStyle =
283 : blume 587 EXTEND of (string * class option * tooloptcvt) list
284 :     | REPLACE of string list * (string * class option * tooloptcvt) list
285 : blume 272
286 : blume 587 fun extend (EXTEND l) (f, too) =
287 :     map (fn (s, co, toc) => (concat [f, ".", s], co, toc too)) l
288 :     | extend (REPLACE (ol, nl)) (f, too) = let
289 : blume 493 val { base, ext } = OS.Path.splitBaseExt f
290 : blume 587 fun join b (e, co, toc) =
291 :     (OS.Path.joinBaseExt { base = b, ext = SOME e }, co, toc too)
292 : blume 493 fun gen b = map (join b) nl
293 :     fun sameExt (e1: string) (e2: string) = e1 = e2
294 :     in
295 :     case ext of
296 :     NONE => gen base
297 :     | SOME e =>
298 :     if List.exists (sameExt e) ol then gen base else gen f
299 :     end
300 :    
301 : blume 678 local
302 :     fun timex f =
303 : blume 493 (OS.FileSys.modTime f, true)
304 :     handle _ => (Time.zeroTime, false)
305 : blume 678 val op < = Time.<
306 :     fun olderThan t f = OS.FileSys.modTime f < t
307 :     fun cannotAccess tool f =
308 :     raise ToolError { tool = tool, msg = "cannot access " ^ f }
309 : blume 493 in
310 : blume 678 fun outdated tool (l, f) = let
311 :     val (ftime, fexists) = timex f
312 :     in
313 :     (List.exists (olderThan ftime) l)
314 :     handle _ => if fexists then true else cannotAccess tool f
315 :     end
316 :    
317 :     fun outdated' tool { src, wtn, tgt } = let
318 :     val (st, se) = timex src
319 :     val (tt, te) = timex tgt
320 :     in
321 :     if not se then
322 :     if te then false else cannotAccess tool src
323 :     else if te then
324 :     let val (wt, we) = timex wtn
325 :     in
326 :     if we then wt < st else tt < st
327 :     end
328 :     else true
329 :     end
330 : blume 493 end
331 :    
332 : blume 678 val openTextOut = AutoDir.openTextOut
333 :     val makeDirs = AutoDir.makeDirs
334 :    
335 : blume 735 fun globally lp arg =
336 :     SafeIO.perform { openIt = fn () => !local_registry before
337 :     local_registry := NONE,
338 :     closeIt = fn previous => local_registry := previous,
339 :     work = fn _ => lp arg,
340 :     cleanup = fn _ => () }
341 : blume 493
342 : blume 272 (* query default class *)
343 : blume 518 fun defaultClassOf load_plugin p = let
344 : blume 272 fun gen_loop [] = NONE
345 :     | gen_loop (h :: t) =
346 :     (case h p of
347 :     NONE => gen_loop t
348 :     | SOME c => SOME c)
349 :    
350 :     fun sfx_loop e = let
351 : blume 735 fun loop [] = gen_loop (gen_classifiers ())
352 : blume 272 | loop (h :: t) =
353 :     (case h e of
354 :     NONE => loop t
355 :     | SOME c => SOME c)
356 :     in
357 : blume 735 loop (sfx_classifiers ())
358 : blume 272 end
359 :     in
360 :     case OS.Path.ext p of
361 : blume 518 SOME e =>
362 :     (case sfx_loop e of
363 :     SOME c => SOME c
364 :     | NONE => let
365 : blume 735 val plugin = concat ["$/", e, "-ext.cm"]
366 : blume 518 in
367 : blume 735 if globally load_plugin plugin then sfx_loop e
368 : blume 578 else NONE
369 : blume 518 end)
370 : blume 735 | NONE => gen_loop (gen_classifiers ())
371 : blume 272 end
372 :    
373 : blume 677 fun parseOptions { tool, keywords, options } = let
374 :     fun err m = raise ToolError { tool = tool, msg = m }
375 :     fun isKW kw = List.exists (fn kw' => kw = kw') keywords
376 :     fun loop ([], m, ro) = { matches = fn kw => StringMap.find (m, kw),
377 :     restoptions = rev ro }
378 :     | loop (STRING { name, ... } :: t, m, ro) = loop (t, m, name :: ro)
379 :     | loop (SUBOPTS { name, opts } :: t, m, ro) =
380 :     if not (isKW name) then
381 :     raise err (concat ["keyword option `", name,
382 :     "' not recognized"])
383 :     else (case StringMap.find (m, name) of
384 :     SOME _ => err (concat ["keyword option `", name,
385 :     "' specified more than once"])
386 :     | NONE => loop (t, StringMap.insert (m, name, opts), ro))
387 :     in
388 :     loop (options, StringMap.empty, [])
389 :     end
390 :    
391 : blume 587 fun smlrule { spec, context, mkNativePath } = let
392 : blume 642 val { name, mkpath, opts = oto, derived, ... } : spec = spec
393 : blume 677 val tool = "sml"
394 :     fun err s = raise ToolError { tool = tool, msg = s }
395 :     val kw_setup = "setup"
396 :     val (srq, setup) =
397 :     case oto of
398 :     NONE => (Sharing.DONTCARE, (NONE, NONE))
399 :     | SOME to => let
400 :     val { matches, restoptions } =
401 :     parseOptions { tool = tool,
402 :     keywords = [kw_setup],
403 :     options = to }
404 :     val srq =
405 :     case restoptions of
406 :     [] => Sharing.DONTCARE
407 :     | ["shared"] => Sharing.SHARED
408 :     | ["private"] => Sharing.PRIVATE
409 :     | _ => err "invalid option(s)"
410 :     val setup =
411 :     case matches kw_setup of
412 :     NONE => (NONE, NONE)
413 :     | SOME [] => (NONE, NONE)
414 :     | SOME [STRING s] => (SOME (#name s), NONE)
415 :     | SOME [SUBOPTS { name = "pre",
416 :     opts = [STRING pre] }] =>
417 :     (SOME (#name pre), NONE)
418 :     | SOME [SUBOPTS { name = "post",
419 :     opts = [STRING post] }] =>
420 :     (NONE, SOME (#name post))
421 :     | (SOME [SUBOPTS { name = "pre",
422 :     opts = [STRING pre] },
423 :     SUBOPTS { name = "post",
424 :     opts = [STRING post] }] |
425 :     SOME [SUBOPTS { name = "post",
426 :     opts = [STRING post] },
427 :     SUBOPTS { name = "pre",
428 :     opts = [STRING pre] }]) =>
429 :     (SOME (#name pre), SOME (#name post))
430 :     | _ => err "invalid setup spec"
431 :     in
432 :     (srq, setup)
433 :     end
434 : blume 666 val p = srcpath (mkpath name)
435 : blume 587 in
436 : blume 677 ({ smlfiles = [(p, srq, setup)],
437 : blume 642 sources = [(p, { class = "sml", derived = derived })],
438 :     cmfiles = [] },
439 :     [])
440 : blume 587 end
441 : blume 642 fun cmrule { spec, context, mkNativePath } = let
442 :     val { name, mkpath, opts = oto, derived, ... } : spec = spec
443 :     fun err m = raise ToolError { tool = "cm", msg = m }
444 : blume 666 fun proc_opts (rb, vrq, []) = (rb, vrq)
445 :     | proc_opts (_, _, STRING _ :: _) = err "ill-formed option"
446 :     | proc_opts (rb, vrq, SUBOPTS { name = "version", opts } :: r) =
447 :     let fun ill () = err "ill-formed version specification"
448 :     in
449 :     case (vrq, opts) of
450 :     (SOME _, _) =>
451 :     err "version cannot be specified more than once"
452 :     | (NONE, [STRING { name, ... }]) =>
453 :     (case Version.fromString name of
454 :     NONE => ill ()
455 :     | SOME v => proc_opts (rb, SOME v, r))
456 :     | _ => ill ()
457 :     end
458 :     | proc_opts (rb, vrq, SUBOPTS { name = "bind", opts } :: r) =
459 :     (case opts of
460 :     [SUBOPTS { name = "anchor", opts = [STRING { name, ... }] },
461 :     SUBOPTS { name = "value", opts = [STRING v] }] =>
462 :     proc_opts ({ anchor = name, value = #mkpath v (#name v) }
463 :     :: rb,
464 :     vrq, r)
465 :     | _ => err "ill-formed bind specification")
466 :     | proc_opts (_, _, SUBOPTS { name, ... } :: _) =
467 :     err ("unknown option: " ^ name)
468 :     val (rb, vrq) = case oto of
469 :     NONE => ([], NONE)
470 :     | SOME l => proc_opts ([], NONE, l)
471 :     val p = srcpath (mkpath name)
472 : blume 642 in
473 :     ({ smlfiles = [],
474 :     sources = [(p, { class = "cm", derived = derived })],
475 : blume 666 cmfiles = [(p, vrq, rev rb)] },
476 : blume 642 [])
477 :     end
478 : blume 272
479 : blume 735 fun expand { error, local_registry = lr, spec, context, load_plugin } = let
480 : blume 666 fun mkNativePath s =
481 :     SrcPath.native { err = error } { context = context, spec = s }
482 : blume 275 fun class2rule class =
483 : blume 735 case StringMap.find (classes (), class) of
484 : blume 275 SOME rule => rule
485 : blume 518 | NONE => let
486 : blume 735 val base = concat ["$/", class, "-tool"]
487 : blume 643 val plugin = OS.Path.joinBaseExt { base = base,
488 : blume 518 ext = SOME "cm" }
489 :     fun complain () =
490 :     (error (concat ["unknown class \"", class, "\""]);
491 : blume 587 smlrule)
492 : blume 518 in
493 : blume 735 if globally (load_plugin context) plugin then
494 :     case StringMap.find (classes (), class) of
495 : blume 518 SOME rule => rule
496 :     | NONE => complain ()
497 :     else complain ()
498 :     end
499 :    
500 : blume 642 fun expand1 (spec as { name, class = co, ... }) = let
501 : blume 493 val rule =
502 :     case co of
503 :     SOME c0 => class2rule (String.map Char.toLower c0)
504 :     | NONE =>
505 : blume 578 (case defaultClassOf (load_plugin context) name of
506 : blume 493 SOME c => class2rule c
507 : blume 587 | NONE => smlrule)
508 : blume 493 fun rcontext rf = let
509 : blume 666 val dir = SrcPath.osstring_dir context
510 : blume 275 val cwd = OS.FileSys.getDir ()
511 :     in
512 : blume 345 SafeIO.perform { openIt = fn () => OS.FileSys.chDir dir,
513 :     closeIt = fn () => OS.FileSys.chDir cwd,
514 :     work = rf,
515 : blume 459 cleanup = fn _ => () }
516 : blume 275 end
517 : blume 272 in
518 : blume 493 rule { spec = spec, context = rcontext,
519 :     mkNativePath = mkNativePath }
520 : blume 587 handle ToolError { tool, msg } =>
521 :     (error (concat ["tool \"", tool, "\" failed: ", msg]);
522 : blume 642 ({ smlfiles = [], cmfiles = [], sources = [] }, []))
523 : blume 272 end
524 : blume 493 fun loop (expansion, []) = expansion
525 : blume 642 | loop ({ smlfiles, cmfiles, sources }, item :: items) = let
526 :     val ({ smlfiles = sfl, cmfiles = cfl, sources = sl }, il) =
527 :     expand1 item
528 : blume 276 in
529 : blume 642 loop ({ smlfiles = smlfiles @ sfl,
530 :     cmfiles = cmfiles @ cfl,
531 :     sources = sources @ sl },
532 : blume 493 il @ items)
533 : blume 276 end
534 : blume 272 in
535 : blume 735 SafeIO.perform { openIt = fn () => !local_registry
536 :     before local_registry := SOME lr,
537 :     closeIt = fn previous => local_registry := previous,
538 :     work = fn _ => loop ({ smlfiles = [], cmfiles = [],
539 :     sources = [] },
540 :     [spec]),
541 :     cleanup = fn _ => () }
542 : blume 272 end
543 :    
544 : blume 274 local
545 :     fun sfx (s, c) =
546 :     registerClassifier (stdSfxClassifier { sfx = s, class = c })
547 :     in
548 : blume 587 val _ = registerClass ("sml", smlrule)
549 : blume 493 val _ = registerClass ("cm", cmrule)
550 :    
551 : blume 274 val _ = sfx ("sml", "sml")
552 :     val _ = sfx ("sig", "sml")
553 : blume 629 val _ = sfx ("fun", "sml")
554 : blume 274 val _ = sfx ("cm", "cm")
555 :     end
556 : blume 270 end
557 : blume 272
558 : blume 525 functor ToolsFn (val load_plugin : string -> bool
559 : blume 735 val load_plugin' : SrcPath.file -> bool
560 : blume 666 val penv: SrcPath.env) : TOOLS = struct
561 : blume 587
562 : blume 518 open PrivateTools
563 :     val defaultClassOf = defaultClassOf load_plugin
564 : blume 525
565 : blume 587 val say = Say.say
566 :     val vsay = Say.vsay
567 :    
568 : blume 645 fun mkCmdName cmdStdPath =
569 : blume 735 (* The result of this function should not be cached. Otherwise
570 :     * a later addition or change of an anchor will go unnoticed. *)
571 : blume 666 case SrcPath.get_anchor (penv, cmdStdPath) of
572 : blume 645 NONE => cmdStdPath
573 : blume 666 | SOME p => OS.Path.joinDirFile { dir = p, file = cmdStdPath }
574 : blume 587
575 : blume 525 fun registerStdShellCmdTool args = let
576 : blume 587 val { tool, class, suffixes, cmdStdPath,
577 :     extensionStyle, template, dflopts } = args
578 : blume 578 val template = getOpt (template, "%c %s")
579 : blume 666 fun err m = raise ToolError { tool = tool, msg = m }
580 : blume 642 fun rule { spec, context, mkNativePath } = let
581 :     val { name, mkpath, opts = oto, derived, ... } : spec = spec
582 : blume 587 val opts = getOpt (oto, dflopts)
583 : blume 595 val sol = let (* only use STRING options for %o *)
584 : blume 588 fun so (SUBOPTS _) = NONE
585 :     | so (STRING { name, mkpath }) =
586 : blume 666 SOME (nativeSpec (srcpath (mkpath name)))
587 : blume 588 in
588 :     List.mapPartial so opts
589 :     end
590 : blume 666 val p = srcpath (mkpath name)
591 : blume 642 val nativename = nativeSpec p
592 : blume 587 val tfiles = extend extensionStyle (nativename, oto)
593 : blume 525 val partial_expansion =
594 : blume 642 ({ smlfiles = [], cmfiles = [],
595 :     sources = [(p, { class = class, derived = derived })] },
596 :     map (fn (f, co, too) => { name = f,
597 :     mkpath = mkNativePath,
598 :     class = co,
599 :     opts = too,
600 :     derived = true })
601 :     tfiles)
602 : blume 525 fun runcmd () = let
603 : blume 587 val cmdname = mkCmdName cmdStdPath
604 : blume 578 fun fill ([], sl) = concat (rev sl)
605 :     | fill (#"%" :: #"%" :: t, sl) = fill (t, "%" :: sl)
606 :     | fill (#"%" :: #"c" :: t, sl) = fill (t, cmdname :: sl)
607 :     | fill (#"%" :: #"s" :: t, sl) = fill (t, nativename :: sl)
608 : blume 587 | fill (#"%" :: t, sl0) = let
609 :     val o0 = Char.ord #"0"
610 :     fun select (0, cl, sl, ol, sel) =
611 :     fill (cl, foldl (fn (x, l) => sel x :: " " :: l)
612 :     sl0 ol)
613 :     | select (n, cl, sl, ol, sel) =
614 :     (fill (cl, sel (List.nth (ol, n-1)) :: sl0)
615 :     handle General.Subscript => fill (cl, sl))
616 :     fun loop (n, [], sl) = fill ([], sl)
617 :     | loop (n, t as (c :: t'), sl) =
618 :     if c >= #"0" andalso c <= #"9" then
619 :     loop (n * 10 + Char.ord c - o0,
620 :     t', String.str c :: sl)
621 :     else let
622 :     val sl = String.str c :: sl
623 :     in
624 :     case c of
625 : blume 588 #"o" => select (n, t', sl, sol, fn x => x)
626 : blume 587 | #"t" => select (n, t', sl, tfiles, #1)
627 :     | _ => fill (t', sl)
628 :     end
629 : blume 578 in
630 : blume 587 loop (0, t, "%" :: sl0)
631 : blume 578 end
632 :     | fill (c :: t, sl) = fill (t, String.str c :: sl)
633 :     val cmd = fill (String.explode template, [])
634 : blume 525 in
635 : blume 587 Say.vsay ["[", cmd, "]\n"];
636 : blume 525 if OS.Process.system cmd = OS.Process.success then ()
637 : blume 666 else err cmd
638 : blume 525 end
639 :     fun rulefn () =
640 : blume 587 (if outdated tool (map #1 tfiles, nativename) then runcmd ()
641 : blume 525 else ();
642 :     partial_expansion)
643 :     in
644 :     context rulefn
645 :     end
646 :     fun sfx s =
647 :     registerClassifier (stdSfxClassifier { sfx = s, class = class })
648 :     in
649 :     registerClass (class, rule);
650 :     app sfx suffixes
651 :     end
652 : blume 735
653 :     local
654 :     val toolclass = "tool"
655 :     val suffixclass = "suffix"
656 :     val empty_expansion =
657 :     ({ cmfiles = [], smlfiles = [], sources = [] }, [])
658 :     fun toolrule { spec, context, mkNativePath } = let
659 :     val { name, mkpath, opts, ... } : spec = spec
660 :     fun err m = raise ToolError { tool = toolclass, msg = m }
661 :     in
662 :     case opts of
663 :     NONE => if load_plugin' (srcpath (mkpath name)) then
664 :     empty_expansion
665 :     else err "tool registration failed"
666 :     | SOME _ => err "no tool options are recognized"
667 :     end
668 :     fun suffixrule { spec, context, mkNativePath } = let
669 :     val { name = s, opts, ... } : spec = spec
670 :     fun err m = raise ToolError { tool = suffixclass, msg = m }
671 :     fun reg c =
672 :     (registerClassifier (stdSfxClassifier { sfx = s, class = c });
673 :     empty_expansion)
674 :     in
675 :     case opts of
676 :     SOME [STRING c] => reg (#name c)
677 :     | SOME [SUBOPTS { name = "class", opts = [STRING c] }] =>
678 :     reg (#name c)
679 :     | _ => err "invalid options"
680 :     end
681 :     in
682 :     val _ = registerClass (toolclass, toolrule)
683 :     val _ = registerClass (suffixclass, suffixrule)
684 :     end
685 : blume 518 end

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