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 578 - (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 493 (* A member specification consists of the actual string, an optional
33 :     * class name, and a function to convert a string to its corresponding
34 :     * srcpath. *)
35 :     type spec = string * pathmaker * class option
36 :    
37 :     (* The goal of applying tools to members is to obtain an "expansion",
38 :     * i.e., a list of ML-files and a list of .cm-files. *)
39 :     type expansion = { smlfiles: (srcpath * Sharing.request) list,
40 :     cmfiles: srcpath list }
41 :    
42 :     (* A partial expansion is an expansion with a list of things yet to be
43 :     * expanded... *)
44 :     type partial_expansion = expansion * spec list
45 :    
46 : blume 518 (* A rule takes a spec and a rulecontext where the name contained
47 : blume 493 * in the spec -- if relative -- is considered relative to the directory
48 :     * of the corresponding description file. In general,
49 : blume 272 * when coding a rule one would write a rule function and pass it to
50 :     * the context, which will temporarily change the current working
51 :     * directory to the one that holds the description file ("the context").
52 :     * If this is not necessary for the rule to work correctly, then
53 :     * one can simply ignore the context (this saves system call overhead
54 : blume 493 * during dependency analysis).
55 :     * If the rule yields a genuine partial expansion (where the resulting
56 :     * spec list is not empty), then it must pass the proper "path maker"
57 :     * along with each new name. For most cases this will be the given
58 :     * "native path maker" because most rules work on native path names.
59 :     * Some rules, however, might want to use the same convention for
60 :     * derived specs that was used for the original spec. *)
61 :     type rulefn = unit -> partial_expansion
62 :     type rulecontext = rulefn -> partial_expansion
63 :     type rule =
64 :     { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
65 :     partial_expansion
66 : blume 272
67 :     (* install a class *)
68 :     val registerClass : class * rule -> unit
69 :    
70 :     (* classifiers are used when the class is not given explicitly *)
71 :     datatype classifier =
72 :     SFX_CLASSIFIER of string -> class option
73 : blume 493 | GEN_CLASSIFIER of string -> class option
74 : blume 272
75 :     (* make a classifier which looks for a specific file name suffix *)
76 : blume 493 val stdSfxClassifier : { sfx: string , class: class } -> classifier
77 : blume 272
78 : blume 276 (* two standard ways of dealing with filename extensions... *)
79 :     datatype extensionStyle =
80 : blume 518 EXTEND of (string * class option) list
81 :     | REPLACE of string list * (string * class option) list
82 : blume 276
83 :     (* perform filename extension *)
84 : blume 518 val extend : extensionStyle -> string -> (string * class option) list
85 : blume 276
86 : blume 493 (* check for outdated files; the pathname strings must be in
87 :     * native syntax! *)
88 :     val outdated : string -> string list * string -> bool
89 : blume 276
90 : blume 272 (* install a classifier *)
91 :     val registerClassifier : classifier -> unit
92 :     end
93 :    
94 :     signature PRIVATETOOLS = sig
95 : blume 518 include CORETOOLS where type srcpath = SrcPath.t
96 :    
97 : blume 493 val expand : { error: string -> unit,
98 :     spec: spec,
99 : blume 518 context: SrcPath.context,
100 : blume 578 load_plugin: SrcPath.context -> string -> bool }
101 : blume 493 -> expansion
102 : blume 518
103 :     val defaultClassOf : (string -> bool) -> string -> class option
104 : blume 270 end
105 :    
106 : blume 518 signature TOOLS = sig
107 :     include CORETOOLS
108 :    
109 : blume 525 (* Register a "standard" tool based on some shell command. *)
110 :     val registerStdShellCmdTool : { tool: string,
111 :     class: string,
112 :     suffixes: string list,
113 :     cmdStdPath: string,
114 : blume 578 extensionStyle: extensionStyle,
115 :     template: string option } -> unit
116 : blume 525
117 : blume 518 (* query default class *)
118 :     val defaultClassOf : string -> class option
119 :     end
120 :    
121 : blume 272 structure PrivateTools :> PRIVATETOOLS = struct
122 : blume 270
123 : blume 272 type class = string
124 : blume 270
125 : blume 493 type srcpath = SrcPath.t
126 :    
127 :     val nativeSpec = SrcPath.specOf
128 :    
129 : blume 272 exception ToolError of { tool: string, msg: string }
130 :    
131 : blume 493 type pathmaker = string -> srcpath
132 : blume 272
133 : blume 493 type spec = string * pathmaker * class option
134 : blume 272
135 : blume 493 type expansion = { smlfiles: (srcpath * Sharing.request) list,
136 :     cmfiles: srcpath list }
137 : blume 270
138 : blume 493 type partial_expansion = expansion * spec list
139 : blume 270
140 : blume 493 type rulefn = unit -> partial_expansion
141 :     type rulecontext = rulefn -> partial_expansion
142 :     type rule =
143 :     { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
144 :     partial_expansion
145 : blume 272
146 : blume 493 val classes : rule StringMap.map ref = ref StringMap.empty
147 : blume 424
148 : blume 272 fun registerClass (class, rule) =
149 : blume 493 classes := StringMap.insert (!classes, class, rule)
150 : blume 272
151 :     datatype classifier =
152 :     SFX_CLASSIFIER of string -> class option
153 : blume 493 | GEN_CLASSIFIER of string -> class option
154 : blume 272
155 :     fun stdSfxClassifier { sfx, class } =
156 :     SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
157 :    
158 : blume 493 datatype extensionStyle =
159 : blume 518 EXTEND of (string * class option) list
160 :     | REPLACE of string list * (string * class option) list
161 : blume 272
162 : blume 518 fun extend (EXTEND l) f = map (fn (s, co) => (concat [f, ".", s], co)) l
163 : blume 493 | extend (REPLACE (ol, nl)) f = let
164 :     val { base, ext } = OS.Path.splitBaseExt f
165 : blume 518 fun join b (e, co) =
166 :     (OS.Path.joinBaseExt { base = b, ext = SOME e }, co)
167 : blume 493 fun gen b = map (join b) nl
168 :     fun sameExt (e1: string) (e2: string) = e1 = e2
169 :     in
170 :     case ext of
171 :     NONE => gen base
172 :     | SOME e =>
173 :     if List.exists (sameExt e) ol then gen base else gen f
174 :     end
175 :    
176 :     fun outdated tool (l, f) = let
177 :     val (ftime, fexists) =
178 :     (OS.FileSys.modTime f, true)
179 :     handle _ => (Time.zeroTime, false)
180 :     fun olderThan t f = Time.< (OS.FileSys.modTime f, t)
181 :     in
182 :     (List.exists (olderThan ftime) l)
183 :     handle _ => if fexists then true
184 :     else raise ToolError { tool = tool,
185 :     msg = "cannot access " ^ f }
186 :     end
187 :    
188 :     val sfx_classifiers : (string -> class option) list ref = ref []
189 :     val gen_classifiers : (string -> class option) list ref = ref []
190 :    
191 : blume 272 local
192 :     fun add (x, r) = r := x :: (!r)
193 :     in
194 :     fun registerClassifier (SFX_CLASSIFIER c) = add (c, sfx_classifiers)
195 :     | registerClassifier (GEN_CLASSIFIER c) = add (c, gen_classifiers)
196 :     end
197 :    
198 :     (* query default class *)
199 : blume 518 fun defaultClassOf load_plugin p = let
200 : blume 272 fun gen_loop [] = NONE
201 :     | gen_loop (h :: t) =
202 :     (case h p of
203 :     NONE => gen_loop t
204 :     | SOME c => SOME c)
205 :    
206 :     fun sfx_loop e = let
207 :     fun loop [] = gen_loop (!gen_classifiers)
208 :     | loop (h :: t) =
209 :     (case h e of
210 :     NONE => loop t
211 :     | SOME c => SOME c)
212 :     in
213 :     loop (!sfx_classifiers)
214 :     end
215 :     in
216 :     case OS.Path.ext p of
217 : blume 518 SOME e =>
218 :     (case sfx_loop e of
219 :     SOME c => SOME c
220 :     | NONE => let
221 :     val plugin = OS.Path.joinBaseExt { base = e ^ "-ext",
222 :     ext = SOME "cm" }
223 :     in
224 : blume 578 if load_plugin plugin then sfx_loop e
225 :     else NONE
226 : blume 518 end)
227 : blume 272 | NONE => gen_loop (!gen_classifiers)
228 :     end
229 :    
230 : blume 493 fun smlrule srq { spec = (name, mkpath, _), context, mkNativePath } =
231 :     ({ smlfiles = [(mkpath name, srq)], cmfiles = [] }, [])
232 :     fun cmrule { spec = (name, mkpath, _), context, mkNativePath } =
233 :     ({ smlfiles = [], cmfiles = [mkpath name] }, [])
234 : blume 272
235 : blume 518 fun expand { error, spec, context, load_plugin } = let
236 : blume 493 fun mkNativePath s = SrcPath.native { context = context, spec = s }
237 : blume 275 fun class2rule class =
238 :     case StringMap.find (!classes, class) of
239 :     SOME rule => rule
240 : blume 518 | NONE => let
241 :     val plugin = OS.Path.joinBaseExt { base = class ^ "-tool",
242 :     ext = SOME "cm" }
243 :     fun complain () =
244 :     (error (concat ["unknown class \"", class, "\""]);
245 : blume 493 smlrule Sharing.DONTCARE)
246 : blume 518 in
247 : blume 578 if load_plugin context plugin then
248 : blume 518 case StringMap.find (!classes, class) of
249 :     SOME rule => rule
250 :     | NONE => complain ()
251 :     else complain ()
252 :     end
253 :    
254 : blume 493 fun expand1 (spec as (name, _, co)) = let
255 :     val rule =
256 :     case co of
257 :     SOME c0 => class2rule (String.map Char.toLower c0)
258 :     | NONE =>
259 : blume 578 (case defaultClassOf (load_plugin context) name of
260 : blume 493 SOME c => class2rule c
261 :     | NONE => smlrule Sharing.DONTCARE)
262 :     fun rcontext rf = let
263 :     val dir = SrcPath.contextName context
264 : blume 275 val cwd = OS.FileSys.getDir ()
265 :     in
266 : blume 345 SafeIO.perform { openIt = fn () => OS.FileSys.chDir dir,
267 :     closeIt = fn () => OS.FileSys.chDir cwd,
268 :     work = rf,
269 : blume 459 cleanup = fn _ => () }
270 : blume 275 handle ToolError { tool, msg } =>
271 : blume 493 (error (concat ["tool \"", tool, "\" failed: ", msg]);
272 :     ({ smlfiles = [], cmfiles = [] }, []))
273 : blume 275 end
274 : blume 272 in
275 : blume 493 rule { spec = spec, context = rcontext,
276 :     mkNativePath = mkNativePath }
277 : blume 272 end
278 : blume 493 fun loop (expansion, []) = expansion
279 :     | loop ({ smlfiles, cmfiles }, item :: items) = let
280 :     val ({ smlfiles = sfl, cmfiles = cfl }, il) = expand1 item
281 : blume 276 in
282 : blume 493 loop ({ smlfiles = smlfiles @ sfl, cmfiles = cmfiles @ cfl},
283 :     il @ items)
284 : blume 276 end
285 : blume 272 in
286 : blume 493 loop ({ smlfiles = [], cmfiles = [] }, [spec])
287 : blume 272 end
288 :    
289 : blume 274 local
290 :     fun sfx (s, c) =
291 :     registerClassifier (stdSfxClassifier { sfx = s, class = c })
292 :     in
293 : blume 493 val _ = registerClass ("sml", smlrule Sharing.DONTCARE)
294 :     val _ = registerClass ("shared", smlrule Sharing.SHARED)
295 :     val _ = registerClass ("private", smlrule Sharing.PRIVATE)
296 :     val _ = registerClass ("cm", cmrule)
297 :    
298 : blume 274 val _ = sfx ("sml", "sml")
299 :     val _ = sfx ("sig", "sml")
300 :     val _ = sfx ("cm", "cm")
301 :     end
302 : blume 270 end
303 : blume 272
304 : blume 525 functor ToolsFn (val load_plugin : string -> bool
305 :     val mkStdSrcPath : string -> SrcPath.t) : TOOLS = struct
306 : blume 518 open PrivateTools
307 :     val defaultClassOf = defaultClassOf load_plugin
308 : blume 525
309 :     fun registerStdShellCmdTool args = let
310 : blume 578 val { tool, class, suffixes, cmdStdPath, extensionStyle, template } =
311 :     args
312 :     val template = getOpt (template, "%c %s")
313 : blume 525 fun mkCmdName () = let
314 :     (* It is not enough to turn the string into a SrcPath.t
315 :     * once. This is because if there was no anchor in the
316 :     * beginning, later additions of an anchor will go unnoticed.
317 :     * This is different from how other files (ML source files)
318 :     * behave: They, once the are found to be unanchored, should
319 :     * never become anchored later (although an existing anchor
320 :     * is allowed to change). *)
321 :     val p = mkStdSrcPath cmdStdPath
322 :     val n = SrcPath.osstring p
323 :     in
324 :     (* If the resulting path is not absolute, then it cannot have
325 :     * been anchored (configured). In this case we just use the
326 :     * given string as-is. *)
327 :     if OS.Path.isAbsolute n then n else cmdStdPath
328 :     end
329 :     fun rule { spec = (name, mkpath, _), context, mkNativePath } = let
330 :     val nativename = nativeSpec (mkpath name)
331 :     val targetfiles = extend extensionStyle nativename
332 :     val partial_expansion =
333 :     ({ smlfiles = [], cmfiles = [] },
334 :     map (fn (f, co) => (f, mkNativePath, co)) targetfiles)
335 :     fun runcmd () = let
336 : blume 578 val cmdname = mkCmdName ()
337 :     fun fill ([], sl) = concat (rev sl)
338 :     | fill (#"%" :: #"%" :: t, sl) = fill (t, "%" :: sl)
339 :     | fill (#"%" :: #"c" :: t, sl) = fill (t, cmdname :: sl)
340 :     | fill (#"%" :: #"s" :: t, sl) = fill (t, nativename :: sl)
341 :     | fill (#"%" :: t, sl) = let
342 :     fun finish (n, t) =
343 :     fill (t, #1 (List.nth (targetfiles, n-1)) :: sl)
344 :     handle General.Subscript =>
345 :     fill (t, Int.toString n :: "%" :: sl)
346 :     fun loop (n, []) = finish (n, [])
347 :     | loop (n, t as (c :: t')) =
348 :     if c >= #"0" andalso c < #"9" then
349 :     loop (n * 10 + Char.ord c - Char.ord #"0", t')
350 :     else finish (n, t)
351 :     in
352 :     loop (0, t)
353 :     end
354 :     | fill (c :: t, sl) = fill (t, String.str c :: sl)
355 :     val cmd = fill (String.explode template, [])
356 : blume 525 val _ = Say.vsay ["[", cmd, "]\n"]
357 :     in
358 :     if OS.Process.system cmd = OS.Process.success then ()
359 :     else raise ToolError { tool = tool, msg = cmd }
360 :     end
361 :     fun rulefn () =
362 :     (if outdated tool (map #1 targetfiles, nativename) then
363 :     runcmd ()
364 :     else ();
365 :     partial_expansion)
366 :     in
367 :     context rulefn
368 :     end
369 :     fun sfx s =
370 :     registerClassifier (stdSfxClassifier { sfx = s, class = class })
371 :     in
372 :     registerClass (class, rule);
373 :     app sfx suffixes
374 :     end
375 : blume 518 end

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