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