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