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 import PrelNames        ( iNTERACTIVE )
  26
  27 import Var
  28 import Id
  29 import VarSet
  30 import VarEnv
  31 import ErrUtils
  32 import SrcLoc
  33 import NameEnv
  34 import NameSet
  35 import Bag
  36 import Outputable
  37 import UniqSupply
  38 import Unique
  39 import UniqFM
  40 import DynFlags
  41 import StaticFlags
  42 import FastString
  43 import Panic
  44 import Util
  45
  46 import System.IO
  47 import Data.IORef
  48 import qualified Data.Set as Set
  49 import Control.Monad
  50 \end{code}
  51
  52
  53
  54 %************************************************************************
  55 %*                                                                      *
  56                         initTc
  57 %*                                                                      *
  58 %************************************************************************
  59
  60 \begin{code}
  61
  62 initTc :: HscEnv
  63        -> HscSource
  64        -> Bool          -- True <=> retain renamed syntax trees
  65        -> Module
  66        -> TcM r
  67        -> IO (Messages, Maybe r)
  68                 -- Nothing => error thrown by the thing inside
  69                 -- (error messages should have been printed already)
  70
  71 initTc hsc_env hsc_src keep_rn_syntax mod do_this
  72  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
  73         meta_var     <- newIORef initTyVarUnique ;
  74         tvs_var      <- newIORef emptyVarSet ;
  75         keep_var     <- newIORef emptyNameSet ;
  76         used_rdr_var <- newIORef Set.empty ;
  77         th_var       <- newIORef False ;
  78         lie_var      <- newIORef emptyWC ;
  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_th_used   = th_var,
 101                 tcg_exports  = [],
 102                 tcg_imports  = emptyImportAvails,
 103                 tcg_used_rdrnames = used_rdr_var,
 104                 tcg_dus      = emptyDUs,
 105
 106                 tcg_rn_imports = [],
 107                 tcg_rn_exports = maybe_rn_syntax [],
 108                 tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
 109
 110                 tcg_binds     = emptyLHsBinds,
 111                 tcg_imp_specs = [],
 112                 tcg_sigs      = emptyNameSet,
 113                 tcg_ev_binds  = emptyBag,
 114                 tcg_warns     = NoWarnings,
 115                 tcg_anns      = [],
 116                 tcg_insts     = [],
 117                 tcg_fam_insts = [],
 118                 tcg_rules     = [],
 119                 tcg_fords     = [],
 120                 tcg_vects     = [],
 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                 tcl_hetMetLevel    = []
 140              } ;
 141         } ;
 142
 143         -- OK, here's the business end!
 144         maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
 145                      do { r <- tryM do_this
 146                         ; case r of
 147                           Right res -> return (Just res)
 148                           Left _    -> return Nothing } ;
 149
 150         -- Check for unsolved constraints
 151         lie <- readIORef lie_var ;
 152         if isEmptyWC lie
 153            then return ()
 154            else pprPanic "initTc: unsolved constraints"
 155                          (pprWantedsWithLocs lie) ;
 156
 157         -- Collect any error messages
 158         msgs <- readIORef errs_var ;
 159
 160         let { dflags = hsc_dflags hsc_env
 161             ; final_res | errorsFound dflags msgs = Nothing
 162                         | otherwise               = maybe_res } ;
 163
 164         return (msgs, final_res)
 165     }
 166
 167 initTcPrintErrors       -- Used from the interactive loop only
 168        :: HscEnv
 169        -> Module
 170        -> TcM r
 171        -> IO (Messages, Maybe r)
 172
 173 initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
 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 (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 takeUniqFromSupply us of { (uniq, us') -> do {
 336         writeMutVar u_var us' ;
 337         return $! uniq }}}
 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 getIsGHCi :: TcRn Bool
 458 getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) }
 459
 460 tcIsHsBoot :: TcRn Bool
 461 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
 462
 463 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 464 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 465
 466 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
 467 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
 468
 469 getImports :: TcRn ImportAvails
 470 getImports = do { env <- getGblEnv; return (tcg_imports env) }
 471
 472 getFixityEnv :: TcRn FixityEnv
 473 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 474
 475 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
 476 extendFixityEnv new_bit
 477   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
 478                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
 479
 480 getRecFieldEnv :: TcRn RecFieldEnv
 481 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
 482
 483 getDeclaredDefaultTys :: TcRn (Maybe [Type])
 484 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 485 \end{code}
 486
 487 %************************************************************************
 488 %*                                                                      *
 489                 Error management
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 \begin{code}
 494 getSrcSpanM :: TcRn SrcSpan
 495         -- Avoid clash with Name.getSrcLoc
 496 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
 497
 498 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
 499 setSrcSpan loc thing_inside
 500   | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
 501   | otherwise         = thing_inside    -- Don't overwrite useful info with useless
 502
 503 addLocM :: (a -> TcM b) -> Located a -> TcM b
 504 addLocM fn (L loc a) = setSrcSpan loc $ fn a
 505
 506 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
 507 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
 508
 509 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
 510 wrapLocFstM fn (L loc a) =
 511   setSrcSpan loc $ do
 512     (b,c) <- fn a
 513     return (L loc b, c)
 514
 515 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
 516 wrapLocSndM fn (L loc a) =
 517   setSrcSpan loc $ do
 518     (b,c) <- fn a
 519     return (b, L loc c)
 520 \end{code}
 521
 522 Reporting errors
 523
 524 \begin{code}
 525 getErrsVar :: TcRn (TcRef Messages)
 526 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 527
 528 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 529 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 530
 531 addErr :: Message -> TcRn ()    -- Ignores the context stack
 532 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 533
 534 failWith :: Message -> TcRn a
 535 failWith msg = addErr msg >> failM
 536
 537 addErrAt :: SrcSpan -> Message -> TcRn ()
 538 -- addErrAt is mainly (exclusively?) used by the renamer, where
 539 -- tidying is not an issue, but it's all lazy so the extra
 540 -- work doesn't matter
 541 addErrAt loc msg = do { ctxt <- getErrCtxt
 542                       ; tidy_env <- tcInitTidyEnv
 543                       ; err_info <- mkErrInfo tidy_env ctxt
 544                       ; addLongErrAt loc msg err_info }
 545
 546 addErrs :: [(SrcSpan,Message)] -> TcRn ()
 547 addErrs msgs = mapM_ add msgs
 548              where
 549                add (loc,msg) = addErrAt loc msg
 550
 551 addWarn :: Message -> TcRn ()
 552 addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty
 553
 554 addWarnAt :: SrcSpan -> Message -> TcRn ()
 555 addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty
 556
 557 checkErr :: Bool -> Message -> TcRn ()
 558 -- Add the error if the bool is False
 559 checkErr ok msg = unless ok (addErr msg)
 560
 561 warnIf :: Bool -> Message -> TcRn ()
 562 warnIf True  msg = addWarn msg
 563 warnIf False _   = return ()
 564
 565 addMessages :: Messages -> TcRn ()
 566 addMessages (m_warns, m_errs)
 567   = do { errs_var <- getErrsVar ;
 568          (warns, errs) <- readTcRef errs_var ;
 569          writeTcRef errs_var (warns `unionBags` m_warns,
 570                                errs  `unionBags` m_errs) }
 571
 572 discardWarnings :: TcRn a -> TcRn a
 573 -- Ignore warnings inside the thing inside;
 574 -- used to ignore-unused-variable warnings inside derived code
 575 -- With -dppr-debug, the effects is switched off, so you can still see
 576 -- what warnings derived code would give
 577 discardWarnings thing_inside
 578   | opt_PprStyle_Debug = thing_inside
 579   | otherwise
 580   = do  { errs_var <- newTcRef emptyMessages
 581         ; result <- setErrsVar errs_var thing_inside
 582         ; (_warns, errs) <- readTcRef errs_var
 583         ; addMessages (emptyBag, errs)
 584         ; return result }
 585 \end{code}
 586
 587
 588 %************************************************************************
 589 %*                                                                      *
 590         Shared error message stuff: renamer and typechecker
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 \begin{code}
 595 addReport :: Message -> Message -> TcRn ()
 596 addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info
 597
 598 addReportAt :: SrcSpan -> Message -> Message -> TcRn ()
 599 addReportAt loc msg extra_info
 600   = do { errs_var <- getErrsVar ;
 601          rdr_env <- getGlobalRdrEnv ;
 602          dflags <- getDOpts ;
 603          let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
 604                                     msg extra_info } ;
 605          (warns, errs) <- readTcRef errs_var ;
 606          writeTcRef errs_var (warns `snocBag` warn, errs) }
 607
 608 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
 609 addLongErrAt loc msg extra
 610   = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ;
 611          errs_var <- getErrsVar ;
 612          rdr_env <- getGlobalRdrEnv ;
 613          dflags <- getDOpts ;
 614          let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
 615          (warns, errs) <- readTcRef errs_var ;
 616          writeTcRef errs_var (warns, errs `snocBag` err) }
 617
 618 dumpDerivingInfo :: SDoc -> TcM ()
 619 dumpDerivingInfo doc
 620   = do { dflags <- getDOpts
 621        ; when (dopt Opt_D_dump_deriv dflags) $ do
 622        { rdr_env <- getGlobalRdrEnv
 623        ; let unqual = mkPrintUnqualified dflags rdr_env
 624        ; liftIO (putMsgWith dflags unqual doc) } }
 625 \end{code}
 626
 627
 628 \begin{code}
 629 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 630 -- Does try_m, with a debug-trace on failure
 631 try_m thing
 632   = do { mb_r <- tryM thing ;
 633          case mb_r of
 634              Left exn -> do { traceTc "tryTc/recoverM recovering from" $
 635                                       text (showException exn)
 636                             ; return mb_r }
 637              Right _  -> return mb_r }
 638
 639 -----------------------
 640 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
 641          -> TcRn r      -- Main action: do this first
 642          -> TcRn r
 643 -- Errors in 'thing' are retained
 644 recoverM recover thing
 645   = do { mb_res <- try_m thing ;
 646          case mb_res of
 647            Left _    -> recover
 648            Right res -> return res }
 649
 650
 651 -----------------------
 652 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
 653 -- Drop elements of the input that fail, so the result
 654 -- list can be shorter than the argument list
 655 mapAndRecoverM _ []     = return []
 656 mapAndRecoverM f (x:xs) = do { mb_r <- try_m (f x)
 657                              ; rs <- mapAndRecoverM f xs
 658                              ; return (case mb_r of
 659                                           Left _  -> rs
 660                                           Right r -> r:rs) }
 661
 662
 663 -----------------------
 664 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 665 -- (tryTc m) executes m, and returns
 666 --      Just r,  if m succeeds (returning r)
 667 --      Nothing, if m fails
 668 -- It also returns all the errors and warnings accumulated by m
 669 -- It always succeeds (never raises an exception)
 670 tryTc m
 671  = do { errs_var <- newTcRef emptyMessages ;
 672         res  <- try_m (setErrsVar errs_var m) ;
 673         msgs <- readTcRef errs_var ;
 674         return (msgs, case res of
 675                             Left _  -> Nothing
 676                             Right val -> Just val)
 677         -- The exception is always the IOEnv built-in
 678         -- in exception; see IOEnv.failM
 679    }
 680
 681 -----------------------
 682 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
 683 -- Run the thing, returning
 684 --      Just r,  if m succceeds with no error messages
 685 --      Nothing, if m fails, or if it succeeds but has error messages
 686 -- Either way, the messages are returned; even in the Just case
 687 -- there might be warnings
 688 tryTcErrs thing
 689   = do  { (msgs, res) <- tryTc thing
 690         ; dflags <- getDOpts
 691         ; let errs_found = errorsFound dflags msgs
 692         ; return (msgs, case res of
 693                           Nothing -> Nothing
 694                           Just val | errs_found -> Nothing
 695                                    | otherwise  -> Just val)
 696         }
 697
 698 -----------------------
 699 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 700 -- Just like tryTcErrs, except that it ensures that the LIE
 701 -- for the thing is propagated only if there are no errors
 702 -- Hence it's restricted to the type-check monad
 703 tryTcLIE thing_inside
 704   = do  { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ;
 705         ; case mb_res of
 706             Nothing  -> return (msgs, Nothing)
 707             Just val -> do { emitConstraints lie; return (msgs, Just val) }
 708         }
 709
 710 -----------------------
 711 tryTcLIE_ :: TcM r -> TcM r -> TcM r
 712 -- (tryTcLIE_ r m) tries m;
 713 --      if m succeeds with no error messages, it's the answer
 714 --      otherwise tryTcLIE_ drops everything from m and tries r instead.
 715 tryTcLIE_ recover main
 716   = do  { (msgs, mb_res) <- tryTcLIE main
 717         ; case mb_res of
 718              Just val -> do { addMessages msgs  -- There might be warnings
 719                              ; return val }
 720              Nothing  -> recover                -- Discard all msgs
 721         }
 722
 723 -----------------------
 724 checkNoErrs :: TcM r -> TcM r
 725 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 726 -- If m fails then (checkNoErrsTc m) fails.
 727 -- If m succeeds, it checks whether m generated any errors messages
 728 --      (it might have recovered internally)
 729 --      If so, it fails too.
 730 -- Regardless, any errors generated by m are propagated to the enclosing context.
 731 checkNoErrs main
 732   = do  { (msgs, mb_res) <- tryTcLIE main
 733         ; addMessages msgs
 734         ; case mb_res of
 735             Nothing  -> failM
 736             Just val -> return val
 737         }
 738
 739 ifErrsM :: TcRn r -> TcRn r -> TcRn r
 740 --      ifErrsM bale_out main
 741 -- does 'bale_out' if there are errors in errors collection
 742 -- otherwise does 'main'
 743 ifErrsM bale_out normal
 744  = do { errs_var <- getErrsVar ;
 745         msgs <- readTcRef errs_var ;
 746         dflags <- getDOpts ;
 747         if errorsFound dflags msgs then
 748            bale_out
 749         else
 750            normal }
 751
 752 failIfErrsM :: TcRn ()
 753 -- Useful to avoid error cascades
 754 failIfErrsM = ifErrsM failM (return ())
 755 \end{code}
 756
 757
 758 %************************************************************************
 759 %*                                                                      *
 760         Context management for the type checker
 761 %*                                                                      *
 762 %************************************************************************
 763
 764 \begin{code}
 765 getErrCtxt :: TcM [ErrCtxt]
 766 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 767
 768 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
 769 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 770
 771 addErrCtxt :: Message -> TcM a -> TcM a
 772 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 773
 774 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
 775 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
 776
 777 addLandmarkErrCtxt :: Message -> TcM a -> TcM a
 778 addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts)
 779
 780 -- Helper function for the above
 781 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
 782 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
 783                            env { tcl_ctxt = upd ctxt })
 784
 785 -- Conditionally add an error context
 786 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
 787 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
 788 maybeAddErrCtxt Nothing    thing_inside = thing_inside
 789
 790 popErrCtxt :: TcM a -> TcM a
 791 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 792
 793 getCtLoc :: orig -> TcM (CtLoc orig)
 794 getCtLoc origin
 795   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
 796          return (CtLoc origin loc (tcl_ctxt env)) }
 797
 798 setCtLoc :: CtLoc orig -> TcM a -> TcM a
 799 setCtLoc (CtLoc _ src_loc ctxt) thing_inside
 800   = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
 801 \end{code}
 802
 803 %************************************************************************
 804 %*                                                                      *
 805              Error message generation (type checker)
 806 %*                                                                      *
 807 %************************************************************************
 808
 809     The addErrTc functions add an error message, but do not cause failure.
 810     The 'M' variants pass a TidyEnv that has already been used to
 811     tidy up the message; we then use it to tidy the context messages
 812
 813 \begin{code}
 814 addErrTc :: Message -> TcM ()
 815 addErrTc err_msg = do { env0 <- tcInitTidyEnv
 816                       ; addErrTcM (env0, err_msg) }
 817
 818 addErrsTc :: [Message] -> TcM ()
 819 addErrsTc err_msgs = mapM_ addErrTc err_msgs
 820
 821 addErrTcM :: (TidyEnv, Message) -> TcM ()
 822 addErrTcM (tidy_env, err_msg)
 823   = do { ctxt <- getErrCtxt ;
 824          loc  <- getSrcSpanM ;
 825          add_err_tcm tidy_env err_msg loc ctxt }
 826 \end{code}
 827
 828 The failWith functions add an error message and cause failure
 829
 830 \begin{code}
 831 failWithTc :: Message -> TcM a               -- Add an error message and fail
 832 failWithTc err_msg
 833   = addErrTc err_msg >> failM
 834
 835 failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
 836 failWithTcM local_and_msg
 837   = addErrTcM local_and_msg >> failM
 838
 839 checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
 840 checkTc True  _   = return ()
 841 checkTc False err = failWithTc err
 842 \end{code}
 843
 844         Warnings have no 'M' variant, nor failure
 845
 846 \begin{code}
 847 addWarnTc :: Message -> TcM ()
 848 addWarnTc msg = do { env0 <- tcInitTidyEnv
 849                    ; addWarnTcM (env0, msg) }
 850
 851 addWarnTcM :: (TidyEnv, Message) -> TcM ()
 852 addWarnTcM (env0, msg)
 853  = do { ctxt <- getErrCtxt ;
 854         err_info <- mkErrInfo env0 ctxt ;
 855         addReport (ptext (sLit "Warning:") <+> msg) err_info }
 856
 857 warnTc :: Bool -> Message -> TcM ()
 858 warnTc warn_if_true warn_msg
 859   | warn_if_true = addWarnTc warn_msg
 860   | otherwise    = return ()
 861 \end{code}
 862
 863 -----------------------------------
 864          Tidying
 865
 866 We initialise the "tidy-env", used for tidying types before printing,
 867 by building a reverse map from the in-scope type variables to the
 868 OccName that the programmer originally used for them
 869
 870 \begin{code}
 871 tcInitTidyEnv :: TcM TidyEnv
 872 tcInitTidyEnv
 873   = do  { lcl_env <- getLclEnv
 874         ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
 875                           | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
 876                           , tcIsTyVarTy ty ]
 877         ; return (foldl add emptyTidyEnv nm_tv_prs) }
 878   where
 879     add (env,subst) (name, tyvar)
 880         = case tidyOccName env (nameOccName name) of
 881             (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
 882                 where
 883                   tyvar' = setTyVarName tyvar name'
 884                   name'  = tidyNameOcc name occ'
 885 \end{code}
 886
 887 -----------------------------------
 888         Other helper functions
 889
 890 \begin{code}
 891 add_err_tcm :: TidyEnv -> Message -> SrcSpan
 892             -> [ErrCtxt]
 893             -> TcM ()
 894 add_err_tcm tidy_env err_msg loc ctxt
 895  = do { err_info <- mkErrInfo tidy_env ctxt ;
 896         addLongErrAt loc err_msg err_info }
 897
 898 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
 899 -- Tidy the error info, trimming excessive contexts
 900 mkErrInfo env ctxts
 901  = go 0 env ctxts
 902  where
 903    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
 904    go _ _   [] = return empty
 905    go n env ((is_landmark, ctxt) : ctxts)
 906      | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
 907      = do { (env', msg) <- ctxt env
 908           ; let n' = if is_landmark then n else n+1
 909           ; rest <- go n' env' ctxts
 910           ; return (msg $$ rest) }
 911      | otherwise
 912      = go n env ctxts
 913
 914 mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
 915 mAX_CONTEXTS = 3
 916 \end{code}
 917
 918 debugTc is useful for monadic debugging code
 919
 920 \begin{code}
 921 debugTc :: TcM () -> TcM ()
 922 debugTc thing
 923  | debugIsOn = thing
 924  | otherwise = return ()
 925 \end{code}
 926
 927 %************************************************************************
 928 %*                                                                      *
 929              Type constraints
 930 %*                                                                      *
 931 %************************************************************************
 932
 933 \begin{code}
 934 newTcEvBinds :: TcM EvBindsVar
 935 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
 936                   ; uniq <- newUnique
 937                   ; return (EvBindsVar ref uniq) }
 938
 939 extendTcEvBinds :: TcEvBinds -> EvVar -> EvTerm -> TcM TcEvBinds
 940 extendTcEvBinds binds@(TcEvBinds binds_var) var rhs
 941   = do { addTcEvBind binds_var var rhs
 942        ; return binds }
 943 extendTcEvBinds (EvBinds bnds) var rhs
 944   = return (EvBinds (bnds `snocBag` EvBind var rhs))
 945
 946 addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
 947 -- Add a binding to the TcEvBinds by side effect
 948 addTcEvBind (EvBindsVar ev_ref _) var rhs
 949   = do { bnds <- readTcRef ev_ref
 950        ; writeTcRef ev_ref (extendEvBinds bnds var rhs) }
 951
 952 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
 953 chooseUniqueOccTc fn =
 954   do { env <- getGblEnv
 955      ; let dfun_n_var = tcg_dfun_n env
 956      ; set <- readTcRef dfun_n_var
 957      ; let occ = fn set
 958      ; writeTcRef dfun_n_var (extendOccSet set occ)
 959      ; return occ }
 960
 961 getConstraintVar :: TcM (TcRef WantedConstraints)
 962 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
 963
 964 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
 965 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 966
 967 emitConstraints :: WantedConstraints -> TcM ()
 968 emitConstraints ct
 969   = do { lie_var <- getConstraintVar ;
 970          updTcRef lie_var (`andWC` ct) }
 971
 972 emitFlat :: WantedEvVar -> TcM ()
 973 emitFlat ct
 974   = do { lie_var <- getConstraintVar ;
 975          updTcRef lie_var (`addFlats` unitBag ct) }
 976
 977 emitFlats :: Bag WantedEvVar -> TcM ()
 978 emitFlats ct
 979   = do { lie_var <- getConstraintVar ;
 980          updTcRef lie_var (`addFlats` ct) }
 981
 982 emitImplication :: Implication -> TcM ()
 983 emitImplication ct
 984   = do { lie_var <- getConstraintVar ;
 985          updTcRef lie_var (`addImplics` unitBag ct) }
 986
 987 emitImplications :: Bag Implication -> TcM ()
 988 emitImplications ct
 989   = do { lie_var <- getConstraintVar ;
 990          updTcRef lie_var (`addImplics` ct) }
 991
 992 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
 993 -- (captureConstraints m) runs m, and returns the type constraints it generates
 994 captureConstraints thing_inside
 995   = do { lie_var <- newTcRef emptyWC ;
 996          res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
 997                           thing_inside ;
 998          lie <- readTcRef lie_var ;
 999          return (res, lie) }
1000
1001 captureUntouchables :: TcM a -> TcM (a, Untouchables)
1002 captureUntouchables thing_inside
1003   = do { env <- getLclEnv
1004        ; low_meta <- readTcRef (tcl_meta env)
1005        ; res <- setLclEnv (env { tcl_untch = low_meta })
1006                 thing_inside
1007        ; high_meta <- readTcRef (tcl_meta env)
1008        ; return (res, TouchableRange low_meta high_meta) }
1009
1010 isUntouchable :: TcTyVar -> TcM Bool
1011 isUntouchable tv = do { env <- getLclEnv
1012                       ; return (varUnique tv < tcl_untch env) }
1013
1014 getLclTypeEnv :: TcM (NameEnv TcTyThing)
1015 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1016
1017 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1018 -- Set the local type envt, but do *not* disturb other fields,
1019 -- notably the lie_var
1020 setLclTypeEnv lcl_env thing_inside
1021   = updLclEnv upd thing_inside
1022   where
1023     upd env = env { tcl_env = tcl_env lcl_env,
1024                     tcl_tyvars = tcl_tyvars lcl_env }
1025 \end{code}
1026
1027
1028 %************************************************************************
1029 %*                                                                      *
1030              Template Haskell context
1031 %*                                                                      *
1032 %************************************************************************
1033
1034 \begin{code}
1035 recordThUse :: TcM ()
1036 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1037
1038 keepAliveTc :: Id -> TcM ()     -- Record the name in the keep-alive set
1039 keepAliveTc id
1040   | isLocalId id = do { env <- getGblEnv;
1041                       ; updTcRef (tcg_keep env) (`addOneToNameSet` idName id) }
1042   | otherwise = return ()
1043
1044 keepAliveSetTc :: NameSet -> TcM ()     -- Record the name in the keep-alive set
1045 keepAliveSetTc ns = do { env <- getGblEnv;
1046                        ; updTcRef (tcg_keep env) (`unionNameSets` ns) }
1047
1048 getStage :: TcM ThStage
1049 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1050
1051 setStage :: ThStage -> TcM a -> TcM a
1052 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1053 \end{code}
1054
1055
1056 %************************************************************************
1057 %*                                                                      *
1058              Stuff for the renamer's local env
1059 %*                                                                      *
1060 %************************************************************************
1061
1062 \begin{code}
1063 getLocalRdrEnv :: RnM LocalRdrEnv
1064 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1065
1066 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1067 setLocalRdrEnv rdr_env thing_inside
1068   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1069 \end{code}
1070
1071
1072 %************************************************************************
1073 %*                                                                      *
1074              Stuff for interface decls
1075 %*                                                                      *
1076 %************************************************************************
1077
1078 \begin{code}
1079 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1080 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
1081                                 if_loc     = loc,
1082                                 if_tv_env  = emptyUFM,
1083                                 if_id_env  = emptyUFM }
1084
1085 initIfaceTcRn :: IfG a -> TcRn a
1086 initIfaceTcRn thing_inside
1087   = do  { tcg_env <- getGblEnv
1088         ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
1089               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1090         ; setEnvs (if_env, ()) thing_inside }
1091
1092 initIfaceExtCore :: IfL a -> TcRn a
1093 initIfaceExtCore thing_inside
1094   = do  { tcg_env <- getGblEnv
1095         ; let { mod = tcg_mod tcg_env
1096               ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
1097               ; if_env = IfGblEnv {
1098                         if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
1099               ; if_lenv = mkIfLclEnv mod doc
1100           }
1101         ; setEnvs (if_env, if_lenv) thing_inside }
1102
1103 initIfaceCheck :: HscEnv -> IfG a -> IO a
1104 -- Used when checking the up-to-date-ness of the old Iface
1105 -- Initialise the environment with no useful info at all
1106 initIfaceCheck hsc_env do_this
1107  = do let rec_types = case hsc_type_env_var hsc_env of
1108                          Just (mod,var) -> Just (mod, readTcRef var)
1109                          Nothing        -> Nothing
1110           gbl_env = IfGblEnv { if_rec_types = rec_types }
1111       initTcRnIf 'i' hsc_env gbl_env () do_this
1112
1113 initIfaceTc :: ModIface
1114             -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1115 -- Used when type-checking checking an up-to-date interface file
1116 -- No type envt from the current module, but we do know the module dependencies
1117 initIfaceTc iface do_this
1118  = do   { tc_env_var <- newTcRef emptyTypeEnv
1119         ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readTcRef tc_env_var) } ;
1120               ; if_lenv = mkIfLclEnv mod doc
1121            }
1122         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1123     }
1124   where
1125     mod = mi_module iface
1126     doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1127
1128 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
1129 -- Used when sucking in new Rules in SimplCore
1130 -- We have available the type envt of the module being compiled, and we must use it
1131 initIfaceRules hsc_env guts do_this
1132  = do   { let {
1133              type_info = (mg_module guts, return (mg_types guts))
1134            ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
1135            }
1136
1137         -- Run the thing; any exceptions just bubble out from here
1138         ; initTcRnIf 'i' hsc_env gbl_env () do_this
1139     }
1140
1141 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1142 initIfaceLcl mod loc_doc thing_inside
1143   = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1144
1145 getIfModule :: IfL Module
1146 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1147
1148 --------------------
1149 failIfM :: Message -> IfL a
1150 -- The Iface monad doesn't have a place to accumulate errors, so we
1151 -- just fall over fast if one happens; it "shouldnt happen".
1152 -- We use IfL here so that we can get context info out of the local env
1153 failIfM msg
1154   = do  { env <- getLclEnv
1155         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1156         ; liftIO (printErrs (full_msg defaultErrStyle))
1157         ; failM }
1158
1159 --------------------
1160 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1161 -- Run thing_inside in an interleaved thread.
1162 -- It shares everything with the parent thread, so this is DANGEROUS.
1163 --
1164 -- It returns Nothing if the computation fails
1165 --
1166 -- It's used for lazily type-checking interface
1167 -- signatures, which is pretty benign
1168
1169 forkM_maybe doc thing_inside
1170  = do { unsafeInterleaveM $
1171         do { traceIf (text "Starting fork {" <+> doc)
1172            ; mb_res <- tryM $
1173                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1174                        thing_inside
1175            ; case mb_res of
1176                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1177                                 ; return (Just r) }
1178                 Left exn -> do {
1179
1180                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1181                     -- Otherwise we silently discard errors. Errors can legitimately
1182                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1183                       ifDOptM Opt_D_dump_if_trace
1184                              (print_errs (hang (text "forkM failed:" <+> doc)
1185                                              2 (text (show exn))))
1186
1187                     ; traceIf (text "} ending fork (badly)" <+> doc)
1188                     ; return Nothing }
1189         }}
1190   where
1191     print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
1192
1193 forkM :: SDoc -> IfL a -> IfL a
1194 forkM doc thing_inside
1195  = do   { mb_res <- forkM_maybe doc thing_inside
1196         ; return (case mb_res of
1197                         Nothing -> pgmError "Cannot continue after interface file error"
1198                                    -- pprPanic "forkM" doc
1199                         Just r  -> r) }
1200 \end{code}