compiler/typecheck/TcRnMonad.lhs

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