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