[hcoop/domtool2.git] / src / order.sml

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006, Adam Chlipala
 * Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>
 *
 * 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))
      | DEnv (name, to, e) => (Env.bindInitialDynEnvVal G (name, dt, (Ast.ESkip, ErrorMsg.dummyLoc)),
			       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/)
095de39e AC	2	* Copyright (c) 2006, Adam Chlipala
e140629f	3	* Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>
095de39e AC	4	*
	5	* This program is free software; you can redistribute it and/or
	6	* modify it under the terms of the GNU General Public License
	7	* as published by the Free Software Foundation; either version 2
	8	* of the License, or (at your option) any later version.
	9	*
	10	* This program is distributed in the hope that it will be useful,
	11	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	13	* GNU General Public License for more details.
	14	*
	15	* You should have received a copy of the GNU General Public License
	16	* along with this program; if not, write to the Free Software
	17	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
	18	*)
	19
	20	(* Topological sorting of source files to take dependencies into account *)
	21
	22	structure Order :> ORDER = struct
	23
	24	open Ast
	25
	26	structure SS = StringSet
	27	structure SM = StringMap
	28
	29	fun predNeeded G (p, _) =
	30	case p of
	31	CRoot => SS.empty
	32	\| CConst s =>
	33	if Env.lookupContext G s then
	34	SS.empty
	35	else
	36	SS.singleton s
	37	\| CPrefix p => predNeeded G p
	38	\| CNot p => predNeeded G p
	39	\| CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)
	40
	41	fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
	42
	43	fun typNeeded G (t, _) =
	44	case t of
	45	TBase s =>
	46	if Env.lookupType G s then
	47	(SS.empty, SS.empty)
	48	else
	49	(SS.empty, SS.singleton s)
	50	\| TList t => typNeeded G t
	51	\| TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
	52	\| TAction (p, d, r) =>
	53	let
	54	val recordNeeded = SM.foldl
	55	(fn (t, ss) => unionCT (ss, typNeeded G t))
	56	in
	57	recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
	58	end
	59	\| TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
	60	typNeeded G t)
	61
	62	\| TError => raise Fail "TError during dependency analysis"
	63	\| TUnif _ => raise Fail "TUnif during dependency analysis"
	64
	65	val empty = ((SS.empty, SS.empty), SS.empty)
	66
	67	fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
68	((SS.union (c1, c2),
69	SS.union (t1, t2)),
70	SS.union (v1, v2))
71
72	val dt = (TError, ErrorMsg.dummyLoc)
73
6bb366c5	74	fun expNeeded G (e, loc) =
095de39e AC	75	case e of
	76	EInt _ => ((SS.empty,
	77	if Env.lookupType G "int" then
	78	SS.empty
	79	else
	80	SS.singleton "int"),
	81	SS.empty)
	82	\| EString _ => ((SS.empty,
	83	if Env.lookupType G "string" then
	84	SS.empty
	85	else
	86	SS.singleton "string"),
	87	SS.empty)
	88	\| EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
	89	empty es
	90
	91	\| ELam (x, to, e) =>
	92	let
	93	val G' = Env.bindVal G (x, dt, NONE)
	94	in
	95	case to of
	96	NONE => expNeeded G' e
	97	\| SOME t => unionCTE ((typNeeded G t, SS.empty),
	98	expNeeded G' e)
	99	end
6bb366c5 AC	100	\| EALam (x, p, e) =>
	101	let
	102	val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE)
	103	in
	104	unionCTE (((predNeeded G p, SS.empty), SS.empty),
	105	expNeeded G' e)
	106	end
095de39e AC	107	\| EVar x =>
	108	(case Env.lookupVal G x of
	109	NONE => ((SS.empty, SS.empty), SS.singleton x)
	110	\| _ => empty)
	111	\| EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
	112
	113	\| ESkip => empty
	114	\| ESet (_, e) => expNeeded G e
8cbb9632 AC	115	\| EGet (x, topt, _, e) =>
	116	(case topt of
	117	NONE => expNeeded (Env.bindVal G (x, dt, NONE)) e
	118	\| SOME t => unionCTE ((typNeeded G t, SS.empty),
	119	expNeeded (Env.bindVal G (x, dt, NONE)) e))
095de39e AC	120	\| ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
	121	empty es
	122	\| ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
	123	\| EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
75d4c2d6 AC	124	\| EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
	125	unionCTE (expNeeded G e2,
	126	expNeeded G e3))
095de39e AC	127
	128	fun declNeeded G (d, _, _) =
	129	case d of
	130	DExternType name => (Env.bindType G name, empty)
	131	\| DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
	132	(typNeeded G t, SS.empty))
	133	\| DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
	134	case to of
	135	NONE => expNeeded G e
	136	\| SOME t => unionCTE ((typNeeded G t, SS.empty),
	137	expNeeded G e))
e140629f CE	138	\| DEnv (name, to, e) => (Env.bindInitialDynEnvVal G (name, dt, (Ast.ESkip, ErrorMsg.dummyLoc)),
	139	case to of
	140	NONE => expNeeded G e
	141	\| SOME t => unionCTE ((typNeeded G t, SS.empty),
	142	expNeeded G e))
095de39e AC	143	\| DContext name => (Env.bindContext G name, empty)
	144
	145	fun fileSig (_, ds, eo) =
	146	let
	147	val (G', needed) = foldl
	148	(fn (d, (G, needed)) =>
	149	let
	150	val (G', needed') = declNeeded G d
	151	in
	152	(G', unionCTE (needed, needed'))
	153	end)
	154	(Env.empty, empty) ds
	155
	156	val needed =
	157	case eo of
	158	NONE => needed
	159	\| SOME e => unionCTE (needed,
	160	expNeeded G' e)
	161	in
	162	(((Env.contexts G', Env.types G'), Env.vals G'),
	163	needed)
	164	end
	165
	166	fun printSig ((cs, ts), vs) =
	167	(print "Contexts:";
	168	SS.app (fn s => (print " "; print s; print ";")) cs;
	169	print "\n Types:";
	170	SS.app (fn s => (print " "; print s; print ";")) ts;
	171	print "\n Values:";
	172	SS.app (fn s => (print " "; print s; print ";")) vs;
	173	print "\n")
	174
76405e1e AC	175	val allNaughty = ref false
	176	val naughtyFiles = ref SS.empty
	177	fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)
	178
095de39e AC	179	fun mergeProvide kind fname (m1, m2) =
	180	SS.foldl (fn (name, provide) =>
	181	(case SM.find (provide, name) of
	182	NONE => ()
76405e1e AC	183	\| SOME fname' =>
	184	(addNaughty fname;
	185	addNaughty fname';
	186	ErrorMsg.error NONE (String.concat ["Files ",
	187	fname',
	188	" and ",
	189	fname,
	190	" both provide ",
	191	kind,
	192	" ",
	193	name]));
095de39e AC	194	SM.insert (provide, name, fname)))
	195	m1 m2
	196
c53e82e4	197	fun order basisOpt fnames =
095de39e	198	let
76405e1e AC	199	val () = allNaughty := false
	200	val () = naughtyFiles := SS.empty
	201
095de39e AC	202	fun doFile (fname, (provideC, provideT, provideV, require)) =
	203	let
	204	val file = Parse.parse fname
	205	val (((provideC', provideT'), provideV'),
	206	require') = fileSig file
	207	in
	208	(mergeProvide "context" fname (provideC, provideC'),
	209	mergeProvide "type" fname (provideT, provideT'),
	210	mergeProvide "value" fname (provideV, provideV'),
	211	SM.insert (require, fname, require'))
	212	end
	213
	214	val (provideC, provideT, provideV, require) =
	215	foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
	216
	217	val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
	218	let
c53e82e4	219	fun consider (kind, provide, lastChance) =
095de39e AC	220	SS.foldl (fn (name, need) =>
095de39e AC	221	case SM.find (provide, name) of
c53e82e4 AC	222	NONE =>
	223	if lastChance name then
	224	need
	225	else
76405e1e AC	226	(addNaughty fname;
76405e1e AC	227	ErrorMsg.error NONE
c53e82e4 AC	228	("File "
	229	^ fname
	230	^ " uses undefined "
	231	^ kind
	232	^ " "
	233	^ name);
	234	need)
095de39e AC	235	\| SOME fname' =>
	236	SS.add (need, fname'))
	237
c53e82e4 AC	238	val need = consider ("context", provideC,
	239	case basisOpt of
	240	NONE => (fn _ => false)
	241	\| SOME b => Env.lookupContext b)
095de39e	242	SS.empty rc
c53e82e4 AC	243	val need = consider ("type", provideT,
	244	case basisOpt of
	245	NONE => (fn _ => false)
	246	\| SOME b => Env.lookupType b)
095de39e	247	need rt
c53e82e4 AC	248	val need = consider ("value", provideV,
	249	case basisOpt of
	250	NONE => (fn _ => false)
	251	\| SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
095de39e AC	252	need rv
	253	in
	254	need
	255	end) require
	256
	257	fun loop (ready, waiting, order) =
	258	case SS.find (fn _ => true) ready of
	259	NONE =>
	260	if SM.numItems waiting = 0 then
	261	rev order
	262	else
76405e1e AC	263	(allNaughty := true;
76405e1e AC	264	ErrorMsg.error NONE "Cyclic dependency in source files";
095de39e AC	265	order)
	266	\| SOME next =>
	267	let
	268	val (ready', waiting') =
	269	SM.foldli (fn (fname, requires, (ready', waiting')) =>
	270	let
	271	val requires' = SS.delete (requires, next)
	272	handle NotFound => requires
	273	in
	274	if SS.numItems requires' = 0 then
	275	(SS.add (ready', fname),
	276	waiting')
	277	else
	278	(ready',
	279	SM.insert (waiting', fname, requires'))
	280	end)
	281	(SS.delete (ready, next), SM.empty) waiting
	282	in
	283	loop (ready', waiting', next :: order)
	284	end
	285
	286	val (ready, waiting) =
	287	SM.foldli (fn (fname, requires, (ready, waiting)) =>
	288	if SS.numItems requires = 0 then
	289	(SS.add (ready, fname),
	290	waiting)
	291	else
	292	(ready,
	293	SM.insert (waiting, fname, requires)))
	294	(SS.empty, SM.empty) require
095de39e	295
76405e1e AC	296	val ordered = loop (ready, waiting, [])
	297	val provider = {provideC = provideC,
	298	provideT = provideT,
	299	provideV = provideV}
	300	in
	301	if !allNaughty then
	302	(provider, [])
	303	else if SS.isEmpty (!naughtyFiles) then
	304	(provider, ordered)
	305	else
	306	order basisOpt (List.filter (fn fname => not (SS.member (!naughtyFiles, fname))) fnames)
095de39e AC	307	end
095de39e AC	308
e796bbff AC	309	val order = fn basisOpt => fn fnames =>
	310	let
	311	val (providers, fnames) = order basisOpt fnames
	312
	313	val (hasLib, fnames) = foldl (fn (fname, (hasLib, fnames)) =>
	314	if OS.Path.file fname = "lib.dtl" then
	315	(SOME fname, fnames)
	316	else
	317	(hasLib, fname :: fnames))
	318	(NONE, []) fnames
	319
	320	val fnames = rev fnames
	321	val fnames = case hasLib of
	322	NONE => fnames
	323	\| SOME hasLib => hasLib :: fnames
	324	in
	325	(providers, fnames)
	326	end
525183a2	327
3196000d AC	328	type providers = {provideC : string SM.map,
	329	provideT : string SM.map,
	330	provideV : string SM.map}
	331
	332	fun providesContext (p : providers, s) = SM.find (#provideC p, s)
	333	fun providesType (p : providers, s) = SM.find (#provideT p, s)
	334	fun providesValue (p : providers, s) = SM.find (#provideV p, s)
	335
095de39e	336	end