[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, (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;*)

	({provideC = provideC,
	  provideT = provideT,
	  provideV = provideV},
	 loop (ready, waiting, []))
    end

type providers = {provideC : string SM.map,
		  provideT : string SM.map,
		  provideV : string SM.map}

fun providesContext (p : providers, s) = SM.find (#provideC p, s)
fun providesType (p : providers, s) = SM.find (#provideT p, s)
fun providesValue (p : providers, s) = SM.find (#provideV p, s)

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
095de39e AC	172	fun doFile (fname, (provideC, provideT, provideV, require)) =
	173	let
	174	val file = Parse.parse fname
	175	val (((provideC', provideT'), provideV'),
	176	require') = fileSig file
	177	in
	178	(mergeProvide "context" fname (provideC, provideC'),
	179	mergeProvide "type" fname (provideT, provideT'),
	180	mergeProvide "value" fname (provideV, provideV'),
	181	SM.insert (require, fname, require'))
	182	end
	183
	184	val (provideC, provideT, provideV, require) =
	185	foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
	186
	187	val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
	188	let
	189	fun consider (kind, provide) =
	190	SS.foldl (fn (name, need) =>
	191	case SM.find (provide, name) of
	192	NONE => (ErrorMsg.error NONE
	193	("File "
	194	^ fname
	195	^ " uses undefined "
	196	^ kind
	197	^ " "
	198	^ name);
	199	need)
	200	\| SOME fname' =>
	201	SS.add (need, fname'))
	202
	203	val need = consider ("context", provideC)
	204	SS.empty rc
	205	val need = consider ("type", provideT)
	206	need rt
	207	val need = consider ("value", provideV)
	208	need rv
	209	in
	210	need
	211	end) require
	212
	213	fun loop (ready, waiting, order) =
	214	case SS.find (fn _ => true) ready of
	215	NONE =>
	216	if SM.numItems waiting = 0 then
	217	rev order
	218	else
	219	(ErrorMsg.error NONE "Cyclic dependency in source files";
	220	order)
	221	\| SOME next =>
	222	let
	223	val (ready', waiting') =
	224	SM.foldli (fn (fname, requires, (ready', waiting')) =>
	225	let
	226	val requires' = SS.delete (requires, next)
	227	handle NotFound => requires
	228	in
	229	if SS.numItems requires' = 0 then
	230	(SS.add (ready', fname),
	231	waiting')
	232	else
	233	(ready',
	234	SM.insert (waiting', fname, requires'))
	235	end)
236	(SS.delete (ready, next), SM.empty) waiting
237	in
238	loop (ready', waiting', next :: order)
239	end
240
241	val (ready, waiting) =
242	SM.foldli (fn (fname, requires, (ready, waiting)) =>
243	if SS.numItems requires = 0 then
244	(SS.add (ready, fname),
245	waiting)
246	else
247	(ready,
248	SM.insert (waiting, fname, requires)))
249	(SS.empty, SM.empty) require
250	in
251	(*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
252	SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
253	SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
254
255	(*SM.appi (fn (fname, requires) =>
256	(print fname;
257	print " requires:";
258	SS.app (fn fname' => (print " "; print fname')) requires;
259	print "\n")) require;*)
260
3196000d AC	261	({provideC = provideC,
	262	provideT = provideT,
	263	provideV = provideV},
	264	loop (ready, waiting, []))
095de39e AC	265	end
095de39e AC	266
3196000d AC	267	type providers = {provideC : string SM.map,
	268	provideT : string SM.map,
	269	provideV : string SM.map}
	270
	271	fun providesContext (p : providers, s) = SM.find (#provideC p, s)
	272	fun providesType (p : providers, s) = SM.find (#provideT p, s)
	273	fun providesValue (p : providers, s) = SM.find (#provideV p, s)
	274
095de39e	275	end