Fix problem noted by omry on original domtool; namely, bad handling of rewrites insid...
[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
177fun order fnames =
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
196 fun consider (kind, provide) =
197 SS.foldl (fn (name, need) =>
198 case SM.find (provide, name) of
199 NONE => (ErrorMsg.error NONE
200 ("File "
201 ^ fname
202 ^ " uses undefined "
203 ^ kind
204 ^ " "
205 ^ name);
206 need)
207 | SOME fname' =>
208 SS.add (need, fname'))
209
210 val need = consider ("context", provideC)
211 SS.empty rc
212 val need = consider ("type", provideT)
213 need rt
214 val need = consider ("value", provideV)
215 need rv
216 in
217 need
218 end) require
219
220 fun loop (ready, waiting, order) =
221 case SS.find (fn _ => true) ready of
222 NONE =>
223 if SM.numItems waiting = 0 then
224 rev order
225 else
226 (ErrorMsg.error NONE "Cyclic dependency in source files";
227 order)
228 | SOME next =>
229 let
230 val (ready', waiting') =
231 SM.foldli (fn (fname, requires, (ready', waiting')) =>
232 let
233 val requires' = SS.delete (requires, next)
234 handle NotFound => requires
235 in
236 if SS.numItems requires' = 0 then
237 (SS.add (ready', fname),
238 waiting')
239 else
240 (ready',
241 SM.insert (waiting', fname, requires'))
242 end)
243 (SS.delete (ready, next), SM.empty) waiting
244 in
245 loop (ready', waiting', next :: order)
246 end
247
248 val (ready, waiting) =
249 SM.foldli (fn (fname, requires, (ready, waiting)) =>
250 if SS.numItems requires = 0 then
251 (SS.add (ready, fname),
252 waiting)
253 else
254 (ready,
255 SM.insert (waiting, fname, requires)))
256 (SS.empty, SM.empty) require
257 in
258 (*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
259 SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
260 SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
261
262 (*SM.appi (fn (fname, requires) =>
263 (print fname;
264 print " requires:";
265 SS.app (fn fname' => (print " "; print fname')) requires;
266 print "\n")) require;*)
267
3196000d
AC
268 ({provideC = provideC,
269 provideT = provideT,
270 provideV = provideV},
271 loop (ready, waiting, []))
095de39e
AC
272 end
273
3196000d
AC
274type providers = {provideC : string SM.map,
275 provideT : string SM.map,
276 provideV : string SM.map}
277
278fun providesContext (p : providers, s) = SM.find (#provideC p, s)
279fun providesType (p : providers, s) = SM.find (#provideT p, s)
280fun providesValue (p : providers, s) = SM.find (#provideV p, s)
281
095de39e 282end