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