compiler/typecheck/TcRnMonad.lhs

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