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 387 - (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 : blume 387 val registerSmlClass : class * Sharing.request -> unit
34 : blume 272
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 387 { sourcepath: SrcPath.t, history: class list,
81 :     sh_spec: Sharing.request }
82 : blume 270
83 :     datatype expansion =
84 : blume 274 SMLSOURCE of smlsource
85 : blume 354 | GROUP of SrcPath.t
86 : blume 270
87 : blume 272 datatype private_rule =
88 : blume 387 ISSML of Sharing.request
89 : blume 272 | ISGROUP
90 :     | ISTOOL of class * rule
91 :    
92 : blume 354 val expand : (string -> unit) -> SrcPath.t * class option -> expansion list
93 : blume 270 end
94 :    
95 : blume 272 structure PrivateTools :> PRIVATETOOLS = struct
96 : blume 270
97 : blume 272 type fname = string
98 :     type class = string
99 : blume 270
100 : blume 272 exception ToolError of { tool: string, msg: string }
101 :    
102 :     type item = fname * class option
103 :    
104 :     type rulefn = unit -> item list
105 :     type rulecontext = rulefn -> item list
106 :     type rule = fname * rulecontext -> item list
107 :    
108 : blume 270 type smlsource =
109 : blume 387 { sourcepath: SrcPath.t, history: class list,
110 :     sh_spec: Sharing.request }
111 : blume 270
112 :     datatype expansion =
113 : blume 274 SMLSOURCE of smlsource
114 : blume 354 | GROUP of SrcPath.t
115 : blume 270
116 : blume 272 datatype private_rule =
117 : blume 387 ISSML of Sharing.request
118 : blume 272 | ISGROUP
119 :     | ISTOOL of class * rule
120 :    
121 :     val classes : private_rule StringMap.map ref = ref (StringMap.empty)
122 :    
123 :     fun registerClass (class, rule) =
124 :     classes := StringMap.insert (!classes, class, ISTOOL (class, rule))
125 :    
126 : blume 387 fun registerSmlClass (class, shrq) =
127 :     classes := StringMap.insert (!classes, class, ISSML shrq)
128 : blume 272
129 :     fun registerGroupClass class =
130 :     classes := StringMap.insert (!classes, class, ISGROUP)
131 :    
132 :     (* classifiers are used when the class is not given explicitly *)
133 :     datatype classifier =
134 :     SFX_CLASSIFIER of string -> class option
135 : blume 276 | GEN_CLASSIFIER of fname -> class option
136 : blume 272
137 :     (* make a classifier which looks for a specific file name suffix *)
138 :     fun stdSfxClassifier { sfx, class } =
139 :     SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
140 :    
141 :     (* install a classifier *)
142 :     val sfx_classifiers: (string -> class option) list ref = ref []
143 :     val gen_classifiers: (fname -> class option) list ref = ref []
144 :    
145 :     local
146 :     fun add (x, r) = r := x :: (!r)
147 :     in
148 :     fun registerClassifier (SFX_CLASSIFIER c) = add (c, sfx_classifiers)
149 :     | registerClassifier (GEN_CLASSIFIER c) = add (c, gen_classifiers)
150 :     end
151 :    
152 :     (* query default class *)
153 :     fun defaultClassOf p = let
154 :     fun gen_loop [] = NONE
155 :     | gen_loop (h :: t) =
156 :     (case h p of
157 :     NONE => gen_loop t
158 :     | SOME c => SOME c)
159 :    
160 :     fun sfx_loop e = let
161 :     fun loop [] = gen_loop (!gen_classifiers)
162 :     | loop (h :: t) =
163 :     (case h e of
164 :     NONE => loop t
165 :     | SOME c => SOME c)
166 :     in
167 :     loop (!sfx_classifiers)
168 :     end
169 :     in
170 :     case OS.Path.ext p of
171 :     SOME e => sfx_loop e
172 :     | NONE => gen_loop (!gen_classifiers)
173 :     end
174 :    
175 : blume 275 fun expand error = let
176 : blume 272
177 : blume 275 (* get the rule corresponding to a given class *)
178 :     fun class2rule class =
179 :     case StringMap.find (!classes, class) of
180 :     SOME rule => rule
181 :     | NONE => (error (concat ["unknown class \"", class, "\""]);
182 : blume 387 ISSML Sharing.DONTCARE)
183 : blume 275
184 :     (* apply a rule to a path within a given context *)
185 :     fun apply (rule, p, c) = let
186 :     fun rctxt rf = let
187 : blume 354 val dir = SrcPath.contextName c
188 : blume 275 val cwd = OS.FileSys.getDir ()
189 :     in
190 : blume 345 SafeIO.perform { openIt = fn () => OS.FileSys.chDir dir,
191 :     closeIt = fn () => OS.FileSys.chDir cwd,
192 :     work = rf,
193 :     cleanup = fn () => () }
194 : blume 275 handle ToolError { tool, msg } =>
195 : blume 345 (error (concat ["tool \"", tool, "\" failed: ", msg]); [])
196 : blume 275 end
197 : blume 272 in
198 : blume 275 rule (p, rctxt)
199 : blume 272 end
200 :    
201 : blume 275 fun expand' context = let
202 :     fun loop (acc, []) = rev acc
203 :     | loop (acc, ((p, c), history) :: t) = let
204 : blume 387 fun step (ISSML shrq) =
205 : blume 275 let
206 : blume 354 val ap = SrcPath.native { context = context,
207 : blume 275 spec = p }
208 :     val src = { sourcepath = ap,
209 :     history = rev history,
210 : blume 387 sh_spec = shrq }
211 : blume 275 in
212 :     loop (SMLSOURCE src :: acc, t)
213 :     end
214 :     | step ISGROUP = let
215 : blume 354 val ap = SrcPath.native { context = context,
216 : blume 275 spec = p }
217 :     in
218 :     loop (GROUP ap :: acc, t)
219 :     end
220 :     | step (ISTOOL (class, rule)) = let
221 :     val l = apply (rule, p, context)
222 :     val l' = map (fn i => (i, class :: history)) l
223 :     in
224 :     loop (acc, l' @ t)
225 :     end
226 :     in
227 :     case c of
228 :     SOME class => step (class2rule class)
229 :     | NONE =>
230 :     (case defaultClassOf p of
231 :     SOME class => step (class2rule class)
232 : blume 387 | NONE => step (ISSML Sharing.DONTCARE))
233 : blume 275 end
234 :     in
235 :     fn l => loop ([], l)
236 :     end
237 :    
238 : blume 276 fun expand0 (ap, NONE) =
239 : blume 354 expand' (SrcPath.contextOf ap) [((SrcPath.specOf ap, NONE), [])]
240 : blume 276 | expand0 (ap, SOME class0) = let
241 :     (* classes are case-insensitive, internally we use lowercase *)
242 :     val class = String.map Char.toLower class0
243 :     in
244 :     case class2rule class of
245 : blume 387 ISSML shrq =>
246 : blume 276 [SMLSOURCE { sourcepath = ap, history = [],
247 : blume 387 sh_spec = shrq }]
248 : blume 276 | ISGROUP =>
249 :     [GROUP ap]
250 :     | ISTOOL (class, rule) => let
251 : blume 354 val c = SrcPath.contextOf ap
252 :     val l = apply (rule, SrcPath.specOf ap, c)
253 : blume 276 val l' = map (fn i => (i, [class])) l
254 :     in
255 : blume 354 expand' (SrcPath.contextOf ap) l'
256 : blume 276 end
257 :     end
258 : blume 272 in
259 : blume 275 expand0
260 : blume 272 end
261 :    
262 : blume 276 datatype extensionStyle =
263 :     EXTEND of string list
264 :     | REPLACE of string list * string list
265 :    
266 :     fun extend (EXTEND l) f = map (fn s => concat [f, ".", s]) l
267 :     | extend (REPLACE (ol, nl)) f = let
268 :     val { base, ext } = OS.Path.splitBaseExt f
269 :     fun join b e = OS.Path.joinBaseExt { base = b, ext = SOME e }
270 :     fun gen b = map (join b) nl
271 :     fun sameExt (e1: string) (e2: string) = e1 = e2
272 :     in
273 :     case ext of
274 :     NONE => gen base
275 :     | SOME e =>
276 :     if List.exists (sameExt e) ol then gen base else gen f
277 :     end
278 :    
279 :     fun outdated tool (l, f) = let
280 :     val (ftime, fexists) =
281 :     (OS.FileSys.modTime f, true)
282 :     handle _ => (Time.zeroTime, false)
283 :     fun olderThan t f = Time.< (OS.FileSys.modTime f, t)
284 :     in
285 :     (List.exists (olderThan ftime) l)
286 :     handle _ => if fexists then true
287 :     else raise ToolError { tool = tool,
288 :     msg = "cannot access " ^ f }
289 :     end
290 :    
291 : blume 282 type cmdGetterSetter = string option -> string
292 :    
293 : blume 321 fun newCmdGetterSetter sp = EnvConfig.getSet (EnvConfig.new SOME sp)
294 : blume 282
295 :     fun registerStdShellCmdTool arg = let
296 :     val { tool, class, suffixes, command, extensionStyle, sml } = arg
297 :     fun rule (f, ctxt) = let
298 :     val targetfiles = extend extensionStyle f
299 :     val mkTarget =
300 :     if sml then (fn tf => (tf, SOME "sml"))
301 :     else (fn tf => (tf, NONE))
302 :     val targets = map mkTarget targetfiles
303 :     fun runcmd () = let
304 :     val cmd = concat [command NONE, " ", f]
305 : blume 310 val _ = Say.vsay ["[", cmd, "]\n"]
306 : blume 282 in
307 :     if OS.Process.system cmd = OS.Process.success then ()
308 :     else raise ToolError { tool = tool, msg = cmd }
309 :     end
310 :     fun rfun () =
311 :     (if outdated tool (targetfiles, f) then runcmd ()
312 :     else ();
313 :     targets)
314 :     in
315 :     ctxt rfun
316 :     end
317 :    
318 :     fun sfx s =
319 :     registerClassifier (stdSfxClassifier { sfx = s, class = class })
320 :     in
321 :     registerClass (class, rule);
322 :     app sfx suffixes
323 :     end
324 :    
325 : blume 274 (* registering standard classes and classifiers *)
326 :     local
327 :     fun sfx (s, c) =
328 :     registerClassifier (stdSfxClassifier { sfx = s, class = c })
329 :     in
330 : blume 387 val _ = registerSmlClass ("sml", Sharing.DONTCARE)
331 :     val _ = registerSmlClass ("shared", Sharing.SHARED)
332 :     val _ = registerSmlClass ("private", Sharing.PRIVATE)
333 : blume 274 val _ = registerGroupClass "cm"
334 :    
335 :     val _ = sfx ("sml", "sml")
336 :     val _ = sfx ("sig", "sml")
337 :     val _ = sfx ("cm", "cm")
338 :     end
339 : blume 270 end
340 : blume 272
341 : blume 276 structure Tools : TOOLS = PrivateTools

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