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
  44 import System.IO
  45 import Data.IORef
  46 import Control.Exception
  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_deprecs  = NoDeprecs,
 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 \end{code}
 328
 329
 330 %************************************************************************
 331 %*                                                                      *
 332                 Debugging
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 \begin{code}
 337 traceTc, traceRn, traceSplice :: SDoc -> TcRn ()
 338 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
 339 traceTc      = traceOptTcRn Opt_D_dump_tc_trace
 340 traceSplice  = traceOptTcRn Opt_D_dump_splices
 341
 342
 343 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 344 traceIf      = traceOptIf Opt_D_dump_if_trace
 345 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
 346
 347
 348 traceOptIf :: DynFlag -> SDoc -> TcRnIf m n ()  -- No RdrEnv available, so qualify everything
 349 traceOptIf flag doc = ifOptM flag $
 350                       liftIO (printForUser stderr alwaysQualify doc)
 351
 352 traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
 353 traceOptTcRn flag doc = ifOptM flag $ do
 354                         { ctxt <- getErrCtxt
 355                         ; loc  <- getSrcSpanM
 356                         ; env0 <- tcInitTidyEnv
 357                         ; ctxt_msgs <- do_ctxt env0 ctxt
 358                         ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
 359                         ; dumpTcRn real_doc }
 360
 361 dumpTcRn :: SDoc -> TcRn ()
 362 dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
 363                     dflags <- getDOpts ;
 364                     liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
 365
 366 dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
 367 dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
 368 \end{code}
 369
 370
 371 %************************************************************************
 372 %*                                                                      *
 373                 Typechecker global environment
 374 %*                                                                      *
 375 %************************************************************************
 376
 377 \begin{code}
 378 getModule :: TcRn Module
 379 getModule = do { env <- getGblEnv; return (tcg_mod env) }
 380
 381 setModule :: Module -> TcRn a -> TcRn a
 382 setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
 383
 384 tcIsHsBoot :: TcRn Bool
 385 tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
 386
 387 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 388 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 389
 390 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
 391 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
 392
 393 getImports :: TcRn ImportAvails
 394 getImports = do { env <- getGblEnv; return (tcg_imports env) }
 395
 396 getFixityEnv :: TcRn FixityEnv
 397 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 398
 399 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
 400 extendFixityEnv new_bit
 401   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
 402                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
 403
 404 getRecFieldEnv :: TcRn RecFieldEnv
 405 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
 406
 407 extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a
 408 extendRecFieldEnv new_bit
 409   = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) ->
 410                 env {tcg_field_env = old_env `plusNameEnv` new_bit})
 411
 412 getDeclaredDefaultTys :: TcRn (Maybe [Type])
 413 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 414 \end{code}
 415
 416 %************************************************************************
 417 %*                                                                      *
 418                 Error management
 419 %*                                                                      *
 420 %************************************************************************
 421
 422 \begin{code}
 423 getSrcSpanM :: TcRn SrcSpan
 424         -- Avoid clash with Name.getSrcLoc
 425 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
 426
 427 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
 428 setSrcSpan loc thing_inside
 429   | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
 430   | otherwise         = thing_inside    -- Don't overwrite useful info with useless
 431
 432 addLocM :: (a -> TcM b) -> Located a -> TcM b
 433 addLocM fn (L loc a) = setSrcSpan loc $ fn a
 434
 435 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
 436 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
 437
 438 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
 439 wrapLocFstM fn (L loc a) =
 440   setSrcSpan loc $ do
 441     (b,c) <- fn a
 442     return (L loc b, c)
 443
 444 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
 445 wrapLocSndM fn (L loc a) =
 446   setSrcSpan loc $ do
 447     (b,c) <- fn a
 448     return (b, L loc c)
 449 \end{code}
 450
 451
 452 \begin{code}
 453 getErrsVar :: TcRn (TcRef Messages)
 454 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 455
 456 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 457 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 458
 459 addErr :: Message -> TcRn ()
 460 addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg }
 461
 462 addLocErr :: Located e -> (e -> Message) -> TcRn ()
 463 addLocErr (L loc e) fn = addErrAt loc (fn e)
 464
 465 addErrAt :: SrcSpan -> Message -> TcRn ()
 466 addErrAt loc msg = addLongErrAt loc msg empty
 467
 468 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
 469 addLongErrAt loc msg extra
 470   = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
 471          errs_var <- getErrsVar ;
 472          rdr_env <- getGlobalRdrEnv ;
 473          dflags <- getDOpts ;
 474          let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
 475          (warns, errs) <- readMutVar errs_var ;
 476          writeMutVar errs_var (warns, errs `snocBag` err) }
 477
 478 addErrs :: [(SrcSpan,Message)] -> TcRn ()
 479 addErrs msgs = mapM_ add msgs
 480              where
 481                add (loc,msg) = addErrAt loc msg
 482
 483 addReport :: Message -> TcRn ()
 484 addReport msg = do loc <- getSrcSpanM; addReportAt loc msg
 485
 486 addReportAt :: SrcSpan -> Message -> TcRn ()
 487 addReportAt loc msg
 488   = do { errs_var <- getErrsVar ;
 489          rdr_env <- getGlobalRdrEnv ;
 490          dflags <- getDOpts ;
 491          let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ;
 492          (warns, errs) <- readMutVar errs_var ;
 493          writeMutVar errs_var (warns `snocBag` warn, errs) }
 494
 495 addWarn :: Message -> TcRn ()
 496 addWarn msg = addReport (ptext (sLit "Warning:") <+> msg)
 497
 498 addWarnAt :: SrcSpan -> Message -> TcRn ()
 499 addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg)
 500
 501 addLocWarn :: Located e -> (e -> Message) -> TcRn ()
 502 addLocWarn (L loc e) fn = addReportAt loc (fn e)
 503
 504 checkErr :: Bool -> Message -> TcRn ()
 505 -- Add the error if the bool is False
 506 checkErr ok msg = unless ok (addErr msg)
 507
 508 warnIf :: Bool -> Message -> TcRn ()
 509 warnIf True  msg = addWarn msg
 510 warnIf False _   = return ()
 511
 512 addMessages :: Messages -> TcRn ()
 513 addMessages (m_warns, m_errs)
 514   = do { errs_var <- getErrsVar ;
 515          (warns, errs) <- readMutVar errs_var ;
 516          writeMutVar errs_var (warns `unionBags` m_warns,
 517                                errs  `unionBags` m_errs) }
 518
 519 discardWarnings :: TcRn a -> TcRn a
 520 -- Ignore warnings inside the thing inside;
 521 -- used to ignore-unused-variable warnings inside derived code
 522 -- With -dppr-debug, the effects is switched off, so you can still see
 523 -- what warnings derived code would give
 524 discardWarnings thing_inside
 525   | opt_PprStyle_Debug = thing_inside
 526   | otherwise
 527   = do  { errs_var <- newMutVar emptyMessages
 528         ; result <- setErrsVar errs_var thing_inside
 529         ; (_warns, errs) <- readMutVar errs_var
 530         ; addMessages (emptyBag, errs)
 531         ; return result }
 532 \end{code}
 533
 534
 535 \begin{code}
 536 try_m :: TcRn r -> TcRn (Either Exception r)
 537 -- Does try_m, with a debug-trace on failure
 538 try_m thing
 539   = do { mb_r <- tryM thing ;
 540          case mb_r of
 541              Left exn -> do { traceTc (exn_msg exn); return mb_r }
 542              Right _  -> return mb_r }
 543   where
 544     exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
 545
 546 -----------------------
 547 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
 548          -> TcRn r      -- Main action: do this first
 549          -> TcRn r
 550 -- Errors in 'thing' are retained
 551 recoverM recover thing
 552   = do { mb_res <- try_m thing ;
 553          case mb_res of
 554            Left _    -> recover
 555            Right res -> return res }
 556
 557
 558 -----------------------
 559 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
 560 -- Drop elements of the input that fail, so the result
 561 -- list can be shorter than the argument list
 562 mapAndRecoverM _ []     = return []
 563 mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x)
 564                              ; rs <- mapAndRecoverM f xs
 565                              ; return (case mb_r of
 566                                           Left _  -> rs
 567                                           Right r -> r:rs) }
 568
 569
 570 -----------------------
 571 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 572 -- (tryTc m) executes m, and returns
 573 --      Just r,  if m succeeds (returning r)
 574 --      Nothing, if m fails
 575 -- It also returns all the errors and warnings accumulated by m
 576 -- It always succeeds (never raises an exception)
 577 tryTc m
 578  = do { errs_var <- newMutVar emptyMessages ;
 579         res  <- try_m (setErrsVar errs_var m) ;
 580         msgs <- readMutVar errs_var ;
 581         return (msgs, case res of
 582                             Left _  -> Nothing
 583                             Right val -> Just val)
 584         -- The exception is always the IOEnv built-in
 585         -- in exception; see IOEnv.failM
 586    }
 587
 588 -----------------------
 589 tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
 590 -- Run the thing, returning
 591 --      Just r,  if m succceeds with no error messages
 592 --      Nothing, if m fails, or if it succeeds but has error messages
 593 -- Either way, the messages are returned; even in the Just case
 594 -- there might be warnings
 595 tryTcErrs thing
 596   = do  { (msgs, res) <- tryTc thing
 597         ; dflags <- getDOpts
 598         ; let errs_found = errorsFound dflags msgs
 599         ; return (msgs, case res of
 600                           Nothing -> Nothing
 601                           Just val | errs_found -> Nothing
 602                                    | otherwise  -> Just val)
 603         }
 604
 605 -----------------------
 606 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 607 -- Just like tryTcErrs, except that it ensures that the LIE
 608 -- for the thing is propagated only if there are no errors
 609 -- Hence it's restricted to the type-check monad
 610 tryTcLIE thing_inside
 611   = do  { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
 612         ; case mb_res of
 613             Nothing  -> return (msgs, Nothing)
 614             Just val -> do { extendLIEs lie; return (msgs, Just val) }
 615         }
 616
 617 -----------------------
 618 tryTcLIE_ :: TcM r -> TcM r -> TcM r
 619 -- (tryTcLIE_ r m) tries m;
 620 --      if m succeeds with no error messages, it's the answer
 621 --      otherwise tryTcLIE_ drops everything from m and tries r instead.
 622 tryTcLIE_ recover main
 623   = do  { (msgs, mb_res) <- tryTcLIE main
 624         ; case mb_res of
 625              Just val -> do { addMessages msgs  -- There might be warnings
 626                              ; return val }
 627              Nothing  -> recover                -- Discard all msgs
 628         }
 629
 630 -----------------------
 631 checkNoErrs :: TcM r -> TcM r
 632 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 633 -- If m fails then (checkNoErrsTc m) fails.
 634 -- If m succeeds, it checks whether m generated any errors messages
 635 --      (it might have recovered internally)
 636 --      If so, it fails too.
 637 -- Regardless, any errors generated by m are propagated to the enclosing context.
 638 checkNoErrs main
 639   = do  { (msgs, mb_res) <- tryTcLIE main
 640         ; addMessages msgs
 641         ; case mb_res of
 642             Nothing  -> failM
 643             Just val -> return val
 644         }
 645
 646 ifErrsM :: TcRn r -> TcRn r -> TcRn r
 647 --      ifErrsM bale_out main
 648 -- does 'bale_out' if there are errors in errors collection
 649 -- otherwise does 'main'
 650 ifErrsM bale_out normal
 651  = do { errs_var <- getErrsVar ;
 652         msgs <- readMutVar errs_var ;
 653         dflags <- getDOpts ;
 654         if errorsFound dflags msgs then
 655            bale_out
 656         else
 657            normal }
 658
 659 failIfErrsM :: TcRn ()
 660 -- Useful to avoid error cascades
 661 failIfErrsM = ifErrsM failM (return ())
 662 \end{code}
 663
 664
 665 %************************************************************************
 666 %*                                                                      *
 667         Context management and error message generation
 668                     for the type checker
 669 %*                                                                      *
 670 %************************************************************************
 671
 672 \begin{code}
 673 getErrCtxt :: TcM ErrCtxt
 674 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
 675
 676 setErrCtxt :: ErrCtxt -> TcM a -> TcM a
 677 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
 678
 679 addErrCtxt :: Message -> TcM a -> TcM a
 680 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
 681
 682 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
 683 addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
 684
 685 -- Helper function for the above
 686 updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
 687 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
 688                            env { tcl_ctxt = upd ctxt })
 689
 690 -- Conditionally add an error context
 691 maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
 692 maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
 693 maybeAddErrCtxt Nothing    thing_inside = thing_inside
 694
 695 popErrCtxt :: TcM a -> TcM a
 696 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 697
 698 getInstLoc :: InstOrigin -> TcM InstLoc
 699 getInstLoc origin
 700   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
 701          return (InstLoc origin loc (tcl_ctxt env)) }
 702
 703 addInstCtxt :: InstLoc -> TcM a -> TcM a
 704 -- Add the SrcSpan and context from the first Inst in the list
 705 --      (they all have similar locations)
 706 addInstCtxt (InstLoc _ src_loc ctxt) thing_inside
 707   = setSrcSpan src_loc (updCtxt (\_ -> ctxt) thing_inside)
 708 \end{code}
 709
 710     The addErrTc functions add an error message, but do not cause failure.
 711     The 'M' variants pass a TidyEnv that has already been used to
 712     tidy up the message; we then use it to tidy the context messages
 713
 714 \begin{code}
 715 addErrTc :: Message -> TcM ()
 716 addErrTc err_msg = do { env0 <- tcInitTidyEnv
 717                       ; addErrTcM (env0, err_msg) }
 718
 719 addErrsTc :: [Message] -> TcM ()
 720 addErrsTc err_msgs = mapM_ addErrTc err_msgs
 721
 722 addErrTcM :: (TidyEnv, Message) -> TcM ()
 723 addErrTcM (tidy_env, err_msg)
 724   = do { ctxt <- getErrCtxt ;
 725          loc  <- getSrcSpanM ;
 726          add_err_tcm tidy_env err_msg loc ctxt }
 727 \end{code}
 728
 729 The failWith functions add an error message and cause failure
 730
 731 \begin{code}
 732 failWithTc :: Message -> TcM a               -- Add an error message and fail
 733 failWithTc err_msg
 734   = addErrTc err_msg >> failM
 735
 736 failWithTcM :: (TidyEnv, Message) -> TcM a   -- Add an error message and fail
 737 failWithTcM local_and_msg
 738   = addErrTcM local_and_msg >> failM
 739
 740 checkTc :: Bool -> Message -> TcM ()         -- Check that the boolean is true
 741 checkTc True  _   = return ()
 742 checkTc False err = failWithTc err
 743 \end{code}
 744
 745         Warnings have no 'M' variant, nor failure
 746
 747 \begin{code}
 748 addWarnTc :: Message -> TcM ()
 749 addWarnTc msg = do { env0 <- tcInitTidyEnv
 750                    ; addWarnTcM (env0, msg) }
 751
 752 addWarnTcM :: (TidyEnv, Message) -> TcM ()
 753 addWarnTcM (env0, msg)
 754  = do { ctxt <- getErrCtxt ;
 755         ctxt_msgs <- do_ctxt env0 ctxt ;
 756         addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) }
 757
 758 warnTc :: Bool -> Message -> TcM ()
 759 warnTc warn_if_true warn_msg
 760   | warn_if_true = addWarnTc warn_msg
 761   | otherwise    = return ()
 762 \end{code}
 763
 764 -----------------------------------
 765          Tidying
 766
 767 We initialise the "tidy-env", used for tidying types before printing,
 768 by building a reverse map from the in-scope type variables to the
 769 OccName that the programmer originally used for them
 770
 771 \begin{code}
 772 tcInitTidyEnv :: TcM TidyEnv
 773 tcInitTidyEnv
 774   = do  { lcl_env <- getLclEnv
 775         ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
 776                           | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
 777                           , tcIsTyVarTy ty ]
 778         ; return (foldl add emptyTidyEnv nm_tv_prs) }
 779   where
 780     add (env,subst) (name, tyvar)
 781         = case tidyOccName env (nameOccName name) of
 782             (env', occ') ->  (env', extendVarEnv subst tyvar tyvar')
 783                 where
 784                   tyvar' = setTyVarName tyvar name'
 785                   name'  = tidyNameOcc name occ'
 786 \end{code}
 787
 788 -----------------------------------
 789         Other helper functions
 790
 791 \begin{code}
 792 add_err_tcm :: TidyEnv -> Message -> SrcSpan
 793             -> [TidyEnv -> TcM (TidyEnv, SDoc)]
 794             -> TcM ()
 795 add_err_tcm tidy_env err_msg loc ctxt
 796  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
 797         addLongErrAt loc err_msg (vcat (ctxt_to_use ctxt_msgs)) }
 798
 799 do_ctxt :: TidyEnv -> [TidyEnv -> TcM (TidyEnv, SDoc)] -> TcM [SDoc]
 800 do_ctxt _ []
 801  = return []
 802 do_ctxt tidy_env (c:cs)
 803  = do { (tidy_env', m) <- c tidy_env  ;
 804         ms             <- do_ctxt tidy_env' cs  ;
 805         return (m:ms) }
 806
 807 ctxt_to_use :: [SDoc] -> [SDoc]
 808 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
 809                  | otherwise          = take 3 ctxt
 810 \end{code}
 811
 812 debugTc is useful for monadic debugging code
 813
 814 \begin{code}
 815 debugTc :: TcM () -> TcM ()
 816 debugTc thing
 817  | debugIsOn = thing
 818  | otherwise = return ()
 819 \end{code}
 820
 821  %************************************************************************
 822 %*                                                                      *
 823              Type constraints (the so-called LIE)
 824 %*                                                                      *
 825 %************************************************************************
 826
 827 \begin{code}
 828 nextDFunIndex :: TcM Int        -- Get the next dfun index
 829 nextDFunIndex = do { env <- getGblEnv
 830                    ; let dfun_n_var = tcg_dfun_n env
 831                    ; n <- readMutVar dfun_n_var
 832                    ; writeMutVar dfun_n_var (n+1)
 833                    ; return n }
 834
 835 getLIEVar :: TcM (TcRef LIE)
 836 getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
 837
 838 setLIEVar :: TcRef LIE -> TcM a -> TcM a
 839 setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 840
 841 getLIE :: TcM a -> TcM (a, [Inst])
 842 -- (getLIE m) runs m, and returns the type constraints it generates
 843 getLIE thing_inside
 844   = do { lie_var <- newMutVar emptyLIE ;
 845          res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
 846                           thing_inside ;
 847          lie <- readMutVar lie_var ;
 848          return (res, lieToList lie) }
 849
 850 extendLIE :: Inst -> TcM ()
 851 extendLIE inst
 852   = do { lie_var <- getLIEVar ;
 853          lie <- readMutVar lie_var ;
 854          writeMutVar lie_var (inst `consLIE` lie) }
 855
 856 extendLIEs :: [Inst] -> TcM ()
 857 extendLIEs []
 858   = return ()
 859 extendLIEs insts
 860   = do { lie_var <- getLIEVar ;
 861          lie <- readMutVar lie_var ;
 862          writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
 863 \end{code}
 864
 865 \begin{code}
 866 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
 867 -- Set the local type envt, but do *not* disturb other fields,
 868 -- notably the lie_var
 869 setLclTypeEnv lcl_env thing_inside
 870   = updLclEnv upd thing_inside
 871   where
 872     upd env = env { tcl_env = tcl_env lcl_env,
 873                     tcl_tyvars = tcl_tyvars lcl_env }
 874 \end{code}
 875
 876
 877 %************************************************************************
 878 %*                                                                      *
 879              Template Haskell context
 880 %*                                                                      *
 881 %************************************************************************
 882
 883 \begin{code}
 884 recordThUse :: TcM ()
 885 recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
 886
 887 keepAliveTc :: Id -> TcM ()     -- Record the name in the keep-alive set
 888 keepAliveTc id
 889   | isLocalId id = do { env <- getGblEnv;
 890                       ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) }
 891   | otherwise = return ()
 892
 893 keepAliveSetTc :: NameSet -> TcM ()     -- Record the name in the keep-alive set
 894 keepAliveSetTc ns = do { env <- getGblEnv;
 895                        ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
 896
 897 getStage :: TcM ThStage
 898 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
 899
 900 setStage :: ThStage -> TcM a -> TcM a
 901 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
 902 \end{code}
 903
 904
 905 %************************************************************************
 906 %*                                                                      *
 907              Stuff for the renamer's local env
 908 %*                                                                      *
 909 %************************************************************************
 910
 911 \begin{code}
 912 getLocalRdrEnv :: RnM LocalRdrEnv
 913 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
 914
 915 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
 916 setLocalRdrEnv rdr_env thing_inside
 917   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
 918 \end{code}
 919
 920
 921 %************************************************************************
 922 %*                                                                      *
 923              Stuff for interface decls
 924 %*                                                                      *
 925 %************************************************************************
 926
 927 \begin{code}
 928 mkIfLclEnv :: Module -> SDoc -> IfLclEnv
 929 mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
 930                                 if_loc     = loc,
 931                                 if_tv_env  = emptyUFM,
 932                                 if_id_env  = emptyUFM }
 933
 934 initIfaceTcRn :: IfG a -> TcRn a
 935 initIfaceTcRn thing_inside
 936   = do  { tcg_env <- getGblEnv
 937         ; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
 938               ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
 939         ; setEnvs (if_env, ()) thing_inside }
 940
 941 initIfaceExtCore :: IfL a -> TcRn a
 942 initIfaceExtCore thing_inside
 943   = do  { tcg_env <- getGblEnv
 944         ; let { mod = tcg_mod tcg_env
 945               ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod)
 946               ; if_env = IfGblEnv {
 947                         if_rec_types = Just (mod, return (tcg_type_env tcg_env)) }
 948               ; if_lenv = mkIfLclEnv mod doc
 949           }
 950         ; setEnvs (if_env, if_lenv) thing_inside }
 951
 952 initIfaceCheck :: HscEnv -> IfG a -> IO a
 953 -- Used when checking the up-to-date-ness of the old Iface
 954 -- Initialise the environment with no useful info at all
 955 initIfaceCheck hsc_env do_this
 956  = do let rec_types = case hsc_type_env_var hsc_env of
 957                          Just (mod,var) -> Just (mod, readMutVar var)
 958                          Nothing        -> Nothing
 959           gbl_env = IfGblEnv { if_rec_types = rec_types }
 960       initTcRnIf 'i' hsc_env gbl_env () do_this
 961
 962 initIfaceTc :: ModIface
 963             -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl a
 964 -- Used when type-checking checking an up-to-date interface file
 965 -- No type envt from the current module, but we do know the module dependencies
 966 initIfaceTc iface do_this
 967  = do   { tc_env_var <- newMutVar emptyTypeEnv
 968         ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
 969               ; if_lenv = mkIfLclEnv mod doc
 970            }
 971         ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
 972     }
 973   where
 974     mod = mi_module iface
 975     doc = ptext (sLit "The interface for") <+> quotes (ppr mod)
 976
 977 initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
 978 -- Used when sucking in new Rules in SimplCore
 979 -- We have available the type envt of the module being compiled, and we must use it
 980 initIfaceRules hsc_env guts do_this
 981  = do   { let {
 982              type_info = (mg_module guts, return (mg_types guts))
 983            ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ;
 984            }
 985
 986         -- Run the thing; any exceptions just bubble out from here
 987         ; initTcRnIf 'i' hsc_env gbl_env () do_this
 988     }
 989
 990 initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a
 991 initIfaceLcl mod loc_doc thing_inside
 992   = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside
 993
 994 getIfModule :: IfL Module
 995 getIfModule = do { env <- getLclEnv; return (if_mod env) }
 996
 997 --------------------
 998 failIfM :: Message -> IfL a
 999 -- The Iface monad doesn't have a place to accumulate errors, so we
1000 -- just fall over fast if one happens; it "shouldnt happen".
1001 -- We use IfL here so that we can get context info out of the local env
1002 failIfM msg
1003   = do  { env <- getLclEnv
1004         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1005         ; liftIO (printErrs (full_msg defaultErrStyle))
1006         ; failM }
1007
1008 --------------------
1009 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1010 -- Run thing_inside in an interleaved thread.
1011 -- It shares everything with the parent thread, so this is DANGEROUS.
1012 --
1013 -- It returns Nothing if the computation fails
1014 --
1015 -- It's used for lazily type-checking interface
1016 -- signatures, which is pretty benign
1017
1018 forkM_maybe doc thing_inside
1019  = do { unsafeInterleaveM $
1020         do { traceIf (text "Starting fork {" <+> doc)
1021            ; mb_res <- tryM $
1022                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1023                        thing_inside
1024            ; case mb_res of
1025                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1026                                 ; return (Just r) }
1027                 Left exn -> do {
1028
1029                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1030                     -- Otherwise we silently discard errors. Errors can legitimately
1031                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1032                       ifOptM Opt_D_dump_if_trace
1033                              (print_errs (hang (text "forkM failed:" <+> doc)
1034                                              4 (text (show exn))))
1035
1036                     ; traceIf (text "} ending fork (badly)" <+> doc)
1037                     ; return Nothing }
1038         }}
1039   where
1040     print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
1041
1042 forkM :: SDoc -> IfL a -> IfL a
1043 forkM doc thing_inside
1044  = do   { mb_res <- forkM_maybe doc thing_inside
1045         ; return (case mb_res of
1046                         Nothing -> pgmError "Cannot continue after interface file error"
1047                                    -- pprPanic "forkM" doc
1048                         Just r  -> r) }
1049 \end{code}