[project @ 2004-07-21 09:25:42 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 52cb3a7..3632acd 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -27,8 +27,9 @@ import InstEnv                ( InstEnv, emptyInstEnv, extendInstEnv )
 import VarSet          ( emptyVarSet )
 import VarEnv          ( TidyEnv, emptyTidyEnv )
 import ErrUtils                ( Message, Messages, emptyMessages, errorsFound, 
-                         mkErrMsg, mkWarnMsg, printErrorsAndWarnings )
-import SrcLoc          ( mkGeneralSrcSpan, SrcSpan, Located(..) )
+                         mkErrMsg, mkWarnMsg, printErrorsAndWarnings,
+                         mkLocMessage, mkLongErrMsg )
+import SrcLoc          ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
 import NameEnv         ( emptyNameEnv )
 import NameSet         ( emptyDUs, emptyNameSet )
 import OccName         ( emptyOccEnv )
@@ -64,7 +65,7 @@ ioToTcRn = ioToIOEnv
 initTc :: HscEnv
        -> Module 
        -> TcM r
-       -> IO (Maybe r)
+       -> IO (Messages, Maybe r)
                -- Nothing => error thrown by the thing inside
                -- (error messages should have been printed already)
 
@@ -73,6 +74,7 @@ initTc hsc_env mod do_this
        tvs_var      <- newIORef emptyVarSet ;
        type_env_var <- newIORef emptyNameEnv ;
        dfuns_var    <- newIORef emptyNameSet ;
+       th_var       <- newIORef False ;
 
        let {
             gbl_env = TcGblEnv {
@@ -84,7 +86,8 @@ initTc hsc_env mod do_this
                tcg_type_env_var = type_env_var,
                tcg_inst_env  = mkImpInstEnv hsc_env,
                tcg_inst_uses = dfuns_var,
-               tcg_exports  = [],
+               tcg_th_used   = th_var,
+               tcg_exports  = emptyNameSet,
                tcg_imports  = init_imports,
                tcg_dus      = emptyDUs,
                tcg_binds    = emptyBag,
@@ -96,7 +99,7 @@ initTc hsc_env mod do_this
             } ;
             lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
-               tcl_loc        = mkGeneralSrcSpan FSLIT("Top level of module"),
+               tcl_loc        = mkGeneralSrcSpan FSLIT("Top level"),
                tcl_ctxt       = [],
                tcl_rdr        = emptyLocalRdrEnv,
                tcl_th_ctxt    = topStage,
@@ -114,15 +117,14 @@ initTc hsc_env mod do_this
                                    Right res -> return (Just res)
                                    Left _    -> return Nothing } ;
 
-       -- Print any error messages
+       -- Collect any error messages
        msgs <- readIORef errs_var ;
-       printErrorsAndWarnings msgs ;
 
        let { dflags = hsc_dflags hsc_env
            ; final_res | errorsFound dflags msgs = Nothing
                        | otherwise               = maybe_res } ;
 
-       return final_res
+       return (msgs, final_res)
     }
   where
     init_imports = emptyImportAvails { imp_qual = unitModuleEnv mod emptyAvailEnv }
@@ -131,6 +133,16 @@ initTc hsc_env mod do_this
        -- list, and there are no bindings in M, we don't bleat 
        -- "unknown module M".
 
+initTcPrintErrors
+       :: HscEnv
+       -> Module 
+       -> TcM r
+       -> IO (Maybe r)
+initTcPrintErrors env mod todo = do
+  (msgs, res) <- initTc env mod todo
+  printErrorsAndWarnings msgs
+  return res
+
 mkImpInstEnv :: HscEnv -> InstEnv
 -- At the moment we (wrongly) build an instance environment from all the
 -- home-package modules we have already compiled.
@@ -262,6 +274,10 @@ updateEps_ upd_fn = do     { eps_var <- getEpsVar
 
 getHpt :: TcRnIf gbl lcl HomePackageTable
 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
+
+getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
+getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
+                 ; return (eps, hsc_HPT env) }
 \end{code}
 
 %************************************************************************
@@ -309,7 +325,12 @@ dumpOptIf flag doc = ifOptM flag $
                     ioToIOEnv (printForUser stderr alwaysQualify doc)
 
 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
-dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
+dumpOptTcRn flag doc = ifOptM flag $ do
+                       { ctxt <- getErrCtxt
+                       ; loc  <- getSrcSpanM
+                       ; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt 
+                       ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
+                       ; dumpTcRn real_doc }
 
 dumpTcRn :: SDoc -> TcRn ()
 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
@@ -357,7 +378,9 @@ getSrcSpanM :: TcRn SrcSpan
 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
 
 addSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-addSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc })
+addSrcSpan loc thing_inside
+  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
+  | otherwise        = thing_inside    -- Don't overwrite useful info with useless
 
 addLocM :: (a -> TcM b) -> Located a -> TcM b
 addLocM fn (L loc a) = addSrcSpan loc $ fn a
@@ -393,10 +416,13 @@ addLocErr :: Located e -> (e -> Message) -> TcRn ()
 addLocErr (L loc e) fn = addErrAt loc (fn e)
 
 addErrAt :: SrcSpan -> Message -> TcRn ()
-addErrAt loc msg
+addErrAt loc msg = addLongErrAt loc msg empty
+
+addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
+addLongErrAt loc msg extra
  = do {  errs_var <- getErrsVar ;
         rdr_env <- getGlobalRdrEnv ;
-        let { err = mkErrMsg loc (unQualInScope rdr_env) msg } ;
+        let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
         (warns, errs) <- readMutVar errs_var ;
         writeMutVar errs_var (warns, errs `snocBag` err) }
 
@@ -646,7 +672,7 @@ warnTc warn_if_true warn_msg
 \begin{code}
 add_err_tcm tidy_env err_msg loc ctxt
  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
-       addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) }
+       addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
 
 do_ctxt tidy_env []
  = return []
@@ -715,6 +741,9 @@ setLclTypeEnv lcl_env thing_inside
 %************************************************************************
 
 \begin{code}
+recordThUse :: TcM ()
+recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
+
 getStage :: TcM ThStage
 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }