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