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