Use OPTIONS rather than OPTIONS_GHC for pragmas

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 8659401..0218e7e 100644 (file)
--- 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/CodingStyle#Warnings
+-- for details
+
 module TcRnDriver (
 #ifdef GHCI
        tcRnStmt, tcRnExpr, tcRnType,
@@ -12,7 +19,6 @@ module TcRnDriver (
        tcRnLookupName,
        tcRnGetInfo,
        getModuleExports, 
-        tcRnRecoverDataCon,
 #endif
        tcRnModule, 
        tcTopSrcDecls,
@@ -198,7 +204,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 \begin{code}
 tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv
 tcRnImports hsc_env this_mod import_decls
-  = do { (rn_imports, rdr_env, imports) <- rnImports import_decls ;
+  = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
 
        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
              ; dep_mods = imp_dep_mods imports
@@ -227,7 +233,8 @@ tcRnImports hsc_env this_mod import_decls
               tcg_rn_imports   = fmap (const rn_imports) (tcg_rn_imports gbl),
              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) 
-                                                      home_fam_insts
+                                                      home_fam_insts,
+             tcg_hpc          = hpc_info
            }) $ do {
 
        ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
@@ -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 }
@@ -314,6 +321,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_types     = final_type_env,
                                mg_insts     = tcg_insts tcg_env,
                                mg_fam_insts = tcg_fam_insts tcg_env,
+                               mg_inst_env  = tcg_inst_env tcg_env,
                                mg_fam_inst_env = tcg_fam_inst_env tcg_env,
                                mg_rules     = [],
                                mg_binds     = core_binds,
@@ -323,7 +331,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                mg_fix_env   = emptyFixityEnv,
                                mg_deprecs   = NoDeprecs,
                                mg_foreign   = NoStubs,
-                               mg_hpc_info  = noHpcInfo,
+                               mg_hpc_info  = emptyHpcInfo False,
                                 mg_modBreaks = emptyModBreaks,
                                 mg_vect_info = noVectInfo
                    } } ;
@@ -876,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 ;
@@ -1058,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))
     }
@@ -1204,13 +1215,6 @@ lookup_rdr_name rdr_name = do {
     return good_names
  }
 
-tcRnRecoverDataCon :: HscEnv -> Ptr () -> IO (Maybe DataCon) 
-tcRnRecoverDataCon hsc_env ptr
-  = initTcPrintErrors hsc_env iNTERACTIVE $ 
-    setInteractiveContext hsc_env (hsc_IC hsc_env) $ do
-        name <- dataConInfoPtrToName ptr
-        tcLookupDataCon name
-
 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 tcRnLookupName hsc_env name
   = initTcPrintErrors hsc_env iNTERACTIVE $ 
@@ -1251,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)
@@ -1273,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