compiler/typecheck/TcRnMonad.lhs

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