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