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

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

#include "HsVersions.h"

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

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
       -> Bool		-- True <=> retain renamed syntax trees
75
76
       -> Module 
       -> TcM r
77
       -> IO (Messages, Maybe r)
78
79
80
		-- Nothing => error thrown by the thing inside
		-- (error messages should have been printed already)

81
initTc hsc_env hsc_src keep_rn_syntax mod do_this
82
83
84
85
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	type_env_var <- newIORef emptyNameEnv ;
	dfuns_var    <- newIORef emptyNameSet ;
86
	keep_var     <- newIORef emptyNameSet ;
87
	th_var	     <- newIORef False ;
88
	dfun_n_var   <- newIORef 1 ;
89
      	let {
90
91
92
93
	     maybe_rn_syntax empty_val
		| keep_rn_syntax = Just empty_val
		| otherwise	 = Nothing ;
			
94
95
	     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_fam_inst_env  = emptyFamInstEnv,
104
		tcg_inst_uses = dfuns_var,
105
		tcg_th_used   = th_var,
106
		tcg_exports  = [],
107
		tcg_imports  = emptyImportAvails,
108
		tcg_dus      = emptyDUs,
109
110
111
112
113

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

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

146
	-- Collect any error messages
147
148
	msgs <- readIORef errs_var ;

149
150
	let { dflags = hsc_dflags hsc_env
	    ; final_res | errorsFound dflags msgs = Nothing
151
			| otherwise	   	  = maybe_res } ;
152

153
	return (msgs, final_res)
154
    }
155

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

167
168
169
170
171
\begin{code}
addBreakpointBindings :: TcM a -> TcM a
addBreakpointBindings thing_inside
   = thing_inside
\end{code}
172

173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
%************************************************************************
%*									*
		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}

199
200
201
202
203
204
205
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

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

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

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

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

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

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

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

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

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

236

237
238
239
Command-line flags

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

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

246
247
248
249
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}} )

250
251
252
253
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}} )

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

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

\begin{code}
263
264
265
266
267
268
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) }

269
270
271
272
273
274
-- 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.
275
276
277

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
278
279
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
280
281
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
282
			; seq eps' (writeMutVar eps_var eps')
283
284
285
286
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
287
288
289
290
291
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') }
292
293
294

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
295
296
297
298

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

301
302
303
304
305
306
307
308
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
309
310
311
312
313
314
315
316
317
318
319
320
321
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.
322
323
324
325
326
327

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
328
        case splitUniqSupply us of { (us1,us2) -> do {
329
	writeMutVar u_var us1 ;
Simon Marlow's avatar
Simon Marlow committed
330
	return us2 }}}
331
332
333

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
334
335
336
337
338
339
340
  = 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) }
341
342
\end{code}

343
344
345
346
347
348
349

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

350
\begin{code}
351
traceTc, traceRn :: SDoc -> TcRn ()
352
353
354
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceTc      = traceOptTcRn Opt_D_dump_tc_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
355
356
357


traceIf :: SDoc -> TcRnIf m n ()	
358
359
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
360

361

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

366
367
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc = ifOptM flag $ do
368
369
			{ ctxt <- getErrCtxt
			; loc  <- getSrcSpanM
370
371
			; env0 <- tcInitTidyEnv
			; ctxt_msgs <- do_ctxt env0 ctxt 
372
373
			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
			; dumpTcRn real_doc }
374
375
376

dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
377
		    ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
378
379
380

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
381
382
383
384
385
386
387
388
\end{code}


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

390
391
\begin{code}
getModule :: TcRn Module
392
393
getModule = do { env <- getGblEnv; return (tcg_mod env) }

394
395
396
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

397
398
399
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

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

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

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

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

414
415
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
416
417
418
419
420
421
422
423
424
\end{code}

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

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

429
430
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
431
432
  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
  | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
433
434

addLocM :: (a -> TcM b) -> Located a -> TcM b
435
addLocM fn (L loc a) = setSrcSpan loc $ fn a
436
437

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

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
442
  setSrcSpan loc $ do
443
444
445
446
447
    (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) =
448
  setSrcSpan loc $ do
449
450
    (b,c) <- fn a
    return (b, L loc c)
451
\end{code}
452
453


454
455
456
457
458
459
460
461
\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 ()
462
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
463

464
465
466
467
addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
468
469
470
471
addErrAt loc msg = addLongErrAt loc msg empty

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

479
addErrs :: [(SrcSpan,Message)] -> TcRn ()
480
481
addErrs msgs = mappM_ add msgs
	     where
482
	       add (loc,msg) = addErrAt loc msg
483

484
addReport :: Message -> TcRn ()
485
486
487
488
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
489
490
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
Simon Marlow's avatar
Simon Marlow committed
491
	 let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
492
493
494
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

495
496
497
addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)

498
499
500
501
502
503
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)

504
checkErr :: Bool -> Message -> TcRn ()
505
506
507
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)

508
warnIf :: Bool -> Message -> TcRn ()
509
510
511
warnIf True  msg = addWarn msg
warnIf False msg = return ()

512
addMessages :: Messages -> TcRn ()
513
514
515
516
517
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) }
518
519
520
521
522
523
524

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
525
526
  | opt_PprStyle_Debug = thing_inside
  | otherwise
527
528
529
530
531
  = do	{ errs_var <- newMutVar emptyMessages
	; result <- setErrsVar errs_var thing_inside
	; (_warns, errs) <- readMutVar errs_var
	; addMessages (emptyBag, errs)
	; return result }
532
533
534
535
\end{code}


\begin{code}
536
537
538
539
540
541
542
543
544
545
546
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)

-----------------------
547
548
549
recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
	 -> TcRn r	-- Main action: do this first
	 -> TcRn r
550
-- Errors in 'thing' are retained
551
recoverM recover thing 
552
  = do { mb_res <- try_m thing ;
553
554
555
556
	 case mb_res of
	   Left exn  -> recover
	   Right res -> returnM res }

557
-----------------------
558
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
559
560
561
562
563
-- (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)
564
tryTc m 
565
 = do {	errs_var <- newMutVar emptyMessages ;
566
567
568
569
570
571
572
	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
573
574
   }

575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
-----------------------
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)
	}
591

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

604
-----------------------
605
tryTcLIE_ :: TcM r -> TcM r -> TcM r
606
607
608
-- (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.
609
tryTcLIE_ recover main
610
611
612
613
614
615
  = 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
	}
616

617
-----------------------
618
619
620
621
622
623
624
625
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
626
627
628
629
630
631
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; addMessages msgs
	; case mb_res of
	    Nothing   -> failM
	    Just val -> return val
	} 
632

633
ifErrsM :: TcRn r -> TcRn r -> TcRn r
634
635
636
637
638
639
--	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 ;
640
641
	dflags <- getDOpts ;
	if errorsFound dflags msgs then
642
643
644
645
	   bale_out
	else	
	   normal }

646
failIfErrsM :: TcRn ()
647
648
649
650
651
652
653
654
655
656
657
658
659
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


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

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

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

666
667
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
668

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

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

677
678
679
680
681
682
683
684
-- 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 })

685
686
getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
687
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
688
689
690
	 return (InstLoc origin loc (tcl_ctxt env)) }

addInstCtxt :: InstLoc -> TcM a -> TcM a
691
-- Add the SrcSpan and context from the first Inst in the list
692
693
-- 	(they all have similar locations)
addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
694
  = setSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside)
695
696
\end{code}

697
    The addErrTc functions add an error message, but do not cause failure.
698
699
700
701
702
    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 ()
703
704
addErrTc err_msg = do { env0 <- tcInitTidyEnv
		      ; addErrTcM (env0, err_msg) }
705
706
707
708
709
710
711

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

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
712
	 loc  <- getSrcSpanM ;
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
	 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 ;
738
739
	env0 <- tcInitTidyEnv ;
	ctxt_msgs <- do_ctxt env0 ctxt ;
740
741
742
743
744
745
746
747
	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}

748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
-----------------------------------
	 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
774
775
776
777

\begin{code}
add_err_tcm tidy_env err_msg loc ctxt
 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
778
	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
779
780
781
782
783
784
785
786
787
788
789
790

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}

791
debugTc is useful for monadic debugging code
792
793
794
795
796
797
798
799
800
801
802

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

 %************************************************************************
803
%*									*
804
	     Type constraints (the so-called LIE)
805
806
807
808
%*									*
%************************************************************************

\begin{code}
809
810
811
812
813
814
815
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 }

816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
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}


858
859
860
861
862
863
864
%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

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

868
869
870
871
872
873
874
875
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) }

876
877
878
879
880
881
882
883
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}


884
885
886
887
888
889
890
891
%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

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

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

899
900
901
902
903
904
905
906

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

\begin{code}
907
908
909
910
911
912
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
			        if_loc     = loc,
			        if_tv_env  = emptyOccEnv,
			        if_id_env  = emptyOccEnv }

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

931
932
933
934
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
935
 = do	{ let gbl_env = IfGblEnv { if_rec_types = Nothing }
936
937
938
	; initTcRnIf 'i' hsc_env gbl_env () do_this
    }

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

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
958
 = do	{ let {
959
960
	     type_info = (mg_module guts, return (mg_types guts))
	   ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
961
962
963
964
965
966
	   }

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

967
968
969
970
971
972
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) }
973

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

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