TcRnMonad.lhs 33.6 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
#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  )
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(..),
26
27
			  TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
			  isHsBoot, ModSummary(..),
28
			  ExternalPackageState(..), HomePackageTable,
29
			  Deprecs(..), FixityEnv, FixItem, 
30
			  lookupType, unQualInScope )
31
import Module		( Module, unitModuleEnv )
David Himmelstrup's avatar
David Himmelstrup committed
32
import RdrName		( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
33
import Name		( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
34
import Type		( Type )
35
36
import TcType		( tcIsTyVarTy, tcGetTyVar )
import NameEnv		( extendNameEnvList, nameEnvElts )
37
import InstEnv		( emptyInstEnv )
38

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



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

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

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

86
initTc hsc_env hsc_src mod do_this
87
88
89
90
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	type_env_var <- newIORef emptyNameEnv ;
	dfuns_var    <- newIORef emptyNameSet ;
91
	keep_var     <- newIORef emptyNameSet ;
92
	th_var	     <- newIORef False ;
93
	dfun_n_var   <- newIORef 1 ;
94
95
96
      	let {
	     gbl_env = TcGblEnv {
		tcg_mod      = mod,
97
		tcg_src	     = hsc_src,
98
		tcg_rdr_env  = hsc_global_rdr_env hsc_env,
99
100
		tcg_fix_env  = emptyNameEnv,
		tcg_default  = Nothing,
101
		tcg_type_env = hsc_global_type_env hsc_env,
102
		tcg_type_env_var = type_env_var,
103
		tcg_inst_env  = emptyInstEnv,
104
		tcg_inst_uses = dfuns_var,
105
		tcg_th_used   = th_var,
106
		tcg_exports  = emptyNameSet,
107
		tcg_imports  = init_imports,
108
		tcg_home_mods = home_mods,
109
		tcg_dus      = emptyDUs,
110
111
                tcg_rn_imports = Nothing,
                tcg_rn_exports = Nothing,
112
		tcg_rn_decls = Nothing,
113
		tcg_binds    = emptyLHsBinds,
114
115
116
		tcg_deprecs  = NoDeprecs,
		tcg_insts    = [],
		tcg_rules    = [],
117
		tcg_fords    = [],
118
		tcg_dfun_n   = dfun_n_var,
119
		tcg_keep     = keep_var
120
	     } ;
121
	     lcl_env = TcLclEnv {
122
		tcl_errs       = errs_var,
123
		tcl_loc	       = mkGeneralSrcSpan FSLIT("Top level"),
124
		tcl_ctxt       = [],
125
		tcl_rdr	       = emptyLocalRdrEnv,
126
		tcl_th_ctxt    = topStage,
ross's avatar
ross committed
127
		tcl_arrow_ctxt = NoArrowCtxt,
128
129
		tcl_env        = emptyNameEnv,
		tcl_tyvars     = tvs_var,
130
		tcl_lie	       = panic "initTc:LIE"	-- LIE only valid inside a getLIE
131
	     } ;
132
	} ;
133
134
   
	-- OK, here's the business end!
135
	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
136
137
138
139
140
		     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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
                                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
155
156
157
                                                     , ATcId breakpointJumpType topLevel False)
                                                     ,(breakpointCondJumpName
                                                     , ATcId breakpointCondJumpType topLevel False)];
158
159
160
161
162
163
164
165
                              };
                          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 } ;
166

167
	-- Collect any error messages
168
169
	msgs <- readIORef errs_var ;

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

174
	return (msgs, final_res)
175
176
    }
  where
177
178
179
180
181
182
183
184
185
186
187
    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}
188
189
190
191
192
	-- 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".

193
initTcPrintErrors	-- Used from the interactive loop only
194
195
196
197
198
       :: HscEnv
       -> Module 
       -> TcM r
       -> IO (Maybe r)
initTcPrintErrors env mod todo = do
199
  (msgs, res) <- initTc env HsSrcFile mod todo
200
  printErrorsAndWarnings (hsc_dflags env) msgs
201
202
  return res

203
204
205
206
207
208
209
210
211
212
213
-- 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}


214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
%************************************************************************
%*									*
		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}

240
241
242
243
244
245
246
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

\begin{code}
247
getTopEnv :: TcRnIf gbl lcl HscEnv
248
249
getTopEnv = do { env <- getEnv; return (env_top env) }

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

253
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
254
255
256
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
			  env { env_gbl = upd gbl })

257
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
258
259
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

260
getLclEnv :: TcRnIf gbl lcl lcl
261
262
getLclEnv = do { env <- getEnv; return (env_lcl env) }

263
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
264
265
266
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 
			  env { env_lcl = upd lcl })

267
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
268
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
269

270
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
271
272
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

273
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
274
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
275
276
\end{code}

277

278
279
280
Command-line flags

\begin{code}
281
282
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
283

284
doptM :: DynFlag -> TcRnIf gbl lcl Bool
285
286
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }

287
288
289
290
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}} )

291
ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()	-- Do it flag is true
292
293
294
ifOptM flag thing_inside = do { b <- doptM flag; 
				if b then thing_inside else return () }

295
296
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
297
298
299
\end{code}

\begin{code}
300
301
302
303
304
305
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) }

306
307
308
309
310
311
-- 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.
312
313
314

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
315
316
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
317
318
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
319
			; seq eps' (writeMutVar eps_var eps')
320
321
322
323
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
324
325
326
327
328
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') }
329
330
331

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
332
333
334
335

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

338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
%************************************************************************
%*									*
		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 }
357
358
359
360

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

364
365
366
367
368
369
370

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

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


traceIf :: SDoc -> TcRnIf m n ()	
379
380
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
381

382

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

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

dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
		    ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
399
400
401

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


%************************************************************************
%*									*
		Typechecker global environment
%*									*
%************************************************************************
410

411
412
\begin{code}
getModule :: TcRn Module
413
414
getModule = do { env <- getGblEnv; return (tcg_mod env) }

415
416
417
setModule :: Module -> TcRn a -> TcRn a
setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside

418
419
420
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }

421
getGlobalRdrEnv :: TcRn GlobalRdrEnv
422
423
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

424
getImports :: TcRn ImportAvails
425
426
getImports = do { env <- getGblEnv; return (tcg_imports env) }

427
getFixityEnv :: TcRn FixityEnv
428
429
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

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

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

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

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

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

addLocM :: (a -> TcM b) -> Located a -> TcM b
456
addLocM fn (L loc a) = setSrcSpan loc $ fn a
457
458

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
459
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
460
461
462

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


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

485
486
487
488
addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
489
490
491
492
addErrAt loc msg = addLongErrAt loc msg empty

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

500
addErrs :: [(SrcSpan,Message)] -> TcRn ()
501
502
addErrs msgs = mappM_ add msgs
	     where
503
	       add (loc,msg) = addErrAt loc msg
504

505
addReport :: Message -> TcRn ()
506
507
508
509
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
510
511
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
512
	 let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ;
513
514
515
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

516
517
518
addWarn :: Message -> TcRn ()
addWarn msg = addReport (ptext SLIT("Warning:") <+> msg)

519
520
521
522
523
524
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)

525
checkErr :: Bool -> Message -> TcRn ()
526
527
528
-- Add the error if the bool is False
checkErr ok msg = checkM ok (addErr msg)

529
warnIf :: Bool -> Message -> TcRn ()
530
531
532
warnIf True  msg = addWarn msg
warnIf False msg = return ()

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

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


\begin{code}
557
558
559
560
561
562
563
564
565
566
567
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)

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

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

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

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

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

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

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

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


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

\begin{code}
681
682
getErrCtxt :: TcM ErrCtxt
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
683

684
685
setErrCtxt :: ErrCtxt -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
686

687
688
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
689

690
691
692
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)

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

698
699
700
701
702
703
704
705
-- 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 })

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

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

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

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

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

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

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

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}

812
debugTc is useful for monadic debugging code
813
814
815
816
817
818
819
820
821
822
823

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

 %************************************************************************
824
%*									*
825
	     Type constraints (the so-called LIE)
826
827
828
829
%*									*
%************************************************************************

\begin{code}
830
831
832
833
834
835
836
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 }

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
874
875
876
877
878
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}


879
880
881
882
883
884
885
%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

\begin{code}
886
887
888
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }

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

897
898
899
900
901
902
903
904
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}


905
906
907
908
909
910
911
912
%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

\begin{code}
getLocalRdrEnv :: RnM LocalRdrEnv
913
getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
914
915
916

setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env thing_inside 
917
  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
918
919
\end{code}

920
921
922
923
924
925
926
927

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

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

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

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

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

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

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

988
989
990
991
992
993
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) }
994

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

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