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

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