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