path: root/compiler/GHC/Tc/Utils/Monad.hs

{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE ExplicitForAll    #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-
(c) The University of Glasgow 2006

-}

-- | Functions for working with the typechecker environment (setters,
-- getters...).
module GHC.Tc.Utils.Monad(
  -- * Initialisation
  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,

  -- * Simple accessors
  discardResult,
  getTopEnv, updTopEnv, getGblEnv, updGblEnv,
  setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv,
  updTopFlags,
  getEnvs, setEnvs, updEnvs, restoreEnvs,
  xoptM, doptM, goptM, woptM,
  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
  whenDOptM, whenGOptM, whenWOptM,
  whenXOptM, unlessXOptM,
  getGhcMode,
  withoutDynamicNow,
  getEpsVar,
  getEps,
  updateEps, updateEps_,
  getHpt, getEpsAndHug,

  -- * Arrow scopes
  newArrowScope, escapeArrowScope,

  -- * Unique supply
  newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
  newSysName, newSysLocalId, newSysLocalIds,

  -- * Accessing input/output
  newTcRef, readTcRef, writeTcRef, updTcRef,

  -- * Debugging
  traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
  dumpTcRn,
  getNamePprCtx,
  printForUserTcRn,
  traceIf, traceOptIf,
  debugTc,

  -- * Typechecker global environment
  getIsGHCi, getGHCiMonad, getInteractivePrintName,
  tcHscSource, tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
  getRdrEnvs, getImports,
  getFixityEnv, extendFixityEnv,
  getDeclaredDefaultTys,
  addDependentFiles,

  -- * Error management
  getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,
  wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
  wrapLocMA_,wrapLocMA,
  getErrsVar, setErrsVar,
  addErr,
  failWith, failAt,
  addErrAt, addErrs,
  checkErr,
  addMessages,
  discardWarnings, mkDetailedMessage,

  -- * Usage environment
  tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,

  -- * Shared error message stuff: renamer and typechecker
  recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
  attemptM, tryTc,
  askNoErrs, discardErrs, tryTcDiscardingErrs,
  checkNoErrs, whenNoErrs,
  ifErrsM, failIfErrsM,

  -- * Context management for the type checker
  getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
  addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM,

  -- * Diagnostic message generation (type checker)
  addErrTc,
  addErrTcM,
  failWithTc, failWithTcM,
  checkTc, checkTcM,
  failIfTc, failIfTcM,
  mkErrInfo,
  addTcRnDiagnostic, addDetailedDiagnostic,
  mkTcRnMessage, reportDiagnostic, reportDiagnostics,
  warnIf, diagnosticTc, diagnosticTcM,
  addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,

  -- * Type constraints
  newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
  addTcEvBind, addTopEvBinds,
  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
  chooseUniqueOccTc,
  getConstraintVar, setConstraintVar,
  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
  emitImplication, emitImplications, emitInsoluble,
  emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError,
  discardConstraints, captureConstraints, tryCaptureConstraints,
  pushLevelAndCaptureConstraints,
  pushTcLevelM_, pushTcLevelM,
  getTcLevel, setTcLevel, isTouchableTcM,
  getLclTypeEnv, setLclTypeEnv,
  traceTcConstraints,
  emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,

  -- * Template Haskell context
  recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps,
  keepAlive, getStage, getStageAndBindLevel, setStage,
  addModFinalizersWithLclEnv,

  -- * Safe Haskell context
  recordUnsafeInfer, finalSafeMode, fixSafeInstances,

  -- * Stuff for the renamer's local env
  getLocalRdrEnv, setLocalRdrEnv,

  -- * Stuff for interface decls
  mkIfLclEnv,
  initIfaceTcRn,
  initIfaceCheck,
  initIfaceLcl,
  initIfaceLclWithSubst,
  initIfaceLoad,
  initIfaceLoadModule,
  getIfModule,
  failIfM,
  forkM,
  setImplicitEnvM,

  withException, withIfaceErr,

  -- * Stuff for cost centres.
  getCCIndexM, getCCIndexTcM,

  -- * Types etc.
  module GHC.Tc.Types,
  module GHC.Data.IOEnv
  ) where

import GHC.Prelude


import GHC.Builtin.Names

import GHC.Tc.Types     -- Re-export all
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType

import GHC.Hs hiding (LIE)

import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module.Warnings
import GHC.Unit.Home.ModInfo

import GHC.Core.UsageEnv
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv

import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic

import GHC.Runtime.Context

import GHC.Data.IOEnv -- Re-export all
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.Maybe

import GHC.Utils.Outputable as Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import qualified GHC.Data.Strict as Strict

import GHC.Types.Error
import GHC.Types.Fixity.Env
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.SafeHaskell
import GHC.Types.Id
import GHC.Types.TypeEnv
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Ppr
import GHC.Types.Unique.FM ( emptyUFM )
import GHC.Types.Unique.Supply
import GHC.Types.Annotations
import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )
import GHC.Types.CostCentre.State
import GHC.Types.SourceFile

import qualified GHC.LanguageExtensions as LangExt

import Data.IORef
import Control.Monad

import GHC.Tc.Errors.Types
import {-# SOURCE #-} GHC.Tc.Utils.Env    ( tcInitTidyEnv )

import qualified Data.Map as Map
import GHC.Driver.Env.KnotVars
import GHC.Linker.Types
import GHC.Types.Unique.DFM
import GHC.Iface.Errors.Types
import GHC.Iface.Errors.Ppr

{-
************************************************************************
*                                                                      *
                        initTc
*                                                                      *
************************************************************************
-}

-- | Setup the initial typechecking environment
initTc :: HscEnv
       -> HscSource
       -> Bool          -- True <=> retain renamed syntax trees
       -> Module
       -> RealSrcSpan
       -> TcM r
       -> IO (Messages TcRnMessage, Maybe r)
                -- Nothing => error thrown by the thing inside
                -- (error messages should have been printed already)

initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
 = do { keep_var     <- newIORef emptyNameSet ;
        used_gre_var <- newIORef [] ;
        th_var       <- newIORef False ;
        th_splice_var<- newIORef False ;
        infer_var    <- newIORef True ;
        infer_reasons_var <- newIORef emptyMessages ;
        dfun_n_var   <- newIORef emptyOccSet ;
        let { type_env_var = hsc_type_env_vars hsc_env };

        dependent_files_var <- newIORef [] ;
        static_wc_var       <- newIORef emptyWC ;
        cc_st_var           <- newIORef newCostCentreState ;
        th_topdecls_var      <- newIORef [] ;
        th_foreign_files_var <- newIORef [] ;
        th_topnames_var      <- newIORef emptyNameSet ;
        th_modfinalizers_var <- newIORef [] ;
        th_coreplugins_var <- newIORef [] ;
        th_state_var         <- newIORef Map.empty ;
        th_remote_state_var  <- newIORef Nothing ;
        th_docs_var          <- newIORef Map.empty ;
        th_needed_deps_var   <- newIORef ([], emptyUDFM) ;
        next_wrapper_num     <- newIORef emptyModuleEnv ;
        let {
             -- bangs to avoid leaking the env (#19356)
             !dflags = hsc_dflags hsc_env ;
             !mhome_unit = hsc_home_unit_maybe hsc_env;
             !logger = hsc_logger hsc_env ;

             maybe_rn_syntax :: forall a. a -> Maybe a ;
             maybe_rn_syntax empty_val
                | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val

                | gopt Opt_WriteHie dflags       = Just empty_val

                  -- We want to serialize the documentation in the .hi-files,
                  -- and need to extract it from the renamed syntax first.
                  -- See 'GHC.HsToCore.Docs.extractDocs'.
                | gopt Opt_Haddock dflags       = Just empty_val

                | keep_rn_syntax                = Just empty_val
                | otherwise                     = Nothing ;

             gbl_env = TcGblEnv {
                tcg_th_topdecls      = th_topdecls_var,
                tcg_th_foreign_files = th_foreign_files_var,
                tcg_th_topnames      = th_topnames_var,
                tcg_th_modfinalizers = th_modfinalizers_var,
                tcg_th_coreplugins = th_coreplugins_var,
                tcg_th_state         = th_state_var,
                tcg_th_remote_state  = th_remote_state_var,
                tcg_th_docs          = th_docs_var,

                tcg_mod            = mod,
                tcg_semantic_mod   = homeModuleInstantiation mhome_unit mod,
                tcg_src            = hsc_src,
                tcg_rdr_env        = emptyGlobalRdrEnv,
                tcg_fix_env        = emptyNameEnv,
                tcg_default        = if moduleUnit mod == primUnit
                                     || moduleUnit mod == bignumUnit
                                     then Just []  -- See Note [Default types]
                                     else Nothing,
                tcg_type_env       = emptyNameEnv,
                tcg_type_env_var   = type_env_var,
                tcg_inst_env       = emptyInstEnv,
                tcg_fam_inst_env   = emptyFamInstEnv,
                tcg_ann_env        = emptyAnnEnv,
                tcg_th_used        = th_var,
                tcg_th_splice_used = th_splice_var,
                tcg_th_needed_deps = th_needed_deps_var,
                tcg_exports        = [],
                tcg_imports        = emptyImportAvails,
                tcg_used_gres     = used_gre_var,
                tcg_dus            = emptyDUs,

                tcg_rn_imports     = [],
                tcg_rn_exports     =
                    if hsc_src == HsigFile
                        -- Always retain renamed syntax, so that we can give
                        -- better errors.  (TODO: how?)
                        then Just []
                        else maybe_rn_syntax [],
                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
                tcg_tr_module      = Nothing,
                tcg_binds          = emptyLHsBinds,
                tcg_imp_specs      = [],
                tcg_sigs           = emptyNameSet,
                tcg_ksigs          = emptyNameSet,
                tcg_ev_binds       = emptyBag,
                tcg_warns          = NoWarnings,
                tcg_anns           = [],
                tcg_tcs            = [],
                tcg_insts          = [],
                tcg_fam_insts      = [],
                tcg_rules          = [],
                tcg_fords          = [],
                tcg_patsyns        = [],
                tcg_merged         = [],
                tcg_dfun_n         = dfun_n_var,
                tcg_keep           = keep_var,
                tcg_doc_hdr        = Nothing,
                tcg_hpc            = False,
                tcg_main           = Nothing,
                tcg_self_boot      = NoSelfBoot,
                tcg_safe_infer     = infer_var,
                tcg_safe_infer_reasons = infer_reasons_var,
                tcg_dependent_files = dependent_files_var,
                tcg_tc_plugin_solvers   = [],
                tcg_tc_plugin_rewriters = emptyUFM,
                tcg_defaulting_plugins  = [],
                tcg_hf_plugins     = [],
                tcg_top_loc        = loc,
                tcg_static_wc      = static_wc_var,
                tcg_complete_matches = [],
                tcg_cc_st          = cc_st_var,
                tcg_next_wrapper_num = next_wrapper_num
             } ;
        } ;

        -- OK, here's the business end!
        initTcWithGbl hsc_env gbl_env loc do_this
    }

-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
initTcWithGbl :: HscEnv
              -> TcGblEnv
              -> RealSrcSpan
              -> TcM r
              -> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl hsc_env gbl_env loc do_this
 = do { lie_var      <- newIORef emptyWC
      ; errs_var     <- newIORef emptyMessages
      ; usage_var    <- newIORef zeroUE
      ; let lcl_env = TcLclEnv {
                tcl_errs       = errs_var,
                tcl_loc        = loc,
                -- tcl_loc should be over-ridden very soon!
                tcl_in_gen_code = False,
                tcl_ctxt       = [],
                tcl_rdr        = emptyLocalRdrEnv,
                tcl_th_ctxt    = topStage,
                tcl_th_bndrs   = emptyNameEnv,
                tcl_arrow_ctxt = NoArrowCtxt,
                tcl_env        = emptyNameEnv,
                tcl_usage      = usage_var,
                tcl_bndrs      = [],
                tcl_lie        = lie_var,
                tcl_tclvl      = topTcLevel
                }

      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
                     do { r <- tryM do_this
                        ; case r of
                          Right res -> return (Just res)
                          Left _    -> return Nothing }

      -- Check for unsolved constraints
      -- If we succeed (maybe_res = Just r), there should be
      -- no unsolved constraints.  But if we exit via an
      -- exception (maybe_res = Nothing), we may have skipped
      -- solving, so don't panic then (#13466)
      ; lie <- readIORef (tcl_lie lcl_env)
      ; when (isJust maybe_res && not (isEmptyWC lie)) $
        pprPanic "initTc: unsolved constraints" (ppr lie)

        -- Collect any error messages
      ; msgs <- readIORef (tcl_errs lcl_env)

      ; let { final_res | errorsFound msgs = Nothing
                        | otherwise        = maybe_res }

      ; return (msgs, final_res)
      }

initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
-- Initialise the type checker monad for use in GHCi
initTcInteractive hsc_env thing_inside
  = initTc hsc_env HsSrcFile False
           (icInteractiveModule (hsc_IC hsc_env))
           (realSrcLocSpan interactive_src_loc)
           thing_inside
  where
    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1

{- Note [Default types]
~~~~~~~~~~~~~~~~~~~~~~~
The Integer type is simply not available in ghc-prim and ghc-bignum packages (it
is declared in ghc-bignum). So we set the defaulting types to (Just []), meaning
there are no default types, rather than Nothing, which means "use the default
default types of Integer, Double".

If you don't do this, attempted defaulting in package ghc-prim causes
an actual crash (attempting to look up the Integer type).


************************************************************************
*                                                                      *
                Initialisation
*                                                                      *
************************************************************************
-}

initTcRnIf :: Char              -- ^ Mask for unique supply
           -> HscEnv
           -> gbl -> lcl
           -> TcRnIf gbl lcl a
           -> IO a
initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside
   = do { let { env = Env { env_top = hsc_env,
                            env_um  = uniq_mask,
                            env_gbl = gbl_env,
                            env_lcl = lcl_env} }

        ; runIOEnv env thing_inside
        }

{-
************************************************************************
*                                                                      *
                Simple accessors
*                                                                      *
************************************************************************
-}

discardResult :: TcM a -> TcM ()
discardResult a = a >> return ()

getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv = do { env <- getEnv; return (env_top env) }

updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
                          env { env_top = upd top })

getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv = do { Env{..} <- getEnv; return env_gbl }

updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
                          env { env_gbl = upd gbl })

setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })

getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv = do { Env{..} <- getEnv; return env_lcl }

updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
                          env { env_lcl = upd lcl })


setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })

restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
-- See Note [restoreLclEnv vs setLclEnv]
restoreLclEnv new_lcl_env = updLclEnv upd
  where
    upd old_lcl_env =  new_lcl_env { tcl_errs  = tcl_errs  old_lcl_env
                                   , tcl_lie   = tcl_lie   old_lcl_env
                                   , tcl_usage = tcl_usage old_lcl_env }

getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }

setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env

updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updEnvs upd_envs = updEnv upd
  where
    upd env@(Env { env_gbl = gbl, env_lcl = lcl })
      = env { env_gbl = gbl', env_lcl = lcl' }
      where
        !(gbl', lcl') = upd_envs (gbl, lcl)

restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
-- See Note [restoreLclEnv vs setLclEnv]
restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl

{- Note [restoreLclEnv vs setLclEnv]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the typechecker we use this idiom quite a lot
   do { (gbl_env, lcl_env) <- tcRnSrcDecls ...
      ; setGblEnv gbl_env $ setLclEnv lcl_env $
        more_stuff }

The `tcRnSrcDecls` extends the environments in `gbl_env` and `lcl_env`
which we then want to be in scope in `more stuff`.

The problem is that `lcl_env :: TcLclEnv` has an IORef for error
messages `tcl_errs`, and another for constraints (`tcl_lie`), and
another for Linear Haskell usage information (`tcl_usage`).  Now
suppose we change it a tiny bit
   do { (gbl_env, lcl_env) <- checkNoErrs $
                              tcRnSrcDecls ...
      ; setGblEnv gbl_env $ setLclEnv lcl_env $
        more_stuff }

That should be innocuous.  But *alas*, `checkNoErrs` gathers errors in
a fresh IORef *which is then captured in the returned `lcl_env`.  When
we do the `setLclEnv` we'll make that captured IORef into the place
where we gather error messages -- but no one is going to look at that!!!
This led to #19470 and #20981.

Solution: instead of setLclEnv use restoreLclEnv, which preserves from
the /parent/ context these mutable collection IORefs:
      tcl_errs, tcl_lie, tcl_usage
-}

-- Command-line flags

xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
xoptM flag = xopt flag <$> getDynFlags

doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM flag = do
  logger <- getLogger
  return (logHasDumpFlag logger flag)

goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM flag = gopt flag <$> getDynFlags

woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM flag = wopt flag <$> getDynFlags

setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag)

unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag)

unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag)

unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag)

-- | Do it flag is true
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM flag thing_inside = do b <- doptM flag
                                 when b thing_inside
{-# INLINE whenDOptM #-} -- see Note [INLINE conditional tracing utilities]


whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM flag thing_inside = do b <- goptM flag
                                 when b thing_inside
{-# INLINE whenGOptM #-} -- see Note [INLINE conditional tracing utilities]

whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM flag thing_inside = do b <- woptM flag
                                 when b thing_inside
{-# INLINE whenWOptM #-} -- see Note [INLINE conditional tracing utilities]

whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM flag thing_inside = do b <- xoptM flag
                                 when b thing_inside
{-# INLINE whenXOptM #-} -- see Note [INLINE conditional tracing utilities]

unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM flag thing_inside = do b <- xoptM flag
                                   unless b thing_inside
{-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities]

getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = ghcMode <$> getDynFlags

withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False})

updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags f = updTopEnv (hscUpdateFlags f)

getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do
  env <- getTopEnv
  return (euc_eps (ue_eps (hsc_unit_env env)))

getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- getTopEnv; liftIO $ hscEPS env }

-- | Update the external package state.  Returns the second result of the
-- modifier function.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
          -> TcRnIf gbl lcl a
updateEps upd_fn = do
  traceIf (text "updating EPS")
  eps_var <- getEpsVar
  atomicUpdMutVar' eps_var upd_fn

-- | Update the external package state.
--
-- This is an atomic operation and forces evaluation of the modified EPS in
-- order to avoid space leaks.
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
           -> TcRnIf gbl lcl ()
updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ()))

getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }

getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env
                  ; return (eps, hsc_HUG env) }

-- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing
-- an exception if it is an error.
withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a
withException ctx do_this = do
    r <- do_this
    case r of
        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err))
        Succeeded result -> return result

withIfaceErr :: MonadIO m => SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr ctx do_this = do
    r <- do_this
    case r of
        Failed err -> do
          let opts = defaultDiagnosticOpts @IfaceMessage
              msg   = missingInterfaceErrorDiagnostic opts err
          liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx msg))
        Succeeded result -> return result

{-
************************************************************************
*                                                                      *
                Arrow scopes
*                                                                      *
************************************************************************
-}

newArrowScope :: TcM a -> TcM a
newArrowScope
  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }

-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
  = updLclEnv $ \ env ->
    case tcl_arrow_ctxt env of
      NoArrowCtxt       -> env
      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
                                   , tcl_lie = lie
                                   , tcl_rdr = rdr_env }

{-
************************************************************************
*                                                                      *
                Unique supply
*                                                                      *
************************************************************************
-}

newUnique :: TcRnIf gbl lcl Unique
newUnique
 = do { env <- getEnv
      ; let mask = env_um env
      ; liftIO $! uniqFromMask mask }

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- getEnv
      ; let mask = env_um env
      ; liftIO $! mkSplitUniqSupply mask }

cloneLocalName :: Name -> TcM Name
-- Make a fresh Internal name with the same OccName and SrcSpan
cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)

newName :: OccName -> TcM Name
newName occ = do { loc  <- getSrcSpanM
                 ; newNameAt occ loc }

newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt occ span
  = do { uniq <- newUnique
       ; return (mkInternalName uniq occ span) }

newSysName :: OccName -> TcRnIf gbl lcl Name
newSysName occ
  = do { uniq <- newUnique
       ; return (mkSystemName uniq occ) }

newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId fs w ty
  = do  { u <- newUnique
        ; return (mkSysLocal fs u w ty) }

newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
  = do  { us <- getUniquesM
        ; let mkId' n (Scaled w t) = mkSysLocal fs n w t
        ; return (zipWith mkId' us tys) }

instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM = newUnique
        getUniqueSupplyM = newUniqueSupply

{-
************************************************************************
*                                                                      *
                Accessing input/output
*                                                                      *
************************************************************************
-}

newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef = newMutVar

readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef = readMutVar

writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = writeMutVar

updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
-- Returns ()
updTcRef ref fn = liftIO $ modifyIORef' ref fn

{-
************************************************************************
*                                                                      *
                Debugging
*                                                                      *
************************************************************************
-}

{- Note [INLINE conditional tracing utilities]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general we want to optimise for the case where tracing is not enabled.
To ensure this happens, we ensure that traceTc and friends are inlined; this
ensures that the allocation of the document can be pushed into the tracing
path, keeping the non-traced path free of this extraneous work. For
instance, if we don't inline traceTc, we'll get

    let stuff_to_print = ...
    in traceTc "wombat" stuff_to_print

and the stuff_to_print thunk will be allocated in the "hot path", regardless
of tracing.  But if we INLINE traceTc we get

    let stuff_to_print = ...
    in if doTracing
         then emitTraceMsg "wombat" stuff_to_print
         else return ()

and then we float in:

    if doTracing
      then let stuff_to_print = ...
           in emitTraceMsg "wombat" stuff_to_print
      else return ()

Now stuff_to_print is allocated only in the "cold path".

Moreover, on the "cold" path, after the conditional, we want to inline
as /little/ as possible.  Performance doesn't matter here, and we'd like
to bloat the caller's code as little as possible.  So we put a NOINLINE
on 'emitTraceMsg'

See #18168.
-}

-- Typechecker trace
traceTc :: String -> SDoc -> TcRn ()
traceTc herald doc =
    labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc
{-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities]

-- Renamer Trace
traceRn :: String -> SDoc -> TcRn ()
traceRn herald doc =
    labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc
{-# INLINE traceRn #-} -- see Note [INLINE conditional tracing utilities]

-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
-- but accepts a string as a label and formats the trace message uniformly.
labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
labelledTraceOptTcRn flag herald doc =
  traceOptTcRn flag (formatTraceMsg herald doc)
{-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]

formatTraceMsg :: String -> SDoc -> SDoc
formatTraceMsg herald doc = hang (text herald) 2 doc

traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc =
  whenDOptM flag $
    dumpTcRn False flag "" FormatText doc
{-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]

-- | Dump if the given 'DumpFlag' is set.
dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
dumpOptTcRn flag title fmt doc =
  whenDOptM flag $
    dumpTcRn False flag title fmt doc
{-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities]

-- | Unconditionally dump some trace output
--
-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
-- output generated by `-ddump-types` to be in 'PprUser' style. However,
-- generally we want all other debugging output to use 'PprDump'
-- style. We 'PprUser' style if 'useUserStyle' is True.
--
dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
dumpTcRn useUserStyle flag title fmt doc = do
  logger <- getLogger
  name_ppr_ctx <- getNamePprCtx
  real_doc <- wrapDocLoc doc
  let sty = if useUserStyle
              then mkUserStyle name_ppr_ctx AllTheWay
              else mkDumpStyle name_ppr_ctx
  liftIO $ logDumpFile logger sty flag title fmt real_doc

-- | Add current location if -dppr-debug
-- (otherwise the full location is usually way too much)
wrapDocLoc :: SDoc -> TcRn SDoc
wrapDocLoc doc = do
  logger <- getLogger
  if logHasDumpFlag logger Opt_D_ppr_debug
    then do
      loc <- getSrcSpanM
      return (mkLocMessage MCOutput loc doc)
    else
      return doc

getNamePprCtx :: TcRn NamePprCtx
getNamePprCtx
  = do { ptc <- initPromotionTickContext <$> getDynFlags
       ; rdr_env <- getGlobalRdrEnv
       ; hsc_env <- getTopEnv
       ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }

-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn doc = do
    logger <- getLogger
    name_ppr_ctx <- getNamePprCtx
    liftIO (printOutputForUser logger name_ppr_ctx doc)

{-
traceIf works in the TcRnIf monad, where no RdrEnv is
available.  Alas, they behave inconsistently with the other stuff;
e.g. are unaffected by -dump-to-file.
-}

traceIf :: SDoc -> TcRnIf m n ()
traceIf = traceOptIf Opt_D_dump_if_trace
{-# INLINE traceIf #-}
  -- see Note [INLINE conditional tracing utilities]

traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf flag doc
  = whenDOptM flag $ do   -- No RdrEnv available, so qualify everything
        logger <- getLogger
        liftIO (putMsg logger doc)
{-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]

{-
************************************************************************
*                                                                      *
                Typechecker global environment
*                                                                      *
************************************************************************
-}

getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule
               ; return (isInteractiveModule mod) }

getGHCiMonad :: TcRn Name
getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }

getInteractivePrintName :: TcRn Name
getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }

tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = isHsBootOrSig <$> tcHscSource

tcHscSource :: TcRn HscSource
tcHscSource = do { env <- getGblEnv; return (tcg_src env)}

tcIsHsig :: TcRn Bool
tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }

tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }

getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }

getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }

getImports :: TcRn ImportAvails
getImports = do { env <- getGblEnv; return (tcg_imports env) }

getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }

extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv new_bit
  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})

getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }

addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
  ref <- fmap tcg_dependent_files getGblEnv
  dep_files <- readTcRef ref
  writeTcRef ref (fs ++ dep_files)

{-
************************************************************************
*                                                                      *
                Error management
*                                                                      *
************************************************************************
-}

getSrcSpanM :: TcRn SrcSpan
        -- Avoid clash with Name.getSrcLoc
getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }

-- See Note [Error contexts in generated code]
inGeneratedCode :: TcRn Bool
inGeneratedCode = tcl_in_gen_code <$> getLclEnv

setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-- See Note [Error contexts in generated code]
-- for the tcl_in_gen_code manipulation
setSrcSpan (RealSrcSpan loc _) thing_inside
  = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
              thing_inside

setSrcSpan loc@(UnhelpfulSpan _) thing_inside
  | isGeneratedSrcSpan loc
  = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside

  | otherwise
  = thing_inside

setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)

addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a

addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA fn (L loc a) = setSrcSpanA loc $ fn a

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
                                            ; return (L loc b) }

wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
wrapLocAM fn a = wrapLocM fn (reLoc a)

wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
                                              ; return (L loc b) }

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
  setSrcSpan loc $ do
    (b,c) <- fn a
    return (L loc b, c)

-- Possible instantiations:
--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA    a -> TcM (LocatedA    b, c)
--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN    a -> TcM (LocatedN    b, c)
--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)
-- and so on.
wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA fn (L loc a) =
  setSrcSpanA loc $ do
    (b,c) <- fn a
    return (L loc b, c)

wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
  setSrcSpan loc $ do
    (b,c) <- fn a
    return (b, L loc c)

-- Possible instantiations:
--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA    a -> TcM (b, LocatedA    c)
--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN    a -> TcM (b, LocatedN    c)
--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)
-- and so on.
wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c)
wrapLocSndMA fn (L loc a) =
  setSrcSpanA loc $ do
    (b,c) <- fn a
    return (b, L loc c)

wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)

wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()
wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a)

-- Reporting errors

getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }

setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })

addErr :: TcRnMessage -> TcRn ()
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }

failWith :: TcRnMessage -> TcRn a
failWith msg = addErr msg >> failM

failAt :: SrcSpan -> TcRnMessage -> TcRn a
failAt loc msg = addErrAt loc msg >> failM

addErrAt :: SrcSpan -> TcRnMessage -> TcRn ()
-- addErrAt is mainly (exclusively?) used by the renamer, where
-- tidying is not an issue, but it's all lazy so the extra
-- work doesn't matter
addErrAt loc msg = do { ctxt <- getErrCtxt
                      ; tidy_env <- tcInitTidyEnv
                      ; err_info <- mkErrInfo tidy_env ctxt
                      ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg
                      ; add_long_err_at loc detailed_msg }

mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage err_info msg =
  TcRnMessageDetailed err_info msg

addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
addErrs msgs = mapM_ add msgs
             where
               add (loc,msg) = addErrAt loc msg

checkErr :: Bool -> TcRnMessage -> TcRn ()
-- Add the error if the bool is False
checkErr ok msg = unless ok (addErr msg)

addMessages :: Messages TcRnMessage -> TcRn ()
addMessages msgs1
  = do { errs_var <- getErrsVar
       ; msgs0    <- readTcRef errs_var
       ; writeTcRef errs_var (msgs0 `unionMessages` msgs1) }

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings thing_inside
  = do  { errs_var <- getErrsVar
        ; old_warns <- getWarningMessages <$> readTcRef errs_var

        ; result <- thing_inside

        -- Revert warnings to old_warns
        ; new_errs <- getErrorMessages <$> readTcRef errs_var
        ; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs)

        ; return result }

{-
************************************************************************
*                                                                      *
        Shared error message stuff: renamer and typechecker
*                                                                      *
************************************************************************
-}

add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn ()
add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic
  where
    mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)
    mk_long_err_at loc msg
      = do { name_ppr_ctx <- getNamePprCtx ;
             unit_state <- hsc_units <$> getTopEnv ;
             return $ mkErrorMsgEnvelope loc name_ppr_ctx
                    $ TcRnMessageWithInfo unit_state msg
                    }

mkTcRnMessage :: SrcSpan
              -> TcRnMessage
              -> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage loc msg
  = do { name_ppr_ctx <- getNamePprCtx ;
         diag_opts <- initDiagOpts <$> getDynFlags ;
         return $ mkMsgEnvelope diag_opts loc name_ppr_ctx msg }

reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
reportDiagnostics = mapM_ reportDiagnostic

reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
reportDiagnostic msg
  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ;
         errs_var <- getErrsVar ;
         msgs     <- readTcRef errs_var ;
         writeTcRef errs_var (msg `addMessage` msgs) }

-----------------------
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrs m) fails.
-- If m succeeds, it checks whether m generated any errors messages
--      (it might have recovered internally)
--      If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
  = do  { (res, no_errs) <- askNoErrs main
        ; unless no_errs failM
        ; return res }

-----------------------
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing = ifErrsM (return ()) thing

ifErrsM :: TcRn r -> TcRn r -> TcRn r
--      ifErrsM bale_out normal
-- does 'bale_out' if there are errors in errors collection
-- otherwise does 'normal'
ifErrsM bale_out normal
 = do { errs_var <- getErrsVar ;
        msgs <- readTcRef errs_var ;
        if errorsFound msgs then
           bale_out
        else
           normal }

failIfErrsM :: TcRn ()
-- Useful to avoid error cascades
failIfErrsM = ifErrsM failM (return ())

{- *********************************************************************
*                                                                      *
        Context management for the type checker
*                                                                      *
************************************************************************
-}

{- Note [Inlining addErrCtxt]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
You will notice a bunch of INLINE pragamas on addErrCtxt and friends.
The reason is to promote better eta-expansion in client modules.
Consider
    \e s. addErrCtxt c (tc_foo x) e s
It looks as if tc_foo is applied to only two arguments, but if we
inline addErrCtxt it'll turn into something more like
    \e s. tc_foo x (munge c e) s
This is much better because Called Arity analysis can see that tc_foo
is applied to four arguments.  See #18379 for a concrete example.

This reliance on delicate inlining and Called Arity is not good.
See #18202 for a more general approach.  But meanwhile, these
inlinings seem unobjectional, and they solve the immediate
problem.

Note [Error contexts in generated code]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
  and back to False when we get a useful SrcSpan

* When tc_in_gen_code is True, addErrCtxt becomes a no-op.

So typically it's better to do setSrcSpan /before/ addErrCtxt.

See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for
more discussion of this fancy footwork.
-}

getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }

setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
{-# INLINE setErrCtxt #-}   -- Note [Inlining addErrCtxt]
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })

-- | Add a fixed message to the error context. This message should not
-- do any tidying.
addErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addErrCtxt #-}   -- Note [Inlining addErrCtxt]
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))

-- | Add a message to the error context. This message may do tidying.
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addErrCtxtM #-}  -- Note [Inlining addErrCtxt]
addErrCtxtM ctxt = pushCtxt (False, ctxt)

-- | Add a fixed landmark message to the error context. A landmark
-- message is always sure to be reported, even if there is a lot of
-- context. It also doesn't count toward the maximum number of contexts
-- reported.
addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxt #-}  -- Note [Inlining addErrCtxt]
addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))

-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
-- and tidying.
addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxtM #-}  -- Note [Inlining addErrCtxt]
addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt)

pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
pushCtxt ctxt = updLclEnv (updCtxt ctxt)

updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
-- Do not update the context if we are in generated code
-- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen })
  | in_gen    = env
  | otherwise = env { tcl_ctxt = ctxt : ctxts }

popErrCtxt :: TcM a -> TcM a
popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
                          env { tcl_ctxt = pop ctxt })
           where
             pop []       = []
             pop (_:msgs) = msgs

getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM origin t_or_k
  = do { env <- getLclEnv
       ; return (CtLoc { ctl_origin   = origin
                       , ctl_env      = env
                       , ctl_t_or_k   = t_or_k
                       , ctl_depth    = initialSubGoalDepth }) }

setCtLocM :: CtLoc -> TcM a -> TcM a
-- Set the SrcSpan and error context from the CtLoc
setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
  = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl
                           , tcl_bndrs = tcl_bndrs lcl
                           , tcl_ctxt  = tcl_ctxt lcl })
              thing_inside


{- *********************************************************************
*                                                                      *
             Error recovery and exceptions
*                                                                      *
********************************************************************* -}

tcTryM :: TcRn r -> TcRn (Maybe r)
-- The most basic function: catch the exception
--   Nothing => an exception happened
--   Just r  => no exception, result R
-- Errors and constraints are propagated in both cases
-- Never throws an exception
tcTryM thing_inside
  = do { either_res <- tryM thing_inside
       ; return (case either_res of
                    Left _  -> Nothing
                    Right r -> Just r) }
         -- In the Left case the exception is always the IOEnv
         -- built-in in exception; see IOEnv.failM

-----------------------
capture_constraints :: TcM r -> TcM (r, WantedConstraints)
-- capture_constraints simply captures and returns the
--                     constraints generated by thing_inside
-- Precondition: thing_inside must not throw an exception!
-- Reason for precondition: an exception would blow past the place
-- where we read the lie_var, and we'd lose the constraints altogether
capture_constraints thing_inside
  = do { lie_var <- newTcRef emptyWC
       ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $
                thing_inside
       ; lie <- readTcRef lie_var
       ; return (res, lie) }

capture_messages :: TcM r -> TcM (r, Messages TcRnMessage)
-- capture_messages simply captures and returns the
--                  errors and warnings generated by thing_inside
-- Precondition: thing_inside must not throw an exception!
-- Reason for precondition: an exception would blow past the place
-- where we read the msg_var, and we'd lose the constraints altogether
capture_messages thing_inside
  = do { msg_var <- newTcRef emptyMessages
       ; res     <- setErrsVar msg_var thing_inside
       ; msgs    <- readTcRef msg_var
       ; return (res, msgs) }

-----------------------
-- (askNoErrs m) runs m
-- If m fails,
--    then (askNoErrs m) fails, propagating only
--         insoluble constraints
--
-- If m succeeds with result r,
--    then (askNoErrs m) succeeds with result (r, b),
--         where b is True iff m generated no errors
--
-- Regardless of success or failure,
--   propagate any errors/warnings generated by m
askNoErrs :: TcRn a -> TcRn (a, Bool)
askNoErrs thing_inside
  = do { ((mb_res, lie), msgs) <- capture_messages    $
                                  capture_constraints $
                                  tcTryM thing_inside
       ; addMessages msgs

       ; case mb_res of
           Nothing  -> do { emitConstraints (dropMisleading lie)
                          ; failM }

           Just res -> do { emitConstraints lie
                          ; let errs_found = errorsFound msgs
                                          || insolubleWC lie
                          ; return (res, not errs_found) } }

-----------------------
tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
-- (tryCaptureConstraints_maybe m) runs m,
--   and returns the type constraints it generates
-- It never throws an exception; instead if thing_inside fails,
--   it returns Nothing and the /insoluble/ constraints
-- Error messages are propagated
tryCaptureConstraints thing_inside
  = do { (mb_res, lie) <- capture_constraints $
                          tcTryM thing_inside

       -- See Note [Constraints and errors]
       ; let lie_to_keep = case mb_res of
                             Nothing -> dropMisleading lie
                             Just {} -> lie

       ; return (mb_res, lie_to_keep) }

captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
-- If thing_inside fails (throwing an exception),
--   then (captureConstraints thing_inside) fails too
--   propagating the insoluble constraints only
-- Error messages are propagated in either case
captureConstraints thing_inside
  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside

            -- See Note [Constraints and errors]
            -- If the thing_inside threw an exception, emit the insoluble
            -- constraints only (returned by tryCaptureConstraints)
            -- so that they are not lost
       ; case mb_res of
           Nothing  -> do { emitConstraints lie; failM }
           Just res -> return (res, lie) }

-----------------------
-- | @tcCollectingUsage thing_inside@ runs @thing_inside@ and returns the usage
-- information which was collected as part of the execution of
-- @thing_inside@. Careful: @tcCollectingUsage thing_inside@ itself does not
-- report any usage information, it's up to the caller to incorporate the
-- returned usage information into the larger context appropriately.
tcCollectingUsage :: TcM a -> TcM (UsageEnv,a)
tcCollectingUsage thing_inside
  = do { local_usage_ref <- newTcRef zeroUE
       ; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside
       ; local_usage <- readTcRef local_usage_ref
       ; return (local_usage,result) }

-- | @tcScalingUsage mult thing_inside@ runs @thing_inside@ and scales all the
-- usage information by @mult@.
tcScalingUsage :: Mult -> TcM a -> TcM a
tcScalingUsage mult thing_inside
  = do { (usage, result) <- tcCollectingUsage thing_inside
       ; traceTc "tcScalingUsage" (ppr mult)
       ; tcEmitBindingUsage $ scaleUE mult usage
       ; return result }

tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage ue
  = do { lcl_env <- getLclEnv
       ; let usage = tcl_usage lcl_env
       ; updTcRef usage (addUE ue) }

-----------------------
attemptM :: TcRn r -> TcRn (Maybe r)
-- (attemptM thing_inside) runs thing_inside
-- If thing_inside succeeds, returning r,
--   we return (Just r), and propagate all constraints and errors
-- If thing_inside fail, throwing an exception,
--   we return Nothing, propagating insoluble constraints,
--                      and all errors
-- attemptM never throws an exception
attemptM thing_inside
  = do { (mb_r, lie) <- tryCaptureConstraints thing_inside
       ; emitConstraints lie

       -- Debug trace
       ; when (isNothing mb_r) $
         traceTc "attemptM recovering with insoluble constraints" $
                 (ppr lie)

       ; return mb_r }

-----------------------
recoverM :: TcRn r      -- Recovery action; do this if the main one fails
         -> TcRn r      -- Main action: do this first;
                        --  if it generates errors, propagate them all
         -> TcRn r
-- (recoverM recover thing_inside) runs thing_inside
-- If thing_inside fails, propagate its errors and insoluble constraints
--                        and run 'recover'
-- If thing_inside succeeds, propagate all its errors and constraints
--
-- Can fail, if 'recover' fails
recoverM recover thing
  = do { mb_res <- attemptM thing ;
         case mb_res of
           Nothing  -> recover
           Just res -> return res }

-----------------------

-- | Drop elements of the input that fail, so the result
-- list can be shorter than the argument list
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM f xs
  = do { mb_rs <- mapM (attemptM . f) xs
       ; return [r | Just r <- mb_rs] }

-- | Apply the function to all elements on the input list
-- If all succeed, return the list of results
-- Otherwise fail, propagating all errors
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM f xs
  = do { mb_rs <- mapM (attemptM . f) xs
       ; when (any isNothing mb_rs) failM
       ; return [r | Just r <- mb_rs] }

-- | The accumulator is not updated if the action fails
foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM _ acc []     = return acc
foldAndRecoverM f acc (x:xs) =
                          do { mb_r <- attemptM (f acc x)
                             ; case mb_r of
                                Nothing   -> foldAndRecoverM f acc xs
                                Just acc' -> foldAndRecoverM f acc' xs  }

-----------------------
tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
-- (tryTc m) executes m, and returns
--      Just r,  if m succeeds (returning r)
--      Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
tryTc thing_inside
 = capture_messages (attemptM thing_inside)

-----------------------
discardErrs :: TcRn a -> TcRn a
-- (discardErrs m) runs m,
--   discarding all error messages and warnings generated by m
-- If m fails, discardErrs fails, and vice versa
discardErrs m
 = do { errs_var <- newTcRef emptyMessages
      ; setErrsVar errs_var m }

-----------------------
tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';
--      if 'main' succeeds with no error messages, it's the answer
--      otherwise discard everything from 'main', including errors,
--          and try 'recover' instead.
tryTcDiscardingErrs recover thing_inside
  = do { ((mb_res, lie), msgs) <- capture_messages    $
                                  capture_constraints $
                                  tcTryM thing_inside
        ; case mb_res of
            Just res | not (errorsFound msgs)
                     , not (insolubleWC lie)
              -> -- 'main' succeeded with no errors
                 do { addMessages msgs  -- msgs might still have warnings
                    ; emitConstraints lie
                    ; return res }

            _ -> -- 'main' failed, or produced an error message
                 recover     -- Discard all errors and warnings
                             -- and unsolved constraints entirely
        }

{-
************************************************************************
*                                                                      *
             Error message generation (type checker)
*                                                                      *
************************************************************************

    The addErrTc functions add an error message, but do not cause failure.
    The 'M' variants pass a TidyEnv that has already been used to
    tidy up the message; we then use it to tidy the context messages
-}

addErrTc :: TcRnMessage -> TcM ()
addErrTc err_msg = do { env0 <- tcInitTidyEnv
                      ; addErrTcM (env0, err_msg) }

addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addErrTcM (tidy_env, err_msg)
  = do { ctxt <- getErrCtxt ;
         loc  <- getSrcSpanM ;
         add_err_tcm tidy_env err_msg loc ctxt }

-- The failWith functions add an error message and cause failure

failWithTc :: TcRnMessage -> TcM a               -- Add an error message and fail
failWithTc err_msg
  = addErrTc err_msg >> failM

failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a   -- Add an error message and fail
failWithTcM local_and_msg
  = addErrTcM local_and_msg >> failM

checkTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is true
checkTc True  _   = return ()
checkTc False err = failWithTc err

checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM True  _   = return ()
checkTcM False err = failWithTcM err

failIfTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is false
failIfTc False _   = return ()
failIfTc True  err = failWithTc err

failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
   -- Check that the boolean is false
failIfTcM False _   = return ()
failIfTcM True  err = failWithTcM err


--         Warnings have no 'M' variant, nor failure

-- | Display a warning if a condition is met.
warnIf :: Bool -> TcRnMessage -> TcRn ()
warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'.
  = when is_bad (addDiagnostic msg)

no_err_info :: ErrInfo
no_err_info = ErrInfo Outputable.empty Outputable.empty

-- | Display a warning if a condition is met.
diagnosticTc :: Bool -> TcRnMessage -> TcM ()
diagnosticTc should_report warn_msg
  | should_report = addDiagnosticTc warn_msg
  | otherwise     = return ()

-- | Display a diagnostic if a condition is met.
diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
diagnosticTcM should_report warn_msg
  | should_report = addDiagnosticTcM warn_msg
  | otherwise     = return ()

-- | Display a diagnostic in the current context.
addDiagnosticTc :: TcRnMessage -> TcM ()
addDiagnosticTc msg
 = do { env0 <- tcInitTidyEnv ;
      addDiagnosticTcM (env0, msg) }

-- | Display a diagnostic in a given context.
addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addDiagnosticTcM (env0, msg)
 = do { ctxt <- getErrCtxt
      ; extra <- mkErrInfo env0 ctxt
      ; let err_info = ErrInfo extra Outputable.empty
            detailed_msg = mkDetailedMessage err_info msg
      ; add_diagnostic detailed_msg }

-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'
-- given some additional context about the diagnostic.
addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic mkMsg = do
  loc <- getSrcSpanM
  name_ppr_ctx <- getNamePprCtx
  !diag_opts  <- initDiagOpts <$> getDynFlags
  env0 <- tcInitTidyEnv
  ctxt <- getErrCtxt
  err_info <- mkErrInfo env0 ctxt
  reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty)))

addTcRnDiagnostic :: TcRnMessage -> TcM ()
addTcRnDiagnostic msg = do
  loc <- getSrcSpanM
  mkTcRnMessage loc msg >>= reportDiagnostic

-- | Display a diagnostic for the current source location, taken from
-- the 'TcRn' monad.
addDiagnostic :: TcRnMessage -> TcRn ()
addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg)

-- | Display a diagnostic for a given source location.
addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt loc msg = do
  unit_state <- hsc_units <$> getTopEnv
  let detailed_msg = mkDetailedMessage no_err_info msg
  mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic

-- | Display a diagnostic, with an optional flag, for the current source
-- location.
add_diagnostic :: TcRnMessageDetailed -> TcRn ()
add_diagnostic msg
  = do { loc <- getSrcSpanM
       ; unit_state <- hsc_units <$> getTopEnv
       ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
       }


{-
-----------------------------------
        Other helper functions
-}

add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan
            -> [ErrCtxt]
            -> TcM ()
add_err_tcm tidy_env msg loc ctxt
 = do { err_info <- mkErrInfo tidy_env ctxt ;
        add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) }

mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
-- Tidy the error info, trimming excessive contexts
mkErrInfo env ctxts
--  = do
--       dbg <- hasPprDebug <$> getDynFlags
--       if dbg                -- In -dppr-debug style the output
--          then return empty  -- just becomes too voluminous
--          else go dbg 0 env ctxts
 = go False 0 env ctxts
 where
   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
   go _ _ _   [] = return empty
   go dbg n env ((is_landmark, ctxt) : ctxts)
     | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
     = do { (env', msg) <- ctxt env
          ; let n' = if is_landmark then n else n+1
          ; rest <- go dbg n' env' ctxts
          ; return (msg $$ rest) }
     | otherwise
     = go dbg n env ctxts

mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
mAX_CONTEXTS = 3

-- debugTc is useful for monadic debugging code

debugTc :: TcM () -> TcM ()
debugTc thing
 | debugIsOn = thing
 | otherwise = return ()

{-
************************************************************************
*                                                                      *
             Type constraints
*                                                                      *
************************************************************************
-}

addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
addTopEvBinds new_ev_binds thing_inside
  =updGblEnv upd_env thing_inside
  where
    upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
                                               `unionBags` new_ev_binds }

newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
                  ; tcvs_ref  <- newTcRef emptyVarSet
                  ; uniq <- newUnique
                  ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
                  ; return (EvBindsVar { ebv_binds = binds_ref
                                       , ebv_tcvs = tcvs_ref
                                       , ebv_uniq = uniq }) }

-- | Creates an EvBindsVar incapable of holding any bindings. It still
-- tracks covar usages (see comments on ebv_tcvs in "GHC.Tc.Types.Evidence"), thus
-- must be made monadically
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds
  = do { tcvs_ref  <- newTcRef emptyVarSet
       ; uniq <- newUnique
       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
       ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
                              , ebv_uniq = uniq }) }

cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
-- Clone the refs, so that any binding created when
-- solving don't pollute the original
cloneEvBindsVar ebv@(EvBindsVar {})
  = do { binds_ref <- newTcRef emptyEvBindMap
       ; tcvs_ref  <- newTcRef emptyVarSet
       ; return (ebv { ebv_binds = binds_ref
                     , ebv_tcvs = tcvs_ref }) }
cloneEvBindsVar ebv@(CoEvBindsVar {})
  = do { tcvs_ref  <- newTcRef emptyVarSet
       ; return (ebv { ebv_tcvs = tcvs_ref }) }

getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
getTcEvTyCoVars ev_binds_var
  = readTcRef (ebv_tcvs ev_binds_var)

getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
  = readTcRef ev_ref
getTcEvBindsMap (CoEvBindsVar {})
  = return emptyEvBindMap

setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
  = writeTcRef ev_ref binds
setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
  | isEmptyEvBindMap ev_binds
  = return ()
  | otherwise
  = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)

addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
-- Add a binding to the TcEvBinds by side effect
addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
  = do { traceTc "addTcEvBind" $ ppr u $$
                                 ppr ev_bind
       ; bnds <- readTcRef ev_ref
       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
  = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)

chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
  do { env <- getGblEnv
     ; let dfun_n_var = tcg_dfun_n env
     ; set <- readTcRef dfun_n_var
     ; let occ = fn set
     ; writeTcRef dfun_n_var (extendOccSet set occ)
     ; return occ }

getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }

setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })

emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints static_lie
  = do { gbl_env <- getGblEnv
       ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }

emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
  | isEmptyWC ct
  = return ()
  | otherwise
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`andWC` ct) }

emitSimple :: Ct -> TcM ()
emitSimple ct
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addSimples` unitBag ct) }

emitSimples :: Cts -> TcM ()
emitSimples cts
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addSimples` cts) }

emitImplication :: Implication -> TcM ()
emitImplication ct
  = do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addImplics` unitBag ct) }

emitImplications :: Bag Implication -> TcM ()
emitImplications ct
  = unless (isEmptyBag ct) $
    do { lie_var <- getConstraintVar ;
         updTcRef lie_var (`addImplics` ct) }

emitInsoluble :: Ct -> TcM ()
emitInsoluble ct
  = do { traceTc "emitInsoluble" (ppr ct)
       ; lie_var <- getConstraintVar
       ; updTcRef lie_var (`addInsols` unitBag ct) }

emitDelayedErrors :: Bag DelayedError -> TcM ()
emitDelayedErrors errs
  = do { traceTc "emitDelayedErrors" (ppr errs)
       ; lie_var <- getConstraintVar
       ; updTcRef lie_var (`addDelayedErrors` errs)}

emitHole :: Hole -> TcM ()
emitHole hole
  = do { traceTc "emitHole" (ppr hole)
       ; lie_var <- getConstraintVar
       ; updTcRef lie_var (`addHoles` unitBag hole) }

emitHoles :: Bag Hole -> TcM ()
emitHoles holes
  = do { traceTc "emitHoles" (ppr holes)
       ; lie_var <- getConstraintVar
       ; updTcRef lie_var (`addHoles` holes) }

emitNotConcreteError :: NotConcreteError -> TcM ()
emitNotConcreteError err
  = do { traceTc "emitNotConcreteError" (ppr err)
       ; lie_var <- getConstraintVar
       ; updTcRef lie_var (`addNotConcreteError` err) }

-- | Throw out any constraints emitted by the thing_inside
discardConstraints :: TcM a -> TcM a
discardConstraints thing_inside = fst <$> captureConstraints thing_inside

-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints thing_inside
  = do { tclvl <- getTcLevel
       ; let tclvl' = pushTcLevel tclvl
       ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
       ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $
                       captureConstraints thing_inside
       ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
       ; return (tclvl', lie, res) }

pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x

pushTcLevelM :: TcM a -> TcM (TcLevel, a)
-- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType
pushTcLevelM thing_inside
  = do { tclvl <- getTcLevel
       ; let tclvl' = pushTcLevel tclvl
       ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside
       ; return (tclvl', res) }

getTcLevel :: TcM TcLevel
getTcLevel = do { env <- getLclEnv
                ; return (tcl_tclvl env) }

setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel tclvl thing_inside
  = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside

isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM tv
  = do { lvl <- getTcLevel
       ; return (isTouchableMetaTyVar lvl tv) }

getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }

setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
-- Set the local type envt, but do *not* disturb other fields,
-- notably the lie_var
setLclTypeEnv lcl_env thing_inside
  = updLclEnv upd thing_inside
  where
    upd env = env { tcl_env = tcl_env lcl_env }

traceTcConstraints :: String -> TcM ()
traceTcConstraints msg
  = do { lie_var <- getConstraintVar
       ; lie     <- readTcRef lie_var
       ; traceOptTcRn Opt_D_dump_tc_trace $
         hang (text (msg ++ ": LIE:")) 2 (ppr lie)
       }

data IsExtraConstraint = YesExtraConstraint
                       | NoExtraConstraint

instance Outputable IsExtraConstraint where
  ppr YesExtraConstraint = text "YesExtraConstraint"
  ppr NoExtraConstraint  = text "NoExtraConstraint"

emitAnonTypeHole :: IsExtraConstraint
                 -> TcTyVar -> TcM ()
emitAnonTypeHole extra_constraints tv
  = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing
       ; let hole = Hole { hole_sort = sort
                         , hole_occ  = mkRdrUnqual occ
                         , hole_ty   = mkTyVarTy tv
                         , hole_loc  = ct_loc }
       ; emitHole hole }
  where
    occ = mkTyVarOccFS (fsLit "_")
    sort | YesExtraConstraint <- extra_constraints = ConstraintHole
         | otherwise                               = TypeHole

emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
emitNamedTypeHole (name, tv)
  = do { ct_loc <- setSrcSpan (nameSrcSpan name) $
                   getCtLocM (TypeHoleOrigin occ) Nothing
       ; let hole = Hole { hole_sort = TypeHole
                         , hole_occ  = nameRdrName name
                         , hole_ty   = mkTyVarTy tv
                         , hole_loc  = ct_loc }
       ; emitHole hole }
  where
    occ       = nameOccName name

{- Note [Constraints and errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (#12124):

  foo :: Maybe Int
  foo = return (case Left 3 of
                  Left -> 1  -- Hard error here!
                  _    -> 0)

The call to 'return' will generate a (Monad m) wanted constraint; but
then there'll be "hard error" (i.e. an exception in the TcM monad), from
the unsaturated Left constructor pattern.

We'll recover in tcPolyBinds, using recoverM.  But then the final
tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
un-filled-in, and will emit a misleading error message.

The underlying problem is that an exception interrupts the constraint
gathering process. Bottom line: if we have an exception, it's best
simply to discard any gathered constraints.  Hence in 'attemptM' we
capture the constraints in a fresh variable, and only emit them into
the surrounding context if we exit normally.  If an exception is
raised, simply discard the collected constraints... we have a hard
error to report.  So this capture-the-emit dance isn't as stupid as it
looks :-).

However suppose we throw an exception inside an invocation of
captureConstraints, and discard all the constraints. Some of those
constraints might be "variable out of scope" Hole constraints, and that
might have been the actual original cause of the exception!  For
example (#12529):
   f = p @ Int
Here 'p' is out of scope, so we get an insoluble Hole constraint. But
the visible type application fails in the monad (throws an exception).
We must not discard the out-of-scope error.

It's distressingly delicate though:

* If we discard too /many/ constraints we may fail to report the error
  that led us to interrupt the constraint gathering process.

  One particular example "variable out of scope" Hole constraints. For
  example (#12529):
   f = p @ Int
  Here 'p' is out of scope, so we get an insoluble Hole constraint. But
  the visible type application fails in the monad (throws an exception).
  We must not discard the out-of-scope error.

  Also GHC.Tc.Solver.simplifyAndEmitFlatConstraints may fail having
  emitted some constraints with skolem-escape problems.

* If we discard too /few/ constraints, we may get the misleading
  class constraints mentioned above.  But we may /also/ end up taking
  constraints built at some inner level, and emitting them at some
  outer level, and then breaking the TcLevel invariants
  See Note [TcLevel invariants] in GHC.Tc.Utils.TcType

So dropMisleading has a horridly ad-hoc structure.  It keeps only
/insoluble/ flat constraints (which are unlikely to very visibly trip
up on the TcLevel invariant, but all /implication/ constraints (except
the class constraints inside them).  The implication constraints are
OK because they set the ambient level before attempting to solve any
inner constraints.  Ugh! I hate this. But it seems to work.

However note that freshly-generated constraints like (Int ~ Bool), or
((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
insoluble.  The constraint solver does that.  So they'll be discarded.
That's probably ok; but see th/5358 as a not-so-good example:
   t1 :: Int
   t1 x = x   -- Manifestly wrong

   foo = $(...raises exception...)
We report the exception, but not the bug in t1.  Oh well.  Possible
solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.


************************************************************************
*                                                                      *
             Template Haskell context
*                                                                      *
************************************************************************
-}

recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }

recordThSpliceUse :: TcM ()
recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }

recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()
recordThNeededRuntimeDeps new_links new_pkgs
  = do { env <- getGblEnv
       ; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->
           let links = new_links ++ needed_links
               !pkgs = plusUDFM needed_pkgs new_pkgs
               in (links, pkgs)
       }

keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
keepAlive name
  = do { env <- getGblEnv
       ; traceRn "keep alive" (ppr name)
       ; updTcRef (tcg_keep env) (`extendNameSet` name) }

getStage :: TcM ThStage
getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }

getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel name
  = do { env <- getLclEnv;
       ; case lookupNameEnv (tcl_th_bndrs env) name of
           Nothing                  -> return Nothing
           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }

setStage :: ThStage -> TcM a -> TcRn a
setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })

-- | Adds the given modFinalizers to the global environment and set them to use
-- the current local environment.
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv mod_finalizers
  = do lcl_env <- getLclEnv
       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
       updTcRef th_modfinalizers_var $ \fins ->
         (lcl_env, mod_finalizers) : fins

{-
************************************************************************
*                                                                      *
             Safe Haskell context
*                                                                      *
************************************************************************
-}

-- | Mark that safe inference has failed
-- See Note [Safe Haskell Overlapping Instances Implementation]
-- although this is used for more than just that failure case.
recordUnsafeInfer :: Messages TcRnMessage -> TcM ()
recordUnsafeInfer msgs =
    getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False
                             writeTcRef (tcg_safe_infer_reasons env) msgs

-- | Figure out the final correct safe haskell mode
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode dflags tcg_env = do
    safeInf <- readIORef (tcg_safe_infer tcg_env)
    return $ case safeHaskell dflags of
        Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred
                | otherwise                     -> Sf_None
        s -> s

-- | Switch instances to safe instances if we're in Safe mode.
fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id
fixSafeInstances _ = map fixSafe
  where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
                       in inst { is_flag = new_flag }

{-
************************************************************************
*                                                                      *
             Stuff for the renamer's local env
*                                                                      *
************************************************************************
-}

getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }

setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env thing_inside
  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside

{-
************************************************************************
*                                                                      *
             Stuff for interface decls
*                                                                      *
************************************************************************
-}

mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv mod loc boot
                   = IfLclEnv { if_mod     = mod,
                                if_loc     = loc,
                                if_boot    = boot,
                                if_nsubst  = Nothing,
                                if_implicits_env = Nothing,
                                if_tv_env  = emptyFsEnv,
                                if_id_env  = emptyFsEnv }

-- | Run an 'IfG' (top-level interface monad) computation inside an existing
-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
-- based on 'TcGblEnv'.
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
  = do  { tcg_env <- getGblEnv
        ; hsc_env <- getTopEnv
          -- bangs to avoid leaking the envs (#19356)
        ; let !mhome_unit = hsc_home_unit_maybe hsc_env
              !knot_vars = tcg_type_env_var tcg_env
              -- When we are instantiating a signature, we DEFINITELY
              -- do not want to knot tie.
              is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit)
        ; let { if_env = IfGblEnv {
                            if_doc = text "initIfaceTcRn",
                            if_rec_types =
                                if is_instantiate
                                    then emptyKnotVars
                                    else readTcRef <$> knot_vars
                            }
                         }
        ; setEnvs (if_env, ()) thing_inside }

-- | 'initIfaceLoad' can be used when there's no chance that the action will
-- call 'typecheckIface' when inside a module loop and hence 'tcIfaceGlobal'.
initIfaceLoad :: HscEnv -> IfG a -> IO a
initIfaceLoad hsc_env do_this
 = do let gbl_env = IfGblEnv {
                        if_doc = text "initIfaceLoad",
                        if_rec_types = emptyKnotVars
                    }
      initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this

-- | This is used when we are doing to call 'typecheckModule' on an 'ModIface',
-- if it's part of a loop with some other modules then we need to use their
-- IORef TypeEnv vars when typechecking but crucially not our own.
initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule hsc_env this_mod do_this
 = do let gbl_env = IfGblEnv {
                        if_doc = text "initIfaceLoadModule",
                        if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)
                    }
      initTcRnIf 'i' hsc_env gbl_env () do_this

initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
-- Used when checking the up-to-date-ness of the old Iface
-- Initialise the environment with no useful info at all
initIfaceCheck doc hsc_env do_this
 = do let gbl_env = IfGblEnv {
                        if_doc = text "initIfaceCheck" <+> doc,
                        if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env
                    }
      initTcRnIf 'i' hsc_env gbl_env () do_this

initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc hi_boot_file thing_inside
  = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside

-- | Initialize interface typechecking, but with a 'NameShape'
-- to apply when typechecking top-level 'OccName's (see
-- 'lookupIfaceTop')
initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
  = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside

getIfModule :: IfL Module
getIfModule = do { env <- getLclEnv; return (if_mod env) }

--------------------
failIfM :: SDoc -> IfL a
-- The Iface monad doesn't have a place to accumulate errors, so we
-- just fall over fast if one happens; it "shouldn't happen".
-- We use IfL here so that we can get context info out of the local env
failIfM msg = do
    env <- getLclEnv
    let full_msg = (if_loc env <> colon) $$ nest 2 msg
    logger <- getLogger
    liftIO (logMsg logger MCFatal
             noSrcSpan $ withPprStyle defaultErrStyle full_msg)
    failM

--------------------

-- | Run thing_inside in an interleaved thread.
-- It shares everything with the parent thread, so this is DANGEROUS.
--
-- It throws an error if the computation fails
--
-- It's used for lazily type-checking interface
-- signatures, which is pretty benign.
--
-- See Note [Masking exceptions in forkM]
forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
 = unsafeInterleaveM $ uninterruptibleMaskM_ $
    do { traceIf (text "Starting fork {" <+> doc)
       ; mb_res <- tryM $
                   updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
                   thing_inside
       ; case mb_res of
            Right r  -> do  { traceIf (text "} ending fork" <+> doc)
                            ; return r }
            Left exn -> do {
                -- Bleat about errors in the forked thread, if -ddump-if-trace is on
                -- Otherwise we silently discard errors. Errors can legitimately
                -- happen when compiling interface signatures.
                  whenDOptM Opt_D_dump_if_trace $ do
                      logger <- getLogger
                      let msg = hang (text "forkM failed:" <+> doc)
                                   2 (text (show exn))
                      liftIO $ logMsg logger
                                         MCFatal
                                         noSrcSpan
                                         $ withPprStyle defaultErrStyle msg
                ; traceIf (text "} ending fork (badly)" <+> doc)
                ; pgmError "Cannot continue after interface file error" }
    }

setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
                                     { if_implicits_env = Just tenv }) m

{-
Note [Masking exceptions in forkM]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When using GHC-as-API it must be possible to interrupt snippets of code
executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
by throwing an asynchronous interrupt to the GHC thread. However, there is a
subtle problem: runStmt first typechecks the code before running it, and the
exception might interrupt the type checker rather than the code. Moreover, the
typechecker might be inside an unsafeInterleaveIO (through forkM), and
more importantly might be inside an exception handler inside that
unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
asynchronous exception as a synchronous exception, and the exception will end
up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
discussion).  We don't currently know a general solution to this problem, but
we can use uninterruptibleMask_ to avoid the situation.
-}

-- | Get the next cost centre index associated with a given name.
getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM get_ccs nm = do
  env <- getGblEnv
  let cc_st_ref = get_ccs env
  cc_st <- readTcRef cc_st_ref
  let (idx, cc_st') = getCCIndex nm cc_st
  writeTcRef cc_st_ref cc_st'
  return idx

-- | See 'getCCIndexM'.
getCCIndexTcM :: FastString -> TcM CostCentreIndex
getCCIndexTcM = getCCIndexM tcg_cc_st