TcRnMonad.lhs 30.8 KB
Newer Older
Simon Marlow's avatar
Simon Marlow committed
1 2 3 4
%
% (c) The University of Glasgow 2006
%

5
\begin{code}
6 7
module TcRnMonad(
	module TcRnMonad,
8 9
	module TcRnTypes,
	module IOEnv
10 11 12 13
  ) where

#include "HsVersions.h"

14 15 16
import TcRnTypes	-- Re-export all
import IOEnv		-- Re-export all

Simon Marlow's avatar
Simon Marlow committed
17 18 19 20 21 22 23 24
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import TcType
import InstEnv
import FamInstEnv
25

Simon Marlow's avatar
Simon Marlow committed
26 27 28 29 30 31 32 33 34 35
import Var
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import OccName
import Bag
36
import Outputable
Simon Marlow's avatar
Simon Marlow committed
37 38 39 40 41 42
import UniqSupply
import Unique
import DynFlags
import StaticFlags
import FastString
import Panic
43
 
Simon Marlow's avatar
Simon Marlow committed
44 45 46
import System.IO
import Data.IORef
import Control.Exception
47 48 49 50 51 52 53 54 55 56 57
\end{code}



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

\begin{code}
58 59 60 61 62
ioToTcRn :: IO r -> TcRn r
ioToTcRn = ioToIOEnv
\end{code}

\begin{code}
mnislaih's avatar
mnislaih committed
63

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

73
initTc hsc_env hsc_src keep_rn_syntax mod do_this
74 75 76 77
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	type_env_var <- newIORef emptyNameEnv ;
	dfuns_var    <- newIORef emptyNameSet ;
78
	keep_var     <- newIORef emptyNameSet ;
79
	th_var	     <- newIORef False ;
80
	dfun_n_var   <- newIORef 1 ;
81
      	let {
82 83 84 85
	     maybe_rn_syntax empty_val
		| keep_rn_syntax = Just empty_val
		| otherwise	 = Nothing ;
			
86 87
	     gbl_env = TcGblEnv {
		tcg_mod      = mod,
88
		tcg_src	     = hsc_src,
89
		tcg_rdr_env  = hsc_global_rdr_env hsc_env,
90 91
		tcg_fix_env  = emptyNameEnv,
		tcg_default  = Nothing,
92
		tcg_type_env = hsc_global_type_env hsc_env,
93
		tcg_type_env_var = type_env_var,
94
		tcg_inst_env  = emptyInstEnv,
95
		tcg_fam_inst_env  = emptyFamInstEnv,
96
		tcg_inst_uses = dfuns_var,
97
		tcg_th_used   = th_var,
98
		tcg_exports  = [],
99
		tcg_imports  = emptyImportAvails,
100
		tcg_dus      = emptyDUs,
101 102 103 104 105

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

106
		tcg_binds    = emptyLHsBinds,
107 108
		tcg_deprecs  = NoDeprecs,
		tcg_insts    = [],
109
		tcg_fam_insts= [],
110
		tcg_rules    = [],
111
		tcg_fords    = [],
112
		tcg_dfun_n   = dfun_n_var,
113 114 115
		tcg_keep     = keep_var,
		tcg_doc      = Nothing,
		tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing
116
	     } ;
117
	     lcl_env = TcLclEnv {
118
		tcl_errs       = errs_var,
119
		tcl_loc	       = mkGeneralSrcSpan FSLIT("Top level"),
120
		tcl_ctxt       = [],
121
		tcl_rdr	       = emptyLocalRdrEnv,
122
		tcl_th_ctxt    = topStage,
ross's avatar
ross committed
123
		tcl_arrow_ctxt = NoArrowCtxt,
124 125
		tcl_env        = emptyNameEnv,
		tcl_tyvars     = tvs_var,
126
		tcl_lie	       = panic "initTc:LIE"	-- LIE only valid inside a getLIE
127
	     } ;
128
	} ;
129 130
   
	-- OK, here's the business end!
131
	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
132 133
		     addBreakpointBindings $
		     do { r <- tryM do_this
134 135 136
			; case r of
			  Right res -> return (Just res)
			  Left _    -> return Nothing } ;
137

138
	-- Collect any error messages
139 140
	msgs <- readIORef errs_var ;

141 142
	let { dflags = hsc_dflags hsc_env
	    ; final_res | errorsFound dflags msgs = Nothing
143
			| otherwise	   	  = maybe_res } ;
144

145
	return (msgs, final_res)
146
    }
147

148
initTcPrintErrors	-- Used from the interactive loop only
149 150 151 152 153
       :: HscEnv
       -> Module 
       -> TcM r
       -> IO (Maybe r)
initTcPrintErrors env mod todo = do
154
  (msgs, res) <- initTc env HsSrcFile False mod todo
155
  printErrorsAndWarnings (hsc_dflags env) msgs
156
  return res
157 158
\end{code}

159 160 161 162 163
\begin{code}
addBreakpointBindings :: TcM a -> TcM a
addBreakpointBindings thing_inside
   = thing_inside
\end{code}
164

165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
%************************************************************************
%*									*
		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}

191 192 193 194 195 196 197
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

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

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

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

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

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

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

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

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

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

228

229 230 231
Command-line flags

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

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

238 239 240 241
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}} )

242 243 244 245
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}} )

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

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

\begin{code}
255 256 257 258 259 260
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) }

261 262 263 264 265 266
-- 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.
267 268 269

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
270 271
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
272 273
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
274
			; seq eps' (writeMutVar eps_var eps')
275 276 277 278
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
279 280 281 282 283
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') }
284 285 286

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
287 288 289 290

getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
		  ; return (eps, hsc_HPT env) }
291
\end{code}
292

293 294 295 296 297 298 299 300
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
301 302 303 304 305 306 307 308 309 310 311 312 313
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.
314 315 316 317 318 319

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
	let { u_var = env_us env } ;
	us <- readMutVar u_var ;
Simon Marlow's avatar
Simon Marlow committed
320
        case splitUniqSupply us of { (us1,us2) -> do {
321
	writeMutVar u_var us1 ;
Simon Marlow's avatar
Simon Marlow committed
322
	return us2 }}}
323 324 325

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
326 327 328 329 330 331 332
  = do	{ uniq <- newUnique
	; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) }

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

335 336 337 338 339 340 341

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

342
\begin{code}
343
traceTc, traceRn :: SDoc -> TcRn ()
344 345 346
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceTc      = traceOptTcRn Opt_D_dump_tc_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
347 348 349


traceIf :: SDoc -> TcRnIf m n ()	
350 351
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
352

353

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

358 359
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc = ifOptM flag $ do
360 361
			{ ctxt <- getErrCtxt
			; loc  <- getSrcSpanM
362 363
			; env0 <- tcInitTidyEnv
			; ctxt_msgs <- do_ctxt env0 ctxt 
364 365
			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
			; dumpTcRn real_doc }
366 367 368

dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
369
		    ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
370 371 372

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
373 374 375 376 377 378 379 380
\end{code}


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

382 383
\begin{code}
getModule :: TcRn Module
384 385
getModule = do { env <- getGblEnv; return (tcg_mod env) }

386 387 388
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

389 390 391
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

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

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

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

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

406 407
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
408 409 410 411 412 413 414 415 416
\end{code}

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

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

421 422
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
423 424
  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
  | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
425 426

addLocM :: (a -> TcM b) -> Located a -> TcM b
427
addLocM fn (L loc a) = setSrcSpan loc $ fn a
428 429

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

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
434
  setSrcSpan loc $ do
435 436 437 438 439
    (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) =
440
  setSrcSpan loc $ do
441 442
    (b,c) <- fn a
    return (b, L loc c)
443
\end{code}
444 445


446 447 448 449 450 451 452 453
\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 ()
454
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
455

456 457 458 459
addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
460 461 462 463
addErrAt loc msg = addLongErrAt loc msg empty

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
464 465
  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
	 errs_var <- getErrsVar ;
466
	 rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
467
	 let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
468 469 470
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns, errs `snocBag` err) }

471
addErrs :: [(SrcSpan,Message)] -> TcRn ()
472 473
addErrs msgs = mappM_ add msgs
	     where
474
	       add (loc,msg) = addErrAt loc msg
475

476
addReport :: Message -> TcRn ()
477 478 479 480
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
481 482
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
483
	 let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
484 485 486
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

487 488 489
addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)

490 491 492 493 494 495
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)

496
checkErr :: Bool -> Message -> TcRn ()
497 498 499
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)

500
warnIf :: Bool -> Message -> TcRn ()
501 502 503
warnIf True  msg = addWarn msg
warnIf False msg = return ()

504
addMessages :: Messages -> TcRn ()
505 506 507 508 509
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) }
510 511 512 513 514 515 516

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
517 518
  | opt_PprStyle_Debug = thing_inside
  | otherwise
519 520 521 522 523
  = do	{ errs_var <- newMutVar emptyMessages
	; result <- setErrsVar errs_var thing_inside
	; (_warns, errs) <- readMutVar errs_var
	; addMessages (emptyBag, errs)
	; return result }
524 525 526 527
\end{code}


\begin{code}
528 529 530 531 532 533 534 535 536 537 538
try_m :: TcRn r -> TcRn (Either Exception 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 r  -> return mb_r }
  where
    exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)

-----------------------
539 540 541
recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
	 -> TcRn r	-- Main action: do this first
	 -> TcRn r
542
-- Errors in 'thing' are retained
543
recoverM recover thing 
544
  = do { mb_res <- try_m thing ;
545 546 547 548
	 case mb_res of
	   Left exn  -> recover
	   Right res -> returnM res }

549
-----------------------
550
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
551 552 553 554 555
-- (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)
556
tryTc m 
557
 = do {	errs_var <- newMutVar emptyMessages ;
558 559 560 561 562 563 564
	res  <- try_m (setErrsVar errs_var m) ; 
	msgs <- readMutVar errs_var ;
	return (msgs, case res of
			    Left exn  -> Nothing
			    Right val -> Just val)
	-- The exception is always the IOEnv built-in
	-- in exception; see IOEnv.failM
565 566
   }

567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582
-----------------------
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)
	}
583

584
-----------------------
585
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
586
-- Just like tryTcErrs, except that it ensures that the LIE
587 588
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
589
tryTcLIE thing_inside
590 591 592 593 594
  = 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) }
	}
595

596
-----------------------
597
tryTcLIE_ :: TcM r -> TcM r -> TcM r
598 599 600
-- (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.
601
tryTcLIE_ recover main
602 603 604 605 606 607
  = 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
	}
608

609
-----------------------
610 611 612 613 614 615 616 617
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
618 619 620 621 622 623
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; addMessages msgs
	; case mb_res of
	    Nothing   -> failM
	    Just val -> return val
	} 
624

625
ifErrsM :: TcRn r -> TcRn r -> TcRn r
626 627 628 629 630 631
--	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 ;
632 633
	dflags <- getDOpts ;
	if errorsFound dflags msgs then
634 635 636 637
	   bale_out
	else	
	   normal }

638
failIfErrsM :: TcRn ()
639 640 641 642 643 644 645 646 647 648 649 650 651
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


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

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

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

658 659
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
660

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

664 665 666 667 668
-- 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 })

669 670 671 672 673 674 675 676
-- 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 { [] -> []; (m:ms) -> ms })

677 678
getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
679
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
680 681 682
	 return (InstLoc origin loc (tcl_ctxt env)) }

addInstCtxt :: InstLoc -> TcM a -> TcM a
683
-- Add the SrcSpan and context from the first Inst in the list
684 685
-- 	(they all have similar locations)
addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
686
  = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
687 688
\end{code}

689
    The addErrTc functions add an error message, but do not cause failure.
690 691 692 693 694
    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 ()
695 696
addErrTc err_msg = do { env0 <- tcInitTidyEnv
		      ; addErrTcM (env0, err_msg) }
697 698 699 700 701 702 703

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

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
704
	 loc  <- getSrcSpanM ;
705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727
	 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  err = returnM ()
checkTc False err = failWithTc err
\end{code}

	Warnings have no 'M' variant, nor failure

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

addWarnTcM :: (TidyEnv, Message) -> TcM ()
addWarnTcM (env0, msg)
733
 = do { ctxt <- getErrCtxt ;
734
	ctxt_msgs <- do_ctxt env0 ctxt ;
735
	addReport (vcat (ptext SLIT("Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
736 737 738 739 740 741 742

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

743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768
-----------------------------------
	 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
769 770 771 772

\begin{code}
add_err_tcm tidy_env err_msg loc ctxt
 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
773
	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
774 775 776 777 778 779 780 781 782 783 784 785

do_ctxt tidy_env []
 = 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 ctxt | opt_PprStyle_Debug = ctxt
		 | otherwise	      = take 3 ctxt
\end{code}

786
debugTc is useful for monadic debugging code
787 788 789 790 791 792 793 794 795 796 797

\begin{code}
debugTc :: TcM () -> TcM ()
#ifdef DEBUG
debugTc thing = thing
#else
debugTc thing = return ()
#endif
\end{code}

 %************************************************************************
798
%*									*
799
	     Type constraints (the so-called LIE)
800 801 802 803
%*									*
%************************************************************************

\begin{code}
804 805 806 807 808 809 810
nextDFunIndex :: TcM Int	-- Get the next dfun index
nextDFunIndex = do { env <- getGblEnv
		   ; let dfun_n_var = tcg_dfun_n env
		   ; n <- readMutVar dfun_n_var
		   ; writeMutVar dfun_n_var (n+1)
		   ; return n }

811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852
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 [] 
  = returnM ()
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}


853 854 855 856 857 858 859
%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

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

863 864 865 866 867 868 869 870
keepAliveTc :: Name -> TcM ()  	-- Record the name in the keep-alive set
keepAliveTc n = do { env <- getGblEnv; 
		   ; updMutVar (tcg_keep env) (`addOneToNameSet` n) }

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

871 872 873 874 875 876 877 878
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}


879 880 881 882 883 884 885 886
%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

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

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

894 895 896 897 898 899 900 901

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

\begin{code}
902 903 904 905 906 907
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
			        if_loc     = loc,
			        if_tv_env  = emptyOccEnv,
			        if_id_env  = emptyOccEnv }

908 909 910
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
  = do  { tcg_env <- getGblEnv 
911
	; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
912 913 914 915 916 917 918
	      ; 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
919
	      ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod)
920
	      ; if_env = IfGblEnv { 
921
			if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
922
	      ; if_lenv = mkIfLclEnv mod doc
923 924 925
	  }
	; setEnvs (if_env, if_lenv) thing_inside }

926 927 928 929
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
930
 = do	{ let gbl_env = IfGblEnv { if_rec_types = Nothing }
931 932 933
	; initTcRnIf 'i' hsc_env gbl_env () do_this
    }

934 935
initIfaceTc :: ModIface 
 	    -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
936 937
-- 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
938 939
initIfaceTc iface do_this
 = do	{ tc_env_var <- newMutVar emptyTypeEnv
940
	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
941
	      ; if_lenv = mkIfLclEnv mod doc
942
	   }
943
	; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
944
    }
945 946
  where
    mod = mi_module iface
947
    doc = ptext SLIT("The interface for") <+> quotes (ppr mod)
948 949 950 951 952

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
953
 = do	{ let {
954 955
	     type_info = (mg_module guts, return (mg_types guts))
	   ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
956 957 958 959 960 961
	   }

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

962 963 964 965 966 967
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) }
968

969 970 971 972 973 974 975
--------------------
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
976
	; let full_msg = (if_loc env <> colon) $$ nest 2 msg
977 978
	; ioToIOEnv (printErrs (full_msg defaultErrStyle))
	; failM }
979 980 981 982 983 984 985 986 987 988 989 990 991 992

--------------------
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)
993 994 995 996
	   ; mb_res <- tryM $
		       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
		       thing_inside
	   ; case mb_res of
997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017
		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 = ioToIOEnv (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 
1018 1019
			Nothing -> pgmError "Cannot continue after interface file error"
				   -- pprPanic "forkM" doc
1020 1021
			Just r  -> r) }
\end{code}
1022 1023