TcRnMonad.lhs 33.1 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
14
15
16
17
18
19
20
21
22
23
#if defined(GHCI) && defined(BREAKPOINT)
import TypeRep          ( Type(..), liftedTypeKind, TyThing(..) )
import Var              ( mkTyVar, mkGlobalId )
import IdInfo           ( GlobalIdDetails(..), vanillaIdInfo )
import OccName          ( mkOccName, tvName )
import SrcLoc           ( noSrcLoc  )
import TysWiredIn       ( intTy, stringTy, mkListTy, unitTy )
import PrelNames        ( breakpointJumpName )
import NameEnv          ( mkNameEnv )
#endif

24
import HsSyn		( emptyLHsBinds )
25
import HscTypes		( HscEnv(..), ModGuts(..), ModIface(..),
26
27
			  TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
			  isHsBoot, ModSummary(..),
28
			  ExternalPackageState(..), HomePackageTable,
29
			  Deprecs(..), FixityEnv, FixItem, 
30
			  lookupType, unQualInScope )
31
import Module		( Module, unitModuleEnv )
32
33
import RdrName		( GlobalRdrEnv, emptyGlobalRdrEnv, 	
			  LocalRdrEnv, emptyLocalRdrEnv )
34
import Name		( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
35
import Type		( Type )
36
37
import TcType		( tcIsTyVarTy, tcGetTyVar )
import NameEnv		( extendNameEnvList, nameEnvElts )
38
import InstEnv		( emptyInstEnv )
39

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



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

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

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

87
initTc hsc_env hsc_src mod do_this
88
89
90
91
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	type_env_var <- newIORef emptyNameEnv ;
	dfuns_var    <- newIORef emptyNameSet ;
92
	keep_var     <- newIORef emptyNameSet ;
93
	th_var	     <- newIORef False ;
94
	dfun_n_var   <- newIORef 1 ;
95
96
97
      	let {
	     gbl_env = TcGblEnv {
		tcg_mod      = mod,
98
		tcg_src	     = hsc_src,
99
		tcg_rdr_env  = hsc_global_rdr_env hsc_env,
100
101
		tcg_fix_env  = emptyNameEnv,
		tcg_default  = Nothing,
102
		tcg_type_env = hsc_global_type_env hsc_env,
103
		tcg_type_env_var = type_env_var,
104
		tcg_inst_env  = emptyInstEnv,
105
		tcg_inst_uses = dfuns_var,
106
		tcg_th_used   = th_var,
107
		tcg_exports  = emptyNameSet,
108
		tcg_imports  = init_imports,
109
		tcg_home_mods = home_mods,
110
		tcg_dus      = emptyDUs,
111
112
                tcg_rn_imports = Nothing,
                tcg_rn_exports = Nothing,
113
		tcg_rn_decls = Nothing,
114
		tcg_binds    = emptyLHsBinds,
115
116
117
		tcg_deprecs  = NoDeprecs,
		tcg_insts    = [],
		tcg_rules    = [],
118
		tcg_fords    = [],
119
		tcg_dfun_n   = dfun_n_var,
120
		tcg_keep     = keep_var
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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
		     do {
#if defined(GHCI) && defined(BREAKPOINT)
                          unique <- newUnique ;
                          let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
                                tyvar = mkTyVar var liftedTypeKind;
                                breakpointJumpType = mkGlobalId
                                                     (VanillaGlobal)
                                                     (breakpointJumpName)
                                                     (FunTy intTy
                                                      (FunTy (mkListTy unitTy)
                                                       (FunTy stringTy
                                                        (ForAllTy tyvar
                                                         (FunTy (TyVarTy tyvar)
                                                          (TyVarTy tyvar))))))
                                                     (vanillaIdInfo);
                                new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
                              };
                          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 } ;
161

162
	-- Collect any error messages
163
164
	msgs <- readIORef errs_var ;

165
166
	let { dflags = hsc_dflags hsc_env
	    ; final_res | errorsFound dflags msgs = Nothing
167
			| otherwise	   	  = maybe_res } ;
168

169
	return (msgs, final_res)
170
171
    }
  where
172
173
174
175
176
177
178
179
180
181
182
    home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env))
	-- A guess at the home modules.  This will be correct in
	-- --make and GHCi modes, but in one-shot mode we need to 
	-- fix it up after we know the real dependencies of the current
	-- module (see tcRnModule).
	-- Setting it here is necessary for the typechecker entry points
	-- other than tcRnModule: tcRnGetInfo, for example.  These are
	-- all called via the GHC module, so hsc_mod_graph will contain
	-- something sensible.

    init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet}
183
184
185
186
187
	-- 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".

188
initTcPrintErrors	-- Used from the interactive loop only
189
190
191
192
193
       :: HscEnv
       -> Module 
       -> TcM r
       -> IO (Maybe r)
initTcPrintErrors env mod todo = do
194
  (msgs, res) <- initTc env HsSrcFile mod todo
195
  printErrorsAndWarnings (hsc_dflags env) msgs
196
197
  return res

198
199
200
201
202
203
204
205
206
207
208
-- mkImpTypeEnv makes the imported symbol table
mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
 	     -> Name -> Maybe TyThing
mkImpTypeEnv pcs hpt = lookup 
  where
    pte = eps_PTE pcs
    lookup name | isInternalName name = Nothing
	        | otherwise	      = lookupType hpt pte name
\end{code}


209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
%************************************************************************
%*									*
		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}

235
236
237
238
239
240
241
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

\begin{code}
242
getTopEnv :: TcRnIf gbl lcl HscEnv
243
244
getTopEnv = do { env <- getEnv; return (env_top env) }

245
getGblEnv :: TcRnIf gbl lcl gbl
246
247
getGblEnv = do { env <- getEnv; return (env_gbl env) }

248
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
249
250
251
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
			  env { env_gbl = upd gbl })

252
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
253
254
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

255
getLclEnv :: TcRnIf gbl lcl lcl
256
257
getLclEnv = do { env <- getEnv; return (env_lcl env) }

258
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
259
260
261
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 
			  env { env_lcl = upd lcl })

262
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
263
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
264

265
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
266
267
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

268
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
269
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
270
271
\end{code}

272

273
274
275
Command-line flags

\begin{code}
276
277
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
278

279
doptM :: DynFlag -> TcRnIf gbl lcl Bool
280
281
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }

282
283
284
285
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}} )

286
ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()	-- Do it flag is true
287
288
289
ifOptM flag thing_inside = do { b <- doptM flag; 
				if b then thing_inside else return () }

290
291
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
292
293
294
\end{code}

\begin{code}
295
296
297
298
299
300
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) }

301
302
303
304
305
306
-- 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.
307
308
309

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
310
311
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
312
313
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
314
			; seq eps' (writeMutVar eps_var eps')
315
316
317
318
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
319
320
321
322
323
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') }
324
325
326

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
327
328
329
330

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

333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
%************************************************************************
%*									*
		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 }
352
353
354
355

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

359
360
361
362
363
364
365

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

366
\begin{code}
367
traceTc, traceRn :: SDoc -> TcRn ()
368
369
370
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceTc      = traceOptTcRn Opt_D_dump_tc_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
371
372
373


traceIf :: SDoc -> TcRnIf m n ()	
374
375
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
376

377

378
379
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
traceOptIf flag doc = ifOptM flag $
380
		     ioToIOEnv (printForUser stderr alwaysQualify doc)
381

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

dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
		    ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
394
395
396

dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
397
398
399
400
401
402
403
404
\end{code}


%************************************************************************
%*									*
		Typechecker global environment
%*									*
%************************************************************************
405

406
407
\begin{code}
getModule :: TcRn Module
408
409
getModule = do { env <- getGblEnv; return (tcg_mod env) }

410
411
412
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

413
414
415
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

416
getGlobalRdrEnv :: TcRn GlobalRdrEnv
417
418
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

419
getImports :: TcRn ImportAvails
420
421
getImports = do { env <- getGblEnv; return (tcg_imports env) }

422
getFixityEnv :: TcRn FixityEnv
423
424
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

425
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
426
427
428
429
extendFixityEnv new_bit
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> 
		env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})	     

430
getDefaultTys :: TcRn (Maybe [Type])
431
432
433
434
435
436
437
438
439
440
getDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
\end{code}

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

\begin{code}
441
getSrcSpanM :: TcRn SrcSpan
442
	-- Avoid clash with Name.getSrcLoc
443
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
444

445
446
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
447
448
  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
  | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
449
450

addLocM :: (a -> TcM b) -> Located a -> TcM b
451
addLocM fn (L loc a) = setSrcSpan loc $ fn a
452
453

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
454
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
455
456
457

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


470
471
472
473
474
475
476
477
\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 ()
478
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
479

480
481
482
483
addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
484
485
486
487
addErrAt loc msg = addLongErrAt loc msg empty

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
488
489
  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
	 errs_var <- getErrsVar ;
490
	 rdr_env <- getGlobalRdrEnv ;
491
	 let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
492
493
494
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns, errs `snocBag` err) }

495
addErrs :: [(SrcSpan,Message)] -> TcRn ()
496
497
addErrs msgs = mappM_ add msgs
	     where
498
	       add (loc,msg) = addErrAt loc msg
499

500
addReport :: Message -> TcRn ()
501
502
503
504
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
505
506
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
507
	 let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ;
508
509
510
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

511
512
513
addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)

514
515
516
517
518
519
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)

520
checkErr :: Bool -> Message -> TcRn ()
521
522
523
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)

524
warnIf :: Bool -> Message -> TcRn ()
525
526
527
warnIf True  msg = addWarn msg
warnIf False msg = return ()

528
addMessages :: Messages -> TcRn ()
529
530
531
532
533
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) }
534
535
536
537
538
539
540

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


\begin{code}
552
553
554
555
556
557
558
559
560
561
562
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)

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

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

591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
-----------------------
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)
	}
607

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

620
-----------------------
621
tryTcLIE_ :: TcM r -> TcM r -> TcM r
622
623
624
-- (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.
625
tryTcLIE_ recover main
626
627
628
629
630
631
  = 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
	}
632

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

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

662
failIfErrsM :: TcRn ()
663
664
665
666
667
668
669
670
671
672
673
674
675
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())
\end{code}


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

\begin{code}
676
677
getErrCtxt :: TcM ErrCtxt
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
678

679
680
setErrCtxt :: ErrCtxt -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
681

682
683
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
684

685
686
687
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)

688
689
690
691
692
-- 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 })

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

701
702
getInstLoc :: InstOrigin -> TcM InstLoc
getInstLoc origin
703
  = do { loc <- getSrcSpanM ; env <- getLclEnv ;
704
705
706
	 return (InstLoc origin loc (tcl_ctxt env)) }

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

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

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

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

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

\begin{code}
add_err_tcm tidy_env err_msg loc ctxt
 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
794
	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
795
796
797
798
799
800
801
802
803
804
805
806

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}

807
debugTc is useful for monadic debugging code
808
809
810
811
812
813
814
815
816
817
818

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

 %************************************************************************
819
%*									*
820
	     Type constraints (the so-called LIE)
821
822
823
824
%*									*
%************************************************************************

\begin{code}
825
826
827
828
829
830
831
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 }

832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
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}


874
875
876
877
878
879
880
%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

\begin{code}
881
882
883
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }

884
885
886
887
888
889
890
891
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) }

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


900
901
902
903
904
905
906
907
%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

\begin{code}
getLocalRdrEnv :: RnM LocalRdrEnv
908
getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
909
910
911

setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env thing_inside 
912
  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
913
914
\end{code}

915
916
917
918
919
920
921
922

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

\begin{code}
923
924
925
926
927
928
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
			        if_loc     = loc,
			        if_tv_env  = emptyOccEnv,
			        if_id_env  = emptyOccEnv }

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

947
948
949
950
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
951
 = do	{ let gbl_env = IfGblEnv { if_rec_types = Nothing }
952
953
954
	; initTcRnIf 'i' hsc_env gbl_env () do_this
    }

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

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
974
 = do	{ let {
975
976
	     type_info = (mg_module guts, return (mg_types guts))
	   ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
977
978
979
980
981
982
	   }

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

983
984
985
986
987
988
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) }
989

990
991
992
993
994
995
996
--------------------
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
997
	; let full_msg = (if_loc env <> colon) $$ nest 2 msg
998
999
	; ioToIOEnv (printErrs (full_msg defaultErrStyle))
	; failM }
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036

--------------------
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)
	   ; mb_res <- tryM thing_inside ;
	     case mb_res of
		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 
1037
1038
			Nothing -> pgmError "Cannot continue after interface file error"
				   -- pprPanic "forkM" doc
1039
1040
			Just r  -> r) }
\end{code}
1041
1042