[hcoop/domtool2.git] / src / order.sml

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006, Adam Chlipala
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 *)

(* Topological sorting of source files to take dependencies into account *)

structure Order :> ORDER = struct

open Ast

structure SS = StringSet
structure SM = StringMap

fun predNeeded G (p, _) =
    case p of
	CRoot => SS.empty
      | CConst s =>
	if Env.lookupContext G s then
	    SS.empty
	else
	    SS.singleton s
      | CPrefix p => predNeeded G p
      | CNot p => predNeeded G p
      | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)

fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))

fun typNeeded G (t, _) =
    case t of
	TBase s =>
	if Env.lookupType G s then
	    (SS.empty, SS.empty)
	else
	    (SS.empty, SS.singleton s)
      | TList t => typNeeded G t
      | TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
      | TAction (p, d, r) =>
	let
	    val recordNeeded = SM.foldl
				   (fn (t, ss) => unionCT (ss, typNeeded G t))
	in
	    recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
	end
      | TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
				   typNeeded G t)

      | TError => raise Fail "TError during dependency analysis"
      | TUnif _ => raise Fail "TUnif during dependency analysis"

val empty = ((SS.empty, SS.empty), SS.empty)

fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
    ((SS.union (c1, c2),
      SS.union (t1, t2)),
     SS.union (v1, v2))
    
val dt = (TError, ErrorMsg.dummyLoc)

fun expNeeded G (e, _) =
    case e of
	EInt _ => ((SS.empty,
		    if Env.lookupType G "int" then
			SS.empty
		    else
			SS.singleton "int"),
		   SS.empty)
      | EString _ => ((SS.empty,
		       if Env.lookupType G "string" then
			   SS.empty
		       else
			   SS.singleton "string"),
		      SS.empty)
      | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
			  empty es

      | ELam (x, to, e) =>
	let
	    val G' = Env.bindVal G (x, dt, NONE)
	in
	    case to of
		NONE => expNeeded G' e
	      | SOME t => unionCTE ((typNeeded G t, SS.empty),
				    expNeeded G' e)
	end
      | EVar x =>
	(case Env.lookupVal G x of
	     NONE => ((SS.empty, SS.empty), SS.singleton x)
	   | _ => empty)
      | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)

      | ESkip => empty
      | ESet (_, e) => expNeeded G e
      | EGet (x, _, e) => expNeeded (Env.bindVal G (x, dt, NONE)) e
      | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
		   empty es
      | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
      | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)

fun declNeeded G (d, _, _) =
    case d of
	DExternType name => (Env.bindType G name, empty)
      | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
				 (typNeeded G t, SS.empty))
      | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
			       case to of
				   NONE => expNeeded G e
				 | SOME t => unionCTE ((typNeeded G t, SS.empty),
						       expNeeded G e))
      | DContext name => (Env.bindContext G name, empty)

fun fileSig (_, ds, eo) =
    let
	val (G', needed) = foldl
			   (fn (d, (G, needed)) =>
			       let
				   val (G', needed') = declNeeded G d
			       in
				   (G', unionCTE (needed, needed'))
			       end)
			   (Env.empty, empty) ds

	val needed =
	    case eo of
		NONE => needed
	      | SOME e => unionCTE (needed,
				    expNeeded G' e)
    in
	(((Env.contexts G', Env.types G'), Env.vals G'),
	 needed)
    end

fun printSig ((cs, ts), vs) =
    (print "Contexts:";
     SS.app (fn s => (print " "; print s; print ";")) cs;
     print "\n   Types:";
     SS.app (fn s => (print " "; print s; print ";")) ts;
     print "\n  Values:";
     SS.app (fn s => (print " "; print s; print ";")) vs;
     print "\n")

fun mergeProvide kind fname (m1, m2) =
    SS.foldl (fn (name, provide) =>
		 (case SM.find (provide, name) of
		      NONE => ()
		    | SOME fname' => ErrorMsg.error NONE (String.concat ["Files ",
									 fname',
									 " and ",
									 fname,
									 " both provide ",
									 kind,
									 " ",
									 name]);
		  SM.insert (provide, name, fname)))
    m1 m2

fun order fnames =
    let
	fun doFile fname =
	    let
		val file = Parse.parse fname
		val (provide, require) = fileSig file
	    in
		print "\nFile ";
		print fname;
		print "\nPROVIDE:\n";
		printSig provide;
		print "\nREQUIRE:\n";
		printSig require
	    end

	fun doFile (fname, (provideC, provideT, provideV, require)) =
	    let
		val file = Parse.parse fname
		val (((provideC', provideT'), provideV'),
		     require') = fileSig file
	    in
		(mergeProvide "context" fname (provideC, provideC'),
		 mergeProvide "type" fname (provideT, provideT'),
		 mergeProvide "value" fname (provideV, provideV'),
		 SM.insert (require, fname, require'))
	    end

	val (provideC, provideT, provideV, require) =
	    foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames

	val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
				  let
				      fun consider (kind, provide) =
					  SS.foldl (fn (name, need) =>
						       case SM.find (provide, name) of
							   NONE => (ErrorMsg.error NONE
								    ("File "
								     ^ fname
								     ^ " uses undefined "
								     ^ kind
								     ^ " "
								     ^ name);
								    need)
							 | SOME fname' =>
							   SS.add (need, fname'))

				      val need = consider ("context", provideC)
							  SS.empty rc
				      val need = consider ("type", provideT)
							  need rt
				      val need = consider ("value", provideV)
							  need rv
				  in
				      need
				  end) require

	fun loop (ready, waiting, order) =
	    case SS.find (fn _ => true) ready of
		NONE =>
		if SM.numItems waiting = 0 then
		    rev order
		else
		    (ErrorMsg.error NONE "Cyclic dependency in source files";
		     order)
	      | SOME next =>
		let
		    val (ready', waiting') =
			SM.foldli (fn (fname, requires, (ready', waiting')) =>
				      let
					  val requires' = SS.delete (requires, next)
					      handle NotFound => requires
				      in
					  if SS.numItems requires' = 0 then
					      (SS.add (ready', fname),
					       waiting')
					  else
					      (ready',
					       SM.insert (waiting', fname, requires'))
				      end)
				  (SS.delete (ready, next), SM.empty) waiting
		in
		    loop (ready', waiting', next :: order)
		end

	val (ready, waiting) =
	    SM.foldli (fn (fname, requires, (ready, waiting)) =>
			  if SS.numItems requires = 0 then
			      (SS.add (ready, fname),
			       waiting)
			  else
			      (ready,
			       SM.insert (waiting, fname, requires)))
		      (SS.empty, SM.empty) require
    in
	(*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
	SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
	SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)

	(*SM.appi (fn (fname, requires) =>
		    (print fname;
		     print " requires:";
		     SS.app (fn fname' => (print " "; print fname')) requires;
		     print "\n")) require;*)

	loop (ready, waiting, [])
    end

end
Commit	Line	Data
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
	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, _) =
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	\| EVar x =>
100	(case Env.lookupVal G x of
101	NONE => ((SS.empty, SS.empty), SS.singleton x)
102	\| _ => empty)
103	\| EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
104
105	\| ESkip => empty
106	\| ESet (_, e) => expNeeded G e
107	\| EGet (x, _, e) => expNeeded (Env.bindVal G (x, dt, NONE)) e
108	\| ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
109	empty es
110	\| ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
111	\| EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
112
113	fun declNeeded G (d, _, _) =
114	case d of
115	DExternType name => (Env.bindType G name, empty)
116	\| DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
117	(typNeeded G t, SS.empty))
118	\| DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
119	case to of
120	NONE => expNeeded G e
121	\| SOME t => unionCTE ((typNeeded G t, SS.empty),
122	expNeeded G e))
123	\| DContext name => (Env.bindContext G name, empty)
124
125	fun fileSig (_, ds, eo) =
126	let
127	val (G', needed) = foldl
128	(fn (d, (G, needed)) =>
129	let
130	val (G', needed') = declNeeded G d
131	in
132	(G', unionCTE (needed, needed'))
133	end)
134	(Env.empty, empty) ds
135
136	val needed =
137	case eo of
138	NONE => needed
139	\| SOME e => unionCTE (needed,
140	expNeeded G' e)
141	in
142	(((Env.contexts G', Env.types G'), Env.vals G'),
143	needed)
144	end
145
146	fun printSig ((cs, ts), vs) =
147	(print "Contexts:";
148	SS.app (fn s => (print " "; print s; print ";")) cs;
149	print "\n Types:";
150	SS.app (fn s => (print " "; print s; print ";")) ts;
151	print "\n Values:";
152	SS.app (fn s => (print " "; print s; print ";")) vs;
153	print "\n")
154
155	fun mergeProvide kind fname (m1, m2) =
156	SS.foldl (fn (name, provide) =>
157	(case SM.find (provide, name) of
158	NONE => ()
159	\| SOME fname' => ErrorMsg.error NONE (String.concat ["Files ",
160	fname',
161	" and ",
162	fname,
163	" both provide ",
164	kind,
165	" ",
166	name]);
167	SM.insert (provide, name, fname)))
168	m1 m2
169
170	fun order fnames =
171	let
172	fun doFile fname =
173	let
174	val file = Parse.parse fname
175	val (provide, require) = fileSig file
176	in
177	print "\nFile ";
178	print fname;
179	print "\nPROVIDE:\n";
180	printSig provide;
181	print "\nREQUIRE:\n";
182	printSig require
183	end
184
185	fun doFile (fname, (provideC, provideT, provideV, require)) =
186	let
187	val file = Parse.parse fname
188	val (((provideC', provideT'), provideV'),
189	require') = fileSig file
190	in
191	(mergeProvide "context" fname (provideC, provideC'),
192	mergeProvide "type" fname (provideT, provideT'),
193	mergeProvide "value" fname (provideV, provideV'),
194	SM.insert (require, fname, require'))
195	end
196
197	val (provideC, provideT, provideV, require) =
198	foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
199
200	val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
201	let
202	fun consider (kind, provide) =
203	SS.foldl (fn (name, need) =>
204	case SM.find (provide, name) of
205	NONE => (ErrorMsg.error NONE
206	("File "
207	^ fname
208	^ " uses undefined "
209	^ kind
210	^ " "
211	^ name);
212	need)
213	\| SOME fname' =>
214	SS.add (need, fname'))
215
216	val need = consider ("context", provideC)
217	SS.empty rc
218	val need = consider ("type", provideT)
219	need rt
220	val need = consider ("value", provideV)
221	need rv
222	in
223	need
224	end) require
225
226	fun loop (ready, waiting, order) =
227	case SS.find (fn _ => true) ready of
228	NONE =>
229	if SM.numItems waiting = 0 then
230	rev order
231	else
232	(ErrorMsg.error NONE "Cyclic dependency in source files";
233	order)
234	\| SOME next =>
235	let
236	val (ready', waiting') =
237	SM.foldli (fn (fname, requires, (ready', waiting')) =>
238	let
239	val requires' = SS.delete (requires, next)
240	handle NotFound => requires
241	in
242	if SS.numItems requires' = 0 then
243	(SS.add (ready', fname),
244	waiting')
245	else
246	(ready',
247	SM.insert (waiting', fname, requires'))
248	end)
249	(SS.delete (ready, next), SM.empty) waiting
250	in
251	loop (ready', waiting', next :: order)
252	end
253
254	val (ready, waiting) =
255	SM.foldli (fn (fname, requires, (ready, waiting)) =>
256	if SS.numItems requires = 0 then
257	(SS.add (ready, fname),
258	waiting)
259	else
260	(ready,
261	SM.insert (waiting, fname, requires)))
262	(SS.empty, SM.empty) require
263	in
264	(*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
265	SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
266	SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
267
268	(*SM.appi (fn (fname, requires) =>
269	(print fname;
270	print " requires:";
271	SS.app (fn fname' => (print " "; print fname')) requires;
272	print "\n")) require;*)
273
274	loop (ready, waiting, [])
275	end
276
277	end