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