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