compiler/typecheck/TcRnMonad.hs

   1 {-
   2 (c) The University of Glasgow 2006
   3
   4
   5 Functions for working with the typechecker environment (setters, getters...).
   6 -}
   7
   8 {-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10
  11 module TcRnMonad(
  12   -- * Initalisation
  13   initTc, initTcWithGbl, initTcInteractive, initTcForLookup, initTcRnIf,
  14
  15   -- * Simple accessors
  16   discardResult,
  17   getTopEnv, updTopEnv, getGblEnv, updGblEnv,
  18   setGblEnv, getLclEnv, updLclEnv, setLclEnv,
  19   getEnvs, setEnvs,
  20   xoptM, doptM, goptM, woptM,
  21   setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
  22   whenDOptM, whenGOptM, whenWOptM,
  23   whenXOptM, unlessXOptM,
  24   getGhcMode,
  25   withDoDynamicToo,
  26   getEpsVar,
  27   getEps,
  28   updateEps, updateEps_,
  29   getHpt, getEpsAndHpt,
  30
  31   -- * Arrow scopes
  32   newArrowScope, escapeArrowScope,
  33
  34   -- * Unique supply
  35   newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
  36   newSysName, newSysLocalId, newSysLocalIds,
  37
  38   -- * Accessing input/output
  39   newTcRef, readTcRef, writeTcRef, updTcRef,
  40
  41   -- * Debugging
  42   traceTc, traceRn, traceOptTcRn, traceTcRn,
  43   getPrintUnqualified,
  44   printForUserTcRn,
  45   traceIf, traceHiDiffs, traceOptIf,
  46   debugTc,
  47
  48   -- * Typechecker global environment
  49   getIsGHCi, getGHCiMonad, getInteractivePrintName,
  50   tcIsHsBootOrSig, tcSelfBootInfo, getGlobalRdrEnv,
  51   getRdrEnvs, getImports,
  52   getFixityEnv, extendFixityEnv, getRecFieldEnv,
  53   getDeclaredDefaultTys,
  54   addDependentFiles,
  55
  56   -- * Error management
  57   getSrcSpanM, setSrcSpan, addLocM,
  58   wrapLocM, wrapLocFstM, wrapLocSndM,
  59   getErrsVar, setErrsVar,
  60   addErr,
  61   failWith, failAt,
  62   addErrAt, addErrs,
  63   checkErr,
  64   addMessages,
  65   discardWarnings,
  66
  67   -- * Shared error message stuff: renamer and typechecker
  68   mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
  69   reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
  70   tryTc,
  71   askNoErrs, discardErrs, tryTcDiscardingErrs,
  72   checkNoErrs, whenNoErrs,
  73   ifErrsM, failIfErrsM,
  74   checkTH, failTH,
  75
  76   -- * Context management for the type checker
  77   getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
  78   addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
  79
  80   -- * Error message generation (type checker)
  81   addErrTc, addErrsTc,
  82   addErrTcM, mkErrTcM, mkErrTc,
  83   failWithTc, failWithTcM,
  84   checkTc, checkTcM,
  85   failIfTc, failIfTcM,
  86   warnIfFlag, warnIf, warnTc, warnTcM,
  87   addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
  88   tcInitTidyEnv, tcInitOpenTidyEnv, mkErrInfo,
  89
  90   -- * Type constraints
  91   newTcEvBinds,
  92   addTcEvBind,
  93   getTcEvTyCoVars, getTcEvBindsMap,
  94   chooseUniqueOccTc,
  95   getConstraintVar, setConstraintVar,
  96   emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
  97   emitImplication, emitImplications, emitInsoluble,
  98   discardConstraints, captureConstraints, tryCaptureConstraints,
  99   pushLevelAndCaptureConstraints,
 100   pushTcLevelM_, pushTcLevelM,
 101   getTcLevel, setTcLevel, isTouchableTcM,
 102   getLclTypeEnv, setLclTypeEnv,
 103   traceTcConstraints, emitWildCardHoleConstraints,
 104
 105   -- * Template Haskell context
 106   recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
 107   getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
 108   addModFinalizersWithLclEnv,
 109
 110   -- * Safe Haskell context
 111   recordUnsafeInfer, finalSafeMode, fixSafeInstances,
 112
 113   -- * Stuff for the renamer's local env
 114   getLocalRdrEnv, setLocalRdrEnv,
 115
 116   -- * Stuff for interface decls
 117   mkIfLclEnv,
 118   initIfaceTcRn,
 119   initIfaceCheck,
 120   initIfaceLcl,
 121   initIfaceLclWithSubst,
 122   initIfaceLoad,
 123   getIfModule,
 124   failIfM,
 125   forkM_maybe,
 126   forkM,
 127   setImplicitEnvM,
 128
 129   withException,
 130
 131   -- * Types etc.
 132   module TcRnTypes,
 133   module IOEnv
 134   ) where
 135
 136 #include "HsVersions.h"
 137
 138 import TcRnTypes        -- Re-export all
 139 import IOEnv            -- Re-export all
 140 import TcEvidence
 141
 142 import HsSyn hiding (LIE)
 143 import HscTypes
 144 import Module
 145 import RdrName
 146 import Name
 147 import Type
 148
 149 import TcType
 150 import InstEnv
 151 import FamInstEnv
 152 import PrelNames
 153
 154 import Id
 155 import VarSet
 156 import VarEnv
 157 import ErrUtils
 158 import SrcLoc
 159 import NameEnv
 160 import NameSet
 161 import Bag
 162 import Outputable
 163 import UniqSupply
 164 import DynFlags
 165 import FastString
 166 import Panic
 167 import Util
 168 import Annotations
 169 import BasicTypes( TopLevelFlag )
 170 import Maybes
 171
 172 import qualified GHC.LanguageExtensions as LangExt
 173
 174 import Control.Exception
 175 import Data.IORef
 176 import Control.Monad
 177 import Data.Set ( Set )
 178 import qualified Data.Set as Set
 179
 180 import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
 181 import qualified Data.Map as Map
 182
 183 {-
 184 ************************************************************************
 185 *                                                                      *
 186                         initTc
 187 *                                                                      *
 188 ************************************************************************
 189 -}
 190
 191 -- | Setup the initial typechecking environment
 192 initTc :: HscEnv
 193        -> HscSource
 194        -> Bool          -- True <=> retain renamed syntax trees
 195        -> Module
 196        -> RealSrcSpan
 197        -> TcM r
 198        -> IO (Messages, Maybe r)
 199                 -- Nothing => error thrown by the thing inside
 200                 -- (error messages should have been printed already)
 201
 202 initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 203  = do { keep_var     <- newIORef emptyNameSet ;
 204         used_gre_var <- newIORef [] ;
 205         th_var       <- newIORef False ;
 206         th_splice_var<- newIORef False ;
 207         th_locs_var  <- newIORef Set.empty ;
 208         infer_var    <- newIORef (True, emptyBag) ;
 209         dfun_n_var   <- newIORef emptyOccSet ;
 210         type_env_var <- case hsc_type_env_var hsc_env of {
 211                            Just (_mod, te_var) -> return te_var ;
 212                            Nothing             -> newIORef emptyNameEnv } ;
 213
 214         dependent_files_var <- newIORef [] ;
 215         static_wc_var       <- newIORef emptyWC ;
 216         th_topdecls_var      <- newIORef [] ;
 217         th_foreign_files_var <- newIORef [] ;
 218         th_topnames_var      <- newIORef emptyNameSet ;
 219         th_modfinalizers_var <- newIORef [] ;
 220         th_state_var         <- newIORef Map.empty ;
 221         th_remote_state_var  <- newIORef Nothing ;
 222         let {
 223              dflags = hsc_dflags hsc_env ;
 224
 225              maybe_rn_syntax :: forall a. a -> Maybe a ;
 226              maybe_rn_syntax empty_val
 227                 | keep_rn_syntax = Just empty_val
 228                 | otherwise      = Nothing ;
 229
 230              gbl_env = TcGblEnv {
 231                 tcg_th_topdecls      = th_topdecls_var,
 232                 tcg_th_foreign_files = th_foreign_files_var,
 233                 tcg_th_topnames      = th_topnames_var,
 234                 tcg_th_modfinalizers = th_modfinalizers_var,
 235                 tcg_th_state         = th_state_var,
 236                 tcg_th_remote_state  = th_remote_state_var,
 237
 238                 tcg_mod            = mod,
 239                 tcg_semantic_mod   =
 240                     if thisPackage dflags == moduleUnitId mod
 241                         then canonicalizeHomeModule dflags (moduleName mod)
 242                         else mod,
 243                 tcg_src            = hsc_src,
 244                 tcg_rdr_env        = emptyGlobalRdrEnv,
 245                 tcg_fix_env        = emptyNameEnv,
 246                 tcg_field_env      = emptyNameEnv,
 247                 tcg_default        = if moduleUnitId mod == primUnitId
 248                                      then Just []  -- See Note [Default types]
 249                                      else Nothing,
 250                 tcg_type_env       = emptyNameEnv,
 251                 tcg_type_env_var   = type_env_var,
 252                 tcg_inst_env       = emptyInstEnv,
 253                 tcg_fam_inst_env   = emptyFamInstEnv,
 254                 tcg_pending_fam_checks = emptyNameEnv,
 255                 tcg_ann_env        = emptyAnnEnv,
 256                 tcg_th_used        = th_var,
 257                 tcg_th_splice_used = th_splice_var,
 258                 tcg_th_top_level_locs
 259                                    = th_locs_var,
 260                 tcg_exports        = [],
 261                 tcg_imports        = emptyImportAvails,
 262                 tcg_used_gres     = used_gre_var,
 263                 tcg_dus            = emptyDUs,
 264
 265                 tcg_rn_imports     = [],
 266                 tcg_rn_exports     =
 267                     if hsc_src == HsigFile
 268                         -- Always retain renamed syntax, so that we can give
 269                         -- better errors.  (TODO: how?)
 270                         then Just []
 271                         else maybe_rn_syntax [],
 272                 tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
 273                 tcg_tr_module      = Nothing,
 274                 tcg_binds          = emptyLHsBinds,
 275                 tcg_imp_specs      = [],
 276                 tcg_sigs           = emptyNameSet,
 277                 tcg_ev_binds       = emptyBag,
 278                 tcg_warns          = NoWarnings,
 279                 tcg_anns           = [],
 280                 tcg_tcs            = [],
 281                 tcg_insts          = [],
 282                 tcg_fam_insts      = [],
 283                 tcg_rules          = [],
 284                 tcg_fords          = [],
 285                 tcg_vects          = [],
 286                 tcg_patsyns        = [],
 287                 tcg_merged         = [],
 288                 tcg_dfun_n         = dfun_n_var,
 289                 tcg_keep           = keep_var,
 290                 tcg_doc_hdr        = Nothing,
 291                 tcg_hpc            = False,
 292                 tcg_main           = Nothing,
 293                 tcg_self_boot      = NoSelfBoot,
 294                 tcg_safeInfer      = infer_var,
 295                 tcg_dependent_files = dependent_files_var,
 296                 tcg_tc_plugins     = [],
 297                 tcg_top_loc        = loc,
 298                 tcg_static_wc      = static_wc_var,
 299                 tcg_complete_matches = []
 300              } ;
 301         } ;
 302
 303         -- OK, here's the business end!
 304         initTcWithGbl hsc_env gbl_env loc do_this
 305     }
 306
 307 -- | Run a 'TcM' action in the context of an existing 'GblEnv'.
 308 initTcWithGbl :: HscEnv
 309               -> TcGblEnv
 310               -> RealSrcSpan
 311               -> TcM r
 312               -> IO (Messages, Maybe r)
 313 initTcWithGbl hsc_env gbl_env loc do_this
 314  = do { tvs_var      <- newIORef emptyVarSet
 315       ; lie_var      <- newIORef emptyWC
 316       ; errs_var     <- newIORef (emptyBag, emptyBag)
 317       ; let lcl_env = TcLclEnv {
 318                 tcl_errs       = errs_var,
 319                 tcl_loc        = loc,     -- Should be over-ridden very soon!
 320                 tcl_ctxt       = [],
 321                 tcl_rdr        = emptyLocalRdrEnv,
 322                 tcl_th_ctxt    = topStage,
 323                 tcl_th_bndrs   = emptyNameEnv,
 324                 tcl_arrow_ctxt = NoArrowCtxt,
 325                 tcl_env        = emptyNameEnv,
 326                 tcl_bndrs      = [],
 327                 tcl_tidy       = emptyTidyEnv,
 328                 tcl_tyvars     = tvs_var,
 329                 tcl_lie        = lie_var,
 330                 tcl_tclvl      = topTcLevel
 331                 }
 332
 333       ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
 334                      do { r <- tryM do_this
 335                         ; case r of
 336                           Right res -> return (Just res)
 337                           Left _    -> return Nothing }
 338
 339       -- Check for unsolved constraints
 340       -- If we succeed (maybe_res = Just r), there should be
 341       -- no unsolved constraints.  But if we exit via an
 342       -- exception (maybe_res = Nothing), we may have skipped
 343       -- solving, so don't panic then (Trac #13466)
 344       ; lie <- readIORef (tcl_lie lcl_env)
 345       ; when (isJust maybe_res && not (isEmptyWC lie)) $
 346         pprPanic "initTc: unsolved constraints" (ppr lie)
 347
 348         -- Collect any error messages
 349       ; msgs <- readIORef (tcl_errs lcl_env)
 350
 351       ; let { final_res | errorsFound dflags msgs = Nothing
 352                         | otherwise               = maybe_res }
 353
 354       ; return (msgs, final_res)
 355       }
 356   where dflags = hsc_dflags hsc_env
 357
 358 initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
 359 -- Initialise the type checker monad for use in GHCi
 360 initTcInteractive hsc_env thing_inside
 361   = initTc hsc_env HsSrcFile False
 362            (icInteractiveModule (hsc_IC hsc_env))
 363            (realSrcLocSpan interactive_src_loc)
 364            thing_inside
 365   where
 366     interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
 367
 368 initTcForLookup :: HscEnv -> TcM a -> IO a
 369 -- The thing_inside is just going to look up something
 370 -- in the environment, so we don't need much setup
 371 initTcForLookup hsc_env thing_inside
 372   = do { (msgs, m) <- initTcInteractive hsc_env thing_inside
 373        ; case m of
 374              Nothing -> throwIO $ mkSrcErr $ snd msgs
 375              Just x -> return x }
 376
 377 {- Note [Default types]
 378 ~~~~~~~~~~~~~~~~~~~~~~~
 379 The Integer type is simply not available in package ghc-prim (it is
 380 declared in integer-gmp).  So we set the defaulting types to (Just
 381 []), meaning there are no default types, rather then Nothing, which
 382 means "use the default default types of Integer, Double".
 383
 384 If you don't do this, attempted defaulting in package ghc-prim causes
 385 an actual crash (attempting to look up the Integer type).
 386
 387
 388 ************************************************************************
 389 *                                                                      *
 390                 Initialisation
 391 *                                                                      *
 392 ************************************************************************
 393 -}
 394
 395 initTcRnIf :: Char              -- Tag for unique supply
 396            -> HscEnv
 397            -> gbl -> lcl
 398            -> TcRnIf gbl lcl a
 399            -> IO a
 400 initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
 401    = do { us     <- mkSplitUniqSupply uniq_tag ;
 402         ; us_var <- newIORef us ;
 403
 404         ; let { env = Env { env_top = hsc_env,
 405                             env_us  = us_var,
 406                             env_gbl = gbl_env,
 407                             env_lcl = lcl_env} }
 408
 409         ; runIOEnv env thing_inside
 410         }
 411
 412 {-
 413 ************************************************************************
 414 *                                                                      *
 415                 Simple accessors
 416 *                                                                      *
 417 ************************************************************************
 418 -}
 419
 420 discardResult :: TcM a -> TcM ()
 421 discardResult a = a >> return ()
 422
 423 getTopEnv :: TcRnIf gbl lcl HscEnv
 424 getTopEnv = do { env <- getEnv; return (env_top env) }
 425
 426 updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 427 updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
 428                           env { env_top = upd top })
 429
 430 getGblEnv :: TcRnIf gbl lcl gbl
 431 getGblEnv = do { env <- getEnv; return (env_gbl env) }
 432
 433 updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 434 updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
 435                           env { env_gbl = upd gbl })
 436
 437 setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 438 setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
 439
 440 getLclEnv :: TcRnIf gbl lcl lcl
 441 getLclEnv = do { env <- getEnv; return (env_lcl env) }
 442
 443 updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 444 updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
 445                           env { env_lcl = upd lcl })
 446
 447 setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
 448 setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
 449
 450 getEnvs :: TcRnIf gbl lcl (gbl, lcl)
 451 getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
 452
 453 setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
 454 setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
 455
 456 -- Command-line flags
 457
 458 xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
 459 xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
 460
 461 doptM :: DumpFlag -> TcRnIf gbl lcl Bool
 462 doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
 463
 464 goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
 465 goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
 466
 467 woptM :: WarningFlag -> TcRnIf gbl lcl Bool
 468 woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
 469
 470 setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 471 setXOptM flag =
 472   updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
 473
 474 unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 475 unsetXOptM flag =
 476   updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})
 477
 478 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 479 unsetGOptM flag =
 480   updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
 481
 482 unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 483 unsetWOptM flag =
 484   updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
 485
 486 -- | Do it flag is true
 487 whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 488 whenDOptM flag thing_inside = do b <- doptM flag
 489                                  when b thing_inside
 490
 491 whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 492 whenGOptM flag thing_inside = do b <- goptM flag
 493                                  when b thing_inside
 494
 495 whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 496 whenWOptM flag thing_inside = do b <- woptM flag
 497                                  when b thing_inside
 498
 499 whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 500 whenXOptM flag thing_inside = do b <- xoptM flag
 501                                  when b thing_inside
 502
 503 unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
 504 unlessXOptM flag thing_inside = do b <- xoptM flag
 505                                    unless b thing_inside
 506
 507 getGhcMode :: TcRnIf gbl lcl GhcMode
 508 getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 509
 510 withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 511 withDoDynamicToo =
 512   updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
 513               top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
 514
 515 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
 516 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
 517
 518 getEps :: TcRnIf gbl lcl ExternalPackageState
 519 getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
 520
 521 -- | Update the external package state.  Returns the second result of the
 522 -- modifier function.
 523 --
 524 -- This is an atomic operation and forces evaluation of the modified EPS in
 525 -- order to avoid space leaks.
 526 updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
 527           -> TcRnIf gbl lcl a
 528 updateEps upd_fn = do
 529   traceIf (text "updating EPS")
 530   eps_var <- getEpsVar
 531   atomicUpdMutVar' eps_var upd_fn
 532
 533 -- | Update the external package state.
 534 --
 535 -- This is an atomic operation and forces evaluation of the modified EPS in
 536 -- order to avoid space leaks.
 537 updateEps_ :: (ExternalPackageState -> ExternalPackageState)
 538            -> TcRnIf gbl lcl ()
 539 updateEps_ upd_fn = do
 540   traceIf (text "updating EPS_")
 541   eps_var <- getEpsVar
 542   atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
 543
 544 getHpt :: TcRnIf gbl lcl HomePackageTable
 545 getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
 546
 547 getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
 548 getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
 549                   ; return (eps, hsc_HPT env) }
 550
 551 -- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing
 552 -- an exception if it is an error.
 553 withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a
 554 withException do_this = do
 555     r <- do_this
 556     dflags <- getDynFlags
 557     case r of
 558         Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
 559         Succeeded result -> return result
 560
 561 {-
 562 ************************************************************************
 563 *                                                                      *
 564                 Arrow scopes
 565 *                                                                      *
 566 ************************************************************************
 567 -}
 568
 569 newArrowScope :: TcM a -> TcM a
 570 newArrowScope
 571   = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
 572
 573 -- Return to the stored environment (from the enclosing proc)
 574 escapeArrowScope :: TcM a -> TcM a
 575 escapeArrowScope
 576   = updLclEnv $ \ env ->
 577     case tcl_arrow_ctxt env of
 578       NoArrowCtxt       -> env
 579       ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
 580                                    , tcl_lie = lie
 581                                    , tcl_rdr = rdr_env }
 582
 583 {-
 584 ************************************************************************
 585 *                                                                      *
 586                 Unique supply
 587 *                                                                      *
 588 ************************************************************************
 589 -}
 590
 591 newUnique :: TcRnIf gbl lcl Unique
 592 newUnique
 593  = do { env <- getEnv ;
 594         let { u_var = env_us env } ;
 595         us <- readMutVar u_var ;
 596         case takeUniqFromSupply us of { (uniq, us') -> do {
 597         writeMutVar u_var us' ;
 598         return $! uniq }}}
 599    -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
 600    -- a chain of unevaluated supplies behind.
 601    -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
 602    -- throw away one half of the new split supply.  This is safe because this
 603    -- is the only place we use that unique.  Using the other half of the split
 604    -- supply is safer, but slower.
 605
 606 newUniqueSupply :: TcRnIf gbl lcl UniqSupply
 607 newUniqueSupply
 608  = do { env <- getEnv ;
 609         let { u_var = env_us env } ;
 610         us <- readMutVar u_var ;
 611         case splitUniqSupply us of { (us1,us2) -> do {
 612         writeMutVar u_var us1 ;
 613         return us2 }}}
 614
 615 cloneLocalName :: Name -> TcM Name
 616 -- Make a fresh Internal name with the same OccName and SrcSpan
 617 cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
 618
 619 newName :: OccName -> TcM Name
 620 newName occ = do { loc  <- getSrcSpanM
 621                  ; newNameAt occ loc }
 622
 623 newNameAt :: OccName -> SrcSpan -> TcM Name
 624 newNameAt occ span
 625   = do { uniq <- newUnique
 626        ; return (mkInternalName uniq occ span) }
 627
 628 newSysName :: OccName -> TcRnIf gbl lcl Name
 629 newSysName occ
 630   = do { uniq <- newUnique
 631        ; return (mkSystemName uniq occ) }
 632
 633 newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
 634 newSysLocalId fs ty
 635   = do  { u <- newUnique
 636         ; return (mkSysLocalOrCoVar fs u ty) }
 637
 638 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
 639 newSysLocalIds fs tys
 640   = do  { us <- newUniqueSupply
 641         ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
 642
 643 instance MonadUnique (IOEnv (Env gbl lcl)) where
 644         getUniqueM = newUnique
 645         getUniqueSupplyM = newUniqueSupply
 646
 647 {-
 648 ************************************************************************
 649 *                                                                      *
 650                 Accessing input/output
 651 *                                                                      *
 652 ************************************************************************
 653 -}
 654
 655 newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
 656 newTcRef = newMutVar
 657
 658 readTcRef :: TcRef a -> TcRnIf gbl lcl a
 659 readTcRef = readMutVar
 660
 661 writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
 662 writeTcRef = writeMutVar
 663
 664 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
 665 -- Returns ()
 666 updTcRef ref fn = liftIO $ do { old <- readIORef ref
 667                               ; writeIORef ref (fn old) }
 668
 669 {-
 670 ************************************************************************
 671 *                                                                      *
 672                 Debugging
 673 *                                                                      *
 674 ************************************************************************
 675 -}
 676
 677
 678 -- Typechecker trace
 679 traceTc :: String -> SDoc -> TcRn ()
 680 traceTc =
 681   labelledTraceOptTcRn Opt_D_dump_tc_trace
 682
 683 -- Renamer Trace
 684 traceRn :: String -> SDoc -> TcRn ()
 685 traceRn =
 686   labelledTraceOptTcRn Opt_D_dump_rn_trace
 687
 688 -- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
 689 -- but accepts a string as a label and formats the trace message uniformly.
 690 labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
 691 labelledTraceOptTcRn flag herald doc = do
 692    traceOptTcRn flag (formatTraceMsg herald doc)
 693
 694 formatTraceMsg :: String -> SDoc -> SDoc
 695 formatTraceMsg herald doc = hang (text herald) 2 doc
 696
 697 -- | Output a doc if the given 'DumpFlag' is set.
 698 --
 699 -- By default this logs to stdout
 700 -- However, if the `-ddump-to-file` flag is set,
 701 -- then this will dump output to a file
 702 --
 703 -- Just a wrapper for 'dumpSDoc'
 704 traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
 705 traceOptTcRn flag doc
 706   = do { dflags <- getDynFlags
 707        ; when (dopt flag dflags)
 708               (traceTcRn flag doc)
 709        }
 710
 711
 712 traceTcRn :: DumpFlag -> SDoc -> TcRn ()
 713 -- ^ Unconditionally dump some trace output
 714 --
 715 -- The DumpFlag is used only to set the output filename
 716 -- for --dump-to-file, not to decide whether or not to output
 717 -- That part is done by the caller
 718 traceTcRn flag doc
 719   = do { dflags   <- getDynFlags
 720        ; real_doc <- prettyDoc dflags doc
 721        ; printer  <- getPrintUnqualified dflags
 722        ; liftIO $ dumpSDoc dflags printer flag "" real_doc  }
 723   where
 724     -- Add current location if -dppr-debug
 725     prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
 726     prettyDoc dflags doc = if hasPprDebug dflags
 727        then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
 728        else return doc -- The full location is usually way too much
 729
 730
 731 getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
 732 getPrintUnqualified dflags
 733   = do { rdr_env <- getGlobalRdrEnv
 734        ; return $ mkPrintUnqualified dflags rdr_env }
 735
 736 -- | Like logInfoTcRn, but for user consumption
 737 printForUserTcRn :: SDoc -> TcRn ()
 738 printForUserTcRn doc
 739   = do { dflags <- getDynFlags
 740        ; printer <- getPrintUnqualified dflags
 741        ; liftIO (printOutputForUser dflags printer doc) }
 742
 743 {-
 744 traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
 745 available.  Alas, they behave inconsistently with the other stuff;
 746 e.g. are unaffected by -dump-to-file.
 747 -}
 748
 749 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 750 traceIf      = traceOptIf Opt_D_dump_if_trace
 751 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
 752
 753
 754 traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
 755 traceOptIf flag doc
 756   = whenDOptM flag $    -- No RdrEnv available, so qualify everything
 757     do { dflags <- getDynFlags
 758        ; liftIO (putMsg dflags doc) }
 759
 760 {-
 761 ************************************************************************
 762 *                                                                      *
 763                 Typechecker global environment
 764 *                                                                      *
 765 ************************************************************************
 766 -}
 767
 768 getIsGHCi :: TcRn Bool
 769 getIsGHCi = do { mod <- getModule
 770                ; return (isInteractiveModule mod) }
 771
 772 getGHCiMonad :: TcRn Name
 773 getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
 774
 775 getInteractivePrintName :: TcRn Name
 776 getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
 777
 778 tcIsHsBootOrSig :: TcRn Bool
 779 tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
 780
 781 tcSelfBootInfo :: TcRn SelfBootInfo
 782 tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
 783
 784 getGlobalRdrEnv :: TcRn GlobalRdrEnv
 785 getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
 786
 787 getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
 788 getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
 789
 790 getImports :: TcRn ImportAvails
 791 getImports = do { env <- getGblEnv; return (tcg_imports env) }
 792
 793 getFixityEnv :: TcRn FixityEnv
 794 getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
 795
 796 extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
 797 extendFixityEnv new_bit
 798   = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
 799                 env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
 800
 801 getRecFieldEnv :: TcRn RecFieldEnv
 802 getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
 803
 804 getDeclaredDefaultTys :: TcRn (Maybe [Type])
 805 getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
 806
 807 addDependentFiles :: [FilePath] -> TcRn ()
 808 addDependentFiles fs = do
 809   ref <- fmap tcg_dependent_files getGblEnv
 810   dep_files <- readTcRef ref
 811   writeTcRef ref (fs ++ dep_files)
 812
 813 {-
 814 ************************************************************************
 815 *                                                                      *
 816                 Error management
 817 *                                                                      *
 818 ************************************************************************
 819 -}
 820
 821 getSrcSpanM :: TcRn SrcSpan
 822         -- Avoid clash with Name.getSrcLoc
 823 getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
 824
 825 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
 826 setSrcSpan (RealSrcSpan real_loc) thing_inside
 827     = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
 828 -- Don't overwrite useful info with useless:
 829 setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
 830
 831 addLocM :: (a -> TcM b) -> Located a -> TcM b
 832 addLocM fn (L loc a) = setSrcSpan loc $ fn a
 833
 834 wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
 835 wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
 836
 837 wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
 838 wrapLocFstM fn (L loc a) =
 839   setSrcSpan loc $ do
 840     (b,c) <- fn a
 841     return (L loc b, c)
 842
 843 wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c)
 844 wrapLocSndM fn (L loc a) =
 845   setSrcSpan loc $ do
 846     (b,c) <- fn a
 847     return (b, L loc c)
 848
 849 -- Reporting errors
 850
 851 getErrsVar :: TcRn (TcRef Messages)
 852 getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
 853
 854 setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
 855 setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
 856
 857 addErr :: MsgDoc -> TcRn ()
 858 addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
 859
 860 failWith :: MsgDoc -> TcRn a
 861 failWith msg = addErr msg >> failM
 862
 863 failAt :: SrcSpan -> MsgDoc -> TcRn a
 864 failAt loc msg = addErrAt loc msg >> failM
 865
 866 addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
 867 -- addErrAt is mainly (exclusively?) used by the renamer, where
 868 -- tidying is not an issue, but it's all lazy so the extra
 869 -- work doesn't matter
 870 addErrAt loc msg = do { ctxt <- getErrCtxt
 871                       ; tidy_env <- tcInitTidyEnv
 872                       ; err_info <- mkErrInfo tidy_env ctxt
 873                       ; addLongErrAt loc msg err_info }
 874
 875 addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
 876 addErrs msgs = mapM_ add msgs
 877              where
 878                add (loc,msg) = addErrAt loc msg
 879
 880 checkErr :: Bool -> MsgDoc -> TcRn ()
 881 -- Add the error if the bool is False
 882 checkErr ok msg = unless ok (addErr msg)
 883
 884 addMessages :: Messages -> TcRn ()
 885 addMessages msgs1
 886   = do { errs_var <- getErrsVar ;
 887          msgs0 <- readTcRef errs_var ;
 888          writeTcRef errs_var (unionMessages msgs0 msgs1) }
 889
 890 discardWarnings :: TcRn a -> TcRn a
 891 -- Ignore warnings inside the thing inside;
 892 -- used to ignore-unused-variable warnings inside derived code
 893 discardWarnings thing_inside
 894   = do  { errs_var <- getErrsVar
 895         ; (old_warns, _) <- readTcRef errs_var
 896
 897         ; result <- thing_inside
 898
 899         -- Revert warnings to old_warns
 900         ; (_new_warns, new_errs) <- readTcRef errs_var
 901         ; writeTcRef errs_var (old_warns, new_errs)
 902
 903         ; return result }
 904
 905 {-
 906 ************************************************************************
 907 *                                                                      *
 908         Shared error message stuff: renamer and typechecker
 909 *                                                                      *
 910 ************************************************************************
 911 -}
 912
 913 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
 914 mkLongErrAt loc msg extra
 915   = do { dflags <- getDynFlags ;
 916          printer <- getPrintUnqualified dflags ;
 917          return $ mkLongErrMsg dflags loc printer msg extra }
 918
 919 mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
 920 mkErrDocAt loc errDoc
 921   = do { dflags <- getDynFlags ;
 922          printer <- getPrintUnqualified dflags ;
 923          return $ mkErrDoc dflags loc printer errDoc }
 924
 925 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 926 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
 927
 928 reportErrors :: [ErrMsg] -> TcM ()
 929 reportErrors = mapM_ reportError
 930
 931 reportError :: ErrMsg -> TcRn ()
 932 reportError err
 933   = do { traceTc "Adding error:" (pprLocErrMsg err) ;
 934          errs_var <- getErrsVar ;
 935          (warns, errs) <- readTcRef errs_var ;
 936          writeTcRef errs_var (warns, errs `snocBag` err) }
 937
 938 reportWarning :: WarnReason -> ErrMsg -> TcRn ()
 939 reportWarning reason err
 940   = do { let warn = makeIntoWarning reason err
 941                     -- 'err' was built by mkLongErrMsg or something like that,
 942                     -- so it's of error severity.  For a warning we downgrade
 943                     -- its severity to SevWarning
 944
 945        ; traceTc "Adding warning:" (pprLocErrMsg warn)
 946        ; errs_var <- getErrsVar
 947        ; (warns, errs) <- readTcRef errs_var
 948        ; writeTcRef errs_var (warns `snocBag` warn, errs) }
 949
 950 try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 951 -- Does tryM, with a debug-trace on failure
 952 try_m thing
 953   = do { (mb_r, lie) <- tryCaptureConstraints thing
 954        ; emitConstraints lie
 955
 956        -- Debug trace
 957        ; case mb_r of
 958             Left exn -> traceTc "tryTc/recoverM recovering from" $
 959                         text (showException exn)
 960             Right {} -> return ()
 961
 962        ; return mb_r }
 963
 964 -----------------------
 965 recoverM :: TcRn r      -- Recovery action; do this if the main one fails
 966          -> TcRn r      -- Main action: do this first;
 967                         --  if it generates errors, propagate them all
 968          -> TcRn r
 969 -- Errors in 'thing' are retained
 970 recoverM recover thing
 971   = do { mb_res <- try_m thing ;
 972          case mb_res of
 973            Left _    -> recover
 974            Right res -> return res }
 975
 976
 977 -----------------------
 978
 979 -- | Drop elements of the input that fail, so the result
 980 -- list can be shorter than the argument list
 981 mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
 982 mapAndRecoverM f = fmap reverse . foldAndRecoverM (\xs x -> (:xs) <$> f x ) []
 983
 984 -- | The accumulator is not updated if the action fails
 985 foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
 986 foldAndRecoverM _ acc []     = return acc
 987 foldAndRecoverM f acc (x:xs) =
 988                           do { mb_r <- try_m (f acc x)
 989                              ; case mb_r of
 990                                 Left _  -> foldAndRecoverM f acc xs
 991                                 Right acc' -> foldAndRecoverM f acc' xs  }
 992
 993 -- | Succeeds if applying the argument to all members of the lists succeeds,
 994 --   but nevertheless runs it on all arguments, to collect all errors.
 995 mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
 996 mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
 997
 998 -----------------------
 999 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
1000 -- (tryTc m) executes m, and returns
1001 --      Just r,  if m succeeds (returning r)
1002 --      Nothing, if m fails
1003 -- It also returns all the errors and warnings accumulated by m
1004 -- It always succeeds (never raises an exception)
1005 tryTc thing_inside
1006  = do { errs_var <- newTcRef emptyMessages ;
1007
1008         res  <- try_m $  -- Be sure to catch exceptions, so that
1009                          -- we guaranteed to read the messages out
1010                          -- of that brand-new errs_var!
1011                 setErrsVar errs_var $
1012                 thing_inside ;
1013
1014         msgs <- readTcRef errs_var ;
1015
1016         return (msgs, case res of
1017                         Left _    -> Nothing
1018                         Right val -> Just val)
1019         -- The exception is always the IOEnv built-in
1020         -- in exception; see IOEnv.failM
1021    }
1022
1023 -----------------------
1024 discardErrs :: TcRn a -> TcRn a
1025 -- (discardErrs m) runs m,
1026 --   discarding all error messages and warnings generated by m
1027 -- If m fails, discardErrs fails, and vice versa
1028 discardErrs m
1029  = do { errs_var <- newTcRef emptyMessages
1030       ; setErrsVar errs_var m }
1031
1032 -----------------------
1033 tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
1034 -- (tryTcDiscardingErrs recover main) tries 'main';
1035 --      if 'main' succeeds with no error messages, it's the answer
1036 --      otherwise discard everything from 'main', including errors,
1037 --          and try 'recover' instead.
1038 tryTcDiscardingErrs recover main
1039   = do  { (msgs, mb_res) <- tryTc main
1040         ; dflags <- getDynFlags
1041         ; case mb_res of
1042             Just res | not (errorsFound dflags msgs)
1043               -> -- 'main' succeeed with no error messages
1044                  do { addMessages msgs  -- msgs might still have warnings
1045                     ; return res }
1046
1047             _ -> -- 'main' failed, or produced an error message
1048                  recover     -- Discard all errors and warnings entirely
1049         }
1050
1051 -----------------------
1052 -- (askNoErrs m) runs m
1053 -- If m fails,
1054 --    then (askNoErrs m) fails
1055 -- If m succeeds with result r,
1056 --    then (askNoErrs m) succeeds with result (r, b),
1057 --         where b is True iff m generated no errors
1058 -- Regardless of success or failure,
1059 --   propagate any errors/warnings generated by m
1060 askNoErrs :: TcRn a -> TcRn (a, Bool)
1061 askNoErrs m
1062   = do { (msgs, mb_res) <- tryTc m
1063        ; addMessages msgs  -- Always propagate errors
1064        ; case mb_res of
1065            Nothing  -> failM
1066            Just res -> do { dflags <- getDynFlags
1067                           ; let errs_found = errorsFound dflags msgs
1068                           ; return (res, not errs_found) } }
1069 -----------------------
1070 checkNoErrs :: TcM r -> TcM r
1071 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
1072 -- If m fails then (checkNoErrsTc m) fails.
1073 -- If m succeeds, it checks whether m generated any errors messages
1074 --      (it might have recovered internally)
1075 --      If so, it fails too.
1076 -- Regardless, any errors generated by m are propagated to the enclosing context.
1077 checkNoErrs main
1078   = do  { (res, no_errs) <- askNoErrs main
1079         ; unless no_errs failM
1080         ; return res }
1081
1082 -----------------------
1083 whenNoErrs :: TcM () -> TcM ()
1084 whenNoErrs thing = ifErrsM (return ()) thing
1085
1086 ifErrsM :: TcRn r -> TcRn r -> TcRn r
1087 --      ifErrsM bale_out normal
1088 -- does 'bale_out' if there are errors in errors collection
1089 -- otherwise does 'normal'
1090 ifErrsM bale_out normal
1091  = do { errs_var <- getErrsVar ;
1092         msgs <- readTcRef errs_var ;
1093         dflags <- getDynFlags ;
1094         if errorsFound dflags msgs then
1095            bale_out
1096         else
1097            normal }
1098
1099 failIfErrsM :: TcRn ()
1100 -- Useful to avoid error cascades
1101 failIfErrsM = ifErrsM failM (return ())
1102
1103 checkTH :: a -> String -> TcRn ()
1104 checkTH _ _ = return () -- OK
1105
1106 failTH :: Outputable a => a -> String -> TcRn x
1107 failTH e what  -- Raise an error in a stage-1 compiler
1108   = failWithTc (vcat [ hang (char 'A' <+> text what
1109                              <+> text "requires GHC with interpreter support:")
1110                           2 (ppr e)
1111                      , text "Perhaps you are using a stage-1 compiler?" ])
1112
1113
1114 {- *********************************************************************
1115 *                                                                      *
1116         Context management for the type checker
1117 *                                                                      *
1118 ************************************************************************
1119 -}
1120
1121 getErrCtxt :: TcM [ErrCtxt]
1122 getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
1123
1124 setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
1125 setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
1126
1127 -- | Add a fixed message to the error context. This message should not
1128 -- do any tidying.
1129 addErrCtxt :: MsgDoc -> TcM a -> TcM a
1130 addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
1131
1132 -- | Add a message to the error context. This message may do tidying.
1133 addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1134 addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
1135
1136 -- | Add a fixed landmark message to the error context. A landmark
1137 -- message is always sure to be reported, even if there is a lot of
1138 -- context. It also doesn't count toward the maximum number of contexts
1139 -- reported.
1140 addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
1141 addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
1142
1143 -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
1144 -- and tidying.
1145 addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
1146 addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
1147
1148 -- Helper function for the above
1149 updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
1150 updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
1151                            env { tcl_ctxt = upd ctxt })
1152
1153 popErrCtxt :: TcM a -> TcM a
1154 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
1155
1156 getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
1157 getCtLocM origin t_or_k
1158   = do { env <- getLclEnv
1159        ; return (CtLoc { ctl_origin = origin
1160                        , ctl_env    = env
1161                        , ctl_t_or_k = t_or_k
1162                        , ctl_depth  = initialSubGoalDepth }) }
1163
1164 setCtLocM :: CtLoc -> TcM a -> TcM a
1165 -- Set the SrcSpan and error context from the CtLoc
1166 setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
1167   = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl
1168                            , tcl_bndrs = tcl_bndrs lcl
1169                            , tcl_ctxt  = tcl_ctxt lcl })
1170               thing_inside
1171
1172 {-
1173 ************************************************************************
1174 *                                                                      *
1175              Error message generation (type checker)
1176 *                                                                      *
1177 ************************************************************************
1178
1179     The addErrTc functions add an error message, but do not cause failure.
1180     The 'M' variants pass a TidyEnv that has already been used to
1181     tidy up the message; we then use it to tidy the context messages
1182 -}
1183
1184 addErrTc :: MsgDoc -> TcM ()
1185 addErrTc err_msg = do { env0 <- tcInitTidyEnv
1186                       ; addErrTcM (env0, err_msg) }
1187
1188 addErrsTc :: [MsgDoc] -> TcM ()
1189 addErrsTc err_msgs = mapM_ addErrTc err_msgs
1190
1191 addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
1192 addErrTcM (tidy_env, err_msg)
1193   = do { ctxt <- getErrCtxt ;
1194          loc  <- getSrcSpanM ;
1195          add_err_tcm tidy_env err_msg loc ctxt }
1196
1197 -- Return the error message, instead of reporting it straight away
1198 mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
1199 mkErrTcM (tidy_env, err_msg)
1200   = do { ctxt <- getErrCtxt ;
1201          loc  <- getSrcSpanM ;
1202          err_info <- mkErrInfo tidy_env ctxt ;
1203          mkLongErrAt loc err_msg err_info }
1204
1205 mkErrTc :: MsgDoc -> TcM ErrMsg
1206 mkErrTc msg = do { env0 <- tcInitTidyEnv
1207                  ; mkErrTcM (env0, msg) }
1208
1209 -- The failWith functions add an error message and cause failure
1210
1211 failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail
1212 failWithTc err_msg
1213   = addErrTc err_msg >> failM
1214
1215 failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail
1216 failWithTcM local_and_msg
1217   = addErrTcM local_and_msg >> failM
1218
1219 checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true
1220 checkTc True  _   = return ()
1221 checkTc False err = failWithTc err
1222
1223 checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1224 checkTcM True  _   = return ()
1225 checkTcM False err = failWithTcM err
1226
1227 failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false
1228 failIfTc False _   = return ()
1229 failIfTc True  err = failWithTc err
1230
1231 failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
1232    -- Check that the boolean is false
1233 failIfTcM False _   = return ()
1234 failIfTcM True  err = failWithTcM err
1235
1236
1237 --         Warnings have no 'M' variant, nor failure
1238
1239 -- | Display a warning if a condition is met,
1240 --   and the warning is enabled
1241 warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
1242 warnIfFlag warn_flag is_bad msg
1243   = do { warn_on <- woptM warn_flag
1244        ; when (warn_on && is_bad) $
1245          addWarn (Reason warn_flag) msg }
1246
1247 -- | Display a warning if a condition is met.
1248 warnIf :: Bool -> MsgDoc -> TcRn ()
1249 warnIf is_bad msg
1250   = when is_bad (addWarn NoReason msg)
1251
1252 -- | Display a warning if a condition is met.
1253 warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
1254 warnTc reason warn_if_true warn_msg
1255   | warn_if_true = addWarnTc reason warn_msg
1256   | otherwise    = return ()
1257
1258 -- | Display a warning if a condition is met.
1259 warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
1260 warnTcM reason warn_if_true warn_msg
1261   | warn_if_true = addWarnTcM reason warn_msg
1262   | otherwise    = return ()
1263
1264 -- | Display a warning in the current context.
1265 addWarnTc :: WarnReason -> MsgDoc -> TcM ()
1266 addWarnTc reason msg
1267  = do { env0 <- tcInitTidyEnv ;
1268       addWarnTcM reason (env0, msg) }
1269
1270 -- | Display a warning in a given context.
1271 addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
1272 addWarnTcM reason (env0, msg)
1273  = do { ctxt <- getErrCtxt ;
1274         err_info <- mkErrInfo env0 ctxt ;
1275         add_warn reason msg err_info }
1276
1277 -- | Display a warning for the current source location.
1278 addWarn :: WarnReason -> MsgDoc -> TcRn ()
1279 addWarn reason msg = add_warn reason msg Outputable.empty
1280
1281 -- | Display a warning for a given source location.
1282 addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
1283 addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
1284
1285 -- | Display a warning, with an optional flag, for the current source
1286 -- location.
1287 add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
1288 add_warn reason msg extra_info
1289   = do { loc <- getSrcSpanM
1290        ; add_warn_at reason loc msg extra_info }
1291
1292 -- | Display a warning, with an optional flag, for a given location.
1293 add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
1294 add_warn_at reason loc msg extra_info
1295   = do { dflags <- getDynFlags ;
1296          printer <- getPrintUnqualified dflags ;
1297          let { warn = mkLongWarnMsg dflags loc printer
1298                                     msg extra_info } ;
1299          reportWarning reason warn }
1300
1301 tcInitTidyEnv :: TcM TidyEnv
1302 tcInitTidyEnv
1303   = do  { lcl_env <- getLclEnv
1304         ; return (tcl_tidy lcl_env) }
1305
1306 -- | Get a 'TidyEnv' that includes mappings for all vars free in the given
1307 -- type. Useful when tidying open types.
1308 tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
1309 tcInitOpenTidyEnv tvs
1310   = do { env1 <- tcInitTidyEnv
1311        ; let env2 = tidyFreeTyCoVars env1 tvs
1312        ; return env2 }
1313
1314
1315 {-
1316 -----------------------------------
1317         Other helper functions
1318 -}
1319
1320 add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
1321             -> [ErrCtxt]
1322             -> TcM ()
1323 add_err_tcm tidy_env err_msg loc ctxt
1324  = do { err_info <- mkErrInfo tidy_env ctxt ;
1325         addLongErrAt loc err_msg err_info }
1326
1327 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
1328 -- Tidy the error info, trimming excessive contexts
1329 mkErrInfo env ctxts
1330 --  = do
1331 --       dbg <- hasPprDebug <$> getDynFlags
1332 --       if dbg                -- In -dppr-debug style the output
1333 --          then return empty  -- just becomes too voluminous
1334 --          else go dbg 0 env ctxts
1335  = go False 0 env ctxts
1336  where
1337    go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
1338    go _ _ _   [] = return empty
1339    go dbg n env ((is_landmark, ctxt) : ctxts)
1340      | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
1341      = do { (env', msg) <- ctxt env
1342           ; let n' = if is_landmark then n else n+1
1343           ; rest <- go dbg n' env' ctxts
1344           ; return (msg $$ rest) }
1345      | otherwise
1346      = go dbg n env ctxts
1347
1348 mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
1349 mAX_CONTEXTS = 3
1350
1351 -- debugTc is useful for monadic debugging code
1352
1353 debugTc :: TcM () -> TcM ()
1354 debugTc thing
1355  | debugIsOn = thing
1356  | otherwise = return ()
1357
1358 {-
1359 ************************************************************************
1360 *                                                                      *
1361              Type constraints
1362 *                                                                      *
1363 ************************************************************************
1364 -}
1365
1366 newTcEvBinds :: TcM EvBindsVar
1367 newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
1368                   ; tcvs_ref  <- newTcRef emptyVarSet
1369                   ; uniq <- newUnique
1370                   ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
1371                   ; return (EvBindsVar { ebv_binds = binds_ref
1372                                        , ebv_tcvs = tcvs_ref
1373                                        , ebv_uniq = uniq }) }
1374
1375 getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
1376 getTcEvTyCoVars (EvBindsVar { ebv_tcvs = ev_ref })
1377   = readTcRef ev_ref
1378
1379 getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
1380 getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
1381   = readTcRef ev_ref
1382
1383 addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
1384 -- Add a binding to the TcEvBinds by side effect
1385 addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
1386   = do { traceTc "addTcEvBind" $ ppr u $$
1387                                  ppr ev_bind
1388        ; bnds <- readTcRef ev_ref
1389        ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
1390
1391 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
1392 chooseUniqueOccTc fn =
1393   do { env <- getGblEnv
1394      ; let dfun_n_var = tcg_dfun_n env
1395      ; set <- readTcRef dfun_n_var
1396      ; let occ = fn set
1397      ; writeTcRef dfun_n_var (extendOccSet set occ)
1398      ; return occ }
1399
1400 getConstraintVar :: TcM (TcRef WantedConstraints)
1401 getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
1402
1403 setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
1404 setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
1405
1406 emitStaticConstraints :: WantedConstraints -> TcM ()
1407 emitStaticConstraints static_lie
1408   = do { gbl_env <- getGblEnv
1409        ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
1410
1411 emitConstraints :: WantedConstraints -> TcM ()
1412 emitConstraints ct
1413   = do { lie_var <- getConstraintVar ;
1414          updTcRef lie_var (`andWC` ct) }
1415
1416 emitSimple :: Ct -> TcM ()
1417 emitSimple ct
1418   = do { lie_var <- getConstraintVar ;
1419          updTcRef lie_var (`addSimples` unitBag ct) }
1420
1421 emitSimples :: Cts -> TcM ()
1422 emitSimples cts
1423   = do { lie_var <- getConstraintVar ;
1424          updTcRef lie_var (`addSimples` cts) }
1425
1426 emitImplication :: Implication -> TcM ()
1427 emitImplication ct
1428   = do { lie_var <- getConstraintVar ;
1429          updTcRef lie_var (`addImplics` unitBag ct) }
1430
1431 emitImplications :: Bag Implication -> TcM ()
1432 emitImplications ct
1433   = unless (isEmptyBag ct) $
1434     do { lie_var <- getConstraintVar ;
1435          updTcRef lie_var (`addImplics` ct) }
1436
1437 emitInsoluble :: Ct -> TcM ()
1438 emitInsoluble ct
1439   = do { traceTc "emitInsoluble" (ppr ct)
1440        ; lie_var <- getConstraintVar
1441        ; updTcRef lie_var (`addInsols` unitBag ct) }
1442
1443 emitInsolubles :: Cts -> TcM ()
1444 emitInsolubles cts
1445   | isEmptyBag cts = return ()
1446   | otherwise      = do { traceTc "emitInsolubles" (ppr cts)
1447                         ; lie_var <- getConstraintVar
1448                         ; updTcRef lie_var (`addInsols` cts) }
1449
1450 -- | Throw out any constraints emitted by the thing_inside
1451 discardConstraints :: TcM a -> TcM a
1452 discardConstraints thing_inside = fst <$> captureConstraints thing_inside
1453
1454 tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)
1455 -- (captureConstraints_maybe m) runs m,
1456 -- and returns the type constraints it generates
1457 -- It never throws an exception; instead if thing_inside fails,
1458 --   it returns Left exn and the insoluble constraints
1459 tryCaptureConstraints thing_inside
1460   = do { lie_var <- newTcRef emptyWC
1461        ; mb_res <- tryM $
1462                    updLclEnv (\ env -> env { tcl_lie = lie_var }) $
1463                    thing_inside
1464        ; lie <- readTcRef lie_var
1465
1466        -- See Note [Constraints and errors]
1467        ; let lie_to_keep = case mb_res of
1468                              Left {}  -> insolublesOnly lie
1469                              Right {} -> lie
1470
1471        ; return (mb_res, lie_to_keep) }
1472
1473 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
1474 -- (captureConstraints m) runs m, and returns the type constraints it generates
1475 captureConstraints thing_inside
1476   = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
1477
1478             -- See Note [Constraints and errors]
1479             -- If the thing_inside threw an exception, emit the insoluble
1480             -- constraints only (returned by tryCaptureConstraints)
1481             -- so that they are not lost
1482        ; case mb_res of
1483            Left _    -> do { emitConstraints lie; failM }
1484            Right res -> return (res, lie) }
1485
1486 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
1487 pushLevelAndCaptureConstraints thing_inside
1488   = do { env <- getLclEnv
1489        ; let tclvl' = pushTcLevel (tcl_tclvl env)
1490        ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
1491                        captureConstraints thing_inside
1492        ; return (tclvl', lie, res) }
1493
1494 pushTcLevelM_ :: TcM a -> TcM a
1495 pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
1496
1497 pushTcLevelM :: TcM a -> TcM (a, TcLevel)
1498 -- See Note [TcLevel assignment] in TcType
1499 pushTcLevelM thing_inside
1500   = do { env <- getLclEnv
1501        ; let tclvl' = pushTcLevel (tcl_tclvl env)
1502        ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
1503                           thing_inside
1504        ; return (res, tclvl') }
1505
1506 getTcLevel :: TcM TcLevel
1507 getTcLevel = do { env <- getLclEnv
1508                 ; return (tcl_tclvl env) }
1509
1510 setTcLevel :: TcLevel -> TcM a -> TcM a
1511 setTcLevel tclvl thing_inside
1512   = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
1513
1514 isTouchableTcM :: TcTyVar -> TcM Bool
1515 isTouchableTcM tv
1516   = do { env <- getLclEnv
1517        ; return (isTouchableMetaTyVar (tcl_tclvl env) tv) }
1518
1519 getLclTypeEnv :: TcM TcTypeEnv
1520 getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
1521
1522 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
1523 -- Set the local type envt, but do *not* disturb other fields,
1524 -- notably the lie_var
1525 setLclTypeEnv lcl_env thing_inside
1526   = updLclEnv upd thing_inside
1527   where
1528     upd env = env { tcl_env = tcl_env lcl_env,
1529                     tcl_tyvars = tcl_tyvars lcl_env }
1530
1531 traceTcConstraints :: String -> TcM ()
1532 traceTcConstraints msg
1533   = do { lie_var <- getConstraintVar
1534        ; lie     <- readTcRef lie_var
1535        ; traceOptTcRn Opt_D_dump_tc_trace $
1536          hang (text (msg ++ ": LIE:")) 2 (ppr lie)
1537        }
1538
1539 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
1540 emitWildCardHoleConstraints wcs
1541   = do { ct_loc <- getCtLocM HoleOrigin Nothing
1542        ; emitInsolubles $ listToBag $
1543          map (do_one ct_loc) wcs }
1544   where
1545     do_one :: CtLoc -> (Name, TcTyVar) -> Ct
1546     do_one ct_loc (name, tv)
1547        = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
1548                                       , ctev_loc  = ct_loc' }
1549                   , cc_hole = TypeHole (occName name) }
1550        where
1551          real_span = case nameSrcSpan name of
1552                            RealSrcSpan span  -> span
1553                            UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
1554                                                       (ppr name <+> quotes (ftext str))
1555                -- Wildcards are defined locally, and so have RealSrcSpans
1556          ct_loc' = setCtLocSpan ct_loc real_span
1557
1558 {- Note [Constraints and errors]
1559 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1560 Consider this (Trac #12124):
1561
1562   foo :: Maybe Int
1563   foo = return (case Left 3 of
1564                   Left -> 1  -- Hard error here!
1565                   _    -> 0)
1566
1567 The call to 'return' will generate a (Monad m) wanted constraint; but
1568 then there'll be "hard error" (i.e. an exception in the TcM monad), from
1569 the unsaturated Left constructor pattern.
1570
1571 We'll recover in tcPolyBinds, using recoverM.  But then the final
1572 tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
1573 un-filled-in, and will emit a misleading error message.
1574
1575 The underlying problem is that an exception interrupts the constraint
1576 gathering process. Bottom line: if we have an exception, it's best
1577 simply to discard any gathered constraints.  Hence in 'try_m' we
1578 capture the constraints in a fresh variable, and only emit them into
1579 the surrounding context if we exit normally.  If an exception is
1580 raised, simply discard the collected constraints... we have a hard
1581 error to report.  So this capture-the-emit dance isn't as stupid as it
1582 looks :-).
1583
1584 However suppose we throw an exception inside an invocation of
1585 captureConstraints, and discard all the constraints. Some of those
1586 contraints might be "variable out of scope" Hole constraints, and that
1587 might have been the actual original cause of the exception!  For
1588 example (Trac #12529):
1589    f = p @ Int
1590 Here 'p' is out of scope, so we get an insolube Hole constraint. But
1591 the visible type application fails in the monad (thows an exception).
1592 We must not discard the out-of-scope error.
1593
1594 So we /retain the insoluble constraints/ if there is an exception.
1595 Hence:
1596   - insolublesOnly in tryCaptureConstraints
1597   - emitConstraints in the Left case of captureConstraints
1598
1599
1600 ************************************************************************
1601 *                                                                      *
1602              Template Haskell context
1603 *                                                                      *
1604 ************************************************************************
1605 -}
1606
1607 recordThUse :: TcM ()
1608 recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
1609
1610 recordThSpliceUse :: TcM ()
1611 recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
1612
1613 -- | When generating an out-of-scope error message for a variable matching a
1614 -- binding in a later inter-splice group, the typechecker uses the splice
1615 -- locations to provide details in the message about the scope of that binding.
1616 recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
1617 recordTopLevelSpliceLoc (RealSrcSpan real_loc)
1618   = do { env <- getGblEnv
1619        ; let locs_var = tcg_th_top_level_locs env
1620        ; locs0 <- readTcRef locs_var
1621        ; writeTcRef locs_var (Set.insert real_loc locs0) }
1622 recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
1623
1624 getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
1625 getTopLevelSpliceLocs
1626   = do { env <- getGblEnv
1627        ; readTcRef (tcg_th_top_level_locs env) }
1628
1629 keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
1630 keepAlive name
1631   = do { env <- getGblEnv
1632        ; traceRn "keep alive" (ppr name)
1633        ; updTcRef (tcg_keep env) (`extendNameSet` name) }
1634
1635 getStage :: TcM ThStage
1636 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
1637
1638 getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
1639 getStageAndBindLevel name
1640   = do { env <- getLclEnv;
1641        ; case lookupNameEnv (tcl_th_bndrs env) name of
1642            Nothing                  -> return Nothing
1643            Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
1644
1645 setStage :: ThStage -> TcM a -> TcRn a
1646 setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
1647
1648 -- | Adds the given modFinalizers to the global environment and set them to use
1649 -- the current local environment.
1650 addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
1651 addModFinalizersWithLclEnv mod_finalizers
1652   = do lcl_env <- getLclEnv
1653        th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
1654        updTcRef th_modfinalizers_var $ \fins ->
1655          setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers)
1656          : fins
1657
1658 {-
1659 ************************************************************************
1660 *                                                                      *
1661              Safe Haskell context
1662 *                                                                      *
1663 ************************************************************************
1664 -}
1665
1666 -- | Mark that safe inference has failed
1667 -- See Note [Safe Haskell Overlapping Instances Implementation]
1668 -- although this is used for more than just that failure case.
1669 recordUnsafeInfer :: WarningMessages -> TcM ()
1670 recordUnsafeInfer warns =
1671     getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
1672
1673 -- | Figure out the final correct safe haskell mode
1674 finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
1675 finalSafeMode dflags tcg_env = do
1676     safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
1677     return $ case safeHaskell dflags of
1678         Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
1679                 | otherwise                     -> Sf_None
1680         s -> s
1681
1682 -- | Switch instances to safe instances if we're in Safe mode.
1683 fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
1684 fixSafeInstances sfMode | sfMode /= Sf_Safe = id
1685 fixSafeInstances _ = map fixSafe
1686   where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
1687                        in inst { is_flag = new_flag }
1688
1689 {-
1690 ************************************************************************
1691 *                                                                      *
1692              Stuff for the renamer's local env
1693 *                                                                      *
1694 ************************************************************************
1695 -}
1696
1697 getLocalRdrEnv :: RnM LocalRdrEnv
1698 getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
1699
1700 setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
1701 setLocalRdrEnv rdr_env thing_inside
1702   = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
1703
1704 {-
1705 ************************************************************************
1706 *                                                                      *
1707              Stuff for interface decls
1708 *                                                                      *
1709 ************************************************************************
1710 -}
1711
1712 mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
1713 mkIfLclEnv mod loc boot
1714                    = IfLclEnv { if_mod     = mod,
1715                                 if_loc     = loc,
1716                                 if_boot    = boot,
1717                                 if_nsubst  = Nothing,
1718                                 if_implicits_env = Nothing,
1719                                 if_tv_env  = emptyFsEnv,
1720                                 if_id_env  = emptyFsEnv }
1721
1722 -- | Run an 'IfG' (top-level interface monad) computation inside an existing
1723 -- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
1724 -- based on 'TcGblEnv'.
1725 initIfaceTcRn :: IfG a -> TcRn a
1726 initIfaceTcRn thing_inside
1727   = do  { tcg_env <- getGblEnv
1728         ; dflags <- getDynFlags
1729         ; let mod = tcg_semantic_mod tcg_env
1730               -- When we are instantiating a signature, we DEFINITELY
1731               -- do not want to knot tie.
1732               is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
1733                                not (null (thisUnitIdInsts dflags))
1734         ; let { if_env = IfGblEnv {
1735                             if_doc = text "initIfaceTcRn",
1736                             if_rec_types =
1737                                 if is_instantiate
1738                                     then Nothing
1739                                     else Just (mod, get_type_env)
1740                          }
1741               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
1742         ; setEnvs (if_env, ()) thing_inside }
1743
1744 -- Used when sucking in a ModIface into a ModDetails to put in
1745 -- the HPT.  Notably, unlike initIfaceCheck, this does NOT use
1746 -- hsc_type_env_var (since we're not actually going to typecheck,
1747 -- so this variable will never get updated!)
1748 initIfaceLoad :: HscEnv -> IfG a -> IO a
1749 initIfaceLoad hsc_env do_this
1750  = do let gbl_env = IfGblEnv {
1751                         if_doc = text "initIfaceLoad",
1752                         if_rec_types = Nothing
1753                     }
1754       initTcRnIf 'i' hsc_env gbl_env () do_this
1755
1756 initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
1757 -- Used when checking the up-to-date-ness of the old Iface
1758 -- Initialise the environment with no useful info at all
1759 initIfaceCheck doc hsc_env do_this
1760  = do let rec_types = case hsc_type_env_var hsc_env of
1761                          Just (mod,var) -> Just (mod, readTcRef var)
1762                          Nothing        -> Nothing
1763           gbl_env = IfGblEnv {
1764                         if_doc = text "initIfaceCheck" <+> doc,
1765                         if_rec_types = rec_types
1766                     }
1767       initTcRnIf 'i' hsc_env gbl_env () do_this
1768
1769 initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
1770 initIfaceLcl mod loc_doc hi_boot_file thing_inside
1771   = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
1772
1773 -- | Initialize interface typechecking, but with a 'NameShape'
1774 -- to apply when typechecking top-level 'OccName's (see
1775 -- 'lookupIfaceTop')
1776 initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
1777 initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
1778   = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
1779
1780 getIfModule :: IfL Module
1781 getIfModule = do { env <- getLclEnv; return (if_mod env) }
1782
1783 --------------------
1784 failIfM :: MsgDoc -> IfL a
1785 -- The Iface monad doesn't have a place to accumulate errors, so we
1786 -- just fall over fast if one happens; it "shouldn't happen".
1787 -- We use IfL here so that we can get context info out of the local env
1788 failIfM msg
1789   = do  { env <- getLclEnv
1790         ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
1791         ; dflags <- getDynFlags
1792         ; liftIO (putLogMsg dflags NoReason SevFatal
1793                    noSrcSpan (defaultErrStyle dflags) full_msg)
1794         ; failM }
1795
1796 --------------------
1797 forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
1798 -- Run thing_inside in an interleaved thread.
1799 -- It shares everything with the parent thread, so this is DANGEROUS.
1800 --
1801 -- It returns Nothing if the computation fails
1802 --
1803 -- It's used for lazily type-checking interface
1804 -- signatures, which is pretty benign
1805
1806 forkM_maybe doc thing_inside
1807  -- NB: Don't share the mutable env_us with the interleaved thread since env_us
1808  --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).
1809  = do { child_us <- newUniqueSupply
1810       ; child_env_us <- newMutVar child_us
1811         -- see Note [Masking exceptions in forkM_maybe]
1812       ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
1813         do { traceIf (text "Starting fork {" <+> doc)
1814            ; mb_res <- tryM $
1815                        updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
1816                        thing_inside
1817            ; case mb_res of
1818                 Right r  -> do  { traceIf (text "} ending fork" <+> doc)
1819                                 ; return (Just r) }
1820                 Left exn -> do {
1821
1822                     -- Bleat about errors in the forked thread, if -ddump-if-trace is on
1823                     -- Otherwise we silently discard errors. Errors can legitimately
1824                     -- happen when compiling interface signatures (see tcInterfaceSigs)
1825                       whenDOptM Opt_D_dump_if_trace $ do
1826                           dflags <- getDynFlags
1827                           let msg = hang (text "forkM failed:" <+> doc)
1828                                        2 (text (show exn))
1829                           liftIO $ putLogMsg dflags
1830                                              NoReason
1831                                              SevFatal
1832                                              noSrcSpan
1833                                              (defaultErrStyle dflags)
1834                                              msg
1835
1836                     ; traceIf (text "} ending fork (badly)" <+> doc)
1837                     ; return Nothing }
1838         }}
1839
1840 forkM :: SDoc -> IfL a -> IfL a
1841 forkM doc thing_inside
1842  = do   { mb_res <- forkM_maybe doc thing_inside
1843         ; return (case mb_res of
1844                         Nothing -> pgmError "Cannot continue after interface file error"
1845                                    -- pprPanic "forkM" doc
1846                         Just r  -> r) }
1847
1848 setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
1849 setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl { if_implicits_env = Just tenv }) m
1850
1851 {-
1852 Note [Masking exceptions in forkM_maybe]
1853 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1854
1855 When using GHC-as-API it must be possible to interrupt snippets of code
1856 executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
1857 by throwing an asynchronous interrupt to the GHC thread. However, there is a
1858 subtle problem: runStmt first typechecks the code before running it, and the
1859 exception might interrupt the type checker rather than the code. Moreover, the
1860 typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
1861 more importantly might be inside an exception handler inside that
1862 unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
1863 asynchronous exception as a synchronous exception, and the exception will end
1864 up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
1865 discussion).  We don't currently know a general solution to this problem, but
1866 we can use uninterruptibleMask_ to avoid the situation.
1867 -}