[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 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
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
c53e82e4	177	fun order basisOpt fnames =
095de39e	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
c53e82e4	196	fun consider (kind, provide, lastChance) =
095de39e AC	197	SS.foldl (fn (name, need) =>
095de39e AC	198	case SM.find (provide, name) of
c53e82e4 AC	199	NONE =>
	200	if lastChance name then
	201	need
	202	else
	203	(ErrorMsg.error NONE
	204	("File "
	205	^ fname
	206	^ " uses undefined "
	207	^ kind
	208	^ " "
	209	^ name);
	210	need)
095de39e AC	211	\| SOME fname' =>
	212	SS.add (need, fname'))
	213
c53e82e4 AC	214	val need = consider ("context", provideC,
	215	case basisOpt of
	216	NONE => (fn _ => false)
	217	\| SOME b => Env.lookupContext b)
095de39e	218	SS.empty rc
c53e82e4 AC	219	val need = consider ("type", provideT,
	220	case basisOpt of
	221	NONE => (fn _ => false)
	222	\| SOME b => Env.lookupType b)
095de39e	223	need rt
c53e82e4 AC	224	val need = consider ("value", provideV,
	225	case basisOpt of
	226	NONE => (fn _ => false)
	227	\| SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
095de39e AC	228	need rv
	229	in
	230	need
	231	end) require
	232
	233	fun loop (ready, waiting, order) =
	234	case SS.find (fn _ => true) ready of
	235	NONE =>
	236	if SM.numItems waiting = 0 then
	237	rev order
	238	else
	239	(ErrorMsg.error NONE "Cyclic dependency in source files";
	240	order)
	241	\| SOME next =>
	242	let
	243	val (ready', waiting') =
	244	SM.foldli (fn (fname, requires, (ready', waiting')) =>
	245	let
	246	val requires' = SS.delete (requires, next)
	247	handle NotFound => requires
	248	in
	249	if SS.numItems requires' = 0 then
	250	(SS.add (ready', fname),
	251	waiting')
	252	else
	253	(ready',
	254	SM.insert (waiting', fname, requires'))
	255	end)
	256	(SS.delete (ready, next), SM.empty) waiting
	257	in
	258	loop (ready', waiting', next :: order)
	259	end
	260
	261	val (ready, waiting) =
	262	SM.foldli (fn (fname, requires, (ready, waiting)) =>
	263	if SS.numItems requires = 0 then
	264	(SS.add (ready, fname),
	265	waiting)
	266	else
	267	(ready,
	268	SM.insert (waiting, fname, requires)))
	269	(SS.empty, SM.empty) require
	270	in
	271	(*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
	272	SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
	273	SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
	274
	275	(*SM.appi (fn (fname, requires) =>
	276	(print fname;
	277	print " requires:";
	278	SS.app (fn fname' => (print " "; print fname')) requires;
	279	print "\n")) require;*)
	280
3196000d AC	281	({provideC = provideC,
	282	provideT = provideT,
	283	provideV = provideV},
	284	loop (ready, waiting, []))
095de39e AC	285	end
095de39e AC	286
3196000d AC	287	type providers = {provideC : string SM.map,
	288	provideT : string SM.map,
	289	provideV : string SM.map}
	290
	291	fun providesContext (p : providers, s) = SM.find (#provideC p, s)
	292	fun providesType (p : providers, s) = SM.find (#provideT p, s)
	293	fun providesValue (p : providers, s) = SM.find (#provideV p, s)
	294
095de39e	295	end