[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, 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

val order = fn basisOpt => fn fnames =>
			      let
				  val (providers, fnames) = order basisOpt fnames

				  val (hasLib, fnames) = foldl (fn (fname, (hasLib, fnames)) =>
								   if OS.Path.file fname = "lib.dtl" then
								       (SOME fname, fnames)
								   else
								       (hasLib, fname :: fnames))
							       (NONE, []) fnames

				  val fnames = rev fnames
				  val fnames = case hasLib of
						   NONE => fnames
						 | SOME hasLib => hasLib :: fnames
			      in
				  (providers, 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
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
8cbb9632 AC	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))
095de39e AC	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)
75d4c2d6 AC	123	\| EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
	124	unionCTE (expNeeded G e2,
	125	expNeeded G e3))
095de39e AC	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
76405e1e AC	169	val allNaughty = ref false
	170	val naughtyFiles = ref SS.empty
	171	fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)
	172
095de39e AC	173	fun mergeProvide kind fname (m1, m2) =
	174	SS.foldl (fn (name, provide) =>
	175	(case SM.find (provide, name) of
	176	NONE => ()
76405e1e AC	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]));
095de39e AC	188	SM.insert (provide, name, fname)))
	189	m1 m2
	190
c53e82e4	191	fun order basisOpt fnames =
095de39e	192	let
76405e1e AC	193	val () = allNaughty := false
	194	val () = naughtyFiles := SS.empty
	195
095de39e AC	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
c53e82e4	213	fun consider (kind, provide, lastChance) =
095de39e AC	214	SS.foldl (fn (name, need) =>
095de39e AC	215	case SM.find (provide, name) of
c53e82e4 AC	216	NONE =>
	217	if lastChance name then
	218	need
	219	else
76405e1e AC	220	(addNaughty fname;
76405e1e AC	221	ErrorMsg.error NONE
c53e82e4 AC	222	("File "
	223	^ fname
	224	^ " uses undefined "
	225	^ kind
	226	^ " "
	227	^ name);
	228	need)
095de39e AC	229	\| SOME fname' =>
	230	SS.add (need, fname'))
	231
c53e82e4 AC	232	val need = consider ("context", provideC,
	233	case basisOpt of
	234	NONE => (fn _ => false)
	235	\| SOME b => Env.lookupContext b)
095de39e	236	SS.empty rc
c53e82e4 AC	237	val need = consider ("type", provideT,
	238	case basisOpt of
	239	NONE => (fn _ => false)
	240	\| SOME b => Env.lookupType b)
095de39e	241	need rt
c53e82e4 AC	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)))
095de39e AC	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
76405e1e AC	257	(allNaughty := true;
76405e1e AC	258	ErrorMsg.error NONE "Cyclic dependency in source files";
095de39e AC	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
095de39e	289
76405e1e AC	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)
095de39e AC	301	end
095de39e AC	302
e796bbff AC	303	val order = fn basisOpt => fn fnames =>
	304	let
	305	val (providers, fnames) = order basisOpt fnames
	306
	307	val (hasLib, fnames) = foldl (fn (fname, (hasLib, fnames)) =>
	308	if OS.Path.file fname = "lib.dtl" then
	309	(SOME fname, fnames)
	310	else
	311	(hasLib, fname :: fnames))
	312	(NONE, []) fnames
	313
	314	val fnames = rev fnames
	315	val fnames = case hasLib of
	316	NONE => fnames
	317	\| SOME hasLib => hasLib :: fnames
	318	in
	319	(providers, fnames)
	320	end
525183a2	321
3196000d AC	322	type providers = {provideC : string SM.map,
	323	provideT : string SM.map,
	324	provideV : string SM.map}
	325
	326	fun providesContext (p : providers, s) = SM.find (#provideC p, s)
	327	fun providesType (p : providers, s) = SM.find (#provideT p, s)
	328	fun providesValue (p : providers, s) = SM.find (#provideV p, s)
	329
095de39e	330	end