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