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

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 6dfae44..bd4eb9b 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -37,6 +37,7 @@ import TcExpr
 import TcRnMonad
 import TcType
 import Inst
+import FamInst
 import InstEnv
 import FamInstEnv
 import TcBinds
@@ -173,6 +174,12 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 	loadOrphanModules (imp_orphs  imports) False ;
 	loadOrphanModules (imp_finsts imports) True  ;
 
+	let { directlyImpMods =   map (\(mod, _, _) -> mod) 
+			        . moduleEnvElts 
+			        . imp_mods 
+			        $ imports } ;
+	checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
+
 	traceRn (text "rn1a") ;
 		-- Rename and type check the declarations
 	tcg_env <- if isHsBoot hsc_src then
@@ -193,6 +200,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 		-- Process the export list
 	(rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
                  
+	traceRn (text "rn4") ;
+
 		-- Rename the Haddock documentation header 
 	rn_module_doc <- rnMbHsDoc maybe_doc ;
 
@@ -294,7 +303,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 				mg_rdr_env   = emptyGlobalRdrEnv,
 				mg_fix_env   = emptyFixityEnv,
 				mg_deprecs   = NoDeprecs,
-				mg_foreign   = NoStubs
+				mg_foreign   = NoStubs,
+				mg_hpc_info = noHpcInfo
 		    } } ;
 
    tcCoreDump mod_guts ;
@@ -454,7 +464,7 @@ tcRnHsBootDecls decls
 	; gbl_env <- getGblEnv 
 	
 		-- Make the final type-env
-		-- Include the dfun_ids so that their type sigs get
+		-- Include the dfun_ids so that their type sigs
 		-- are written into the interface file
 	; let { type_env0 = tcg_type_env gbl_env
 	      ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
@@ -1095,7 +1105,7 @@ tcGetModuleExports mod = do
   loadOrphanModules (dep_orphs (mi_deps iface)) False 
   		-- Load any orphan-module interfaces,
   		-- so their instances are visible
-  loadOrphanModules (dep_finsts (mi_finsts iface)) True
+  loadOrphanModules (dep_finsts (mi_deps iface)) True
   		-- Load any family instance-module interfaces,
   		-- so all family instances are visible
   ifaceExportNames (mi_exports iface)
@@ -1269,6 +1279,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
 		        tcg_rules     = rules,
 			tcg_imports   = imports })
   = vcat [ ppr_types insts type_env
+	 , ppr_tycons fam_insts type_env
 	 , ppr_insts insts
 	 , ppr_fam_insts fam_insts
 	 , vcat (map ppr rules)
@@ -1297,6 +1308,17 @@ ppr_types insts type_env
 	-- that the type checker has invented.  Top-level user-defined things 
 	-- have External names.
 
+ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
+ppr_tycons fam_insts type_env
+  = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+  where
+    fi_tycons = map famInstTyCon fam_insts
+    tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
+    want_tycon tycon | opt_PprStyle_Debug = True
+	             | otherwise	  = not (isImplicitTyCon tycon) &&
+					    isExternalName (tyConName tycon) &&
+				            not (tycon `elem` fi_tycons)
+
 ppr_insts :: [Instance] -> SDoc
 ppr_insts []     = empty
 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
@@ -1314,6 +1336,16 @@ ppr_sigs ids
     le_sig id1 id2 = getOccName id1 <= getOccName id2
     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
 
+ppr_tydecls :: [TyCon] -> SDoc
+ppr_tydecls tycons
+	-- Print type constructor info; sort by OccName 
+  = vcat (map ppr_tycon (sortLe le_sig tycons))
+  where
+    le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
+    ppr_tycon tycon 
+      | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon
+      | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
+
 ppr_rules :: [CoreRule] -> SDoc
 ppr_rules [] = empty
 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),