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