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

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