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