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

17
#if defined(GHCI) && defined(BREAKPOINT)
Simon Marlow's avatar
Simon Marlow committed
18
19
20
21
22
23
24
25
26
import TypeRep
import Var
import IdInfo
import OccName
import SrcLoc
import TysWiredIn
import PrelNames
import NameEnv
import TcEnv
27
28
#endif

Simon Marlow's avatar
Simon Marlow committed
29
30
31
32
33
34
35
36
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import TcType
import InstEnv
import FamInstEnv
37

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



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

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

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

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

143
	-- Collect any error messages
144
145
	msgs <- readIORef errs_var ;

146
147
	let { dflags = hsc_dflags hsc_env
	    ; final_res | errorsFound dflags msgs = Nothing
148
			| otherwise	   	  = maybe_res } ;
149

150
	return (msgs, final_res)
151
152
    }
  where
153
    init_imports = emptyImportAvails {imp_env = unitUFM (moduleName mod) []}
154
155
156
157
158
	-- 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".

159
initTcPrintErrors	-- Used from the interactive loop only
160
161
162
163
164
       :: HscEnv
       -> Module 
       -> TcM r
       -> IO (Maybe r)
initTcPrintErrors env mod todo = do
165
  (msgs, res) <- initTc env HsSrcFile mod todo
166
  printErrorsAndWarnings (hsc_dflags env) msgs
167
  return res
168
169
\end{code}

170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
\begin{code}
addBreakpointBindings :: TcM a -> TcM a
addBreakpointBindings thing_inside
#if defined(GHCI) && defined(BREAKPOINT)
  = do	{ unique <- newUnique
        ; let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
                tyvar = mkTyVar var liftedTypeKind;
                basicType extra = (FunTy intTy
                                   (FunTy (mkListTy unitTy)
                                    (FunTy stringTy
                                     (ForAllTy tyvar
                                      (extra
                                       (FunTy (TyVarTy tyvar)
                                        (TyVarTy tyvar)))))));
                breakpointJumpId
                    = mkGlobalId VanillaGlobal breakpointJumpName
                                 (basicType id) vanillaIdInfo;
                breakpointCondJumpId
                    = mkGlobalId VanillaGlobal breakpointCondJumpName
                                 (basicType (FunTy boolTy)) vanillaIdInfo
	  }
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
191
	; tcExtendIdEnv [breakpointJumpId, breakpointCondJumpId] thing_inside}
192
193
194
195
#else
   = thing_inside
#endif
\end{code}
196

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

223
224
225
226
227
228
229
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

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

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

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

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

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

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

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

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

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

260

261
262
263
Command-line flags

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

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

270
271
272
273
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}} )

274
275
276
277
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}} )

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

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

\begin{code}
287
288
289
290
291
292
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) }

293
294
295
296
297
298
-- 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.
299
300
301

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
302
303
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
304
305
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
306
			; seq eps' (writeMutVar eps_var eps')
307
308
309
310
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
311
312
313
314
315
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') }
316
317
318

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
319
320
321
322

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

325
326
327
328
329
330
331
332
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
333
334
335
336
337
338
339
340
341
342
343
344
345
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.
346
347
348
349
350
351

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
352
        case splitUniqSupply us of { (us1,us2) -> do {
353
	writeMutVar u_var us1 ;
Simon Marlow's avatar
Simon Marlow committed
354
	return us2 }}}
355
356
357

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
358
359
360
361
362
363
364
  = 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) }
365
366
\end{code}

367
368
369
370
371
372
373

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

374
\begin{code}
375
traceTc, traceRn :: SDoc -> TcRn ()
376
377
378
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceTc      = traceOptTcRn Opt_D_dump_tc_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
379
380
381


traceIf :: SDoc -> TcRnIf m n ()	
382
383
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
384

385

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

390
391
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc = ifOptM flag $ do
392
393
			{ ctxt <- getErrCtxt
			; loc  <- getSrcSpanM
394
395
			; env0 <- tcInitTidyEnv
			; ctxt_msgs <- do_ctxt env0 ctxt 
396
397
			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
			; dumpTcRn real_doc }
398
399
400

dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
401
		    ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
402
403
404

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
405
406
407
408
409
410
411
412
\end{code}


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

414
415
\begin{code}
getModule :: TcRn Module
416
417
getModule = do { env <- getGblEnv; return (tcg_mod env) }

418
419
420
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

421
422
423
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

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

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

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

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

438
getDefaultTys :: TcRn (Maybe [Type])
439
440
441
442
443
444
445
446
447
448
getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
\end{code}

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

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

453
454
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
455
456
  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
  | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
457
458

addLocM :: (a -> TcM b) -> Located a -> TcM b
459
addLocM fn (L loc a) = setSrcSpan loc $ fn a
460
461

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

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
466
  setSrcSpan loc $ do
467
468
469
470
471
    (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) =
472
  setSrcSpan loc $ do
473
474
    (b,c) <- fn a
    return (b, L loc c)
475
\end{code}
476
477


478
479
480
481
482
483
484
485
\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 ()
486
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
487

488
489
490
491
addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
492
493
494
495
addErrAt loc msg = addLongErrAt loc msg empty

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
496
497
  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
	 errs_var <- getErrsVar ;
498
	 rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
499
	 let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
500
501
502
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns, errs `snocBag` err) }

503
addErrs :: [(SrcSpan,Message)] -> TcRn ()
504
505
addErrs msgs = mappM_ add msgs
	     where
506
	       add (loc,msg) = addErrAt loc msg
507

508
addReport :: Message -> TcRn ()
509
510
511
512
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
513
514
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
515
	 let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
516
517
518
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

519
520
521
addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)

522
523
524
525
526
527
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)

528
checkErr :: Bool -> Message -> TcRn ()
529
530
531
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)

532
warnIf :: Bool -> Message -> TcRn ()
533
534
535
warnIf True  msg = addWarn msg
warnIf False msg = return ()

536
addMessages :: Messages -> TcRn ()
537
538
539
540
541
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) }
542
543
544
545
546
547
548

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
549
550
  | opt_PprStyle_Debug = thing_inside
  | otherwise
551
552
553
554
555
  = do	{ errs_var <- newMutVar emptyMessages
	; result <- setErrsVar errs_var thing_inside
	; (_warns, errs) <- readMutVar errs_var
	; addMessages (emptyBag, errs)
	; return result }
556
557
558
559
\end{code}


\begin{code}
560
561
562
563
564
565
566
567
568
569
570
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)

-----------------------
571
572
573
recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
	 -> TcRn r	-- Main action: do this first
	 -> TcRn r
574
-- Errors in 'thing' are retained
575
recoverM recover thing 
576
  = do { mb_res <- try_m thing ;
577
578
579
580
	 case mb_res of
	   Left exn  -> recover
	   Right res -> returnM res }

581
-----------------------
582
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
583
584
585
586
587
-- (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)
588
tryTc m 
589
 = do {	errs_var <- newMutVar emptyMessages ;
590
591
592
593
594
595
596
	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
597
598
   }

599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
-----------------------
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)
	}
615

616
-----------------------
617
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
618
-- Just like tryTcErrs, except that it ensures that the LIE
619
620
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
621
tryTcLIE thing_inside
622
623
624
625
626
  = 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) }
	}
627

628
-----------------------
629
tryTcLIE_ :: TcM r -> TcM r -> TcM r
630
631
632
-- (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.
633
tryTcLIE_ recover main
634
635
636
637
638
639
  = 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
	}
640

641
-----------------------
642
643
644
645
646
647
648
649
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
650
651
652
653
654
655
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; addMessages msgs
	; case mb_res of
	    Nothing   -> failM
	    Just val -> return val
	} 
656

657
ifErrsM :: TcRn r -> TcRn r -> TcRn r
658
659
660
661
662
663
--	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 ;
664
665
	dflags <- getDOpts ;
	if errorsFound dflags msgs then
666
667
668
669
	   bale_out
	else	
	   normal }

670
failIfErrsM :: TcRn ()
671
672
673
674
675
676
677
678
679
680
681
682
683
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


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

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

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

690
691
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
692

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

696
697
698
699
700
-- 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 })

701
702
703
704
705
706
707
708
-- 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 })

709
710
getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
711
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
712
713
714
	 return (InstLoc origin loc (tcl_ctxt env)) }

addInstCtxt :: InstLoc -> TcM a -> TcM a
715
-- Add the SrcSpan and context from the first Inst in the list
716
717
-- 	(they all have similar locations)
addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
718
  = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
719
720
\end{code}

721
    The addErrTc functions add an error message, but do not cause failure.
722
723
724
725
726
    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 ()
727
728
addErrTc err_msg = do { env0 <- tcInitTidyEnv
		      ; addErrTcM (env0, err_msg) }
729
730
731
732
733
734
735

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

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
736
	 loc  <- getSrcSpanM ;
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
	 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 ;
762
763
	env0 <- tcInitTidyEnv ;
	ctxt_msgs <- do_ctxt env0 ctxt ;
764
765
766
767
768
769
770
771
	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}

772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
-----------------------------------
	 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
798
799
800
801

\begin{code}
add_err_tcm tidy_env err_msg loc ctxt
 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
802
	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
803
804
805
806
807
808
809
810
811
812
813
814

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}

815
debugTc is useful for monadic debugging code
816
817
818
819
820
821
822
823
824
825
826

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

 %************************************************************************
827
%*									*
828
	     Type constraints (the so-called LIE)
829
830
831
832
%*									*
%************************************************************************

\begin{code}
833
834
835
836
837
838
839
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 }

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


882
883
884
885
886
887
888
%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

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

892
893
894
895
896
897
898
899
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) }

900
901
902
903
904
905
906
907
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}


908
909
910
911
912
913
914
915
%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

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

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

923
924
925
926
927
928
929
930

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

\begin{code}
931
932
933
934
935
936
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
			        if_loc     = loc,
			        if_tv_env  = emptyOccEnv,
			        if_id_env  = emptyOccEnv }

937
938
939
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
  = do  { tcg_env <- getGblEnv 
940
	; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
941
942
943
944
945
946
947
	      ; 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
948
	      ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod)
949
	      ; if_env = IfGblEnv { 
950
			if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
951
	      ; if_lenv = mkIfLclEnv mod doc
952
953
954
	  }
	; setEnvs (if_env, if_lenv) thing_inside }

955
956
957
958
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
959
 = do	{ let gbl_env = IfGblEnv { if_rec_types = Nothing }
960
961
962
	; initTcRnIf 'i' hsc_env gbl_env () do_this
    }

963
964
initIfaceTc :: ModIface 
 	    -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
965
966
-- 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
967
968
initIfaceTc iface do_this
 = do	{ tc_env_var <- newMutVar emptyTypeEnv
969
	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
970
	      ; if_lenv = mkIfLclEnv mod doc
971
	   }
972
	; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
973
    }
974
975
  where
    mod = mi_module iface
976
    doc = ptext SLIT("The interface for") <+> quotes (ppr mod)
977
978
979
980
981

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
982
 = do	{ let {
983
984
	     type_info = (mg_module guts, return (mg_types guts))
	   ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
985
986
987
988
989
990
	   }

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

991
992
993
994
995
996
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) }
997

998
999
1000
1001
1002
1003
1004
--------------------
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
1005
	; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1006
1007
	; ioToIOEnv (printErrs (full_msg defaultErrStyle))
	; failM }
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021

--------------------
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)
1022
1023
1024
1025
	   ; mb_res <- tryM $
		       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
		       thing_inside
	   ; case mb_res of
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
		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 
1047
1048
			Nothing -> pgmError "Cannot continue after interface file error"
				   -- pprPanic "forkM" doc
1049
1050
			Just r  -> r) }
\end{code}
1051
1052