X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=88dfe81f9eb7adb9cc561139c18381af91accf23;hb=2423c249f5ca7785d0ec89eb33e72662da7561c1;hp=bd4eb9b54cb2437ac6de138de085c0acf4b48200;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index bd4eb9b..88dfe81 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -65,7 +65,6 @@ import Module
 import UniqFM
 import Name
 import NameSet
-import NameEnv
 import TyCon
 import SrcLoc
 import HscTypes
@@ -174,6 +173,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 	loadOrphanModules (imp_orphs  imports) False ;
 	loadOrphanModules (imp_finsts imports) True  ;
 
+	traceRn (text "rn1: checking family instance consistency") ;
 	let { directlyImpMods =   map (\(mod, _, _) -> mod) 
 			        . moduleEnvElts 
 			        . imp_mods 
@@ -188,6 +188,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 			tcRnSrcDecls local_decls ;
 	setGblEnv tcg_env		$ do {
 
+	failIfErrsM ;	-- reportDeprecations crashes sometimes 
+			-- as a result of typechecker repairs (e.g. unboundNames)
 	traceRn (text "rn3") ;
 
 		-- Report the use of any deprecated things
@@ -336,29 +338,34 @@ tcRnSrcDecls decls
 	boot_iface <- tcHiBootIface mod ;
 
 	  	-- Do all the declarations
-	(tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
+	(tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
 
+	     -- 	Finish simplifying class constraints
+	     -- 
 	     -- tcSimplifyTop deals with constant or ambiguous InstIds.  
 	     -- How could there be ambiguous ones?  They can only arise if a
-	     -- top-level decl falls under the monomorphism
-	     -- restriction, and no subsequent decl instantiates its
-	     -- type.  (Usually, ambiguous type variables are resolved
-	     -- during the generalisation step.)
+	     -- top-level decl falls under the monomorphism restriction
+	     -- and no subsequent decl instantiates its type.
+	     --
+	     -- We do this after checkMain, so that we use the type info 
+	     -- thaat checkMain adds
+	     -- 
+	     -- We do it with both global and local env in scope:
+	     --	 * the global env exposes the instances to tcSimplifyTop
+	     --  * the local env exposes the local Ids to tcSimplifyTop, 
+	     --    so that we get better error messages (monomorphism restriction)
         traceTc (text "Tc8") ;
 	inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
-		-- Setting the global env exposes the instances to tcSimplifyTop
-		-- Setting the local env exposes the local Ids to tcSimplifyTop, 
-		-- so that we get better error messages (monomorphism restriction)
 
 	    -- Backsubstitution.  This must be done last.
 	    -- Even tcSimplifyTop may do some unification.
         traceTc (text "Tc9") ;
-	let { (tcg_env, _) = tc_envs ;
-	      TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
-		         tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
+	let { (tcg_env, _) = tc_envs
+	    ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
+		         tcg_rules = rules, tcg_fords = fords } = tcg_env
+	    ; all_binds = binds `unionBags` inst_binds } ;
 
-	(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
-							   rules fords ;
+	(bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
 
 	let { final_type_env = extendTypeEnvWithIds type_env bind_ids
 	    ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
@@ -382,21 +389,17 @@ tc_rn_src_decls boot_details ds
  = do { let { (first_group, group_tail) = findSplice ds } ;
 		-- If ds is [] we get ([], Nothing)
 
-	-- Type check the decls up to, but not including, the first splice
-	tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
-
-	-- Bale out if errors; for example, error recovery when checking
-	-- the RHS of 'main' can mean that 'main' is not in the envt for 
-	-- the subsequent checkMain test
-	failIfErrsM ;
-
-	setEnvs tc_envs $
+	-- Deal with decls up to, but not including, the first splice
+	(tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
+		-- checkNoErrs: don't typecheck if renaming failed
+	tc_envs <- setGblEnv tcg_env $ 
+		   tcTopSrcDecls boot_details rn_decls ;
 
 	-- If there is no splice, we're nearly done
+	setEnvs tc_envs $ 
 	case group_tail of {
-	   Nothing -> do { 	-- Last thing: check for `main'
-			   tcg_env <- checkMain ;
-			   return (tcg_env, tcl_env) 
+	   Nothing -> do { tcg_env <- checkMain ;	-- Check for `main'
+			   return (tcg_env, snd tc_envs) 
 		      } ;
 
 	-- If there's a splice, we must carry on
@@ -406,8 +409,8 @@ tc_rn_src_decls boot_details ds
 #else
 
 	-- Rename the splice expression, and get its supporting decls
-	(rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
-	failIfErrsM ;	-- Don't typecheck if renaming failed
+	(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
+		-- checkNoErrs: don't typecheck if renaming failed
 	rnDump (ppr rn_splice_expr) ;
 
 	-- Execute the splice
@@ -417,7 +420,7 @@ tc_rn_src_decls boot_details ds
 	setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 	tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
 #endif /* GHCI */
-    }}}
+    } } }
 \end{code}
 
 %************************************************************************
@@ -568,17 +571,6 @@ declarations.  It expects there to be an incoming TcGblEnv in the
 monad; it augments it and returns the new TcGblEnv.
 
 \begin{code}
-tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
-	-- Returns the variables free in the decls, for unused-binding reporting
-tcRnGroup boot_details decls
- = do {		-- Rename the declarations
-	(tcg_env, rn_decls) <- rnTopSrcDecls decls ;
-	setGblEnv tcg_env $ do {
-
-		-- Typecheck the declarations
-	tcTopSrcDecls boot_details rn_decls 
-  }}
-
 ------------------------------------------------
 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 rnTopSrcDecls group