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