Fix regeneration of multi-file dependencies
[hcoop/domtool2.git] / src / order.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 *
4 * This program is free software; you can redistribute it and/or
5 * modify it under the terms of the GNU General Public License
6 * as published by the Free Software Foundation; either version 2
7 * of the License, or (at your option) any later version.
8 *
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
13 *
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
17 *)
18
19 (* Topological sorting of source files to take dependencies into account *)
20
21 structure Order :> ORDER = struct
22
23 open Ast
24
25 structure SS = StringSet
26 structure SM = StringMap
27
28 fun predNeeded G (p, _) =
29 case p of
30 CRoot => SS.empty
31 | CConst s =>
32 if Env.lookupContext G s then
33 SS.empty
34 else
35 SS.singleton s
36 | CPrefix p => predNeeded G p
37 | CNot p => predNeeded G p
38 | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)
39
40 fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
41
42 fun typNeeded G (t, _) =
43 case t of
44 TBase s =>
45 if Env.lookupType G s then
46 (SS.empty, SS.empty)
47 else
48 (SS.empty, SS.singleton s)
49 | TList t => typNeeded G t
50 | TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
51 | TAction (p, d, r) =>
52 let
53 val recordNeeded = SM.foldl
54 (fn (t, ss) => unionCT (ss, typNeeded G t))
55 in
56 recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
57 end
58 | TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
59 typNeeded G t)
60
61 | TError => raise Fail "TError during dependency analysis"
62 | TUnif _ => raise Fail "TUnif during dependency analysis"
63
64 val empty = ((SS.empty, SS.empty), SS.empty)
65
66 fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
67 ((SS.union (c1, c2),
68 SS.union (t1, t2)),
69 SS.union (v1, v2))
70
71 val dt = (TError, ErrorMsg.dummyLoc)
72
73 fun expNeeded G (e, loc) =
74 case e of
75 EInt _ => ((SS.empty,
76 if Env.lookupType G "int" then
77 SS.empty
78 else
79 SS.singleton "int"),
80 SS.empty)
81 | EString _ => ((SS.empty,
82 if Env.lookupType G "string" then
83 SS.empty
84 else
85 SS.singleton "string"),
86 SS.empty)
87 | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
88 empty es
89
90 | ELam (x, to, e) =>
91 let
92 val G' = Env.bindVal G (x, dt, NONE)
93 in
94 case to of
95 NONE => expNeeded G' e
96 | SOME t => unionCTE ((typNeeded G t, SS.empty),
97 expNeeded G' e)
98 end
99 | EALam (x, p, e) =>
100 let
101 val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE)
102 in
103 unionCTE (((predNeeded G p, SS.empty), SS.empty),
104 expNeeded G' e)
105 end
106 | EVar x =>
107 (case Env.lookupVal G x of
108 NONE => ((SS.empty, SS.empty), SS.singleton x)
109 | _ => empty)
110 | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
111
112 | ESkip => empty
113 | ESet (_, e) => expNeeded G e
114 | EGet (x, topt, _, e) =>
115 (case topt of
116 NONE => expNeeded (Env.bindVal G (x, dt, NONE)) e
117 | SOME t => unionCTE ((typNeeded G t, SS.empty),
118 expNeeded (Env.bindVal G (x, dt, NONE)) e))
119 | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
120 empty es
121 | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
122 | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
123 | EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
124 unionCTE (expNeeded G e2,
125 expNeeded G e3))
126
127 fun declNeeded G (d, _, _) =
128 case d of
129 DExternType name => (Env.bindType G name, empty)
130 | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
131 (typNeeded G t, SS.empty))
132 | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
133 case to of
134 NONE => expNeeded G e
135 | SOME t => unionCTE ((typNeeded G t, SS.empty),
136 expNeeded G e))
137 | DContext name => (Env.bindContext G name, empty)
138
139 fun fileSig (_, ds, eo) =
140 let
141 val (G', needed) = foldl
142 (fn (d, (G, needed)) =>
143 let
144 val (G', needed') = declNeeded G d
145 in
146 (G', unionCTE (needed, needed'))
147 end)
148 (Env.empty, empty) ds
149
150 val needed =
151 case eo of
152 NONE => needed
153 | SOME e => unionCTE (needed,
154 expNeeded G' e)
155 in
156 (((Env.contexts G', Env.types G'), Env.vals G'),
157 needed)
158 end
159
160 fun printSig ((cs, ts), vs) =
161 (print "Contexts:";
162 SS.app (fn s => (print " "; print s; print ";")) cs;
163 print "\n Types:";
164 SS.app (fn s => (print " "; print s; print ";")) ts;
165 print "\n Values:";
166 SS.app (fn s => (print " "; print s; print ";")) vs;
167 print "\n")
168
169 val allNaughty = ref false
170 val naughtyFiles = ref SS.empty
171 fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)
172
173 fun mergeProvide kind fname (m1, m2) =
174 SS.foldl (fn (name, provide) =>
175 (case SM.find (provide, name) of
176 NONE => ()
177 | SOME fname' =>
178 (addNaughty fname;
179 addNaughty fname';
180 ErrorMsg.error NONE (String.concat ["Files ",
181 fname',
182 " and ",
183 fname,
184 " both provide ",
185 kind,
186 " ",
187 name]));
188 SM.insert (provide, name, fname)))
189 m1 m2
190
191 fun order basisOpt fnames =
192 let
193 val () = allNaughty := false
194 val () = naughtyFiles := SS.empty
195
196 fun doFile (fname, (provideC, provideT, provideV, require)) =
197 let
198 val file = Parse.parse fname
199 val (((provideC', provideT'), provideV'),
200 require') = fileSig file
201 in
202 (mergeProvide "context" fname (provideC, provideC'),
203 mergeProvide "type" fname (provideT, provideT'),
204 mergeProvide "value" fname (provideV, provideV'),
205 SM.insert (require, fname, require'))
206 end
207
208 val (provideC, provideT, provideV, require) =
209 foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
210
211 val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
212 let
213 fun consider (kind, provide, lastChance) =
214 SS.foldl (fn (name, need) =>
215 case SM.find (provide, name) of
216 NONE =>
217 if lastChance name then
218 need
219 else
220 (addNaughty fname;
221 ErrorMsg.error NONE
222 ("File "
223 ^ fname
224 ^ " uses undefined "
225 ^ kind
226 ^ " "
227 ^ name);
228 need)
229 | SOME fname' =>
230 SS.add (need, fname'))
231
232 val need = consider ("context", provideC,
233 case basisOpt of
234 NONE => (fn _ => false)
235 | SOME b => Env.lookupContext b)
236 SS.empty rc
237 val need = consider ("type", provideT,
238 case basisOpt of
239 NONE => (fn _ => false)
240 | SOME b => Env.lookupType b)
241 need rt
242 val need = consider ("value", provideV,
243 case basisOpt of
244 NONE => (fn _ => false)
245 | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
246 need rv
247 in
248 need
249 end) require
250
251 fun loop (ready, waiting, order) =
252 case SS.find (fn _ => true) ready of
253 NONE =>
254 if SM.numItems waiting = 0 then
255 rev order
256 else
257 (allNaughty := true;
258 ErrorMsg.error NONE "Cyclic dependency in source files";
259 order)
260 | SOME next =>
261 let
262 val (ready', waiting') =
263 SM.foldli (fn (fname, requires, (ready', waiting')) =>
264 let
265 val requires' = SS.delete (requires, next)
266 handle NotFound => requires
267 in
268 if SS.numItems requires' = 0 then
269 (SS.add (ready', fname),
270 waiting')
271 else
272 (ready',
273 SM.insert (waiting', fname, requires'))
274 end)
275 (SS.delete (ready, next), SM.empty) waiting
276 in
277 loop (ready', waiting', next :: order)
278 end
279
280 val (ready, waiting) =
281 SM.foldli (fn (fname, requires, (ready, waiting)) =>
282 if SS.numItems requires = 0 then
283 (SS.add (ready, fname),
284 waiting)
285 else
286 (ready,
287 SM.insert (waiting, fname, requires)))
288 (SS.empty, SM.empty) require
289
290 val ordered = loop (ready, waiting, [])
291 val provider = {provideC = provideC,
292 provideT = provideT,
293 provideV = provideV}
294 in
295 if !allNaughty then
296 (provider, [])
297 else if SS.isEmpty (!naughtyFiles) then
298 (provider, ordered)
299 else
300 order basisOpt (List.filter (fn fname => not (SS.member (!naughtyFiles, fname))) fnames)
301 end
302
303 val order = fn basisOpt => fn fnames =>
304 let
305 val (providers, fnames) = order basisOpt fnames
306
307 val (hasLib, fnames) = foldl (fn (fname, (hasLib, fnames)) =>
308 if OS.Path.file fname = "lib.dtl" then
309 (SOME fname, fnames)
310 else
311 (hasLib, fname :: fnames))
312 (NONE, []) fnames
313
314 val fnames = rev fnames
315 val fnames = case hasLib of
316 NONE => fnames
317 | SOME hasLib => hasLib :: fnames
318 in
319 (providers, fnames)
320 end
321
322 type providers = {provideC : string SM.map,
323 provideT : string SM.map,
324 provideV : string SM.map}
325
326 fun providesContext (p : providers, s) = SM.find (#provideC p, s)
327 fun providesType (p : providers, s) = SM.find (#provideT p, s)
328 fun providesValue (p : providers, s) = SM.find (#provideV p, s)
329
330 end