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