[project @ 2005-10-27 14:35: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 ea8b69d..a4032cd 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}
 
 
@@ -314,22 +332,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 
@@ -339,6 +357,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}
 
 
@@ -427,12 +448,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 ()
@@ -910,7 +931,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 }
 
@@ -950,7 +971,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}