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