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