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