TcRnMonad.lhs 33.3 KB
Newer Older
1
\begin{code}
2
3
module TcRnMonad(
	module TcRnMonad,
4
5
	module TcRnTypes,
	module IOEnv
6
7
8
9
  ) where

#include "HsVersions.h"

10
11
12
import TcRnTypes	-- Re-export all
import IOEnv		-- Re-export all

13
#if defined(GHCI) && defined(BREAKPOINT)
Simon Marlow's avatar
Simon Marlow committed
14
import TypeRep          ( Type(..), liftedTypeKind )
15
16
17
18
import Var              ( mkTyVar, mkGlobalId )
import IdInfo           ( GlobalIdDetails(..), vanillaIdInfo )
import OccName          ( mkOccName, tvName )
import SrcLoc           ( noSrcLoc  )
David Himmelstrup's avatar
David Himmelstrup committed
19
20
import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy, boolTy )
import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
21
22
23
import NameEnv          ( mkNameEnv )
#endif

24
import HsSyn		( emptyLHsBinds )
25
import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
Simon Marlow's avatar
Simon Marlow committed
26
			  TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
27
			  ExternalPackageState(..), HomePackageTable,
28
			  Deprecs(..), FixityEnv, FixItem, 
Simon Marlow's avatar
Simon Marlow committed
29
30
			  mkPrintUnqualified )
import Module		( Module, moduleName )
David Himmelstrup's avatar
David Himmelstrup committed
31
import RdrName		( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
Simon Marlow's avatar
Simon Marlow committed
32
import Name		( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
33
import Type		( Type )
34
35
import TcType		( tcIsTyVarTy, tcGetTyVar )
import NameEnv		( extendNameEnvList, nameEnvElts )
36
import InstEnv		( emptyInstEnv )
37

38
import Var		( setTyVarName )
39
import VarSet		( emptyVarSet )
40
import VarEnv		( TidyEnv, emptyTidyEnv, extendVarEnv )
41
import ErrUtils		( Message, Messages, emptyMessages, errorsFound, 
42
			  mkWarnMsg, printErrorsAndWarnings,
43
			  mkLocMessage, mkLongErrMsg )
44
import SrcLoc		( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
45
import NameEnv		( emptyNameEnv )
46
import NameSet		( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
47
import OccName		( emptyOccEnv, tidyOccName )
48
49
50
import Bag		( emptyBag )
import Outputable
import UniqSupply	( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
Simon Marlow's avatar
Simon Marlow committed
51
import UniqFM		( unitUFM )
52
import Unique		( Unique )
53
54
import DynFlags		( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
import StaticFlags	( opt_PprStyle_Debug )
55
import Bag		( snocBag, unionBags )
56
57
import Panic		( showException )
 
58
59
import IO		( stderr )
import DATA_IOREF	( newIORef, readIORef )
60
import EXCEPTION	( Exception )
61
62
63
64
65
66
67
68
69
70
71
\end{code}



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

\begin{code}
72
73
74
75
76
77
ioToTcRn :: IO r -> TcRn r
ioToTcRn = ioToIOEnv
\end{code}

\begin{code}
initTc :: HscEnv
78
       -> HscSource
79
80
       -> Module 
       -> TcM r
81
       -> IO (Messages, Maybe r)
82
83
84
		-- Nothing => error thrown by the thing inside
		-- (error messages should have been printed already)

85
initTc hsc_env hsc_src mod do_this
86
87
88
89
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	type_env_var <- newIORef emptyNameEnv ;
	dfuns_var    <- newIORef emptyNameSet ;
90
	keep_var     <- newIORef emptyNameSet ;
91
	th_var	     <- newIORef False ;
92
	dfun_n_var   <- newIORef 1 ;
93
94
95
      	let {
	     gbl_env = TcGblEnv {
		tcg_mod      = mod,
96
		tcg_src	     = hsc_src,
97
		tcg_rdr_env  = hsc_global_rdr_env hsc_env,
98
99
		tcg_fix_env  = emptyNameEnv,
		tcg_default  = Nothing,
100
		tcg_type_env = hsc_global_type_env hsc_env,
101
		tcg_type_env_var = type_env_var,
102
		tcg_inst_env  = emptyInstEnv,
103
		tcg_inst_uses = dfuns_var,
104
		tcg_th_used   = th_var,
105
		tcg_exports  = emptyNameSet,
106
		tcg_imports  = init_imports,
107
		tcg_dus      = emptyDUs,
108
109
                tcg_rn_imports = Nothing,
                tcg_rn_exports = Nothing,
110
		tcg_rn_decls = Nothing,
111
		tcg_binds    = emptyLHsBinds,
112
113
114
		tcg_deprecs  = NoDeprecs,
		tcg_insts    = [],
		tcg_rules    = [],
115
		tcg_fords    = [],
116
		tcg_dfun_n   = dfun_n_var,
117
		tcg_keep     = keep_var
118
	     } ;
119
	     lcl_env = TcLclEnv {
120
		tcl_errs       = errs_var,
121
		tcl_loc	       = mkGeneralSrcSpan FSLIT("Top level"),
122
		tcl_ctxt       = [],
123
		tcl_rdr	       = emptyLocalRdrEnv,
124
		tcl_th_ctxt    = topStage,
ross's avatar
ross committed
125
		tcl_arrow_ctxt = NoArrowCtxt,
126
127
		tcl_env        = emptyNameEnv,
		tcl_tyvars     = tvs_var,
128
		tcl_lie	       = panic "initTc:LIE"	-- LIE only valid inside a getLIE
129
	     } ;
130
	} ;
131
132
   
	-- OK, here's the business end!
133
	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
134
135
136
137
138
		     do {
#if defined(GHCI) && defined(BREAKPOINT)
                          unique <- newUnique ;
                          let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
                                tyvar = mkTyVar var liftedTypeKind;
David Himmelstrup's avatar
David Himmelstrup committed
139
140
141
142
143
144
145
146
147
148
149
150
151
152
                                basicType extra = (FunTy intTy
                                                   (FunTy (mkListTy unitTy)
                                                    (FunTy stringTy
                                                     (ForAllTy tyvar
                                                      (extra
                                                       (FunTy (TyVarTy tyvar)
                                                        (TyVarTy tyvar)))))));
                                breakpointJumpType
                                    = mkGlobalId VanillaGlobal breakpointJumpName
                                                 (basicType id) vanillaIdInfo;
                                breakpointCondJumpType
                                    = mkGlobalId VanillaGlobal breakpointCondJumpName
                                                 (basicType (FunTy boolTy)) vanillaIdInfo;
                                new_env = mkNameEnv [(breakpointJumpName
153
154
155
                                                     , ATcId breakpointJumpType topLevel False)
                                                     ,(breakpointCondJumpName
                                                     , ATcId breakpointCondJumpType topLevel False)];
156
157
158
159
160
161
162
163
                              };
                          r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
#else
                          r <- tryM do_this
#endif
			; case r of
			  Right res -> return (Just res)
			  Left _    -> return Nothing } ;
164

165
	-- Collect any error messages
166
167
	msgs <- readIORef errs_var ;

168
169
	let { dflags = hsc_dflags hsc_env
	    ; final_res | errorsFound dflags msgs = Nothing
170
			| otherwise	   	  = maybe_res } ;
171

172
	return (msgs, final_res)
173
174
    }
  where
Simon Marlow's avatar
Simon Marlow committed
175
176
    init_imports = emptyImportAvails {imp_env = 
					unitUFM (moduleName mod) emptyNameSet}
177
178
179
180
181
	-- Initialise tcg_imports with an empty set of bindings for
	-- this module, so that if we see 'module M' in the export
	-- list, and there are no bindings in M, we don't bleat 
	-- "unknown module M".

182
initTcPrintErrors	-- Used from the interactive loop only
183
184
185
186
187
       :: HscEnv
       -> Module 
       -> TcM r
       -> IO (Maybe r)
initTcPrintErrors env mod todo = do
188
  (msgs, res) <- initTc env HsSrcFile mod todo
189
  printErrorsAndWarnings (hsc_dflags env) msgs
190
  return res
191
192
193
\end{code}


194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
%************************************************************************
%*									*
		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}

220
221
222
223
224
225
226
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

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

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

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

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

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

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

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

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

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

257

258
259
260
Command-line flags

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

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

267
268
269
270
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}} )

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

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

\begin{code}
280
281
282
283
284
285
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) }

286
287
288
289
290
291
-- 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.
292
293
294

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
295
296
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
297
298
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
299
			; seq eps' (writeMutVar eps_var eps')
300
301
302
303
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
304
305
306
307
308
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') }
309
310
311

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
312
313
314
315

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

318
319
320
321
322
323
324
325
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
326
327
328
329
330
331
332
333
334
335
336
337
338
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.
339
340
341
342
343
344

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
345
        case splitUniqSupply us of { (us1,us2) -> do {
346
	writeMutVar u_var us1 ;
Simon Marlow's avatar
Simon Marlow committed
347
	return us2 }}}
348
349
350
351

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
  = newUnique		`thenM` \ uniq ->
352
    returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name))
353
354
\end{code}

355
356
357
358
359
360
361

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

362
\begin{code}
363
traceTc, traceRn :: SDoc -> TcRn ()
364
365
366
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceTc      = traceOptTcRn Opt_D_dump_tc_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
367
368
369


traceIf :: SDoc -> TcRnIf m n ()	
370
371
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
372

373

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

378
379
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc = ifOptM flag $ do
380
381
			{ ctxt <- getErrCtxt
			; loc  <- getSrcSpanM
382
383
			; env0 <- tcInitTidyEnv
			; ctxt_msgs <- do_ctxt env0 ctxt 
384
385
			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
			; dumpTcRn real_doc }
386
387
388

dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
389
		    ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
390
391
392

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
393
394
395
396
397
398
399
400
\end{code}


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

402
403
\begin{code}
getModule :: TcRn Module
404
405
getModule = do { env <- getGblEnv; return (tcg_mod env) }

406
407
408
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

409
410
411
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

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

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

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

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

426
getDefaultTys :: TcRn (Maybe [Type])
427
428
429
430
431
432
433
434
435
436
getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
\end{code}

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

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

441
442
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
443
444
  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
  | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
445
446

addLocM :: (a -> TcM b) -> Located a -> TcM b
447
addLocM fn (L loc a) = setSrcSpan loc $ fn a
448
449

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

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
454
  setSrcSpan loc $ do
455
456
457
458
459
    (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) =
460
  setSrcSpan loc $ do
461
462
    (b,c) <- fn a
    return (b, L loc c)
463
\end{code}
464
465


466
467
468
469
470
471
472
473
\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 ()
474
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
475

476
477
478
479
addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
480
481
482
483
addErrAt loc msg = addLongErrAt loc msg empty

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
484
485
  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
	 errs_var <- getErrsVar ;
486
	 rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
487
	 let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
488
489
490
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns, errs `snocBag` err) }

491
addErrs :: [(SrcSpan,Message)] -> TcRn ()
492
493
addErrs msgs = mappM_ add msgs
	     where
494
	       add (loc,msg) = addErrAt loc msg
495

496
addReport :: Message -> TcRn ()
497
498
499
500
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
501
502
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
503
	 let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
504
505
506
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

507
508
509
addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)

510
511
512
513
514
515
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)

516
checkErr :: Bool -> Message -> TcRn ()
517
518
519
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)

520
warnIf :: Bool -> Message -> TcRn ()
521
522
523
warnIf True  msg = addWarn msg
warnIf False msg = return ()

524
addMessages :: Messages -> TcRn ()
525
526
527
528
529
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) }
530
531
532
533
534
535
536

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
537
538
  | opt_PprStyle_Debug = thing_inside
  | otherwise
539
540
541
542
543
  = do	{ errs_var <- newMutVar emptyMessages
	; result <- setErrsVar errs_var thing_inside
	; (_warns, errs) <- readMutVar errs_var
	; addMessages (emptyBag, errs)
	; return result }
544
545
546
547
\end{code}


\begin{code}
548
549
550
551
552
553
554
555
556
557
558
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)

-----------------------
559
560
561
recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
	 -> TcRn r	-- Main action: do this first
	 -> TcRn r
562
-- Errors in 'thing' are retained
563
recoverM recover thing 
564
  = do { mb_res <- try_m thing ;
565
566
567
568
	 case mb_res of
	   Left exn  -> recover
	   Right res -> returnM res }

569
-----------------------
570
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
571
572
573
574
575
-- (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)
576
tryTc m 
577
 = do {	errs_var <- newMutVar emptyMessages ;
578
579
580
581
582
583
584
	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
585
586
   }

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
-----------------------
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)
	}
603

604
-----------------------
605
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
606
-- Just like tryTcErrs, except that it ensures that the LIE
607
608
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
609
tryTcLIE thing_inside
610
611
612
613
614
  = 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) }
	}
615

616
-----------------------
617
tryTcLIE_ :: TcM r -> TcM r -> TcM r
618
619
620
-- (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.
621
tryTcLIE_ recover main
622
623
624
625
626
627
  = 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
	}
628

629
-----------------------
630
631
632
633
634
635
636
637
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
638
639
640
641
642
643
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; addMessages msgs
	; case mb_res of
	    Nothing   -> failM
	    Just val -> return val
	} 
644

645
ifErrsM :: TcRn r -> TcRn r -> TcRn r
646
647
648
649
650
651
--	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 ;
652
653
	dflags <- getDOpts ;
	if errorsFound dflags msgs then
654
655
656
657
	   bale_out
	else	
	   normal }

658
failIfErrsM :: TcRn ()
659
660
661
662
663
664
665
666
667
668
669
670
671
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


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

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

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

678
679
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
680

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

684
685
686
687
688
-- 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 })

689
690
691
692
693
694
695
696
-- 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 })

697
698
getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
699
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
700
701
702
	 return (InstLoc origin loc (tcl_ctxt env)) }

addInstCtxt :: InstLoc -> TcM a -> TcM a
703
-- Add the SrcSpan and context from the first Inst in the list
704
705
-- 	(they all have similar locations)
addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
706
  = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
707
708
\end{code}

709
    The addErrTc functions add an error message, but do not cause failure.
710
711
712
713
714
    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 ()
715
716
addErrTc err_msg = do { env0 <- tcInitTidyEnv
		      ; addErrTcM (env0, err_msg) }
717
718
719
720
721
722
723

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

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
724
	 loc  <- getSrcSpanM ;
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
	 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 ;
750
751
	env0 <- tcInitTidyEnv ;
	ctxt_msgs <- do_ctxt env0 ctxt ;
752
753
754
755
756
757
758
759
	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}

760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
-----------------------------------
	 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
786
787
788
789

\begin{code}
add_err_tcm tidy_env err_msg loc ctxt
 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
790
	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
791
792
793
794
795
796
797
798
799
800
801
802

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}

803
debugTc is useful for monadic debugging code
804
805
806
807
808
809
810
811
812
813
814

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

 %************************************************************************
815
%*									*
816
	     Type constraints (the so-called LIE)
817
818
819
820
%*									*
%************************************************************************

\begin{code}
821
822
823
824
825
826
827
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 }

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
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
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}


870
871
872
873
874
875
876
%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

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

880
881
882
883
884
885
886
887
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) }

888
889
890
891
892
893
894
895
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}


896
897
898
899
900
901
902
903
%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

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

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

911
912
913
914
915
916
917
918

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

\begin{code}
919
920
921
922
923
924
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
			        if_loc     = loc,
			        if_tv_env  = emptyOccEnv,
			        if_id_env  = emptyOccEnv }

925
926
927
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
  = do  { tcg_env <- getGblEnv 
928
	; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
929
930
931
932
933
934
935
	      ; 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
936
	      ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod)
937
	      ; if_env = IfGblEnv { 
938
			if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
939
	      ; if_lenv = mkIfLclEnv mod doc
940
941
942
	  }
	; setEnvs (if_env, if_lenv) thing_inside }

943
944
945
946
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
947
 = do	{ let gbl_env = IfGblEnv { if_rec_types = Nothing }
948
949
950
	; initTcRnIf 'i' hsc_env gbl_env () do_this
    }

951
952
initIfaceTc :: ModIface 
 	    -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
953
954
-- 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
955
956
initIfaceTc iface do_this
 = do	{ tc_env_var <- newMutVar emptyTypeEnv
957
	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
958
	      ; if_lenv = mkIfLclEnv mod doc
959
	   }
960
	; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
961
    }
962
963
  where
    mod = mi_module iface
964
    doc = ptext SLIT("The interface for") <+> quotes (ppr mod)
965
966
967
968
969

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
970
 = do	{ let {
971
972
	     type_info = (mg_module guts, return (mg_types guts))
	   ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
973
974
975
976
977
978
	   }

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

979
980
981
982
983
984
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) }
985

986
987
988
989
990
991
992
--------------------
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
993
	; let full_msg = (if_loc env <> colon) $$ nest 2 msg
994
995
	; ioToIOEnv (printErrs (full_msg defaultErrStyle))
	; failM }
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009

--------------------
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)
1010
1011
1012
1013
	   ; mb_res <- tryM $
		       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
		       thing_inside
	   ; case mb_res of
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
		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 
1035
1036
			Nothing -> pgmError "Cannot continue after interface file error"
				   -- pprPanic "forkM" doc
1037
1038
			Just r  -> r) }
\end{code}
1039
1040