TcRnMonad.lhs

%
% (c) The University of Glasgow 2006
%

\begin{code}
module TcRnMonad(
	module TcRnMonad,
	module TcRnTypes,
	module IOEnv
  ) where

#include "HsVersions.h"

import TcRnTypes	-- Re-export all
import IOEnv		-- Re-export all

import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import TcType
import InstEnv
import FamInstEnv

import Var
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
import Outputable
import UniqSupply
import Unique
import LazyUniqFM
import DynFlags
import StaticFlags
import FastString
import Panic
import Util

import System.IO
import Data.IORef
import qualified Data.Set as Set
import Control.Monad
\end{code}



%************************************************************************
%*									*
			initTc
%*									*
%************************************************************************

\begin{code}

initTc :: HscEnv
       -> HscSource
       -> Bool		-- True <=> retain renamed syntax trees
       -> Module 
       -> TcM r
       -> IO (Messages, Maybe r)
		-- Nothing => error thrown by the thing inside
		-- (error messages should have been printed already)

initTc hsc_env hsc_src keep_rn_syntax mod do_this
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	dfuns_var    <- newIORef emptyNameSet ;
	keep_var     <- newIORef emptyNameSet ;
    used_rdrnames_var <- newIORef Set.empty ;
	th_var	     <- newIORef False ;
	dfun_n_var   <- newIORef emptyOccSet ;
	type_env_var <- case hsc_type_env_var hsc_env of {
                           Just (_mod, te_var) -> return te_var ;
                           Nothing             -> newIORef emptyNameEnv } ;
      	let {
	     maybe_rn_syntax empty_val
		| keep_rn_syntax = Just empty_val
		| otherwise	 = Nothing ;
			
	     gbl_env = TcGblEnv {
		tcg_mod       = mod,
		tcg_src	      = hsc_src,
		tcg_rdr_env   = hsc_global_rdr_env hsc_env,
		tcg_fix_env   = emptyNameEnv,
		tcg_field_env = RecFields emptyNameEnv emptyNameSet,
		tcg_default   = Nothing,
		tcg_type_env  = hsc_global_type_env hsc_env,
		tcg_type_env_var = type_env_var,
		tcg_inst_env  = emptyInstEnv,
		tcg_fam_inst_env  = emptyFamInstEnv,
		tcg_inst_uses = dfuns_var,
		tcg_th_used   = th_var,
		tcg_exports  = [],
		tcg_imports  = emptyImportAvails,
        tcg_used_rdrnames = used_rdrnames_var,
		tcg_dus      = emptyDUs,

                tcg_rn_imports = [],
                tcg_rn_exports = maybe_rn_syntax [],
		tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,

		tcg_binds    = emptyLHsBinds,
		tcg_warns    = NoWarnings,
		tcg_anns     = [],
		tcg_insts    = [],
		tcg_fam_insts= [],
		tcg_rules    = [],
		tcg_fords    = [],
		tcg_dfun_n   = dfun_n_var,
		tcg_keep     = keep_var,
		tcg_doc      = Nothing,
		tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing,
                tcg_hpc      = False
	     } ;
	     lcl_env = TcLclEnv {
		tcl_errs       = errs_var,
		tcl_loc	       = mkGeneralSrcSpan (fsLit "Top level"),
		tcl_ctxt       = [],
		tcl_rdr	       = emptyLocalRdrEnv,
		tcl_th_ctxt    = topStage,
		tcl_arrow_ctxt = NoArrowCtxt,
		tcl_env        = emptyNameEnv,
		tcl_tyvars     = tvs_var,
		tcl_lie	       = panic "initTc:LIE", -- only valid inside getLIE
		tcl_tybinds    = panic "initTc:tybinds"	
                                               -- only valid inside a getTyBinds
	     } ;
	} ;
   
	-- OK, here's the business end!
	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
		     do { r <- tryM do_this
			; case r of
			  Right res -> return (Just res)
			  Left _    -> return Nothing } ;

	-- Collect any error messages
	msgs <- readIORef errs_var ;

	let { dflags = hsc_dflags hsc_env
	    ; final_res | errorsFound dflags msgs = Nothing
			| otherwise	   	  = maybe_res } ;

	return (msgs, final_res)
    }

initTcPrintErrors	-- Used from the interactive loop only
       :: HscEnv
       -> Module 
       -> TcM r
       -> IO (Messages, Maybe r)
initTcPrintErrors env mod todo = do
  (msgs, res) <- initTc env HsSrcFile False mod todo
  return (msgs, res)
\end{code}

%************************************************************************
%*									*
		Initialisation
%*									*
%************************************************************************


\begin{code}
initTcRnIf :: Char		-- Tag for unique supply
	   -> HscEnv
	   -> gbl -> lcl 
	   -> TcRnIf gbl lcl a 
	   -> IO a
initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
   = do	{ us     <- mkSplitUniqSupply uniq_tag ;
	; us_var <- newIORef us ;

	; let { env = Env { env_top = hsc_env,
			    env_us  = us_var,
			    env_gbl = gbl_env,
			    env_lcl = lcl_env} }

	; runIOEnv env thing_inside
	}
\end{code}

%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

\begin{code}
getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv = do { env <- getEnv; return (env_top env) }

getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv = do { env <- getEnv; return (env_gbl env) }

updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
			  env { env_gbl = upd gbl })

setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv = do { env <- getEnv; return (env_lcl env) }

updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 
			  env { env_lcl = upd lcl })

setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })

getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
\end{code}


Command-line flags

\begin{code}
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }

doptM :: DynFlag -> TcRnIf gbl lcl Bool
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }

setOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
			 env { env_top = top { hsc_dflags = dopt_set (hsc_dflags top) flag}} )

unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
			 env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )

-- | Do it flag is true
ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
ifOptM flag thing_inside = do { b <- doptM flag; 
				if b then thing_inside else return () }

getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
\end{code}

\begin{code}
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }

getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }

-- Updating the EPS.  This should be an atomic operation.
-- Note the delicate 'seq' which forces the EPS before putting it in the
-- variable.  Otherwise what happens is that we get
--	write eps_var (....(unsafeRead eps_var)....)
-- and if the .... is strict, that's obviously bottom.  By forcing it beforehand
-- we make the unsafeRead happen before we update the variable.

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
			; seq eps' (writeMutVar eps_var eps')
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
updateEps_ upd_fn = do	{ traceIf (text "updating EPS_")
			; eps_var <- getEpsVar
			; eps <- readMutVar eps_var
			; let { eps' = upd_fn eps }
			; seq eps' (writeMutVar eps_var eps') }

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}

%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
newUnique
 = do { env <- getEnv ;
	let { u_var = env_us env } ;
	us <- readMutVar u_var ;
        case splitUniqSupply us of { (us1,_) -> do {
	writeMutVar u_var us1 ;
	return $! uniqFromSupply us }}}
   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
   -- a chain of unevaluated supplies behind.
   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
   -- throw away one half of the new split supply.  This is safe because this
   -- is the only place we use that unique.  Using the other half of the split
   -- supply is safer, but slower.

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
	let { u_var = env_us env } ;
	us <- readMutVar u_var ;
        case splitUniqSupply us of { (us1,us2) -> do {
	writeMutVar u_var us1 ;
	return us2 }}}

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
  = do	{ uniq <- newUnique
	; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }

newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
  = do	{ us <- newUniqueSupply
	; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }

instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
\end{code}


%************************************************************************
%*									*
		Debugging
%*									*
%************************************************************************

\begin{code}
traceTc, traceRn, traceSplice :: SDoc -> TcRn ()
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceTc      = traceOptTcRn Opt_D_dump_tc_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices


traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs


traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
traceOptIf flag doc = ifOptM flag $
		      liftIO (printForUser stderr alwaysQualify doc)

traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc = ifOptM flag $ do
			{ ctxt <- getErrCtxt
			; loc  <- getSrcSpanM
			; env0 <- tcInitTidyEnv
			; ctxt_msgs <- do_ctxt env0 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 
                  ; dflags <- getDOpts 
                  ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }

debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
                  | otherwise         = dumpTcRn doc

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
\end{code}


%************************************************************************
%*									*
		Typechecker global environment
%*									*
%************************************************************************

\begin{code}
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)) }

getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

getImports :: TcRn ImportAvails
getImports = do { env <- getGblEnv; return (tcg_imports env) }

getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv new_bit
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> 
		env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})	     

getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
\end{code}

%************************************************************************
%*									*
		Error management
%*									*
%************************************************************************

\begin{code}
getSrcSpanM :: TcRn SrcSpan
	-- Avoid clash with Name.getSrcLoc
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }

setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan 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) = setSrcSpan loc $ fn a

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
  setSrcSpan loc $ do
    (b,c) <- fn a
    return (L loc b, c)

wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
  setSrcSpan loc $ do
    (b,c) <- fn a
    return (b, L loc c)
\end{code}


\begin{code}
getErrsVar :: TcRn (TcRef Messages)
getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }

setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })

addErr :: Message -> TcRn ()	-- Ignores the context stack
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }

failWith :: Message -> TcRn a
failWith msg = addErr msg >> failM

addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
addErrAt loc msg = addLongErrAt loc msg empty

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
	 errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
         dflags <- getDOpts ;
	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns, errs `snocBag` err) }

addErrs :: [(SrcSpan,Message)] -> TcRn ()
addErrs msgs = mapM_ add msgs
	     where
	       add (loc,msg) = addErrAt loc msg

addReport :: Message -> TcRn ()
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
         dflags <- getDOpts ;
	 let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext (sLit "Warning:") <+> msg)

addWarnAt :: SrcSpan -> Message -> TcRn ()
addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg)

addLocWarn :: Located e -> (e -> Message) -> TcRn ()
addLocWarn (L loc e) fn = addReportAt loc (fn e)

checkErr :: Bool -> Message -> TcRn ()
-- Add the error if the bool is False
checkErr ok msg = unless ok (addErr msg)

warnIf :: Bool -> Message -> TcRn ()
warnIf True  msg = addWarn msg
warnIf False _   = return ()

addMessages :: Messages -> TcRn ()
addMessages (m_warns, m_errs)
  = do { errs_var <- getErrsVar ;
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `unionBags` m_warns,
			       errs  `unionBags` m_errs) }

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
-- With -dppr-debug, the effects is switched off, so you can still see
-- what warnings derived code would give
discardWarnings thing_inside
  | opt_PprStyle_Debug = thing_inside
  | otherwise
  = do	{ errs_var <- newMutVar emptyMessages
	; result <- setErrsVar errs_var thing_inside
	; (_warns, errs) <- readMutVar errs_var
	; addMessages (emptyBag, errs)
	; return result }
\end{code}


\begin{code}
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
-- Does try_m, with a debug-trace on failure
try_m thing 
  = do { mb_r <- tryM thing ;
	 case mb_r of 
	     Left exn -> do { traceTc (exn_msg exn); return mb_r }
	     Right _  -> return mb_r }
  where
    exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)

-----------------------
recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
	 -> TcRn r	-- Main action: do this first
	 -> TcRn r
-- Errors in 'thing' are retained
recoverM recover thing 
  = do { mb_res <- try_m thing ;
	 case mb_res of
	   Left _    -> recover
	   Right res -> return res }


-----------------------
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
-- Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
mapAndRecoverM _ []     = return []
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
			     ; rs <- mapAndRecoverM f xs
			     ; return (case mb_r of
					  Left _  -> rs
					  Right r -> r:rs) }
			

-----------------------
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
-- (tryTc m) executes m, and returns
--	Just r,  if m succeeds (returning r)
--	Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
tryTc m 
 = do {	errs_var <- newMutVar emptyMessages ;
	res  <- try_m (setErrsVar errs_var m) ; 
	msgs <- readMutVar errs_var ;
	return (msgs, case res of
			    Left _  -> Nothing
			    Right val -> Just val)
	-- The exception is always the IOEnv built-in
	-- in exception; see IOEnv.failM
   }

-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
-- Run the thing, returning 
--	Just r,  if m succceeds with no error messages
--	Nothing, if m fails, or if it succeeds but has error messages
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
tryTcErrs thing 
  = do  { (msgs, res) <- tryTc thing
	; dflags <- getDOpts
	; let errs_found = errorsFound dflags msgs
	; return (msgs, case res of
			  Nothing -> Nothing
			  Just val | errs_found -> Nothing
			 	   | otherwise  -> Just val)
	}

-----------------------
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
-- Just like tryTcErrs, except that it ensures that the LIE
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
tryTcLIE thing_inside
  = do  { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
	; case mb_res of
	    Nothing  -> return (msgs, Nothing)
	    Just val -> do { extendLIEs lie; return (msgs, Just val) }
	}

-----------------------
tryTcLIE_ :: TcM r -> TcM r -> TcM r
-- (tryTcLIE_ r m) tries m; 
--	if m succeeds with no error messages, it's the answer
-- 	otherwise tryTcLIE_ drops everything from m and tries r instead.
tryTcLIE_ recover main
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; case mb_res of
	     Just val -> do { addMessages msgs	-- There might be warnings
			     ; return val }
	     Nothing  -> recover		-- Discard all msgs
	}

-----------------------
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If m succeeds, it checks whether m generated any errors messages
--	(it might have recovered internally)
-- 	If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; addMessages msgs
	; case mb_res of
	    Nothing  -> failM
	    Just val -> return val
	} 

ifErrsM :: TcRn r -> TcRn r -> TcRn r
--	ifErrsM bale_out main
-- does 'bale_out' if there are errors in errors collection
-- otherwise does 'main'
ifErrsM bale_out normal
 = do { errs_var <- getErrsVar ;
	msgs <- readMutVar errs_var ;
	dflags <- getDOpts ;
	if errorsFound dflags msgs then
	   bale_out
	else	
	   normal }

failIfErrsM :: TcRn ()
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


%************************************************************************
%*									*
	Context management and error message generation
	  	    for the type checker
%*									*
%************************************************************************

\begin{code}
getErrCtxt :: TcM ErrCtxt
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }

setErrCtxt :: ErrCtxt -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })

addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))

addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)

-- Helper function for the above
updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
			   env { tcl_ctxt = upd ctxt })

-- Conditionally add an error context
maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
maybeAddErrCtxt Nothing    thing_inside = thing_inside

popErrCtxt :: TcM a -> TcM a
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })

getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
	 return (InstLoc origin loc (tcl_ctxt env)) }

setInstCtxt :: InstLoc -> TcM a -> TcM a
-- Add the SrcSpan and context from the first Inst in the list
-- 	(they all have similar locations)
setInstCtxt (InstLoc _ src_loc ctxt) thing_inside
  = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
\end{code}

    The addErrTc functions add an error message, but do not cause failure.
    The 'M' variants pass a TidyEnv that has already been used to
    tidy up the message; we then use it to tidy the context messages

\begin{code}
addErrTc :: Message -> TcM ()
addErrTc err_msg = do { env0 <- tcInitTidyEnv
		      ; addErrTcM (env0, err_msg) }

addErrsTc :: [Message] -> TcM ()
addErrsTc err_msgs = mapM_ addErrTc err_msgs

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
	 loc  <- getSrcSpanM ;
	 add_err_tcm tidy_env err_msg loc ctxt }
\end{code}

The failWith functions add an error message and cause failure

\begin{code}
failWithTc :: Message -> TcM a		     -- Add an error message and fail
failWithTc err_msg 
  = addErrTc err_msg >> failM

failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
failWithTcM local_and_msg
  = addErrTcM local_and_msg >> failM

checkTc :: Bool -> Message -> TcM ()	     -- Check that the boolean is true
checkTc True  _   = return ()
checkTc False err = failWithTc err
\end{code}

	Warnings have no 'M' variant, nor failure

\begin{code}
addWarnTc :: Message -> TcM ()
addWarnTc msg = do { env0 <- tcInitTidyEnv 
		   ; addWarnTcM (env0, msg) }

addWarnTcM :: (TidyEnv, Message) -> TcM ()
addWarnTcM (env0, msg)
 = do { ctxt <- getErrCtxt ;
	ctxt_msgs <- do_ctxt env0 ctxt ;
	addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }

warnTc :: Bool -> Message -> TcM ()
warnTc warn_if_true warn_msg
  | warn_if_true = addWarnTc warn_msg
  | otherwise	 = return ()
\end{code}

-----------------------------------
	 Tidying

We initialise the "tidy-env", used for tidying types before printing,
by building a reverse map from the in-scope type variables to the
OccName that the programmer originally used for them

\begin{code}
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
  = do	{ lcl_env <- getLclEnv
	; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
			  | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
			  , tcIsTyVarTy ty ]
	; return (foldl add emptyTidyEnv nm_tv_prs) }
  where
    add (env,subst) (name, tyvar)
	= case tidyOccName env (nameOccName name) of
	    (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
		where
		  tyvar' = setTyVarName tyvar name'
		  name'  = tidyNameOcc name occ'
\end{code}

-----------------------------------
 	Other helper functions

\begin{code}
add_err_tcm :: TidyEnv -> Message -> SrcSpan
            -> [TidyEnv -> TcM (TidyEnv, SDoc)]
            -> TcM ()
add_err_tcm tidy_env err_msg loc ctxt
 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }

do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc]
do_ctxt _ []
 = return []
do_ctxt tidy_env (c:cs)
 = do {	(tidy_env', m) <- c tidy_env  ;
	ms	       <- do_ctxt tidy_env' cs  ;
	return (m:ms) }

ctxt_to_use :: [SDoc] -> [SDoc]
ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
		 | otherwise	      = take 3 ctxt
\end{code}

debugTc is useful for monadic debugging code

\begin{code}
debugTc :: TcM () -> TcM ()
debugTc thing
 | debugIsOn = thing
 | otherwise = return ()
\end{code}

%************************************************************************
%*									*
	     Type constraints (the so-called LIE)
%*									*
%************************************************************************

\begin{code}
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
  do { env <- getGblEnv
     ; let dfun_n_var = tcg_dfun_n env
     ; set <- readMutVar dfun_n_var
     ; let occ = fn set
     ; writeMutVar dfun_n_var (extendOccSet set occ)
     ; return occ
     }

getLIEVar :: TcM (TcRef LIE)
getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }

setLIEVar :: TcRef LIE -> TcM a -> TcM a
setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })

getLIE :: TcM a -> TcM (a, [Inst])
-- (getLIE m) runs m, and returns the type constraints it generates
getLIE thing_inside
  = do { lie_var <- newMutVar emptyLIE ;
	 res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
			  thing_inside ;
	 lie <- readMutVar lie_var ;
	 return (res, lieToList lie) }

extendLIE :: Inst -> TcM ()
extendLIE inst
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
	 writeMutVar lie_var (inst `consLIE` lie) }

extendLIEs :: [Inst] -> TcM ()
extendLIEs [] 
  = return ()
extendLIEs insts
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
	 writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
\end{code}

\begin{code}
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
-- Set the local type envt, but do *not* disturb other fields,
-- notably the lie_var
setLclTypeEnv lcl_env thing_inside
  = updLclEnv upd thing_inside
  where
    upd env = env { tcl_env = tcl_env lcl_env,
		    tcl_tyvars = tcl_tyvars lcl_env }
\end{code}


%************************************************************************
%*									*
	     Meta type variable bindings
%*									*
%************************************************************************

\begin{code}
getTcTyVarBindsVar :: TcM (TcRef TcTyVarBinds)
getTcTyVarBindsVar = do { env <- getLclEnv; return (tcl_tybinds env) }

getTcTyVarBinds :: TcM a -> TcM (a, TcTyVarBinds)
getTcTyVarBinds thing_inside
  = do { tybinds_var <- newMutVar emptyBag
       ; res <- updLclEnv (\ env -> env { tcl_tybinds = tybinds_var }) 
			  thing_inside
       ; tybinds <- readMutVar tybinds_var
       ; return (res, tybinds) 
       }

bindMetaTyVar :: TcTyVar -> TcType -> TcM ()
bindMetaTyVar tv ty
  = do { ASSERTM2( do { details <- readMutVar (metaTvRef tv)
                      ; return (isFlexi details) }, ppr tv )
       ; tybinds_var <- getTcTyVarBindsVar
       ; tybinds <- readMutVar tybinds_var
       ; writeMutVar tybinds_var (tybinds `snocBag` TcTyVarBind tv ty) 
       }

getTcTyVarBindsRelation :: TcM [(TcTyVar, TcTyVarSet)]
getTcTyVarBindsRelation
  = do { tybinds_var <- getTcTyVarBindsVar
       ; tybinds <- readMutVar tybinds_var
       ; return $ map freeTvs (bagToList tybinds)
       }
  where
    freeTvs (TcTyVarBind tv ty) = (tv, tyVarsOfType ty)
\end{code}

%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

\begin{code}
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }

keepAliveTc :: Id -> TcM ()  	-- Record the name in the keep-alive set
keepAliveTc id 
  | isLocalId id = do { env <- getGblEnv; 
		      ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) }
  | otherwise = return ()

keepAliveSetTc :: NameSet -> TcM ()  	-- Record the name in the keep-alive set
keepAliveSetTc ns = do { env <- getGblEnv; 
		       ; updMutVar (tcg_keep env) (`unionNameSets` ns) }

getStage :: TcM ThStage
getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }

setStage :: ThStage -> TcM a -> TcM a 
setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
\end{code}


%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

\begin{code}
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }

setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env thing_inside 
  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
\end{code}


%************************************************************************
%*									*
	     Stuff for interface decls
%*									*
%************************************************************************

\begin{code}
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
			        if_loc     = loc,
			        if_tv_env  = emptyUFM,
			        if_id_env  = emptyUFM }

initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
  = do  { tcg_env <- getGblEnv 
	; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
	      ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
	; setEnvs (if_env, ()) thing_inside }

initIfaceExtCore :: IfL a -> TcRn a
initIfaceExtCore thing_inside
  = do  { tcg_env <- getGblEnv 
	; let { mod = tcg_mod tcg_env
	      ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
	      ; if_env = IfGblEnv { 
			if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
	      ; if_lenv = mkIfLclEnv mod doc
	  }
	; setEnvs (if_env, if_lenv) thing_inside }

initIfaceCheck :: HscEnv -> IfG a -> IO a
-- Used when checking the up-to-date-ness of the old Iface
-- Initialise the environment with no useful info at all
initIfaceCheck hsc_env do_this
 = do let rec_types = case hsc_type_env_var hsc_env of
                         Just (mod,var) -> Just (mod, readMutVar var)
                         Nothing        -> Nothing
          gbl_env = IfGblEnv { if_rec_types = rec_types }
      initTcRnIf 'i' hsc_env gbl_env () do_this

initIfaceTc :: ModIface 
 	    -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
-- Used when type-checking checking an up-to-date interface file
-- No type envt from the current module, but we do know the module dependencies
initIfaceTc iface do_this
 = do	{ tc_env_var <- newMutVar emptyTypeEnv
	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
	      ; if_lenv = mkIfLclEnv mod doc
	   }
	; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
    }
  where
    mod = mi_module iface
    doc = ptext (sLit "The interface for") <+> quotes (ppr mod)

initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
-- Used when sucking in new Rules in SimplCore
-- We have available the type envt of the module being compiled, and we must use it
initIfaceRules hsc_env guts do_this
 = do	{ let {
	     type_info = (mg_module guts, return (mg_types guts))
	   ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
	   }

	-- Run the thing; any exceptions just bubble out from here
	; initTcRnIf 'i' hsc_env gbl_env () do_this
    }

initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc thing_inside 
  = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside

getIfModule :: IfL Module
getIfModule = do { env <- getLclEnv; return (if_mod env) }

--------------------
failIfM :: Message -> IfL a
-- The Iface monad doesn't have a place to accumulate errors, so we
-- just fall over fast if one happens; it "shouldnt happen".
-- 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 <> colon) $$ nest 2 msg
	; liftIO (printErrs (full_msg defaultErrStyle))
	; failM }

--------------------
forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
-- Run thing_inside in an interleaved thread.  
-- It shares everything with the parent thread, so this is DANGEROUS.  
--
-- It returns Nothing if the computation fails
-- 
-- It's used for lazily type-checking interface
-- signatures, which is pretty benign

forkM_maybe doc thing_inside
 = do {	unsafeInterleaveM $
	do { traceIf (text "Starting fork {" <+> doc)
	   ; mb_res <- tryM $
		       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
		       thing_inside
	   ; case mb_res of
		Right r  -> do	{ traceIf (text "} ending fork" <+> doc)
				; return (Just r) }
		Left exn -> do {

		    -- Bleat about errors in the forked thread, if -ddump-if-trace is on
		    -- Otherwise we silently discard errors. Errors can legitimately
		    -- happen when compiling interface signatures (see tcInterfaceSigs)
		      ifOptM Opt_D_dump_if_trace 
			     (print_errs (hang (text "forkM failed:" <+> doc)
				             4 (text (show exn))))

		    ; traceIf (text "} ending fork (badly)" <+> doc)
	  	    ; return Nothing }
	}}
  where
    print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))

forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
 = do	{ mb_res <- forkM_maybe doc thing_inside
	; return (case mb_res of 
			Nothing -> pgmError "Cannot continue after interface file error"
				   -- pprPanic "forkM" doc
			Just r  -> r) }
\end{code}