[project @ 2005-11-02 09:57:45 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 5fc329f..845bdd4 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -12,14 +12,15 @@ 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 )
 import Module          ( Module, unitModuleEnv )
 import RdrName         ( GlobalRdrEnv, emptyGlobalRdrEnv,      
                          LocalRdrEnv, emptyLocalRdrEnv )
-import Name            ( Name, isInternalName )
+import Name            ( Name, isInternalName, mkInternalName, getOccName, getSrcLoc )
 import Type            ( Type )
 import NameEnv         ( extendNameEnvList )
 import InstEnv         ( emptyInstEnv )
@@ -27,8 +28,9 @@ import InstEnv                ( emptyInstEnv )
 import VarSet          ( emptyVarSet )
 import VarEnv          ( TidyEnv, emptyTidyEnv, emptyVarEnv )
 import ErrUtils                ( Message, Messages, emptyMessages, errorsFound, 
-                         mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors,
+                         mkWarnMsg, printErrorsAndWarnings,
                          mkLocMessage, mkLongErrMsg )
+import Packages                ( mkHomeModules )
 import SrcLoc          ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
 import NameEnv         ( emptyNameEnv )
 import NameSet         ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
@@ -39,7 +41,7 @@ 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, unitBag )
+import Bag             ( snocBag, unionBags )
 import Panic           ( showException )
  
 import IO              ( stderr )
@@ -92,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,
@@ -133,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 
@@ -146,7 +159,7 @@ initTcPrintErrors   -- Used from the interactive loop only
        -> IO (Maybe r)
 initTcPrintErrors env mod todo = do
   (msgs, res) <- initTc env HsSrcFile mod todo
-  printErrorsAndWarnings msgs
+  printErrorsAndWarnings (hsc_dflags env) msgs
   return res
 
 -- mkImpTypeEnv makes the imported symbol table
@@ -303,6 +316,11 @@ newUniqueSupply
        let { (us1, us2) = splitUniqSupply us } ;
        writeMutVar u_var us1 ;
        return us2 }
+
+newLocalName :: Name -> TcRnIf gbl lcl Name
+newLocalName name      -- Make a clone
+  = newUnique          `thenM` \ uniq ->
+    returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
 \end{code}
 
 
@@ -355,6 +373,9 @@ dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
 getModule :: TcRn Module
 getModule = do { env <- getGblEnv; return (tcg_mod env) }
 
+setModule :: Module -> TcRn a -> TcRn a
+setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
+
 tcIsHsBoot :: TcRn Bool
 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
 
@@ -430,12 +451,12 @@ addErrAt loc msg = addLongErrAt loc msg empty
 
 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
 addLongErrAt loc msg extra
- = do {  errs_var <- getErrsVar ;
+  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; 
+
+        errs_var <- getErrsVar ;
         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 ()
@@ -913,7 +934,7 @@ failIfM :: Message -> IfL a
 -- We use IfL here so that we can get context info out of the local env
 failIfM msg
   = do         { env <- getLclEnv
-       ; let full_msg = if_loc env $$ nest 2 msg
+       ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
        ; ioToIOEnv (printErrs (full_msg defaultErrStyle))
        ; failM }
 
@@ -953,7 +974,8 @@ forkM :: SDoc -> IfL a -> IfL a
 forkM doc thing_inside
  = do  { mb_res <- forkM_maybe doc thing_inside
        ; return (case mb_res of 
-                       Nothing -> pprPanic "forkM" doc
+                       Nothing -> pgmError "Cannot continue after interface file error"
+                                  -- pprPanic "forkM" doc
                        Just r  -> r) }
 \end{code}