[project @ 2005-07-11 10:47:20 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 1023f56..86b2fbe 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -12,7 +12,8 @@ import IOEnv          -- Re-export all
 
 import HsSyn           ( emptyLHsBinds )
 import HscTypes                ( HscEnv(..), ModGuts(..), ModIface(..),
-                         TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
+                         TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
+                         isHsBoot, ModSummary(..),
                          ExternalPackageState(..), HomePackageTable,
                          Deprecs(..), FixityEnv, FixItem, 
                          lookupType, unQualInScope )
@@ -27,8 +28,9 @@ import InstEnv                ( emptyInstEnv )
 import VarSet          ( emptyVarSet )
 import VarEnv          ( TidyEnv, emptyTidyEnv, emptyVarEnv )
 import ErrUtils                ( Message, Messages, emptyMessages, errorsFound, 
-                         mkWarnMsg, printErrorsAndWarnings,
+                         mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors,
                          mkLocMessage, mkLongErrMsg )
+import Packages                ( mkHomeModules )
 import SrcLoc          ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
 import NameEnv         ( emptyNameEnv )
 import NameSet         ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
@@ -39,10 +41,9 @@ import UniqSupply    ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupp
 import Unique          ( Unique )
 import DynFlags                ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
 import StaticFlags     ( opt_PprStyle_Debug )
-import Bag             ( snocBag, unionBags )
+import Bag             ( snocBag, unionBags, unitBag )
 import Panic           ( showException )
  
-import Maybe           ( isJust )
 import IO              ( stderr )
 import DATA_IOREF      ( newIORef, readIORef )
 import EXCEPTION       ( Exception )
@@ -93,6 +94,7 @@ initTc hsc_env hsc_src mod do_this
                tcg_th_used   = th_var,
                tcg_exports  = emptyNameSet,
                tcg_imports  = init_imports,
+               tcg_home_mods = home_mods,
                tcg_dus      = emptyDUs,
                tcg_rn_decls = Nothing,
                tcg_binds    = emptyLHsBinds,
@@ -134,7 +136,17 @@ initTc hsc_env hsc_src mod do_this
        return (msgs, final_res)
     }
   where
-    init_imports = emptyImportAvails { imp_env = unitModuleEnv mod emptyNameSet }
+    home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env))
+       -- A guess at the home modules.  This will be correct in
+       -- --make and GHCi modes, but in one-shot mode we need to 
+       -- fix it up after we know the real dependencies of the current
+       -- module (see tcRnModule).
+       -- Setting it here is necessary for the typechecker entry points
+       -- other than tcRnModule: tcRnGetInfo, for example.  These are
+       -- all called via the GHC module, so hsc_mod_graph will contain
+       -- something sensible.
+
+    init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet}
        -- Initialise tcg_imports with an empty set of bindings for
        -- this module, so that if we see 'module M' in the export
        -- list, and there are no bindings in M, we don't bleat 
@@ -315,22 +327,22 @@ newUniqueSupply
 
 \begin{code}
 traceTc, traceRn :: SDoc -> TcRn ()
-traceRn      = dumpOptTcRn Opt_D_dump_rn_trace
-traceTc      = dumpOptTcRn Opt_D_dump_tc_trace
-traceSplice  = dumpOptTcRn Opt_D_dump_splices
+traceRn      = traceOptTcRn Opt_D_dump_rn_trace
+traceTc      = traceOptTcRn Opt_D_dump_tc_trace
+traceSplice  = traceOptTcRn Opt_D_dump_splices
 
 
 traceIf :: SDoc -> TcRnIf m n ()       
-traceIf      = dumpOptIf Opt_D_dump_if_trace
-traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs
+traceIf      = traceOptIf Opt_D_dump_if_trace
+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
 
 
-dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
-dumpOptIf flag doc = ifOptM flag $
+traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
+traceOptIf flag doc = ifOptM flag $
                     ioToIOEnv (printForUser stderr alwaysQualify doc)
 
-dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
-dumpOptTcRn flag doc = ifOptM flag $ do
+traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
+traceOptTcRn flag doc = ifOptM flag $ do
                        { ctxt <- getErrCtxt
                        ; loc  <- getSrcSpanM
                        ; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt 
@@ -340,6 +352,9 @@ dumpOptTcRn flag doc = ifOptM flag $ do
 dumpTcRn :: SDoc -> TcRn ()
 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
                    ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
+
+dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
+dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
 \end{code}
 
 
@@ -432,6 +447,8 @@ addLongErrAt loc msg extra
         rdr_env <- getGlobalRdrEnv ;
         let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
         (warns, errs) <- readMutVar errs_var ;
+        traceTc (ptext SLIT("Adding error:") <+> \ _ -> pprBagOfErrors (unitBag err)) ;        
+               -- Ugh!  traceTc is too specific; unitBag is horrible
         writeMutVar errs_var (warns, errs `snocBag` err) }
 
 addErrs :: [(SrcSpan,Message)] -> TcRn ()