compiler/typecheck/TcRnMonad.lhs

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