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