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