TcRnMonad.lhs 32.7 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
326
327
328
329
330
331
332
333
334
335
336
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
newUnique = do { us <- newUniqueSupply ; 
		 return (uniqFromSupply us) }

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
	let { u_var = env_us env } ;
	us <- readMutVar u_var ;
    	let { (us1, us2) = splitUniqSupply us } ;
	writeMutVar u_var us1 ;
	return us2 }
337
338
339
340

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

344
345
346
347
348
349
350

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

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


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

362

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

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

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

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


%************************************************************************
%*									*
		Typechecker global environment
%*									*
%************************************************************************
390

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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
774
-----------------------------------
	 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
775
776
777
778

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

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}

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

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

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

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

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


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

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

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

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


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

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

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

900
901
902
903
904
905
906
907

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

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

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

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

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

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

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

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

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

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