Permission revocation
[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, _, 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
120 fun 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
132 fun 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
153 fun 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
162 fun 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
177 fun order fnames =
178 let
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
268 ({provideC = provideC,
269 provideT = provideT,
270 provideV = provideV},
271 loop (ready, waiting, []))
272 end
273
274 type providers = {provideC : string SM.map,
275 provideT : string SM.map,
276 provideV : string SM.map}
277
278 fun providesContext (p : providers, s) = SM.find (#provideC p, s)
279 fun providesType (p : providers, s) = SM.find (#provideT p, s)
280 fun providesValue (p : providers, s) = SM.find (#provideV p, s)
281
282 end