[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, loc) =
    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
      | EALam (x, p, e) =>
	let
	    val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE)
	in
	    unionCTE (((predNeeded G p, SS.empty), 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
6bb366c5	73	fun 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
	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
095de39e AC	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
3196000d AC	268	({provideC = provideC,
	269	provideT = provideT,
	270	provideV = provideV},
	271	loop (ready, waiting, []))
095de39e AC	272	end
095de39e AC	273
3196000d AC	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
095de39e	282	end