compiler/typecheck/TcRnMonad.lhs

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