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