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 emptyBag ;
  79         dfun_n_var   <- newIORef emptyOccSet ;
  80         type_env_var <- case hsc_type_env_var hsc_env of {
  81                            Just (_mod, te_var) -> return te_var ;
  82                            Nothing             -> newIORef emptyNameEnv } ;
  83         let {
  84              maybe_rn_syntax :: forall a. a -> Maybe a ;
  85              maybe_rn_syntax empty_val
  86                 | keep_rn_syntax = Just empty_val
  87                 | otherwise      = Nothing ;
  88
  89              gbl_env = TcGblEnv {
  90                 tcg_mod       = mod,
  91                 tcg_src       = hsc_src,
  92                 tcg_rdr_env   = emptyGlobalRdrEnv,
  93                 tcg_fix_env   = emptyNameEnv,
  94                 tcg_field_env = RecFields emptyNameEnv emptyNameSet,
  95                 tcg_default   = Nothing,
  96                 tcg_type_env  = emptyNameEnv,
  97                 tcg_type_env_var = type_env_var,
  98                 tcg_inst_env  = emptyInstEnv,
  99                 tcg_fam_inst_env  = emptyFamInstEnv,
 100                 tcg_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              } ;
 139         } ;
 140
 141         -- OK, here's the business end!
 142         maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
 143                      do { r <- tryM do_this
 144                         ; case r of
 145                           Right res -> return (Just res)
 146                           Left _    -> return Nothing } ;
 147
 148         -- Check for unsolved constraints
 149         lie <- readIORef lie_var ;
 150         if isEmptyBag lie
 151            then return ()
 152            else pprPanic "initTc: unsolved constraints"
 153                          (pprWantedsWithLocs lie) ;
 154
 155         -- Collect any error messages
 156         msgs <- readIORef errs_var ;
 157
 158         let { dflags = hsc_dflags hsc_env
 159             ; final_res | errorsFound dflags msgs = Nothing
 160                         | otherwise               = maybe_res } ;
 161
 162         return (msgs, final_res)
 163     }
 164
 165 initTcPrintErrors       -- Used from the interactive loop only
 166        :: HscEnv
 167        -> Module
 168        -> TcM r
 169        -> IO (Messages, Maybe r)
 170
 171 initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo
 172 \end{code}
 173
 174 %************************************************************************
 175 %*                                                                      *
 176                 Initialisation
 177 %*                                                                      *
 178 %************************************************************************
 179
 180
 181 \begin{code}
 182 initTcRnIf :: Char              -- Tag for unique supply
 183            -> HscEnv
 184            -> gbl -> lcl
 185            -> TcRnIf gbl lcl a
 186            -> IO a
 187 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
 188    = do { us     <- mkSplitUniqSupply uniq_tag ;
 189         ; us_var <- newIORef us ;
 190
 191         ; let { env = Env { env_top = hsc_env,
 192                             env_us  = us_var,
 193                             env_gbl = gbl_env,
 194                             env_lcl = lcl_env} }
 195
 196         ; runIOEnv env thing_inside
 197         }
 198 \end{code}
 199
 200 %************************************************************************
 201 %*                                                                      *
 202                 Simple accessors
 203 %*                                                                      *
 204 %************************************************************************
 205
 206 \begin{code}
 207 getTopEnv :: TcRnIf gbl lcl HscEnv
 208 getTopEnv = do { env <- getEnv; return (env_top env) }
 209
 210 getGblEnv :: TcRnIf gbl lcl gbl
 211 getGblEnv = do { env <- getEnv; return (env_gbl env) }
 212
 213 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 214 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
 215                           env { env_gbl = upd gbl })
 216
 217 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 218 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 219
 220 getLclEnv :: TcRnIf gbl lcl lcl
 221 getLclEnv = do { env <- getEnv; return (env_lcl env) }
 222
 223 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 224 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
 225                           env { env_lcl = upd lcl })
 226
 227 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
 228 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
 229
 230 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
 231 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
 232
 233 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
 234 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
 235 \end{code}
 236
 237
 238 Command-line flags
 239
 240 \begin{code}
 241 getDOpts :: TcRnIf gbl lcl DynFlags
 242 getDOpts = do { env <- getTopEnv; return (hsc_dflags env) }
 243
 244 xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool
 245 xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) }
 246
 247 doptM :: DynFlag -> TcRnIf gbl lcl Bool
 248 doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
 249
 250 -- XXX setOptM and unsetOptM operate on different types. One should be renamed.
 251
 252 setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 253 setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
 254                          env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
 255
 256 unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 257 unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
 258                          env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} )
 259
 260 -- | Do it flag is true
 261 ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 262 ifDOptM flag thing_inside = do { b <- doptM flag;
 263                                 if b then thing_inside else return () }
 264
 265 ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 266 ifXOptM flag thing_inside = do { b <- xoptM flag;
 267                                 if b then thing_inside else return () }
 268
 269 getGhcMode :: TcRnIf gbl lcl GhcMode
 270 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 271 \end{code}
 272
 273 \begin{code}
 274 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
 275 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
 276
 277 getEps :: TcRnIf gbl lcl ExternalPackageState
 278 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
 279
 280 -- | Update the external package state.  Returns the second result of the
 281 -- modifier function.
 282 --
 283 -- This is an atomic operation and forces evaluation of the modified EPS in
 284 -- order to avoid space leaks.
 285 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
 286           -> TcRnIf gbl lcl a
 287 updateEps upd_fn = do
 288   traceIf (text "updating EPS")
 289   eps_var <- getEpsVar
 290   atomicUpdMutVar' eps_var upd_fn
 291
 292 -- | Update the external package state.
 293 --
 294 -- This is an atomic operation and forces evaluation of the modified EPS in
 295 -- order to avoid space leaks.
 296 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
 297            -> TcRnIf gbl lcl ()
 298 updateEps_ upd_fn = do
 299   traceIf (text "updating EPS_")
 300   eps_var <- getEpsVar
 301   atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
 302
 303 getHpt :: TcRnIf gbl lcl HomePackageTable
 304 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
 305
 306 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
 307 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
 308                   ; return (eps, hsc_HPT env) }
 309 \end{code}
 310
 311 %************************************************************************
 312 %*                                                                      *
 313                 Unique supply
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 \begin{code}
 318 newMetaUnique :: TcM Unique
 319 -- The uniques for TcMetaTyVars are allocated specially
 320 -- in guaranteed linear order, starting at zero for each module
 321 newMetaUnique
 322  = do { env <- getLclEnv
 323       ; let meta_var = tcl_meta env
 324       ; uniq <- readMutVar meta_var
 325       ; writeMutVar meta_var (incrUnique uniq)
 326       ; return uniq }
 327
 328 newUnique :: TcRnIf gbl lcl Unique
 329 newUnique
 330  = do { env <- getEnv ;
 331         let { u_var = env_us env } ;
 332         us <- readMutVar u_var ;
 333         case takeUniqFromSupply us of { (uniq, us') -> do {
 334         writeMutVar u_var us' ;
 335         return $! uniq }}}
 336    -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
 337    -- a chain of unevaluated supplies behind.
 338    -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
 339    -- throw away one half of the new split supply.  This is safe because this
 340    -- is the only place we use that unique.  Using the other half of the split
 341    -- supply is safer, but slower.
 342
 343 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
 344 newUniqueSupply
 345  = do { env <- getEnv ;
 346         let { u_var = env_us env } ;
 347         us <- readMutVar u_var ;
 348         case splitUniqSupply us of { (us1,us2) -> do {
 349         writeMutVar u_var us1 ;
 350         return us2 }}}
 351
 352 newLocalName :: Name -> TcRnIf gbl lcl Name
 353 newLocalName name       -- Make a clone
 354   = do  { uniq <- newUnique
 355         ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) }
 356
 357 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
 358 newSysLocalIds fs tys
 359   = do  { us <- newUniqueSupply
 360         ; return (zipWith (mkSysLocal fs) (uniqsFromSupply us) tys) }
 361
 362 instance MonadUnique (IOEnv (Env gbl lcl)) where
 363         getUniqueM = newUnique
 364         getUniqueSupplyM = newUniqueSupply
 365 \end{code}
 366
 367
 368 %************************************************************************
 369 %*                                                                      *
 370                 Debugging
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 \begin{code}
 375 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
 376 newTcRef = newMutVar
 377
 378 readTcRef :: TcRef a -> TcRnIf gbl lcl a
 379 readTcRef = readMutVar
 380
 381 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
 382 writeTcRef = writeMutVar
 383
 384 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
 385 updTcRef = updMutVar
 386 \end{code}
 387
 388 %************************************************************************
 389 %*                                                                      *
 390                 Debugging
 391 %*                                                                      *
 392 %************************************************************************
 393
 394 \begin{code}
 395 traceTc :: String -> SDoc -> TcRn ()
 396 traceTc = traceTcN 1
 397
 398 traceTcN :: Int -> String -> SDoc -> TcRn ()
 399 traceTcN level herald doc
 400   | level <= opt_TraceLevel = traceOptTcRn Opt_D_dump_tc_trace $
 401                               hang (text herald) 2 doc
 402   | otherwise               = return ()
 403
 404 traceRn, traceSplice :: SDoc -> TcRn ()
 405 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
 406 traceSplice  = traceOptTcRn Opt_D_dump_splices
 407
 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 -- Conditionally add an error context
 784 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
 785 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
 786 maybeAddErrCtxt Nothing    thing_inside = thing_inside
 787
 788 popErrCtxt :: TcM a -> TcM a
 789 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 790
 791 getCtLoc :: orig -> TcM (CtLoc orig)
 792 getCtLoc origin
 793   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
 794          return (CtLoc origin loc (tcl_ctxt env)) }
 795
 796 setCtLoc :: CtLoc orig -> TcM a -> TcM a
 797 setCtLoc (CtLoc _ src_loc ctxt) thing_inside
 798   = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
 799 \end{code}
 800
 801 %************************************************************************
 802 %*                                                                      *
 803              Error message generation (type checker)
 804 %*                                                                      *
 805 %************************************************************************
 806
 807     The addErrTc functions add an error message, but do not cause failure.
 808     The 'M' variants pass a TidyEnv that has already been used to
 809     tidy up the message; we then use it to tidy the context messages
 810
 811 \begin{code}
 812 addErrTc :: Message -> TcM ()
 813 addErrTc err_msg = do { env0 <- tcInitTidyEnv
 814                       ; addErrTcM (env0, err_msg) }
 815
 816 addErrsTc :: [Message] -> TcM ()
 817 addErrsTc err_msgs = mapM_ addErrTc err_msgs
 818
 819 addErrTcM :: (TidyEnv, Message) -> TcM ()
 820 addErrTcM (tidy_env, err_msg)
 821   = do { ctxt <- getErrCtxt ;
 822          loc  <- getSrcSpanM ;
 823          add_err_tcm tidy_env err_msg loc ctxt }
 824 \end{code}
 825
 826 The failWith functions add an error message and cause failure
 827
 828 \begin{code}
 829 failWithTc :: Message -> TcM a               -- Add an error message and fail
 830 failWithTc err_msg
 831   = addErrTc err_msg >> failM
 832
 833 failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
 834 failWithTcM local_and_msg
 835   = addErrTcM local_and_msg >> failM
 836
 837 checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
 838 checkTc True  _   = return ()
 839 checkTc False err = failWithTc err
 840 \end{code}
 841
 842         Warnings have no 'M' variant, nor failure
 843
 844 \begin{code}
 845 addWarnTc :: Message -> TcM ()
 846 addWarnTc msg = do { env0 <- tcInitTidyEnv
 847                    ; addWarnTcM (env0, msg) }
 848
 849 addWarnTcM :: (TidyEnv, Message) -> TcM ()
 850 addWarnTcM (env0, msg)
 851  = do { ctxt <- getErrCtxt ;
 852         err_info <- mkErrInfo env0 ctxt ;
 853         addReport (ptext (sLit "Warning:") <+> msg) err_info }
 854
 855 warnTc :: Bool -> Message -> TcM ()
 856 warnTc warn_if_true warn_msg
 857   | warn_if_true = addWarnTc warn_msg
 858   | otherwise    = return ()
 859 \end{code}
 860
 861 -----------------------------------
 862          Tidying
 863
 864 We initialise the "tidy-env", used for tidying types before printing,
 865 by building a reverse map from the in-scope type variables to the
 866 OccName that the programmer originally used for them
 867
 868 \begin{code}
 869 tcInitTidyEnv :: TcM TidyEnv
 870 tcInitTidyEnv
 871   = do  { lcl_env <- getLclEnv
 872         ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
 873                           | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
 874                           , tcIsTyVarTy ty ]
 875         ; return (foldl add emptyTidyEnv nm_tv_prs) }
 876   where
 877     add (env,subst) (name, tyvar)
 878         = case tidyOccName env (nameOccName name) of
 879             (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
 880                 where
 881                   tyvar' = setTyVarName tyvar name'
 882                   name'  = tidyNameOcc name occ'
 883 \end{code}
 884
 885 -----------------------------------
 886         Other helper functions
 887
 888 \begin{code}
 889 add_err_tcm :: TidyEnv -> Message -> SrcSpan
 890             -> [ErrCtxt]
 891             -> TcM ()
 892 add_err_tcm tidy_env err_msg loc ctxt
 893  = do { err_info <- mkErrInfo tidy_env ctxt ;
 894         addLongErrAt loc err_msg err_info }
 895
 896 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
 897 -- Tidy the error info, trimming excessive contexts
 898 mkErrInfo env ctxts
 899  = go 0 env ctxts
 900  where
 901    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
 902    go _ _   [] = return empty
 903    go n env ((is_landmark, ctxt) : ctxts)
 904      | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
 905      = do { (env', msg) <- ctxt env
 906           ; let n' = if is_landmark then n else n+1
 907           ; rest <- go n' env' ctxts
 908           ; return (msg $$ rest) }
 909      | otherwise
 910      = go n env ctxts
 911
 912 mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
 913 mAX_CONTEXTS = 3
 914 \end{code}
 915
 916 debugTc is useful for monadic debugging code
 917
 918 \begin{code}
 919 debugTc :: TcM () -> TcM ()
 920 debugTc thing
 921  | debugIsOn = thing
 922  | otherwise = return ()
 923 \end{code}
 924
 925 %************************************************************************
 926 %*                                                                      *
 927              Type constraints
 928 %*                                                                      *
 929 %************************************************************************
 930
 931 \begin{code}
 932 newTcEvBinds :: TcM EvBindsVar
 933 newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
 934                   ; uniq <- newUnique
 935                   ; return (EvBindsVar ref uniq) }
 936
 937 extendTcEvBinds :: TcEvBinds -> EvVar -> EvTerm -> TcM TcEvBinds
 938 extendTcEvBinds binds@(TcEvBinds binds_var) var rhs
 939   = do { addTcEvBind binds_var var rhs
 940        ; return binds }
 941 extendTcEvBinds (EvBinds bnds) var rhs
 942   = return (EvBinds (bnds `snocBag` EvBind var rhs))
 943
 944 addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
 945 -- Add a binding to the TcEvBinds by side effect
 946 addTcEvBind (EvBindsVar ev_ref _) var rhs
 947   = do { bnds <- readTcRef ev_ref
 948        ; writeTcRef ev_ref (extendEvBinds bnds var rhs) }
 949
 950 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
 951 chooseUniqueOccTc fn =
 952   do { env <- getGblEnv
 953      ; let dfun_n_var = tcg_dfun_n env
 954      ; set <- readTcRef dfun_n_var
 955      ; let occ = fn set
 956      ; writeTcRef dfun_n_var (extendOccSet set occ)
 957      ; return occ }
 958
 959 getConstraintVar :: TcM (TcRef WantedConstraints)
 960 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
 961
 962 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
 963 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 964
 965 emitConstraints :: WantedConstraints -> TcM ()
 966 emitConstraints ct
 967   = do { lie_var <- getConstraintVar ;
 968          updTcRef lie_var (`andWanteds` ct) }
 969
 970 emitConstraint :: WantedConstraint -> TcM ()
 971 emitConstraint ct
 972   = do { lie_var <- getConstraintVar ;
 973          updTcRef lie_var (`extendWanteds` ct) }
 974
 975 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
 976 -- (captureConstraints m) runs m, and returns the type constraints it generates
 977 captureConstraints thing_inside
 978   = do { lie_var <- newTcRef emptyWanteds ;
 979          res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
 980                           thing_inside ;
 981          lie <- readTcRef lie_var ;
 982          return (res, lie) }
 983
 984 captureUntouchables :: TcM a -> TcM (a, Untouchables)
 985 captureUntouchables thing_inside
 986   = do { env <- getLclEnv
 987        ; low_meta <- readTcRef (tcl_meta env)
 988        ; res <- setLclEnv (env { tcl_untch = low_meta })
 989                 thing_inside
 990        ; high_meta <- readTcRef (tcl_meta env)
 991        ; return (res, TouchableRange low_meta high_meta) }
 992
 993 isUntouchable :: TcTyVar -> TcM Bool
 994 isUntouchable tv = do { env <- getLclEnv
 995                       ; return (varUnique tv < tcl_untch env) }
 996
 997 getLclTypeEnv :: TcM (NameEnv TcTyThing)
 998 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
 999
1000 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1001 -- Set the local type envt, but do *not* disturb other fields,
1002 -- notably the lie_var
1003 setLclTypeEnv lcl_env thing_inside
1004   = updLclEnv upd thing_inside
1005   where
1006     upd env = env { tcl_env = tcl_env lcl_env,
1007                     tcl_tyvars = tcl_tyvars lcl_env }
1008 \end{code}
1009
1010
1011 %************************************************************************
1012 %*                                                                      *
1013              Template Haskell context
1014 %*                                                                      *
1015 %************************************************************************
1016
1017 \begin{code}
1018 recordThUse :: TcM ()
1019 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1020
1021 keepAliveTc :: Id -> TcM ()     -- Record the name in the keep-alive set
1022 keepAliveTc id
1023   | isLocalId id = do { env <- getGblEnv;
1024                       ; updTcRef (tcg_keep env) (`addOneToNameSet` idName id) }
1025   | otherwise = return ()
1026
1027 keepAliveSetTc :: NameSet -> TcM ()     -- Record the name in the keep-alive set
1028 keepAliveSetTc ns = do { env <- getGblEnv;
1029                        ; updTcRef (tcg_keep env) (`unionNameSets` ns) }
1030
1031 getStage :: TcM ThStage
1032 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1033
1034 setStage :: ThStage -> TcM a -> TcM a
1035 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1036 \end{code}
1037
1038
1039 %************************************************************************
1040 %*                                                                      *
1041              Stuff for the renamer's local env
1042 %*                                                                      *
1043 %************************************************************************
1044
1045 \begin{code}
1046 getLocalRdrEnv :: RnM LocalRdrEnv
1047 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1048
1049 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1050 setLocalRdrEnv rdr_env thing_inside
1051   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1052 \end{code}
1053
1054
1055 %************************************************************************
1056 %*                                                                      *
1057              Stuff for interface decls
1058 %*                                                                      *
1059 %************************************************************************
1060
1061 \begin{code}
1062 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
1063 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
1064                                 if_loc     = loc,
1065                                 if_tv_env  = emptyUFM,
1066                                 if_id_env  = emptyUFM }
1067
1068 initIfaceTcRn :: IfG a -> TcRn a
1069 initIfaceTcRn thing_inside
1070   = do  { tcg_env <- getGblEnv
1071         ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
1072               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1073         ; setEnvs (if_env, ()) thing_inside }
1074
1075 initIfaceExtCore :: IfL a -> TcRn a
1076 initIfaceExtCore thing_inside
1077   = do  { tcg_env <- getGblEnv
1078         ; let { mod = tcg_mod tcg_env
1079               ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
1080               ; if_env = IfGblEnv {
1081                         if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
1082               ; if_lenv = mkIfLclEnv mod doc
1083           }
1084         ; setEnvs (if_env, if_lenv) thing_inside }
1085
1086 initIfaceCheck :: HscEnv -> IfG a -> IO a
1087 -- Used when checking the up-to-date-ness of the old Iface
1088 -- Initialise the environment with no useful info at all
1089 initIfaceCheck hsc_env do_this
1090  = do let rec_types = case hsc_type_env_var hsc_env of
1091                          Just (mod,var) -> Just (mod, readTcRef var)
1092                          Nothing        -> Nothing
1093           gbl_env = IfGblEnv { if_rec_types = rec_types }
1094       initTcRnIf 'i' hsc_env gbl_env () do_this
1095
1096 initIfaceTc :: ModIface
1097             -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
1098 -- Used when type-checking checking an up-to-date interface file
1099 -- No type envt from the current module, but we do know the module dependencies
1100 initIfaceTc iface do_this
1101  = do   { tc_env_var <- newTcRef emptyTypeEnv
1102         ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readTcRef tc_env_var) } ;
1103               ; if_lenv = mkIfLclEnv mod doc
1104            }
1105         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
1106     }
1107   where
1108     mod = mi_module iface
1109     doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
1110
1111 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
1112 -- Used when sucking in new Rules in SimplCore
1113 -- We have available the type envt of the module being compiled, and we must use it
1114 initIfaceRules hsc_env guts do_this
1115  = do   { let {
1116              type_info = (mg_module guts, return (mg_types guts))
1117            ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
1118            }
1119
1120         -- Run the thing; any exceptions just bubble out from here
1121         ; initTcRnIf 'i' hsc_env gbl_env () do_this
1122     }
1123
1124 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
1125 initIfaceLcl mod loc_doc thing_inside
1126   = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
1127
1128 getIfModule :: IfL Module
1129 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1130
1131 --------------------
1132 failIfM :: Message -> IfL a
1133 -- The Iface monad doesn't have a place to accumulate errors, so we
1134 -- just fall over fast if one happens; it "shouldnt happen".
1135 -- We use IfL here so that we can get context info out of the local env
1136 failIfM msg
1137   = do  { env <- getLclEnv
1138         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1139         ; liftIO (printErrs (full_msg defaultErrStyle))
1140         ; failM }
1141
1142 --------------------
1143 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1144 -- Run thing_inside in an interleaved thread.
1145 -- It shares everything with the parent thread, so this is DANGEROUS.
1146 --
1147 -- It returns Nothing if the computation fails
1148 --
1149 -- It's used for lazily type-checking interface
1150 -- signatures, which is pretty benign
1151
1152 forkM_maybe doc thing_inside
1153  = do { unsafeInterleaveM $
1154         do { traceIf (text "Starting fork {" <+> doc)
1155            ; mb_res <- tryM $
1156                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1157                        thing_inside
1158            ; case mb_res of
1159                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1160                                 ; return (Just r) }
1161                 Left exn -> do {
1162
1163                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1164                     -- Otherwise we silently discard errors. Errors can legitimately
1165                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1166                       ifDOptM Opt_D_dump_if_trace
1167                              (print_errs (hang (text "forkM failed:" <+> doc)
1168                                              2 (text (show exn))))
1169
1170                     ; traceIf (text "} ending fork (badly)" <+> doc)
1171                     ; return Nothing }
1172         }}
1173   where
1174     print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
1175
1176 forkM :: SDoc -> IfL a -> IfL a
1177 forkM doc thing_inside
1178  = do   { mb_res <- forkM_maybe doc thing_inside
1179         ; return (case mb_res of
1180                         Nothing -> pgmError "Cannot continue after interface file error"
1181                                    -- pprPanic "forkM" doc
1182                         Just r  -> r) }
1183 \end{code}