[project @ 2003-10-10 07:34:34 by simonpj]

[ghc-hetmet.git] / ghc / compiler / iface / TcIface.lhs

diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs
index 911f4b1..92c8d38 100644 (file)
--- 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 )
@@ -112,12 +112,12 @@ tcImportDecl name
   = do { 
     -- Make sure the interface is loaded
        ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name }
-       ; traceIf nd_doc
+       ; traceIf (nd_doc <+> char '{')         -- Brace matches the later message
        ; loadHomeInterface nd_doc name
 
     -- Get the real name of the thing, with a correct nameParent field.
-    -- Before the interface is loaded, we may have a non-commital 'Nothing' in
-    -- the namePareent field (made up by IfaceEnv.lookupOrig), but 
+    -- Before the interface is loaded, we may have a non-committal 'Nothing'
+    -- in the namePareent field (made up by IfaceEnv.lookupOrig), but 
     -- loading the interface updates the name cache.
     -- We need the right nameParent field in getThing
        ; real_name <- lookupOrig (nameModuleName name) (nameOccName name)
@@ -132,7 +132,7 @@ tcImportDecl name
 
        ; let { extra | getName main_thing == real_name = empty
                      | otherwise = brackets (ptext SLIT("when seeking") <+> ppr real_name) }
-       ; traceIf (ptext SLIT("...imported decl for") <+> ppr main_thing <+> extra)
+       ; traceIf (ptext SLIT(" ...imported decl for") <+> ppr main_thing <+> extra <+> char '}')
 
 
     -- Look up the wanted Name in the type envt; it might be
@@ -173,6 +173,7 @@ recordImportOf thing
 
     -- Now type-check those rules (which may side-effect the EPS again)
        ; traceIf (text "tcImport: extend type env" <+> ppr new_things)
+       ; traceIf (text "tcImport: rules" <+> vcat (map ppr iface_rules))
        ; core_rules <- mapM tc_rule iface_rules
        ; updateEps_ (\ eps -> 
            eps { eps_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
@@ -445,10 +446,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 +826,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 +835,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}