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