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