X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=7c79e6252382603777a03931f7c14d945e1a9a67;hb=eeb635d0ed2346568e312ac06ce7f2f1ecb434be;hp=8468f8753723667761adfac5b624223047fa438b;hpb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 8468f87..7c79e62 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -5,6 +5,13 @@
 \section[TcModule]{Typechecking a whole module}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module TcRnDriver (
 #ifdef GHCI
 	tcRnStmt, tcRnExpr, tcRnType,
@@ -245,7 +252,7 @@ tcRnImports hsc_env this_mod import_decls
 
 		-- Check type-familily consistency
 	; traceRn (text "rn1: checking family instance consistency")
-	; let { dir_imp_mods = map (\ (mod, _, _) -> mod) 
+	; let { dir_imp_mods = map (\ (mod, _) -> mod) 
 			     . moduleEnvElts 
 			     . imp_mods 
 			     $ imports }
@@ -830,16 +837,16 @@ get two defns for 'main' in the interface file!
 #ifdef GHCI
 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
 setInteractiveContext hsc_env icxt thing_inside 
-  = let 
-	-- Initialise the tcg_inst_env with instances 
-	-- from all home modules.  This mimics the more selective
-	-- call to hptInstances in tcRnModule
-	dfuns = fst (hptInstances hsc_env (\mod -> True))
+  = let -- Initialise the tcg_inst_env with instances from all home modules.  
+        -- This mimics the more selective call to hptInstances in tcRnModule.
+	(home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
     in
     updGblEnv (\env -> env { 
-	tcg_rdr_env  = ic_rn_gbl_env icxt,
-	tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
-
+	tcg_rdr_env      = ic_rn_gbl_env icxt,
+	tcg_inst_env     = extendInstEnvList    (tcg_inst_env env) home_insts,
+	tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) 
+                                                home_fam_insts 
+      }) $
 
     tcExtendGhciEnv (ic_tmp_ids icxt) $
         -- tcExtendGhciEnv does lots: 
@@ -877,6 +884,7 @@ tcRnStmt hsc_env ictxt rdr_stmt
     (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
     failIfErrsM ;
+    rnDump (ppr rn_stmt) ;
     
     -- The real work is done here
     (bound_ids, tc_expr) <- mkPlan rn_stmt ;
@@ -1059,16 +1067,18 @@ tcGhciStmts stmts
 	 } ;
 
 	-- OK, we're ready to typecheck the stmts
-	traceTc (text "tcs 2") ;
+	traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ;
 	((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
 					   mappM tcLookupId names ;
 					-- Look up the names right in the middle,
 					-- where they will all be in scope
 
 	-- Simplify the context
+	traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ;
 	const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
 		-- checkNoErrs ensures that the plan fails if context redn fails
 
+	traceTc (text "TcRnDriver.tcGhciStmts: done") ;
 	return (ids, mkHsDictLet const_binds $
 		     noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
     }
@@ -1245,21 +1255,17 @@ tcRnGetInfo hsc_env name
 	--  in the home package all relevant modules are loaded.)
     loadUnqualIfaces ictxt
 
-    thing <- tcRnLookupName' name
+    thing  <- tcRnLookupName' name
     fixity <- lookupFixityRn name
-    ispecs <- lookupInsts (icPrintUnqual ictxt) thing
+    ispecs <- lookupInsts thing
     return (thing, fixity, ispecs)
 
-lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
--- Filter the instances by the ones whose tycons (or clases resp) 
--- are in scope unqualified.  Otherwise we list a whole lot too many!
-lookupInsts print_unqual (AClass cls)
+lookupInsts :: TyThing -> TcM [Instance]
+lookupInsts (AClass cls)
   = do	{ inst_envs <- tcGetInstEnvs
-	; return [ ispec
-		 | ispec <- classInstances inst_envs cls
-		 , plausibleDFun print_unqual (instanceDFunId ispec) ] }
+	; return (classInstances inst_envs cls) }
 
-lookupInsts print_unqual (ATyCon tc)
+lookupInsts (ATyCon tc)
   = do 	{ eps <- getEps	-- Load all instances for all classes that are
 			-- in the type environment (which are all the ones
 			-- we've seen in any interface file so far)
@@ -1267,22 +1273,12 @@ lookupInsts print_unqual (ATyCon tc)
 	; return [ ispec
 		 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
 		 , let dfun = instanceDFunId ispec
-		 , relevant dfun
-		 , plausibleDFun print_unqual dfun ] }
+		 , relevant dfun ] } 
   where
     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
     tc_name     = tyConName tc		  
 
-lookupInsts print_unqual other = return []
-
-plausibleDFun print_unqual dfun	-- Dfun involving only names that print unqualified
-  = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
-  where
-    ok name | isBuiltInSyntax name = True
-	    | isExternalName name  = 
-                isNothing $ fst print_unqual (nameModule name) 
-                                             (nameOccName name)
-	    | otherwise		   = True
+lookupInsts other = return []
 
 loadUnqualIfaces :: InteractiveContext -> TcM ()
 -- Load the home module for everything that is in scope unqualified