TcRnMonad.lhs 30.6 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

mnislaih's avatar
mnislaih committed
17
#if defined(GHCI)
Simon Marlow's avatar
Simon Marlow committed
18
19
20
21
import TypeRep
import IdInfo
import TysWiredIn
import PrelNames
mnislaih's avatar
mnislaih committed
22
import {-#SOURCE#-} TcEnv
23
24
#endif

Simon Marlow's avatar
Simon Marlow committed
25
26
27
28
29
30
31
32
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import TcType
import InstEnv
import FamInstEnv
33

Simon Marlow's avatar
Simon Marlow committed
34
35
36
37
38
39
40
41
42
43
import Var
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import OccName
import Bag
44
import Outputable
Simon Marlow's avatar
Simon Marlow committed
45
46
47
48
49
50
import UniqSupply
import Unique
import DynFlags
import StaticFlags
import FastString
import Panic
51
 
Simon Marlow's avatar
Simon Marlow committed
52
53
54
import System.IO
import Data.IORef
import Control.Exception
55
56
57
58
59
60
61
62
63
64
65
\end{code}



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

\begin{code}
66
67
68
69
70
ioToTcRn :: IO r -> TcRn r
ioToTcRn = ioToIOEnv
\end{code}

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

72
initTc :: HscEnv
73
       -> HscSource
74
75
       -> Module 
       -> TcM r
76
       -> IO (Messages, Maybe r)
77
78
79
		-- Nothing => error thrown by the thing inside
		-- (error messages should have been printed already)

80
initTc hsc_env hsc_src mod do_this
81
82
83
84
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	type_env_var <- newIORef emptyNameEnv ;
	dfuns_var    <- newIORef emptyNameSet ;
85
	keep_var     <- newIORef emptyNameSet ;
86
	th_var	     <- newIORef False ;
87
	dfun_n_var   <- newIORef 1 ;
88
89
90
      	let {
	     gbl_env = TcGblEnv {
		tcg_mod      = mod,
91
		tcg_src	     = hsc_src,
92
		tcg_rdr_env  = hsc_global_rdr_env hsc_env,
93
94
		tcg_fix_env  = emptyNameEnv,
		tcg_default  = Nothing,
95
		tcg_type_env = hsc_global_type_env hsc_env,
96
		tcg_type_env_var = type_env_var,
97
		tcg_inst_env  = emptyInstEnv,
98
		tcg_fam_inst_env  = emptyFamInstEnv,
99
		tcg_inst_uses = dfuns_var,
100
		tcg_th_used   = th_var,
101
		tcg_exports  = [],
102
		tcg_imports  = emptyImportAvails,
103
		tcg_dus      = emptyDUs,
104
105
                tcg_rn_imports = Nothing,
                tcg_rn_exports = Nothing,
106
		tcg_rn_decls = Nothing,
107
		tcg_binds    = emptyLHsBinds,
108
109
		tcg_deprecs  = NoDeprecs,
		tcg_insts    = [],
110
		tcg_fam_insts= [],
111
		tcg_rules    = [],
112
		tcg_fords    = [],
113
		tcg_dfun_n   = dfun_n_var,
114
115
116
		tcg_keep     = keep_var,
		tcg_doc      = Nothing,
		tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing
117
	     } ;
118
	     lcl_env = TcLclEnv {
119
		tcl_errs       = errs_var,
120
		tcl_loc	       = mkGeneralSrcSpan FSLIT("Top level"),
121
		tcl_ctxt       = [],
122
		tcl_rdr	       = emptyLocalRdrEnv,
123
		tcl_th_ctxt    = topStage,
ross's avatar
ross committed
124
		tcl_arrow_ctxt = NoArrowCtxt,
125
126
		tcl_env        = emptyNameEnv,
		tcl_tyvars     = tvs_var,
127
		tcl_lie	       = panic "initTc:LIE"	-- LIE only valid inside a getLIE
128
	     } ;
129
	} ;
130
131
   
	-- OK, here's the business end!
132
	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
133
134
		     addBreakpointBindings $
		     do { r <- tryM do_this
135
136
137
			; case r of
			  Right res -> return (Just res)
			  Left _    -> return Nothing } ;
138

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

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

146
	return (msgs, final_res)
147
    }
148

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

160
161
162
163
\begin{code}
addBreakpointBindings :: TcM a -> TcM a
addBreakpointBindings thing_inside
   = thing_inside
mnislaih's avatar
mnislaih committed
164

165
\end{code}
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
191
192
%************************************************************************
%*									*
		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}

193
194
195
196
197
198
199
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

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

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

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

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

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

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

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

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

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

230

231
232
233
Command-line flags

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

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

240
241
242
243
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}} )

244
245
246
247
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}} )

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

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

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

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

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

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

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

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

295
296
297
298
299
300
301
302
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

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

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
322
        case splitUniqSupply us of { (us1,us2) -> do {
323
	writeMutVar u_var us1 ;
Simon Marlow's avatar
Simon Marlow committed
324
	return us2 }}}
325
326
327

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
328
329
330
331
332
333
334
  = 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) }
335
336
\end{code}

337
338
339
340
341
342
343

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

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


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

355

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

492
493
494
495
496
497
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)

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

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

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

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


\begin{code}
530
531
532
533
534
535
536
537
538
539
540
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)

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

551
-----------------------
552
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
553
554
555
556
557
-- (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)
558
tryTc m 
559
 = do {	errs_var <- newMutVar emptyMessages ;
560
561
562
563
564
565
566
	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
567
568
   }

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

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

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

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

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

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


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

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

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

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

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

666
667
668
669
670
-- 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 })

671
672
673
674
675
676
677
678
-- 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 })

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

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

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

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

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
706
	 loc  <- getSrcSpanM ;
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
	 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 ()
addWarnTc msg
 = do { ctxt <- getErrCtxt ;
732
733
	env0 <- tcInitTidyEnv ;
	ctxt_msgs <- do_ctxt env0 ctxt ;
734
735
736
737
738
739
740
741
	addWarn (vcat (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}

742
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
-----------------------------------
	 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
768
769
770
771

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

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}

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

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

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

\begin{code}
803
804
805
806
807
808
809
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 }

810
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
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}


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

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

862
863
864
865
866
867
868
869
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) }

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


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

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

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

893
894
895
896
897
898
899
900

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

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

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

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

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

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

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

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

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

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