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, topt, _, e) =>
	(case topt of
	     NONE => expNeeded (Env.bindVal G (x, dt, NONE)) e
	   | SOME t => unionCTE ((typNeeded G t, SS.empty),
				 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)
      | EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
				      unionCTE (expNeeded G e2,
						expNeeded G e3))

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")

val allNaughty = ref false
val naughtyFiles = ref SS.empty
fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)

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

fun order basisOpt fnames =
    let
	val () = allNaughty := false
	val () = naughtyFiles := SS.empty

	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, lastChance) =
					  SS.foldl (fn (name, need) =>
						       case SM.find (provide, name) of
							   NONE =>
							   if lastChance name then
							       need
							   else
							       (addNaughty fname;
								ErrorMsg.error NONE
									       ("File "
										^ fname
										^ " uses undefined "
										^ kind
										^ " "
										^ name);
								need)
							 | SOME fname' =>
							   SS.add (need, fname'))

				      val need = consider ("context", provideC,
							   case basisOpt of
							       NONE => (fn _ => false)
							     | SOME b => Env.lookupContext b)
							  SS.empty rc
				      val need = consider ("type", provideT,
							   case basisOpt of
							       NONE => (fn _ => false)
							     | SOME b => Env.lookupType b)
							  need rt
				      val need = consider ("value", provideV,
							   case basisOpt of
							       NONE => (fn _ => false)
							     | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
							  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
		    (allNaughty := true;
		     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

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