compiler/typecheck/TcRnMonad.lhs

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