compiler/typecheck/TcRnMonad.lhs

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