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