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