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