From 76405e1e2e13a95cdb4accd6af014ee21eed2c57 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 17 Nov 2007 20:11:58 +0000
Subject: [PATCH] Allow some of a user's config to survive regen, even when
 some doesn't type-check

---
 src/main.sml  | 11 ++++++++--
 src/order.sml | 57 +++++++++++++++++++++++++++++----------------------
 2 files changed, 42 insertions(+), 26 deletions(-)

diff --git a/src/main.sml b/src/main.sml
index fc8df17..d769a61 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -939,7 +939,13 @@ fun domainList dname =
 
 fun regenerateEither tc checker context =
     let
-	val domainsBefore = domainList Config.resultRoot
+	val () = print "Starting regeneration....\n"
+
+	val domainsBefore =
+	    if tc then
+		SS.empty
+	    else
+		domainList Config.resultRoot
 
 	fun ifReal f =
 	    if tc then
@@ -1015,7 +1021,8 @@ fun regenerateEither tc checker context =
 			     print ("User " ^ user ^ "'s configuration has errors!\n");
 			     ok := false)
 			else
-			    app checker files
+			    ();
+			app checker files
 		    end
 		else
 		    ()
diff --git a/src/order.sml b/src/order.sml
index 422856d..08db062 100644
--- a/src/order.sml
+++ b/src/order.sml
@@ -163,23 +163,33 @@ fun printSig ((cs, ts), vs) =
      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' => ErrorMsg.error NONE (String.concat ["Files ",
-									 fname',
-									 " and ",
-									 fname,
-									 " both provide ",
-									 kind,
-									 " ",
-									 name]);
+		    | 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
@@ -204,7 +214,8 @@ fun order basisOpt fnames =
 							   if lastChance name then
 							       need
 							   else
-							       (ErrorMsg.error NONE
+							       (addNaughty fname;
+								ErrorMsg.error NONE
 									       ("File "
 										^ fname
 										^ " uses undefined "
@@ -240,7 +251,8 @@ fun order basisOpt fnames =
 		if SM.numItems waiting = 0 then
 		    rev order
 		else
-		    (ErrorMsg.error NONE "Cyclic dependency in source files";
+		    (allNaughty := true;
+		     ErrorMsg.error NONE "Cyclic dependency in source files";
 		     order)
 	      | SOME next =>
 		let
@@ -271,21 +283,18 @@ fun order basisOpt fnames =
 			      (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, []))
+	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,
-- 
2.20.1