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

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

12
13
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
17
18
19
20
21
22
23
24
import HsSyn hiding (LIE)
import HscTypes
import Module
import RdrName
import Name
import TcType
import InstEnv
import FamInstEnv
25

Simon Marlow's avatar
Simon Marlow committed
26
27
28
29
30
31
32
33
34
import Var
import Id
import VarSet
import VarEnv
import ErrUtils
import SrcLoc
import NameEnv
import NameSet
import Bag
35
import Outputable
Simon Marlow's avatar
Simon Marlow committed
36
37
import UniqSupply
import Unique
38
import LazyUniqFM
Simon Marlow's avatar
Simon Marlow committed
39
40
41
42
import DynFlags
import StaticFlags
import FastString
import Panic
Ian Lynagh's avatar
Ian Lynagh committed
43
import Util
44

Simon Marlow's avatar
Simon Marlow committed
45
46
import System.IO
import Data.IORef
47
import qualified Data.Set as Set
48
import Control.Monad
49
50
51
52
53
54
55
56
57
58
\end{code}



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

59
\begin{code}
mnislaih's avatar
mnislaih committed
60

61
initTc :: HscEnv
62
       -> HscSource
63
       -> Bool		-- True <=> retain renamed syntax trees
64
65
       -> Module 
       -> TcM r
66
       -> IO (Messages, Maybe r)
67
68
69
		-- Nothing => error thrown by the thing inside
		-- (error messages should have been printed already)

70
initTc hsc_env hsc_src keep_rn_syntax mod do_this
71
72
73
 = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
      	tvs_var      <- newIORef emptyVarSet ;
	dfuns_var    <- newIORef emptyNameSet ;
74
	keep_var     <- newIORef emptyNameSet ;
75
    used_rdrnames_var <- newIORef Set.empty ;
76
	th_var	     <- newIORef False ;
77
	dfun_n_var   <- newIORef emptyOccSet ;
78
79
80
	type_env_var <- case hsc_type_env_var hsc_env of {
                           Just (_mod, te_var) -> return te_var ;
                           Nothing             -> newIORef emptyNameEnv } ;
81
      	let {
82
83
84
85
	     maybe_rn_syntax empty_val
		| keep_rn_syntax = Just empty_val
		| otherwise	 = Nothing ;
			
86
	     gbl_env = TcGblEnv {
87
88
89
90
		tcg_mod       = mod,
		tcg_src	      = hsc_src,
		tcg_rdr_env   = hsc_global_rdr_env hsc_env,
		tcg_fix_env   = emptyNameEnv,
91
		tcg_field_env = RecFields emptyNameEnv emptyNameSet,
92
93
		tcg_default   = Nothing,
		tcg_type_env  = hsc_global_type_env hsc_env,
94
		tcg_type_env_var = type_env_var,
95
		tcg_inst_env  = emptyInstEnv,
96
		tcg_fam_inst_env  = emptyFamInstEnv,
97
		tcg_inst_uses = dfuns_var,
98
		tcg_th_used   = th_var,
99
		tcg_exports  = [],
100
		tcg_imports  = emptyImportAvails,
101
        tcg_used_rdrnames = used_rdrnames_var,
102
		tcg_dus      = emptyDUs,
103

104
                tcg_rn_imports = [],
105
106
107
                tcg_rn_exports = maybe_rn_syntax [],
		tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,

108
		tcg_binds    = emptyLHsBinds,
109
110
		tcg_warns    = NoWarnings,
		tcg_anns     = [],
111
		tcg_insts    = [],
112
		tcg_fam_insts= [],
113
		tcg_rules    = [],
114
		tcg_fords    = [],
115
		tcg_dfun_n   = dfun_n_var,
116
117
		tcg_keep     = keep_var,
		tcg_doc      = Nothing,
118
119
		tcg_hmi      = HaddockModInfo Nothing Nothing Nothing Nothing,
                tcg_hpc      = False
120
	     } ;
121
	     lcl_env = TcLclEnv {
122
		tcl_errs       = errs_var,
Ian Lynagh's avatar
Ian Lynagh committed
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
131
132
		tcl_lie	       = panic "initTc:LIE", -- only valid inside getLIE
		tcl_tybinds    = panic "initTc:tybinds"	
                                               -- only valid inside a getTyBinds
133
	     } ;
134
	} ;
135
136
   
	-- OK, here's the business end!
137
	maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
138
		     do { r <- tryM do_this
139
140
141
			; case r of
			  Right res -> return (Just res)
			  Left _    -> return Nothing } ;
142

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

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

150
	return (msgs, final_res)
151
    }
152

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

163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
%************************************************************************
%*									*
		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,
183
			    env_lcl = lcl_env} }
184
185
186
187
188

	; runIOEnv env thing_inside
	}
\end{code}

189
190
191
192
193
194
195
%************************************************************************
%*									*
		Simple accessors
%*									*
%************************************************************************

\begin{code}
196
getTopEnv :: TcRnIf gbl lcl HscEnv
197
198
getTopEnv = do { env <- getEnv; return (env_top env) }

199
getGblEnv :: TcRnIf gbl lcl gbl
200
201
getGblEnv = do { env <- getEnv; return (env_gbl env) }

202
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
203
204
205
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
			  env { env_gbl = upd gbl })

206
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
207
208
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

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

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

216
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
217
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
218

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

222
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
223
setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
224
225
\end{code}

226

227
228
229
Command-line flags

\begin{code}
230
231
getDOpts :: TcRnIf gbl lcl DynFlags
getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
232

233
doptM :: DynFlag -> TcRnIf gbl lcl Bool
234
235
doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }

236
237
238
239
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}} )

240
241
242
243
unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
			 env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )

244
245
-- | Do it flag is true
ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
246
247
248
ifOptM flag thing_inside = do { b <- doptM flag; 
				if b then thing_inside else return () }

249
250
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
251
252
253
\end{code}

\begin{code}
254
255
256
257
258
259
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) }

260
261
262
263
264
265
-- 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.
266
267
268

updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
	  -> TcRnIf gbl lcl a
269
270
updateEps upd_fn = do	{ traceIf (text "updating EPS")
			; eps_var <- getEpsVar
271
272
			; eps <- readMutVar eps_var
			; let { (eps', val) = upd_fn eps }
273
			; seq eps' (writeMutVar eps_var eps')
274
275
276
277
			; return val }

updateEps_ :: (ExternalPackageState -> ExternalPackageState)
	   -> TcRnIf gbl lcl ()
278
279
280
281
282
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') }
283
284
285

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
286
287
288
289

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

292
293
294
295
296
297
298
299
%************************************************************************
%*									*
		Unique supply
%*									*
%************************************************************************

\begin{code}
newUnique :: TcRnIf gbl lcl Unique
Simon Marlow's avatar
Simon Marlow committed
300
301
302
303
304
305
306
307
308
309
310
311
312
newUnique
 = do { env <- getEnv ;
	let { u_var = env_us env } ;
	us <- readMutVar u_var ;
        case splitUniqSupply us of { (us1,_) -> do {
	writeMutVar u_var us1 ;
	return $! uniqFromSupply us }}}
   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
   -- a chain of unevaluated supplies behind.
   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
   -- throw away one half of the new split supply.  This is safe because this
   -- is the only place we use that unique.  Using the other half of the split
   -- supply is safer, but slower.
313
314
315
316
317
318

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv ;
	let { u_var = env_us env } ;
	us <- readMutVar u_var ;
Simon Marlow's avatar
Simon Marlow committed
319
        case splitUniqSupply us of { (us1,us2) -> do {
320
	writeMutVar u_var us1 ;
Simon Marlow's avatar
Simon Marlow committed
321
	return us2 }}}
322
323
324

newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name	-- Make a clone
325
  = do	{ uniq <- newUnique
326
	; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
327
328
329
330
331

newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
  = do	{ us <- newUniqueSupply
	; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
batterseapower's avatar
batterseapower committed
332
333
334
335

instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply
336
337
\end{code}

338
339
340
341
342
343
344

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

345
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
346
traceTc, traceRn, traceSplice :: SDoc -> TcRn ()
347
348
349
traceRn      = traceOptTcRn Opt_D_dump_rn_trace
traceTc      = traceOptTcRn Opt_D_dump_tc_trace
traceSplice  = traceOptTcRn Opt_D_dump_splices
350
351


Ian Lynagh's avatar
Ian Lynagh committed
352
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
353
354
traceIf      = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
355

356

357
358
traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
traceOptIf flag doc = ifOptM flag $
359
		      liftIO (printForUser stderr alwaysQualify doc)
360

361
362
traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc = ifOptM flag $ do
363
364
			{ ctxt <- getErrCtxt
			; loc  <- getSrcSpanM
365
366
			; env0 <- tcInitTidyEnv
			; ctxt_msgs <- do_ctxt env0 ctxt 
367
368
			; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
			; dumpTcRn real_doc }
369
370

dumpTcRn :: SDoc -> TcRn ()
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
371
372
373
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv 
                  ; dflags <- getDOpts 
                  ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
374
375
376
377

debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
                  | otherwise         = dumpTcRn doc
378
379
380

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


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

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

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

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

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

403
404
405
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

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

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

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

417
418
419
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }

420
421
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
422
423
424
425
426
427
428
429
430
\end{code}

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

\begin{code}
431
getSrcSpanM :: TcRn SrcSpan
432
	-- Avoid clash with Name.getSrcLoc
433
getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
434

435
436
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan loc thing_inside
437
438
  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
  | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
439
440

addLocM :: (a -> TcM b) -> Located a -> TcM b
441
addLocM fn (L loc a) = setSrcSpan loc $ fn a
442
443

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
444
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
445
446
447

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
448
  setSrcSpan loc $ do
449
450
451
452
453
    (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) =
454
  setSrcSpan loc $ do
455
456
    (b,c) <- fn a
    return (b, L loc c)
457
\end{code}
458
459


460
461
462
463
464
465
466
\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 })

467
addErr :: Message -> TcRn ()	-- Ignores the context stack
468
addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
469

470
471
472
failWith :: Message -> TcRn a
failWith msg = addErr msg >> failM

473
474
475
476
addLocErr :: Located e -> (e -> Message) -> TcRn ()
addLocErr (L loc e) fn = addErrAt loc (fn e)

addErrAt :: SrcSpan -> Message -> TcRn ()
477
478
479
480
addErrAt loc msg = addLongErrAt loc msg empty

addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
Ian Lynagh's avatar
Ian Lynagh committed
481
  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
482
	 errs_var <- getErrsVar ;
483
	 rdr_env <- getGlobalRdrEnv ;
484
485
         dflags <- getDOpts ;
	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
486
487
488
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns, errs `snocBag` err) }

489
addErrs :: [(SrcSpan,Message)] -> TcRn ()
490
addErrs msgs = mapM_ add msgs
491
	     where
492
	       add (loc,msg) = addErrAt loc msg
493

494
addReport :: Message -> TcRn ()
495
496
497
498
addReport msg = do loc <- getSrcSpanM; addReportAt loc msg

addReportAt :: SrcSpan -> Message -> TcRn ()
addReportAt loc msg
499
500
  = do { errs_var <- getErrsVar ;
	 rdr_env <- getGlobalRdrEnv ;
501
502
         dflags <- getDOpts ;
	 let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
503
504
505
	 (warns, errs) <- readMutVar errs_var ;
  	 writeMutVar errs_var (warns `snocBag` warn, errs) }

506
addWarn :: Message -> TcRn ()
Ian Lynagh's avatar
Ian Lynagh committed
507
addWarn msg = addReport (ptext (sLit "Warning:") <+> msg)
508

509
addWarnAt :: SrcSpan -> Message -> TcRn ()
Ian Lynagh's avatar
Ian Lynagh committed
510
addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg)
511
512
513
514

addLocWarn :: Located e -> (e -> Message) -> TcRn ()
addLocWarn (L loc e) fn = addReportAt loc (fn e)

515
checkErr :: Bool -> Message -> TcRn ()
516
-- Add the error if the bool is False
517
checkErr ok msg = unless ok (addErr msg)
518

519
warnIf :: Bool -> Message -> TcRn ()
520
warnIf True  msg = addWarn msg
Ian Lynagh's avatar
Ian Lynagh committed
521
warnIf False _   = return ()
522

523
addMessages :: Messages -> TcRn ()
524
525
526
527
528
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) }
529
530
531
532
533
534
535

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
536
537
  | opt_PprStyle_Debug = thing_inside
  | otherwise
538
539
540
541
542
  = do	{ errs_var <- newMutVar emptyMessages
	; result <- setErrsVar errs_var thing_inside
	; (_warns, errs) <- readMutVar errs_var
	; addMessages (emptyBag, errs)
	; return result }
543
544
545
546
\end{code}


\begin{code}
547
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
548
549
550
551
552
-- 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 }
Ian Lynagh's avatar
Ian Lynagh committed
553
	     Right _  -> return mb_r }
554
555
556
557
  where
    exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)

-----------------------
558
559
560
recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
	 -> TcRn r	-- Main action: do this first
	 -> TcRn r
561
-- Errors in 'thing' are retained
562
recoverM recover thing 
563
  = do { mb_res <- try_m thing ;
564
	 case mb_res of
Ian Lynagh's avatar
Ian Lynagh committed
565
	   Left _    -> recover
566
	   Right res -> return res }
567

568
569
570
571
572

-----------------------
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
-- Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
Ian Lynagh's avatar
Ian Lynagh committed
573
mapAndRecoverM _ []     = return []
574
mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
575
576
577
578
579
580
			     ; rs <- mapAndRecoverM f xs
			     ; return (case mb_r of
					  Left _  -> rs
					  Right r -> r:rs) }
			

581
-----------------------
582
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
583
584
585
586
587
-- (tryTc m) executes m, and returns
--	Just r,  if m succeeds (returning r)
--	Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
588
tryTc m 
589
 = do {	errs_var <- newMutVar emptyMessages ;
590
591
592
	res  <- try_m (setErrsVar errs_var m) ; 
	msgs <- readMutVar errs_var ;
	return (msgs, case res of
Ian Lynagh's avatar
Ian Lynagh committed
593
			    Left _  -> Nothing
594
595
596
			    Right val -> Just val)
	-- The exception is always the IOEnv built-in
	-- in exception; see IOEnv.failM
597
598
   }

599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
-- Run the thing, returning 
--	Just r,  if m succceeds with no error messages
--	Nothing, if m fails, or if it succeeds but has error messages
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
tryTcErrs thing 
  = do  { (msgs, res) <- tryTc thing
	; dflags <- getDOpts
	; let errs_found = errorsFound dflags msgs
	; return (msgs, case res of
			  Nothing -> Nothing
			  Just val | errs_found -> Nothing
			 	   | otherwise  -> Just val)
	}
615

616
-----------------------
617
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
618
-- Just like tryTcErrs, except that it ensures that the LIE
619
620
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
621
tryTcLIE thing_inside
622
623
624
625
626
  = do  { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
	; case mb_res of
	    Nothing  -> return (msgs, Nothing)
	    Just val -> do { extendLIEs lie; return (msgs, Just val) }
	}
627

628
-----------------------
629
tryTcLIE_ :: TcM r -> TcM r -> TcM r
630
631
632
-- (tryTcLIE_ r m) tries m; 
--	if m succeeds with no error messages, it's the answer
-- 	otherwise tryTcLIE_ drops everything from m and tries r instead.
633
tryTcLIE_ recover main
634
635
636
637
638
639
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; case mb_res of
	     Just val -> do { addMessages msgs	-- There might be warnings
			     ; return val }
	     Nothing  -> recover		-- Discard all msgs
	}
640

641
-----------------------
642
643
644
645
646
647
648
649
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
-- If m succeeds, it checks whether m generated any errors messages
--	(it might have recovered internally)
-- 	If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
650
651
652
  = do	{ (msgs, mb_res) <- tryTcLIE main
	; addMessages msgs
	; case mb_res of
653
	    Nothing  -> failM
654
655
	    Just val -> return val
	} 
656

657
ifErrsM :: TcRn r -> TcRn r -> TcRn r
658
659
660
661
662
663
--	ifErrsM bale_out main
-- does 'bale_out' if there are errors in errors collection
-- otherwise does 'main'
ifErrsM bale_out normal
 = do { errs_var <- getErrsVar ;
	msgs <- readMutVar errs_var ;
664
665
	dflags <- getDOpts ;
	if errorsFound dflags msgs then
666
667
668
669
	   bale_out
	else	
	   normal }

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


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

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

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

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

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

696
697
698
699
700
-- Helper function for the above
updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
			   env { tcl_ctxt = upd ctxt })

701
702
703
704
705
706
-- 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
Ian Lynagh's avatar
Ian Lynagh committed
707
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
708

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

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

721
    The addErrTc functions add an error message, but do not cause failure.
722
723
724
725
726
    The 'M' variants pass a TidyEnv that has already been used to
    tidy up the message; we then use it to tidy the context messages

\begin{code}
addErrTc :: Message -> TcM ()
727
728
addErrTc err_msg = do { env0 <- tcInitTidyEnv
		      ; addErrTcM (env0, err_msg) }
729
730

addErrsTc :: [Message] -> TcM ()
731
addErrsTc err_msgs = mapM_ addErrTc err_msgs
732
733
734
735

addErrTcM :: (TidyEnv, Message) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
736
	 loc  <- getSrcSpanM ;
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
	 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
Ian Lynagh's avatar
Ian Lynagh committed
752
checkTc True  _   = return ()
753
754
755
756
757
758
759
checkTc False err = failWithTc err
\end{code}

	Warnings have no 'M' variant, nor failure

\begin{code}
addWarnTc :: Message -> TcM ()
760
761
762
763
764
addWarnTc msg = do { env0 <- tcInitTidyEnv 
		   ; addWarnTcM (env0, msg) }

addWarnTcM :: (TidyEnv, Message) -> TcM ()
addWarnTcM (env0, msg)
765
 = do { ctxt <- getErrCtxt ;
766
	ctxt_msgs <- do_ctxt env0 ctxt ;
Ian Lynagh's avatar
Ian Lynagh committed
767
	addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
768
769
770
771
772
773
774

warnTc :: Bool -> Message -> TcM ()
warnTc warn_if_true warn_msg
  | warn_if_true = addWarnTc warn_msg
  | otherwise	 = return ()
\end{code}

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

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
803
804
805
add_err_tcm :: TidyEnv -> Message -> SrcSpan
            -> [TidyEnv -> TcM (TidyEnv, SDoc)]
            -> TcM ()
806
807
add_err_tcm tidy_env err_msg loc ctxt
 = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
808
	addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
809

Ian Lynagh's avatar
Ian Lynagh committed
810
811
do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc]
do_ctxt _ []
812
813
814
815
816
817
 = return []
do_ctxt tidy_env (c:cs)
 = do {	(tidy_env', m) <- c tidy_env  ;
	ms	       <- do_ctxt tidy_env' cs  ;
	return (m:ms) }

Ian Lynagh's avatar
Ian Lynagh committed
818
ctxt_to_use :: [SDoc] -> [SDoc]
819
820
821
822
ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
		 | otherwise	      = take 3 ctxt
\end{code}

823
debugTc is useful for monadic debugging code
824
825
826

\begin{code}
debugTc :: TcM () -> TcM ()
Ian Lynagh's avatar
Ian Lynagh committed
827
828
829
debugTc thing
 | debugIsOn = thing
 | otherwise = return ()
830
831
\end{code}

832
%************************************************************************
833
%*									*
834
	     Type constraints (the so-called LIE)
835
836
837
838
%*									*
%************************************************************************

\begin{code}
839
840
841
842
843
844
845
846
847
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
  do { env <- getGblEnv
     ; let dfun_n_var = tcg_dfun_n env
     ; set <- readMutVar dfun_n_var
     ; let occ = fn set
     ; writeMutVar dfun_n_var (extendOccSet set occ)
     ; return occ
     }
848

849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
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 [] 
872
  = return ()
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
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}


891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
%************************************************************************
%*									*
	     Meta type variable bindings
%*									*
%************************************************************************

\begin{code}
getTcTyVarBindsVar :: TcM (TcRef TcTyVarBinds)
getTcTyVarBindsVar = do { env <- getLclEnv; return (tcl_tybinds env) }

getTcTyVarBinds :: TcM a -> TcM (a, TcTyVarBinds)
getTcTyVarBinds thing_inside
  = do { tybinds_var <- newMutVar emptyBag
       ; res <- updLclEnv (\ env -> env { tcl_tybinds = tybinds_var }) 
			  thing_inside
       ; tybinds <- readMutVar tybinds_var
       ; return (res, tybinds) 
       }

bindMetaTyVar :: TcTyVar -> TcType -> TcM ()
bindMetaTyVar tv ty
  = do { ASSERTM2( do { details <- readMutVar (metaTvRef tv)
                      ; return (isFlexi details) }, ppr tv )
       ; tybinds_var <- getTcTyVarBindsVar
       ; tybinds <- readMutVar tybinds_var
       ; writeMutVar tybinds_var (tybinds `snocBag` TcTyVarBind tv ty) 
       }

getTcTyVarBindsRelation :: TcM [(TcTyVar, TcTyVarSet)]
getTcTyVarBindsRelation
  = do { tybinds_var <- getTcTyVarBindsVar
       ; tybinds <- readMutVar tybinds_var
       ; return $ map freeTvs (bagToList tybinds)
       }
  where
    freeTvs (TcTyVarBind tv ty) = (tv, tyVarsOfType ty)
\end{code}

929
930
931
932
933
934
935
%************************************************************************
%*									*
	     Template Haskell context
%*									*
%************************************************************************

\begin{code}
936
937
938
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }

939
940
941
942
943
keepAliveTc :: Id -> TcM ()  	-- Record the name in the keep-alive set
keepAliveTc id 
  | isLocalId id = do { env <- getGblEnv; 
		      ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) }
  | otherwise = return ()
944
945
946
947
948

keepAliveSetTc :: NameSet -> TcM ()  	-- Record the name in the keep-alive set
keepAliveSetTc ns = do { env <- getGblEnv; 
		       ; updMutVar (tcg_keep env) (`unionNameSets` ns) }

949
950
951
952
953
954
955
956
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}


957
958
959
960
961
962
963
964
%************************************************************************
%*									*
	     Stuff for the renamer's local env
%*									*
%************************************************************************

\begin{code}
getLocalRdrEnv :: RnM LocalRdrEnv
965
getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
966
967
968

setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env thing_inside 
969
  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
970
971
\end{code}

972
973
974
975
976
977
978
979

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

\begin{code}
980
981
982
mkIfLclEnv :: Module -> SDoc -> IfLclEnv
mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
			        if_loc     = loc,
983
984
			        if_tv_env  = emptyUFM,
			        if_id_env  = emptyUFM }
985

986
987
988
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
  = do  { tcg_env <- getGblEnv 
989
	; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
990
991
992
993
994
995
996
	      ; 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
Ian Lynagh's avatar
Ian Lynagh committed
997
	      ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
998
	      ; if_env = IfGblEnv { 
999
			if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
1000
	      ; if_lenv = mkIfLclEnv mod doc
1001
1002
1003
	  }
	; setEnvs (if_env, if_lenv) thing_inside }

1004
1005
1006
1007
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
1008
1009
1010
1011
1012
 = do let rec_types = case hsc_type_env_var hsc_env of
                         Just (mod,var) -> Just (mod, readMutVar var)
                         Nothing        -> Nothing
          gbl_env = IfGblEnv { if_rec_types = rec_types }
      initTcRnIf 'i' hsc_env gbl_env () do_this
1013

1014
1015
initIfaceTc :: ModIface 
 	    -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1016
1017
-- 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
1018
1019
initIfaceTc iface do_this
 = do	{ tc_env_var <- newMutVar emptyTypeEnv
1020
	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
1021
	      ; if_lenv = mkIfLclEnv mod doc
1022
	   }
1023
	; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1024
    }
1025
1026
  where
    mod = mi_module iface
Ian Lynagh's avatar
Ian Lynagh committed
1027
    doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1028
1029
1030
1031
1032

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
1033
 = do	{ let {
1034
1035
	     type_info = (mg_module guts, return (mg_types guts))
	   ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
1036
1037
1038
1039
1040
1041
	   }

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

1042
1043
1044
1045
1046
1047
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) }
1048

1049
1050
1051
1052
1053
1054
1055
--------------------
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
1056
	; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1057
	; liftIO (printErrs (full_msg defaultErrStyle))
1058
	; failM }
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072

--------------------
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)
1073
1074
1075
1076
	   ; mb_res <- tryM $
		       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
		       thing_inside
	   ; case mb_res of
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
		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
1092
    print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
1093
1094
1095
1096
1097

forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
 = do	{ mb_res <- forkM_maybe doc thing_inside
	; return (case mb_res of 
1098
1099
			Nothing -> pgmError "Cannot continue after interface file error"
				   -- pprPanic "forkM" doc
1100
1101
			Just r  -> r) }
\end{code}