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)

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