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