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