37d4e625a46de15f0e43a2f2957c311131efa0d2
[ghc.git] / compiler / typecheck / TcRnMonad.lhs
1 %
2 % (c) The University of Glasgow 2006
3 %
4
5 \begin{code}
6 module TcRnMonad(
7         module TcRnMonad,
8         module TcRnTypes,
9         module IOEnv
10   ) where
11
12 #include "HsVersions.h"
13
14 import TcRnTypes        -- Re-export all
15 import IOEnv            -- Re-export all
16
17 import HsSyn hiding (LIE)
18 import HscTypes
19 import Module
20 import RdrName
21 import Name
22 import TcType
23 import InstEnv
24 import FamInstEnv
25
26 import Var
27 import Id
28 import VarSet
29 import VarEnv
30 import ErrUtils
31 import SrcLoc
32 import NameEnv
33 import NameSet
34 import Bag
35 import Outputable
36 import UniqSupply
37 import Unique
38 import UniqFM
39 import DynFlags
40 import StaticFlags
41 import FastString
42 import Panic
43 import Util
44
45 import System.IO
46 import Data.IORef
47 import qualified Data.Set as Set
48 import Control.Monad
49 \end{code}
50
51
52
53 %************************************************************************
54 %*                                                                      *
55                         initTc
56 %*                                                                      *
57 %************************************************************************
58
59 \begin{code}
60
61 initTc :: HscEnv
62        -> HscSource
63        -> Bool          -- True <=> retain renamed syntax trees
64        -> Module 
65        -> TcM r
66        -> IO (Messages, Maybe r)
67                 -- Nothing => error thrown by the thing inside
68                 -- (error messages should have been printed already)
69
70 initTc hsc_env hsc_src keep_rn_syntax mod do_this
71  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
72         tvs_var      <- newIORef emptyVarSet ;
73         dfuns_var    <- newIORef emptyNameSet ;
74         keep_var     <- newIORef emptyNameSet ;
75         used_rdr_var <- newIORef Set.empty ;
76         th_var       <- newIORef False ;
77         lie_var      <- newIORef emptyBag ;
78         dfun_n_var   <- newIORef emptyOccSet ;
79         type_env_var <- case hsc_type_env_var hsc_env of {
80                            Just (_mod, te_var) -> return te_var ;
81                            Nothing             -> newIORef emptyNameEnv } ;
82         let {
83              maybe_rn_syntax :: forall a. a -> Maybe a ;
84              maybe_rn_syntax empty_val
85                 | keep_rn_syntax = Just empty_val
86                 | otherwise      = Nothing ;
87                         
88              gbl_env = TcGblEnv {
89                 tcg_mod       = mod,
90                 tcg_src       = hsc_src,
91                 tcg_rdr_env   = hsc_global_rdr_env hsc_env,
92                 tcg_fix_env   = emptyNameEnv,
93                 tcg_field_env = RecFields emptyNameEnv emptyNameSet,
94                 tcg_default   = Nothing,
95                 tcg_type_env  = hsc_global_type_env hsc_env,
96                 tcg_type_env_var = type_env_var,
97                 tcg_inst_env  = emptyInstEnv,
98                 tcg_fam_inst_env  = emptyFamInstEnv,
99                 tcg_inst_uses = dfuns_var,
100                 tcg_th_used   = th_var,
101                 tcg_exports  = [],
102                 tcg_imports  = emptyImportAvails,
103                 tcg_used_rdrnames = used_rdr_var,
104                 tcg_dus      = emptyDUs,
105
106                 tcg_rn_imports = [],
107                 tcg_rn_exports = maybe_rn_syntax [],
108                 tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
109
110                 tcg_binds    = emptyLHsBinds,
111                 tcg_ev_binds = emptyBag,
112                 tcg_warns    = NoWarnings,
113                 tcg_anns     = [],
114                 tcg_insts    = [],
115                 tcg_fam_insts= [],
116                 tcg_rules    = [],
117                 tcg_fords    = [],
118                 tcg_dfun_n   = dfun_n_var,
119                 tcg_keep     = keep_var,
120                 tcg_doc_hdr  = Nothing,
121                 tcg_hpc      = False,
122                 tcg_main     = Nothing
123              } ;
124              lcl_env = TcLclEnv {
125                 tcl_errs       = errs_var,
126                 tcl_loc        = mkGeneralSrcSpan (fsLit "Top level"),
127                 tcl_ctxt       = [],
128                 tcl_rdr        = emptyLocalRdrEnv,
129                 tcl_th_ctxt    = topStage,
130                 tcl_arrow_ctxt = NoArrowCtxt,
131                 tcl_env        = emptyNameEnv,
132                 tcl_tyvars     = tvs_var,
133                 tcl_lie        = lie_var,
134                 tcl_untch      = emptyVarSet
135              } ;
136         } ;
137    
138         -- OK, here's the business end!
139         maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
140                      do { r <- tryM do_this
141                         ; case r of
142                           Right res -> return (Just res)
143                           Left _    -> return Nothing } ;
144
145         -- Check for unsolved constraints
146         lie <- readIORef lie_var ;
147         if isEmptyBag lie 
148            then return ()
149            else pprPanic "initTc: unsolved constraints" 
150                          (pprWantedsWithLocs lie) ;
151
152         -- Collect any error messages
153         msgs <- readIORef errs_var ;
154
155         let { dflags = hsc_dflags hsc_env
156             ; final_res | errorsFound dflags msgs = Nothing
157                         | otherwise               = maybe_res } ;
158
159         return (msgs, final_res)
160     }
161
162 initTcPrintErrors       -- Used from the interactive loop only
163        :: HscEnv
164        -> Module 
165        -> TcM r
166        -> IO (Messages, Maybe r)
167 initTcPrintErrors env mod todo = do
168   (msgs, res) <- initTc env HsSrcFile False mod todo
169   return (msgs, res)
170 \end{code}
171
172 %************************************************************************
173 %*                                                                      *
174                 Initialisation
175 %*                                                                      *
176 %************************************************************************
177
178
179 \begin{code}
180 initTcRnIf :: Char              -- Tag for unique supply
181            -> HscEnv
182            -> gbl -> lcl 
183            -> TcRnIf gbl lcl a 
184            -> IO a
185 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
186    = do { us     <- mkSplitUniqSupply uniq_tag ;
187         ; us_var <- newIORef us ;
188
189         ; let { env = Env { env_top = hsc_env,
190                             env_us  = us_var,
191                             env_gbl = gbl_env,
192                             env_lcl = lcl_env} }
193
194         ; runIOEnv env thing_inside
195         }
196 \end{code}
197
198 %************************************************************************
199 %*                                                                      *
200                 Simple accessors
201 %*                                                                      *
202 %************************************************************************
203
204 \begin{code}
205 getTopEnv :: TcRnIf gbl lcl HscEnv
206 getTopEnv = do { env <- getEnv; return (env_top env) }
207
208 getGblEnv :: TcRnIf gbl lcl gbl
209 getGblEnv = do { env <- getEnv; return (env_gbl env) }
210
211 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
212 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) -> 
213                           env { env_gbl = upd gbl })
214
215 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
216 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
217
218 getLclEnv :: TcRnIf gbl lcl lcl
219 getLclEnv = do { env <- getEnv; return (env_lcl env) }
220
221 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
222 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> 
223                           env { env_lcl = upd lcl })
224
225 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
226 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
227
228 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
229 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
230
231 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
232 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
233 \end{code}
234
235
236 Command-line flags
237
238 \begin{code}
239 getDOpts :: TcRnIf gbl lcl DynFlags
240 getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
241
242 doptM :: DOpt d => d -> TcRnIf gbl lcl Bool
243 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
244
245 -- XXX setOptM and unsetOptM operate on different types. One should be renamed.
246
247 setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
248 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
249                          env { env_top = top { hsc_dflags = lopt_set_flattened (hsc_dflags top) flag}} )
250
251 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
252 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
253                          env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
254
255 -- | Do it flag is true
256 ifOptM :: DOpt d => d -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
257 ifOptM flag thing_inside = do { b <- doptM flag; 
258                                 if b then thing_inside else return () }
259
260 getGhcMode :: TcRnIf gbl lcl GhcMode
261 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
262 \end{code}
263
264 \begin{code}
265 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
266 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
267
268 getEps :: TcRnIf gbl lcl ExternalPackageState
269 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
270
271 -- | Update the external package state.  Returns the second result of the
272 -- modifier function.
273 --
274 -- This is an atomic operation and forces evaluation of the modified EPS in
275 -- order to avoid space leaks.
276 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
277           -> TcRnIf gbl lcl a
278 updateEps upd_fn = do
279   traceIf (text "updating EPS")
280   eps_var <- getEpsVar
281   atomicUpdMutVar' eps_var upd_fn
282
283 -- | Update the external package state.
284 --
285 -- This is an atomic operation and forces evaluation of the modified EPS in
286 -- order to avoid space leaks.
287 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
288            -> TcRnIf gbl lcl ()
289 updateEps_ upd_fn = do
290   traceIf (text "updating EPS_")
291   eps_var <- getEpsVar
292   atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
293
294 getHpt :: TcRnIf gbl lcl HomePackageTable
295 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
296
297 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
298 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
299                   ; return (eps, hsc_HPT env) }
300 \end{code}
301
302 %************************************************************************
303 %*                                                                      *
304                 Unique supply
305 %*                                                                      *
306 %************************************************************************
307
308 \begin{code}
309 newUnique :: TcRnIf gbl lcl Unique
310 newUnique
311  = do { env <- getEnv ;
312         let { u_var = env_us env } ;
313         us <- readMutVar u_var ;
314         case splitUniqSupply us of { (us1,_) -> do {
315         writeMutVar u_var us1 ;
316         return $! uniqFromSupply us }}}
317    -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
318    -- a chain of unevaluated supplies behind.
319    -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
320    -- throw away one half of the new split supply.  This is safe because this
321    -- is the only place we use that unique.  Using the other half of the split
322    -- supply is safer, but slower.
323
324 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
325 newUniqueSupply
326  = do { env <- getEnv ;
327         let { u_var = env_us env } ;
328         us <- readMutVar u_var ;
329         case splitUniqSupply us of { (us1,us2) -> do {
330         writeMutVar u_var us1 ;
331         return us2 }}}
332
333 newLocalName :: Name -> TcRnIf gbl lcl Name
334 newLocalName name       -- Make a clone
335   = do  { uniq <- newUnique
336         ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
337
338 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
339 newSysLocalIds fs tys
340   = do  { us <- newUniqueSupply
341         ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
342
343 instance MonadUnique (IOEnv (Env gbl lcl)) where
344         getUniqueM = newUnique
345         getUniqueSupplyM = newUniqueSupply
346 \end{code}
347
348
349 %************************************************************************
350 %*                                                                      *
351                 Debugging
352 %*                                                                      *
353 %************************************************************************
354
355 \begin{code}
356 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
357 newTcRef = newMutVar 
358
359 readTcRef :: TcRef a -> TcRnIf gbl lcl a
360 readTcRef = readMutVar
361
362 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
363 writeTcRef = writeMutVar
364
365 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
366 updTcRef = updMutVar
367 \end{code}
368
369 %************************************************************************
370 %*                                                                      *
371                 Debugging
372 %*                                                                      *
373 %************************************************************************
374
375 \begin{code}
376 traceTc :: String -> SDoc -> TcRn () 
377 traceTc = traceTcN 1
378
379 traceTcN :: Int -> String -> SDoc -> TcRn () 
380 traceTcN level herald doc
381   | level <= opt_TraceLevel = traceOptTcRn Opt_D_dump_tc_trace $
382                               hang (text herald) 2 doc
383   | otherwise               = return ()
384
385 traceRn, traceSplice :: SDoc -> TcRn ()
386 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
387 traceSplice  = traceOptTcRn Opt_D_dump_splices
388
389
390 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
391 traceIf      = traceOptIf Opt_D_dump_if_trace
392 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
393
394
395 traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
396 traceOptIf flag doc = ifOptM flag $
397                       liftIO (printForUser stderr alwaysQualify doc)
398
399 traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
400 -- Output the message, with current location if opt_PprStyle_Debug
401 traceOptTcRn flag doc = ifOptM flag $ do
402                         { loc  <- getSrcSpanM
403                         ; let real_doc 
404                                 | opt_PprStyle_Debug = mkLocMessage loc doc
405                                 | otherwise = doc   -- The full location is 
406                                                     -- usually way too much
407                         ; dumpTcRn real_doc }
408
409 dumpTcRn :: SDoc -> TcRn ()
410 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv 
411                   ; dflags <- getDOpts 
412                   ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
413
414 debugDumpTcRn :: SDoc -> TcRn ()
415 debugDumpTcRn doc | opt_NoDebugOutput = return ()
416                   | otherwise         = dumpTcRn doc
417
418 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
419 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
420 \end{code}
421
422
423 %************************************************************************
424 %*                                                                      *
425                 Typechecker global environment
426 %*                                                                      *
427 %************************************************************************
428
429 \begin{code}
430 getModule :: TcRn Module
431 getModule = do { env <- getGblEnv; return (tcg_mod env) }
432
433 setModule :: Module -> TcRn a -> TcRn a
434 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
435
436 tcIsHsBoot :: TcRn Bool
437 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
438
439 getGlobalRdrEnv :: TcRn GlobalRdrEnv
440 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
441
442 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
443 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
444
445 getImports :: TcRn ImportAvails
446 getImports = do { env <- getGblEnv; return (tcg_imports env) }
447
448 getFixityEnv :: TcRn FixityEnv
449 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
450
451 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
452 extendFixityEnv new_bit
453   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> 
454                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})           
455
456 getRecFieldEnv :: TcRn RecFieldEnv
457 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
458
459 getDeclaredDefaultTys :: TcRn (Maybe [Type])
460 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
461 \end{code}
462
463 %************************************************************************
464 %*                                                                      *
465                 Error management
466 %*                                                                      *
467 %************************************************************************
468
469 \begin{code}
470 getSrcSpanM :: TcRn SrcSpan
471         -- Avoid clash with Name.getSrcLoc
472 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
473
474 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
475 setSrcSpan loc thing_inside
476   | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
477   | otherwise         = thing_inside    -- Don't overwrite useful info with useless
478
479 addLocM :: (a -> TcM b) -> Located a -> TcM b
480 addLocM fn (L loc a) = setSrcSpan loc $ fn a
481
482 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
483 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
484
485 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
486 wrapLocFstM fn (L loc a) =
487   setSrcSpan loc $ do
488     (b,c) <- fn a
489     return (L loc b, c)
490
491 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
492 wrapLocSndM fn (L loc a) =
493   setSrcSpan loc $ do
494     (b,c) <- fn a
495     return (b, L loc c)
496 \end{code}
497
498 Reporting errors
499
500 \begin{code}
501 getErrsVar :: TcRn (TcRef Messages)
502 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
503
504 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
505 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
506
507 addErr :: Message -> TcRn ()    -- Ignores the context stack
508 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
509
510 failWith :: Message -> TcRn a
511 failWith msg = addErr msg >> failM
512
513 addErrAt :: SrcSpan -> Message -> TcRn ()
514 -- addErrAt is mainly (exclusively?) used by the renamer, where
515 -- tidying is not an issue, but it's all lazy so the extra
516 -- work doesn't matter
517 addErrAt loc msg = do { ctxt <- getErrCtxt 
518                       ; tidy_env <- tcInitTidyEnv
519                       ; err_info <- mkErrInfo tidy_env ctxt
520                       ; addLongErrAt loc msg err_info }
521
522 addErrs :: [(SrcSpan,Message)] -> TcRn ()
523 addErrs msgs = mapM_ add msgs
524              where
525                add (loc,msg) = addErrAt loc msg
526
527 addWarn :: Message -> TcRn ()
528 addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
529
530 addWarnAt :: SrcSpan -> Message -> TcRn ()
531 addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
532
533 checkErr :: Bool -> Message -> TcRn ()
534 -- Add the error if the bool is False
535 checkErr ok msg = unless ok (addErr msg)
536
537 warnIf :: Bool -> Message -> TcRn ()
538 warnIf True  msg = addWarn msg
539 warnIf False _   = return ()
540
541 addMessages :: Messages -> TcRn ()
542 addMessages (m_warns, m_errs)
543   = do { errs_var <- getErrsVar ;
544          (warns, errs) <- readTcRef errs_var ;
545          writeTcRef errs_var (warns `unionBags` m_warns,
546                                errs  `unionBags` m_errs) }
547
548 discardWarnings :: TcRn a -> TcRn a
549 -- Ignore warnings inside the thing inside;
550 -- used to ignore-unused-variable warnings inside derived code
551 -- With -dppr-debug, the effects is switched off, so you can still see
552 -- what warnings derived code would give
553 discardWarnings thing_inside
554   | opt_PprStyle_Debug = thing_inside
555   | otherwise
556   = do  { errs_var <- newTcRef emptyMessages
557         ; result <- setErrsVar errs_var thing_inside
558         ; (_warns, errs) <- readTcRef errs_var
559         ; addMessages (emptyBag, errs)
560         ; return result }
561 \end{code}
562
563
564 %************************************************************************
565 %*                                                                      *
566         Shared error message stuff: renamer and typechecker
567 %*                                                                      *
568 %************************************************************************
569
570 \begin{code}
571 addReport :: Message -> Message -> TcRn ()
572 addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
573
574 addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
575 addReportAt loc msg extra_info
576   = do { errs_var <- getErrsVar ;
577          rdr_env <- getGlobalRdrEnv ;
578          dflags <- getDOpts ;
579          let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
580                                     msg extra_info } ;
581          (warns, errs) <- readTcRef errs_var ;
582          writeTcRef errs_var (warns `snocBag` warn, errs) }
583
584 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
585 addLongErrAt loc msg extra
586   = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ;    
587          errs_var <- getErrsVar ;
588          rdr_env <- getGlobalRdrEnv ;
589          dflags <- getDOpts ;
590          let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
591          (warns, errs) <- readTcRef errs_var ;
592          writeTcRef errs_var (warns, errs `snocBag` err) }
593 \end{code}
594
595
596 \begin{code}
597 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
598 -- Does try_m, with a debug-trace on failure
599 try_m thing 
600   = do { mb_r <- tryM thing ;
601          case mb_r of 
602              Left exn -> do { traceTc "tryTc/recoverM recovering from" $
603                                       text (showException exn)
604                             ; return mb_r }
605              Right _  -> return mb_r }
606
607 -----------------------
608 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
609          -> TcRn r      -- Main action: do this first
610          -> TcRn r
611 -- Errors in 'thing' are retained
612 recoverM recover thing 
613   = do { mb_res <- try_m thing ;
614          case mb_res of
615            Left _    -> recover
616            Right res -> return res }
617
618
619 -----------------------
620 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
621 -- Drop elements of the input that fail, so the result
622 -- list can be shorter than the argument list
623 mapAndRecoverM _ []     = return []
624 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
625                              ; rs <- mapAndRecoverM f xs
626                              ; return (case mb_r of
627                                           Left _  -> rs
628                                           Right r -> r:rs) }
629                         
630
631 -----------------------
632 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
633 -- (tryTc m) executes m, and returns
634 --      Just r,  if m succeeds (returning r)
635 --      Nothing, if m fails
636 -- It also returns all the errors and warnings accumulated by m
637 -- It always succeeds (never raises an exception)
638 tryTc m 
639  = do { errs_var <- newTcRef emptyMessages ;
640         res  <- try_m (setErrsVar errs_var m) ; 
641         msgs <- readTcRef errs_var ;
642         return (msgs, case res of
643                             Left _  -> Nothing
644                             Right val -> Just val)
645         -- The exception is always the IOEnv built-in
646         -- in exception; see IOEnv.failM
647    }
648
649 -----------------------
650 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
651 -- Run the thing, returning 
652 --      Just r,  if m succceeds with no error messages
653 --      Nothing, if m fails, or if it succeeds but has error messages
654 -- Either way, the messages are returned; even in the Just case
655 -- there might be warnings
656 tryTcErrs thing 
657   = do  { (msgs, res) <- tryTc thing
658         ; dflags <- getDOpts
659         ; let errs_found = errorsFound dflags msgs
660         ; return (msgs, case res of
661                           Nothing -> Nothing
662                           Just val | errs_found -> Nothing
663                                    | otherwise  -> Just val)
664         }
665
666 -----------------------
667 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
668 -- Just like tryTcErrs, except that it ensures that the LIE
669 -- for the thing is propagated only if there are no errors
670 -- Hence it's restricted to the type-check monad
671 tryTcLIE thing_inside
672   = do  { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ;
673         ; case mb_res of
674             Nothing  -> return (msgs, Nothing)
675             Just val -> do { emitConstraints lie; return (msgs, Just val) }
676         }
677
678 -----------------------
679 tryTcLIE_ :: TcM r -> TcM r -> TcM r
680 -- (tryTcLIE_ r m) tries m; 
681 --      if m succeeds with no error messages, it's the answer
682 --      otherwise tryTcLIE_ drops everything from m and tries r instead.
683 tryTcLIE_ recover main
684   = do  { (msgs, mb_res) <- tryTcLIE main
685         ; case mb_res of
686              Just val -> do { addMessages msgs  -- There might be warnings
687                              ; return val }
688              Nothing  -> recover                -- Discard all msgs
689         }
690
691 -----------------------
692 checkNoErrs :: TcM r -> TcM r
693 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
694 -- If m fails then (checkNoErrsTc m) fails.
695 -- If m succeeds, it checks whether m generated any errors messages
696 --      (it might have recovered internally)
697 --      If so, it fails too.
698 -- Regardless, any errors generated by m are propagated to the enclosing context.
699 checkNoErrs main
700   = do  { (msgs, mb_res) <- tryTcLIE main
701         ; addMessages msgs
702         ; case mb_res of
703             Nothing  -> failM
704             Just val -> return val
705         } 
706
707 ifErrsM :: TcRn r -> TcRn r -> TcRn r
708 --      ifErrsM bale_out main
709 -- does 'bale_out' if there are errors in errors collection
710 -- otherwise does 'main'
711 ifErrsM bale_out normal
712  = do { errs_var <- getErrsVar ;
713         msgs <- readTcRef errs_var ;
714         dflags <- getDOpts ;
715         if errorsFound dflags msgs then
716            bale_out
717         else    
718            normal }
719
720 failIfErrsM :: TcRn ()
721 -- Useful to avoid error cascades
722 failIfErrsM = ifErrsM failM (return ())
723 \end{code}
724
725
726 %************************************************************************
727 %*                                                                      *
728         Context management for the type checker
729 %*                                                                      *
730 %************************************************************************
731
732 \begin{code}
733 getErrCtxt :: TcM [ErrCtxt]
734 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
735
736 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
737 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
738
739 addErrCtxt :: Message -> TcM a -> TcM a
740 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
741
742 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
743 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
744
745 addLandmarkErrCtxt :: Message -> TcM a -> TcM a
746 addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
747
748 -- Helper function for the above
749 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
750 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> 
751                            env { tcl_ctxt = upd ctxt })
752
753 -- Conditionally add an error context
754 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
755 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
756 maybeAddErrCtxt Nothing    thing_inside = thing_inside
757
758 popErrCtxt :: TcM a -> TcM a
759 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
760
761 getCtLoc :: orig -> TcM (CtLoc orig)
762 getCtLoc origin
763   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
764          return (CtLoc origin loc (tcl_ctxt env)) }
765
766 setCtLoc :: CtLoc orig -> TcM a -> TcM a
767 setCtLoc (CtLoc _ src_loc ctxt) thing_inside
768   = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
769 \end{code}
770
771 %************************************************************************
772 %*                                                                      *
773              Error message generation (type checker)
774 %*                                                                      *
775 %************************************************************************
776
777     The addErrTc functions add an error message, but do not cause failure.
778     The 'M' variants pass a TidyEnv that has already been used to
779     tidy up the message; we then use it to tidy the context messages
780
781 \begin{code}
782 addErrTc :: Message -> TcM ()
783 addErrTc err_msg = do { env0 <- tcInitTidyEnv
784                       ; addErrTcM (env0, err_msg) }
785
786 addErrsTc :: [Message] -> TcM ()
787 addErrsTc err_msgs = mapM_ addErrTc err_msgs
788
789 addErrTcM :: (TidyEnv, Message) -> TcM ()
790 addErrTcM (tidy_env, err_msg)
791   = do { ctxt <- getErrCtxt ;
792          loc  <- getSrcSpanM ;
793          add_err_tcm tidy_env err_msg loc ctxt }
794 \end{code}
795
796 The failWith functions add an error message and cause failure
797
798 \begin{code}
799 failWithTc :: Message -> TcM a               -- Add an error message and fail
800 failWithTc err_msg 
801   = addErrTc err_msg >> failM
802
803 failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
804 failWithTcM local_and_msg
805   = addErrTcM local_and_msg >> failM
806
807 checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
808 checkTc True  _   = return ()
809 checkTc False err = failWithTc err
810 \end{code}
811
812         Warnings have no 'M' variant, nor failure
813
814 \begin{code}
815 addWarnTc :: Message -> TcM ()
816 addWarnTc msg = do { env0 <- tcInitTidyEnv 
817                    ; addWarnTcM (env0, msg) }
818
819 addWarnTcM :: (TidyEnv, Message) -> TcM ()
820 addWarnTcM (env0, msg)
821  = do { ctxt <- getErrCtxt ;
822         err_info <- mkErrInfo env0 ctxt ;
823         addReport (ptext (sLit "Warning:") <+> msg) err_info }
824
825 warnTc :: Bool -> Message -> TcM ()
826 warnTc warn_if_true warn_msg
827   | warn_if_true = addWarnTc warn_msg
828   | otherwise    = return ()
829 \end{code}
830
831 -----------------------------------
832          Tidying
833
834 We initialise the "tidy-env", used for tidying types before printing,
835 by building a reverse map from the in-scope type variables to the
836 OccName that the programmer originally used for them
837
838 \begin{code}
839 tcInitTidyEnv :: TcM TidyEnv
840 tcInitTidyEnv
841   = do  { lcl_env <- getLclEnv
842         ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
843                           | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
844                           , tcIsTyVarTy ty ]
845         ; return (foldl add emptyTidyEnv nm_tv_prs) }
846   where
847     add (env,subst) (name, tyvar)
848         = case tidyOccName env (nameOccName name) of
849             (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
850                 where
851                   tyvar' = setTyVarName tyvar name'
852                   name'  = tidyNameOcc name occ'
853 \end{code}
854
855 -----------------------------------
856         Other helper functions
857
858 \begin{code}
859 add_err_tcm :: TidyEnv -> Message -> SrcSpan
860             -> [ErrCtxt]
861             -> TcM ()
862 add_err_tcm tidy_env err_msg loc ctxt
863  = do { err_info <- mkErrInfo tidy_env ctxt ;
864         addLongErrAt loc err_msg err_info }
865
866 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
867 -- Tidy the error info, trimming excessive contexts
868 mkErrInfo env ctxts
869  = go 0 env ctxts
870  where
871    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
872    go _ _   [] = return empty
873    go n env ((is_landmark, ctxt) : ctxts)
874      | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug 
875      = do { (env', msg) <- ctxt env
876           ; let n' = if is_landmark then n else n+1
877           ; rest <- go n' env' ctxts
878           ; return (msg $$ rest) }
879      | otherwise
880      = go n env ctxts
881
882 mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
883 mAX_CONTEXTS = 3
884 \end{code}
885
886 debugTc is useful for monadic debugging code
887
888 \begin{code}
889 debugTc :: TcM () -> TcM ()
890 debugTc thing
891  | debugIsOn = thing
892  | otherwise = return ()
893 \end{code}
894
895 %************************************************************************
896 %*                                                                      *
897              Type constraints
898 %*                                                                      *
899 %************************************************************************
900
901 \begin{code}
902 newTcEvBinds :: TcM EvBindsVar
903 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
904                   ; uniq <- newUnique
905                   ; return (EvBindsVar ref uniq) }
906
907 extendTcEvBinds :: TcEvBinds -> EvVar -> EvTerm -> TcM TcEvBinds
908 extendTcEvBinds binds@(TcEvBinds binds_var) var rhs 
909   = do { addTcEvBind binds_var var rhs
910        ; return binds }
911 extendTcEvBinds (EvBinds bnds) var rhs
912   = return (EvBinds (bnds `snocBag` EvBind var rhs))
913
914 addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
915 -- Add a binding to the TcEvBinds by side effect
916 addTcEvBind (EvBindsVar ev_ref _) var rhs
917   = do { bnds <- readTcRef ev_ref
918        ; writeTcRef ev_ref (extendEvBinds bnds var rhs) }
919
920 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
921 chooseUniqueOccTc fn =
922   do { env <- getGblEnv
923      ; let dfun_n_var = tcg_dfun_n env
924      ; set <- readTcRef dfun_n_var
925      ; let occ = fn set
926      ; writeTcRef dfun_n_var (extendOccSet set occ)
927      ; return occ }
928
929 getConstraintVar :: TcM (TcRef WantedConstraints)
930 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
931
932 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
933 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
934
935 emitConstraints :: WantedConstraints -> TcM ()
936 emitConstraints ct
937   = do { lie_var <- getConstraintVar ;
938          updTcRef lie_var (`andWanteds` ct) }
939
940 emitConstraint :: WantedConstraint -> TcM ()
941 emitConstraint ct
942   = do { lie_var <- getConstraintVar ;
943          updTcRef lie_var (`extendWanteds` ct) }
944
945 getConstraints :: TcM a -> TcM (a, WantedConstraints)
946 -- (getConstraints m) runs m, and returns the type constraints it generates
947 getConstraints thing_inside
948   = do { lie_var <- newTcRef emptyWanteds ;
949          res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
950                           thing_inside ;
951          lie <- readTcRef lie_var ;
952          return (res, lie) }
953
954 setUntouchables :: TcTyVarSet -> TcM a -> TcM a
955 setUntouchables untch_tvs thing_inside
956   = updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside 
957
958 getUntouchables :: TcM TcTyVarSet 
959 getUntouchables
960    = do { env <- getLclEnv; return (tcl_untch env) } 
961
962 isUntouchable :: TcTyVar -> TcM Bool
963 isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) }
964
965 getLclTypeEnv :: TcM (NameEnv TcTyThing)
966 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
967
968 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
969 -- Set the local type envt, but do *not* disturb other fields,
970 -- notably the lie_var
971 setLclTypeEnv lcl_env thing_inside
972   = updLclEnv upd thing_inside
973   where
974     upd env = env { tcl_env = tcl_env lcl_env,
975                     tcl_tyvars = tcl_tyvars lcl_env }
976 \end{code}
977
978
979 %************************************************************************
980 %*                                                                      *
981              Template Haskell context
982 %*                                                                      *
983 %************************************************************************
984
985 \begin{code}
986 recordThUse :: TcM ()
987 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
988
989 keepAliveTc :: Id -> TcM ()     -- Record the name in the keep-alive set
990 keepAliveTc id 
991   | isLocalId id = do { env <- getGblEnv; 
992                       ; updTcRef (tcg_keep env) (`addOneToNameSet` idName id) }
993   | otherwise = return ()
994
995 keepAliveSetTc :: NameSet -> TcM ()     -- Record the name in the keep-alive set
996 keepAliveSetTc ns = do { env <- getGblEnv; 
997                        ; updTcRef (tcg_keep env) (`unionNameSets` ns) }
998
999 getStage :: TcM ThStage
1000 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1001
1002 setStage :: ThStage -> TcM a -> TcM a 
1003 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1004 \end{code}
1005
1006
1007 %************************************************************************
1008 %*                                                                      *
1009              Stuff for the renamer's local env
1010 %*                                                                      *
1011 %************************************************************************
1012
1013 \begin{code}
1014 getLocalRdrEnv :: RnM LocalRdrEnv
1015 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1016
1017 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1018 setLocalRdrEnv rdr_env thing_inside 
1019   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1020 \end{code}
1021
1022
1023 %************************************************************************
1024 %*                                                                      *
1025              Stuff for interface decls
1026 %*                                                                      *
1027 %************************************************************************
1028
1029 \begin{code}
1030 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1031 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
1032                                 if_loc     = loc,
1033                                 if_tv_env  = emptyUFM,
1034                                 if_id_env  = emptyUFM }
1035
1036 initIfaceTcRn :: IfG a -> TcRn a
1037 initIfaceTcRn thing_inside
1038   = do  { tcg_env <- getGblEnv 
1039         ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
1040               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1041         ; setEnvs (if_env, ()) thing_inside }
1042
1043 initIfaceExtCore :: IfL a -> TcRn a
1044 initIfaceExtCore thing_inside
1045   = do  { tcg_env <- getGblEnv 
1046         ; let { mod = tcg_mod tcg_env
1047               ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
1048               ; if_env = IfGblEnv { 
1049                         if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
1050               ; if_lenv = mkIfLclEnv mod doc
1051           }
1052         ; setEnvs (if_env, if_lenv) thing_inside }
1053
1054 initIfaceCheck :: HscEnv -> IfG a -> IO a
1055 -- Used when checking the up-to-date-ness of the old Iface
1056 -- Initialise the environment with no useful info at all
1057 initIfaceCheck hsc_env do_this
1058  = do let rec_types = case hsc_type_env_var hsc_env of
1059                          Just (mod,var) -> Just (mod, readTcRef var)
1060                          Nothing        -> Nothing
1061           gbl_env = IfGblEnv { if_rec_types = rec_types }
1062       initTcRnIf 'i' hsc_env gbl_env () do_this
1063
1064 initIfaceTc :: ModIface 
1065             -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1066 -- Used when type-checking checking an up-to-date interface file
1067 -- No type envt from the current module, but we do know the module dependencies
1068 initIfaceTc iface do_this
1069  = do   { tc_env_var <- newTcRef emptyTypeEnv
1070         ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readTcRef tc_env_var) } ;
1071               ; if_lenv = mkIfLclEnv mod doc
1072            }
1073         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1074     }
1075   where
1076     mod = mi_module iface
1077     doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1078
1079 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
1080 -- Used when sucking in new Rules in SimplCore
1081 -- We have available the type envt of the module being compiled, and we must use it
1082 initIfaceRules hsc_env guts do_this
1083  = do   { let {
1084              type_info = (mg_module guts, return (mg_types guts))
1085            ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
1086            }
1087
1088         -- Run the thing; any exceptions just bubble out from here
1089         ; initTcRnIf 'i' hsc_env gbl_env () do_this
1090     }
1091
1092 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1093 initIfaceLcl mod loc_doc thing_inside 
1094   = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1095
1096 getIfModule :: IfL Module
1097 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1098
1099 --------------------
1100 failIfM :: Message -> IfL a
1101 -- The Iface monad doesn't have a place to accumulate errors, so we
1102 -- just fall over fast if one happens; it "shouldnt happen".
1103 -- We use IfL here so that we can get context info out of the local env
1104 failIfM msg
1105   = do  { env <- getLclEnv
1106         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1107         ; liftIO (printErrs (full_msg defaultErrStyle))
1108         ; failM }
1109
1110 --------------------
1111 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1112 -- Run thing_inside in an interleaved thread.  
1113 -- It shares everything with the parent thread, so this is DANGEROUS.  
1114 --
1115 -- It returns Nothing if the computation fails
1116 -- 
1117 -- It's used for lazily type-checking interface
1118 -- signatures, which is pretty benign
1119
1120 forkM_maybe doc thing_inside
1121  = do { unsafeInterleaveM $
1122         do { traceIf (text "Starting fork {" <+> doc)
1123            ; mb_res <- tryM $
1124                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $ 
1125                        thing_inside
1126            ; case mb_res of
1127                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1128                                 ; return (Just r) }
1129                 Left exn -> do {
1130
1131                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1132                     -- Otherwise we silently discard errors. Errors can legitimately
1133                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1134                       ifOptM Opt_D_dump_if_trace 
1135                              (print_errs (hang (text "forkM failed:" <+> doc)
1136                                              2 (text (show exn))))
1137
1138                     ; traceIf (text "} ending fork (badly)" <+> doc)
1139                     ; return Nothing }
1140         }}
1141   where
1142     print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
1143
1144 forkM :: SDoc -> IfL a -> IfL a
1145 forkM doc thing_inside
1146  = do   { mb_res <- forkM_maybe doc thing_inside
1147         ; return (case mb_res of 
1148                         Nothing -> pgmError "Cannot continue after interface file error"
1149                                    -- pprPanic "forkM" doc
1150                         Just r  -> r) }
1151 \end{code}