compiler/typecheck/TcRnMonad.lhs

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