From: simonpj <unknown>
Date: Thu, 9 Oct 2003 15:38:24 +0000 (+0000)
Subject: [project @ 2003-10-09 15:38:22 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~380
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0dfa678a3be85a7b8353b510a026ae684b1ee7cc;p=ghc-hetmet.git

[project @ 2003-10-09 15:38:22 by simonpj]
Wibles
---

diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs
index 4916653..0141f77 100644
--- a/ghc/compiler/iface/IfaceEnv.lhs
+++ b/ghc/compiler/iface/IfaceEnv.lhs
@@ -279,7 +279,8 @@ tcIfaceGlobal name
 	    Just thing -> return thing ;
 	    Nothing    -> 
 
-	setLclEnv () $ do
+	setLclEnv () $ do	-- This gets us back to IfG, mainly to 
+				-- pacify get_type_env; rather untidy
 	{ env <- getGblEnv
 	; case if_rec_types env of
 	    Just (mod, get_type_env) 
diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs
index 04ca8eb..2c83155 100644
--- a/ghc/compiler/iface/IfaceType.lhs
+++ b/ghc/compiler/iface/IfaceType.lhs
@@ -342,7 +342,7 @@ toIfaceKind k
   | Just (arg,res) <- splitFunTy_maybe k 
   = IfaceFunKind (toIfaceKind arg) (toIfaceKind res)
 #ifdef DEBUG
-  | otherwise = pprPanic "toIfaceKind" (crudePprType k)
+  | otherwise = pprTrace "toIfaceKind" (crudePprType k) IfaceOpenTypeKind
 #endif
 
 ---------------------
diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs
index 911f4b1..8c2653d 100644
--- a/ghc/compiler/iface/TcIface.lhs
+++ b/ghc/compiler/iface/TcIface.lhs
@@ -26,7 +26,7 @@ import Type		( Kind, openTypeKind, liftedTypeKind,
 import TypeRep		( Type(..), PredType(..) )
 import TyCon		( TyCon, tyConName )
 import HscTypes		( ExternalPackageState(..), PackageInstEnv,
-			  TyThing(..), implicitTyThings, 
+			  TyThing(..), implicitTyThings, typeEnvIds,
 			  ModIface(..), ModDetails(..), InstPool, 
 			  TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
 			  DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
@@ -445,10 +445,6 @@ loadImportedInsts cls tys
 	; let { (inst_pool', iface_insts) 
 		    = selectInsts (eps_insts eps) cls_gate tc_gates }
 
-	; traceTc (text "loadImportedInsts" <+> vcat [ppr cls <+> ppr tys,
-			text "new pool" <+> ppr inst_pool',
-			text "new insts" <+> ppr iface_insts])
-
 	-- Empty => finish up rapidly, without writing to eps
 	; if null iface_insts then
 		return (eps_inst_env eps)
@@ -829,7 +825,8 @@ tcPragExpr name expr
 
 		-- Check for type consistency in the unfolding
     ifOptM Opt_DoCoreLinting (
-	case lintUnfolding noSrcLoc [{- in scope -}] core_expr' of
+	get_in_scope_ids			`thenM` \ in_scope -> 
+	case lintUnfolding noSrcLoc in_scope core_expr' of
 	  Nothing       -> returnM ()
 	  Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
     )				`thenM_`
@@ -837,6 +834,14 @@ tcPragExpr name expr
    returnM core_expr'	
   where
     doc = text "Unfolding of" <+> ppr name
+    get_in_scope_ids 	-- Urgh; but just for linting
+	= setLclEnv () $ 
+	  do	{ env <- getGblEnv 
+		; case if_rec_types env of {
+			  Nothing -> return [] ;
+			  Just (_, get_env) -> do
+		{ type_env <- get_env
+		; return (typeEnvIds type_env) }}}
 \end{code}
 
 
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 20d0d21..480b28f 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -517,9 +517,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
 	-- Deal with the type declarations; first bring their stuff
 	-- into scope, then rname them, then type check them
-   (rdr_env, imports) <- importsFromLocalDecls $
-	HsGroup { hs_tyclds = decls, hs_valds = EmptyBinds, hs_fords = [] } ;
-		-- Rather clumsy; lots of unused fields
+   (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup decls) ;
 
    updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 			    tcg_imports = imports `plusImportAvails` tcg_imports gbl }) 
@@ -570,6 +568,12 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 
    return mod_guts
    }}}}
+
+mkFakeGroup decls -- Rather clumsy; lots of unused fields
+  = HsGroup {	hs_tyclds = decls, 	-- This is the one we want
+		hs_valds = EmptyBinds, hs_fords = [],
+		hs_instds = [], hs_fixds = [], hs_depds = [],
+		hs_ruleds = [] }
 \end{code}