compiler/typecheck/TcRnMonad.lhs

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