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