Fix file paths for recursive rmdom
[hcoop/domtool2.git] / src / order.sml
CommitLineData
095de39e
AC
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
21structure Order :> ORDER = struct
22
23open Ast
24
25structure SS = StringSet
26structure SM = StringMap
27
28fun 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
40fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
41
42fun 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
64val empty = ((SS.empty, SS.empty), SS.empty)
65
66fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
67 ((SS.union (c1, c2),
68 SS.union (t1, t2)),
69 SS.union (v1, v2))
70
71val dt = (TError, ErrorMsg.dummyLoc)
72
6bb366c5 73fun expNeeded G (e, loc) =
095de39e
AC
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
6bb366c5
AC
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
095de39e
AC
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, _, e) => expNeeded (Env.bindVal G (x, dt, NONE)) e
115 | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
116 empty es
117 | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
118 | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
119
120fun declNeeded G (d, _, _) =
121 case d of
122 DExternType name => (Env.bindType G name, empty)
123 | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
124 (typNeeded G t, SS.empty))
125 | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
126 case to of
127 NONE => expNeeded G e
128 | SOME t => unionCTE ((typNeeded G t, SS.empty),
129 expNeeded G e))
130 | DContext name => (Env.bindContext G name, empty)
131
132fun fileSig (_, ds, eo) =
133 let
134 val (G', needed) = foldl
135 (fn (d, (G, needed)) =>
136 let
137 val (G', needed') = declNeeded G d
138 in
139 (G', unionCTE (needed, needed'))
140 end)
141 (Env.empty, empty) ds
142
143 val needed =
144 case eo of
145 NONE => needed
146 | SOME e => unionCTE (needed,
147 expNeeded G' e)
148 in
149 (((Env.contexts G', Env.types G'), Env.vals G'),
150 needed)
151 end
152
153fun printSig ((cs, ts), vs) =
154 (print "Contexts:";
155 SS.app (fn s => (print " "; print s; print ";")) cs;
156 print "\n Types:";
157 SS.app (fn s => (print " "; print s; print ";")) ts;
158 print "\n Values:";
159 SS.app (fn s => (print " "; print s; print ";")) vs;
160 print "\n")
161
162fun mergeProvide kind fname (m1, m2) =
163 SS.foldl (fn (name, provide) =>
164 (case SM.find (provide, name) of
165 NONE => ()
166 | SOME fname' => ErrorMsg.error NONE (String.concat ["Files ",
167 fname',
168 " and ",
169 fname,
170 " both provide ",
171 kind,
172 " ",
173 name]);
174 SM.insert (provide, name, fname)))
175 m1 m2
176
c53e82e4 177fun order basisOpt fnames =
095de39e 178 let
095de39e
AC
179 fun doFile (fname, (provideC, provideT, provideV, require)) =
180 let
181 val file = Parse.parse fname
182 val (((provideC', provideT'), provideV'),
183 require') = fileSig file
184 in
185 (mergeProvide "context" fname (provideC, provideC'),
186 mergeProvide "type" fname (provideT, provideT'),
187 mergeProvide "value" fname (provideV, provideV'),
188 SM.insert (require, fname, require'))
189 end
190
191 val (provideC, provideT, provideV, require) =
192 foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
193
194 val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
195 let
c53e82e4 196 fun consider (kind, provide, lastChance) =
095de39e
AC
197 SS.foldl (fn (name, need) =>
198 case SM.find (provide, name) of
c53e82e4
AC
199 NONE =>
200 if lastChance name then
201 need
202 else
203 (ErrorMsg.error NONE
204 ("File "
205 ^ fname
206 ^ " uses undefined "
207 ^ kind
208 ^ " "
209 ^ name);
210 need)
095de39e
AC
211 | SOME fname' =>
212 SS.add (need, fname'))
213
c53e82e4
AC
214 val need = consider ("context", provideC,
215 case basisOpt of
216 NONE => (fn _ => false)
217 | SOME b => Env.lookupContext b)
095de39e 218 SS.empty rc
c53e82e4
AC
219 val need = consider ("type", provideT,
220 case basisOpt of
221 NONE => (fn _ => false)
222 | SOME b => Env.lookupType b)
095de39e 223 need rt
c53e82e4
AC
224 val need = consider ("value", provideV,
225 case basisOpt of
226 NONE => (fn _ => false)
227 | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
095de39e
AC
228 need rv
229 in
230 need
231 end) require
232
233 fun loop (ready, waiting, order) =
234 case SS.find (fn _ => true) ready of
235 NONE =>
236 if SM.numItems waiting = 0 then
237 rev order
238 else
239 (ErrorMsg.error NONE "Cyclic dependency in source files";
240 order)
241 | SOME next =>
242 let
243 val (ready', waiting') =
244 SM.foldli (fn (fname, requires, (ready', waiting')) =>
245 let
246 val requires' = SS.delete (requires, next)
247 handle NotFound => requires
248 in
249 if SS.numItems requires' = 0 then
250 (SS.add (ready', fname),
251 waiting')
252 else
253 (ready',
254 SM.insert (waiting', fname, requires'))
255 end)
256 (SS.delete (ready, next), SM.empty) waiting
257 in
258 loop (ready', waiting', next :: order)
259 end
260
261 val (ready, waiting) =
262 SM.foldli (fn (fname, requires, (ready, waiting)) =>
263 if SS.numItems requires = 0 then
264 (SS.add (ready, fname),
265 waiting)
266 else
267 (ready,
268 SM.insert (waiting, fname, requires)))
269 (SS.empty, SM.empty) require
270 in
271 (*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
272 SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
273 SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
274
275 (*SM.appi (fn (fname, requires) =>
276 (print fname;
277 print " requires:";
278 SS.app (fn fname' => (print " "; print fname')) requires;
279 print "\n")) require;*)
280
3196000d
AC
281 ({provideC = provideC,
282 provideT = provideT,
283 provideV = provideV},
284 loop (ready, waiting, []))
095de39e
AC
285 end
286
3196000d
AC
287type providers = {provideC : string SM.map,
288 provideT : string SM.map,
289 provideV : string SM.map}
290
291fun providesContext (p : providers, s) = SM.find (#provideC p, s)
292fun providesType (p : providers, s) = SM.find (#provideT p, s)
293fun providesValue (p : providers, s) = SM.find (#provideV p, s)
294
095de39e 295end