domain: export validIpv6 and validIp
[hcoop/domtool2.git] / src / order.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006, Adam Chlipala
3 * Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>
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
74 fun expNeeded G (e, loc) =
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
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
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
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))
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)
124 | EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
125 unionCTE (expNeeded G e2,
126 expNeeded G e3))
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))
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))
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
175 val allNaughty = ref false
176 val naughtyFiles = ref SS.empty
177 fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)
178
179 fun mergeProvide kind fname (m1, m2) =
180 SS.foldl (fn (name, provide) =>
181 (case SM.find (provide, name) of
182 NONE => ()
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]));
194 SM.insert (provide, name, fname)))
195 m1 m2
196
197 fun order basisOpt fnames =
198 let
199 val () = allNaughty := false
200 val () = naughtyFiles := SS.empty
201
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
219 fun consider (kind, provide, lastChance) =
220 SS.foldl (fn (name, need) =>
221 case SM.find (provide, name) of
222 NONE =>
223 if lastChance name then
224 need
225 else
226 (addNaughty fname;
227 ErrorMsg.error NONE
228 ("File "
229 ^ fname
230 ^ " uses undefined "
231 ^ kind
232 ^ " "
233 ^ name);
234 need)
235 | SOME fname' =>
236 SS.add (need, fname'))
237
238 val need = consider ("context", provideC,
239 case basisOpt of
240 NONE => (fn _ => false)
241 | SOME b => Env.lookupContext b)
242 SS.empty rc
243 val need = consider ("type", provideT,
244 case basisOpt of
245 NONE => (fn _ => false)
246 | SOME b => Env.lookupType b)
247 need rt
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)))
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
263 (allNaughty := true;
264 ErrorMsg.error NONE "Cyclic dependency in source files";
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
295
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)
307 end
308
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
327
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
336 end