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