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 518 - (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 : blume 493 type cmdController = { get: unit -> string, set: string -> unit }
84 : blume 282
85 : blume 493 val newCmdController : string * string -> cmdController
86 : blume 282
87 : blume 493 val registerStdShellCmdTool : { tool: string,
88 :     class: string,
89 :     suffixes: string list,
90 :     command: cmdController,
91 : blume 518 extensionStyle: extensionStyle } -> unit
92 : blume 282
93 : blume 276 (* perform filename extension *)
94 : blume 518 val extend : extensionStyle -> string -> (string * class option) list
95 : blume 276
96 : blume 493 (* check for outdated files; the pathname strings must be in
97 :     * native syntax! *)
98 :     val outdated : string -> string list * string -> bool
99 : blume 276
100 : blume 272 (* install a classifier *)
101 :     val registerClassifier : classifier -> unit
102 :     end
103 :    
104 :     signature PRIVATETOOLS = sig
105 : blume 518 include CORETOOLS where type srcpath = SrcPath.t
106 :    
107 : blume 493 val expand : { error: string -> unit,
108 :     spec: spec,
109 : blume 518 context: SrcPath.context,
110 :     load_plugin: string -> bool }
111 : blume 493 -> expansion
112 : blume 518
113 :     val defaultClassOf : (string -> bool) -> string -> class option
114 : blume 270 end
115 :    
116 : blume 518 signature TOOLS = sig
117 :     include CORETOOLS
118 :    
119 :     (* query default class *)
120 :     val defaultClassOf : string -> class option
121 :     end
122 :    
123 : blume 272 structure PrivateTools :> PRIVATETOOLS = struct
124 : blume 270
125 : blume 272 type class = string
126 : blume 270
127 : blume 493 type srcpath = SrcPath.t
128 :    
129 :     val nativeSpec = SrcPath.specOf
130 :    
131 : blume 272 exception ToolError of { tool: string, msg: string }
132 :    
133 : blume 493 type pathmaker = string -> srcpath
134 : blume 272
135 : blume 493 type spec = string * pathmaker * class option
136 : blume 272
137 : blume 493 type expansion = { smlfiles: (srcpath * Sharing.request) list,
138 :     cmfiles: srcpath list }
139 : blume 270
140 : blume 493 type partial_expansion = expansion * spec list
141 : blume 270
142 : blume 493 type rulefn = unit -> partial_expansion
143 :     type rulecontext = rulefn -> partial_expansion
144 :     type rule =
145 :     { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
146 :     partial_expansion
147 : blume 272
148 : blume 493 val classes : rule StringMap.map ref = ref StringMap.empty
149 : blume 424
150 : blume 272 fun registerClass (class, rule) =
151 : blume 493 classes := StringMap.insert (!classes, class, rule)
152 : blume 272
153 :     datatype classifier =
154 :     SFX_CLASSIFIER of string -> class option
155 : blume 493 | GEN_CLASSIFIER of string -> class option
156 : blume 272
157 :     fun stdSfxClassifier { sfx, class } =
158 :     SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
159 :    
160 : blume 493 datatype extensionStyle =
161 : blume 518 EXTEND of (string * class option) list
162 :     | REPLACE of string list * (string * class option) list
163 : blume 272
164 : blume 493 type cmdController = { get: unit -> string, set: string -> unit }
165 :    
166 :     fun newCmdController sp = EnvConfig.new SOME sp
167 :    
168 : blume 518 fun extend (EXTEND l) f = map (fn (s, co) => (concat [f, ".", s], co)) l
169 : blume 493 | extend (REPLACE (ol, nl)) f = let
170 :     val { base, ext } = OS.Path.splitBaseExt f
171 : blume 518 fun join b (e, co) =
172 :     (OS.Path.joinBaseExt { base = b, ext = SOME e }, co)
173 : blume 493 fun gen b = map (join b) nl
174 :     fun sameExt (e1: string) (e2: string) = e1 = e2
175 :     in
176 :     case ext of
177 :     NONE => gen base
178 :     | SOME e =>
179 :     if List.exists (sameExt e) ol then gen base else gen f
180 :     end
181 :    
182 :     fun outdated tool (l, f) = let
183 :     val (ftime, fexists) =
184 :     (OS.FileSys.modTime f, true)
185 :     handle _ => (Time.zeroTime, false)
186 :     fun olderThan t f = Time.< (OS.FileSys.modTime f, t)
187 :     in
188 :     (List.exists (olderThan ftime) l)
189 :     handle _ => if fexists then true
190 :     else raise ToolError { tool = tool,
191 :     msg = "cannot access " ^ f }
192 :     end
193 :    
194 :     val sfx_classifiers : (string -> class option) list ref = ref []
195 :     val gen_classifiers : (string -> class option) list ref = ref []
196 :    
197 : blume 272 local
198 :     fun add (x, r) = r := x :: (!r)
199 :     in
200 :     fun registerClassifier (SFX_CLASSIFIER c) = add (c, sfx_classifiers)
201 :     | registerClassifier (GEN_CLASSIFIER c) = add (c, gen_classifiers)
202 :     end
203 :    
204 : blume 493 fun registerStdShellCmdTool args = let
205 : blume 518 val { tool, class, suffixes, command, extensionStyle } = args
206 : blume 493 fun rule { spec = (name, mkpath, _), context, mkNativePath } = let
207 :     val nativename = nativeSpec (mkpath name)
208 :     val targetfiles = extend extensionStyle nativename
209 :     val partial_expansion =
210 : blume 518 ({ smlfiles = [], cmfiles = [] },
211 :     map (fn (f, co) => (f, mkNativePath, co)) targetfiles)
212 : blume 493 fun runcmd () = let
213 :     val cmd =
214 :     concat [#get (command: cmdController) (), " ", nativename]
215 :     val _ = Say.vsay ["[", cmd, "]\n"]
216 :     in
217 :     if OS.Process.system cmd = OS.Process.success then ()
218 :     else raise ToolError { tool = tool, msg = cmd }
219 :     end
220 :     fun rulefn () =
221 : blume 518 (if outdated tool (map #1 targetfiles, nativename) then
222 :     runcmd ()
223 : blume 493 else ();
224 :     partial_expansion)
225 :     in
226 :     context rulefn
227 :     end
228 :     fun sfx s =
229 :     registerClassifier (stdSfxClassifier { sfx = s, class = class })
230 :     in
231 :     registerClass (class, rule);
232 :     app sfx suffixes
233 :     end
234 :    
235 : blume 272 (* query default class *)
236 : blume 518 fun defaultClassOf load_plugin p = let
237 : blume 272 fun gen_loop [] = NONE
238 :     | gen_loop (h :: t) =
239 :     (case h p of
240 :     NONE => gen_loop t
241 :     | SOME c => SOME c)
242 :    
243 :     fun sfx_loop e = let
244 :     fun loop [] = gen_loop (!gen_classifiers)
245 :     | loop (h :: t) =
246 :     (case h e of
247 :     NONE => loop t
248 :     | SOME c => SOME c)
249 :     in
250 :     loop (!sfx_classifiers)
251 :     end
252 :     in
253 :     case OS.Path.ext p of
254 : blume 518 SOME e =>
255 :     (case sfx_loop e of
256 :     SOME c => SOME c
257 :     | NONE => let
258 :     val plugin = OS.Path.joinBaseExt { base = e ^ "-ext",
259 :     ext = SOME "cm" }
260 :     in
261 :     if load_plugin plugin then sfx_loop e else NONE
262 :     end)
263 : blume 272 | NONE => gen_loop (!gen_classifiers)
264 :     end
265 :    
266 : blume 493 fun smlrule srq { spec = (name, mkpath, _), context, mkNativePath } =
267 :     ({ smlfiles = [(mkpath name, srq)], cmfiles = [] }, [])
268 :     fun cmrule { spec = (name, mkpath, _), context, mkNativePath } =
269 :     ({ smlfiles = [], cmfiles = [mkpath name] }, [])
270 : blume 272
271 : blume 518 fun expand { error, spec, context, load_plugin } = let
272 : blume 493 fun mkNativePath s = SrcPath.native { context = context, spec = s }
273 : blume 275 fun class2rule class =
274 :     case StringMap.find (!classes, class) of
275 :     SOME rule => rule
276 : blume 518 | NONE => let
277 :     val plugin = OS.Path.joinBaseExt { base = class ^ "-tool",
278 :     ext = SOME "cm" }
279 :     fun complain () =
280 :     (error (concat ["unknown class \"", class, "\""]);
281 : blume 493 smlrule Sharing.DONTCARE)
282 : blume 518 in
283 :     if load_plugin plugin then
284 :     case StringMap.find (!classes, class) of
285 :     SOME rule => rule
286 :     | NONE => complain ()
287 :     else complain ()
288 :     end
289 :    
290 : blume 493 fun expand1 (spec as (name, _, co)) = let
291 :     val rule =
292 :     case co of
293 :     SOME c0 => class2rule (String.map Char.toLower c0)
294 :     | NONE =>
295 : blume 518 (case defaultClassOf load_plugin name of
296 : blume 493 SOME c => class2rule c
297 :     | NONE => smlrule Sharing.DONTCARE)
298 :     fun rcontext rf = let
299 :     val dir = SrcPath.contextName context
300 : blume 275 val cwd = OS.FileSys.getDir ()
301 :     in
302 : blume 345 SafeIO.perform { openIt = fn () => OS.FileSys.chDir dir,
303 :     closeIt = fn () => OS.FileSys.chDir cwd,
304 :     work = rf,
305 : blume 459 cleanup = fn _ => () }
306 : blume 275 handle ToolError { tool, msg } =>
307 : blume 493 (error (concat ["tool \"", tool, "\" failed: ", msg]);
308 :     ({ smlfiles = [], cmfiles = [] }, []))
309 : blume 275 end
310 : blume 272 in
311 : blume 493 rule { spec = spec, context = rcontext,
312 :     mkNativePath = mkNativePath }
313 : blume 272 end
314 : blume 493 fun loop (expansion, []) = expansion
315 :     | loop ({ smlfiles, cmfiles }, item :: items) = let
316 :     val ({ smlfiles = sfl, cmfiles = cfl }, il) = expand1 item
317 : blume 276 in
318 : blume 493 loop ({ smlfiles = smlfiles @ sfl, cmfiles = cmfiles @ cfl},
319 :     il @ items)
320 : blume 276 end
321 : blume 272 in
322 : blume 493 loop ({ smlfiles = [], cmfiles = [] }, [spec])
323 : blume 272 end
324 :    
325 : blume 274 local
326 :     fun sfx (s, c) =
327 :     registerClassifier (stdSfxClassifier { sfx = s, class = c })
328 :     in
329 : blume 493 val _ = registerClass ("sml", smlrule Sharing.DONTCARE)
330 :     val _ = registerClass ("shared", smlrule Sharing.SHARED)
331 :     val _ = registerClass ("private", smlrule Sharing.PRIVATE)
332 :     val _ = registerClass ("cm", cmrule)
333 :    
334 : blume 274 val _ = sfx ("sml", "sml")
335 :     val _ = sfx ("sig", "sml")
336 :     val _ = sfx ("cm", "cm")
337 :     end
338 : blume 270 end
339 : blume 272
340 : blume 518 functor ToolsFn (val load_plugin : string -> bool) : TOOLS = struct
341 :     open PrivateTools
342 :     val defaultClassOf = defaultClassOf load_plugin
343 :     end

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