compiler/typecheck/TcRnMonad.lhs

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