{-# LANGUAGE RecordWildCards #-}

{-# 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, initTcInteractive, initTcRnIf,

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

  -- * Initialising TcM plugins
  TcMPluginHandling(..),
  withTcMPlugins, shutdownTcMPluginsIO,
  rewriterTcMPlugins, holeFitTcMPlugins, defaultingTcMPlugins, solverTcMPlugins,

  -- * Arrow scopes
  newArrowScope, escapeArrowScope,

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

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

  -- * 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, addDependentDirectories,

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

  -- * Usage environment
  tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,

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

  -- * Context management for the type checker
  getErrCtxt, setErrCtxt, addErrCtxt,
  addExprCtxt,
  popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv,

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

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

  -- * Template Haskell context
  recordThUse, recordThNeededRuntimeDeps,
  keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel,
  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,

  -- * Zonking
  liftZonkM, newUnusedType,

  -- * Complete matches
  localAndImportedCompleteMatches, getCompleteMatchesTcM,

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

import GHC.Prelude


import GHC.Builtin.Names
import GHC.Builtin.Types( unusedTypeTyCon )

import GHC.Tc.Errors.Types
import GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin, HoleFitPluginR (..) )
import GHC.Tc.Types     -- Re-export all
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.ErrCtxt
import GHC.Tc.Types.LclEnv
import GHC.Tc.Types.Origin
import GHC.Tc.Types.TcRef
import GHC.Tc.Types.TH
import GHC.Tc.Utils.TcType
import GHC.Tc.Zonk.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.PackageTable

import GHC.Core.UsageEnv
import GHC.Core.Coercion ( isReflCo )
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Core.Type( mkStrLitTy )
import GHC.Core.TyCo.Rep( CoercionHole(..) )
import GHC.Core.TyCo.FVs( coVarsOfCo )
import GHC.Core.TyCon ( TyCon )

import GHC.Driver.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.Plugins ( Plugin(..), mapPlugins )
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic

import GHC.Iface.Errors.Types
import GHC.Iface.Errors.Ppr

import GHC.Linker.Types

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.Misc
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import qualified GHC.Data.Strict as Strict
import qualified Data.Set as Set

import GHC.Types.Error
import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv )
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.Env
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Ppr
import GHC.Types.Unique.FM ( UniqFM, emptyUFM, sequenceUFMList )
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Supply
import GHC.Types.Unique (uniqueTag)
import GHC.Types.Annotations
import GHC.Types.Basic( TypeOrKind(..) )
import GHC.Types.CostCentre.State
import GHC.Types.SourceFile

import qualified GHC.LanguageExtensions as LangExt

import Control.Exception ( throwIO )
import Control.Monad
import Control.Monad.Catch ( bracket_, finally, onException, mask, mask_, MonadCatch )
import Data.Foldable (traverse_)
import Data.IORef
import qualified Data.Map as Map

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

-- | How should 'TcM' plugins be handled when initialising of the
-- typechecker? See Note [Stop TcM plugins after desugaring].
--
-- Usage:
--
--  1. If you want to typecheck then desugar, use 'StartAndKeepRunningTcMPlugins'.
--     This will ensure 'TcM' plugins are kept running for the benefit of the
--     pattern-match checker, and shut down after desugaring.
--  2. If you only want to typecheck and not desugar, use 'StartAndStopTcMPlugins'.
--  3. If a prior operation has started 'TcM' plugins, you can use 'UseRunningTcMPlugins'
--     to avoid re-initialising the plugins, for example in 'initTc'.
--  4. If you don't care about 'TcM' plugins at all, you can use 'NoTcMPlugins'.
data TcMPluginHandling
  -- | Start 'TcM' plugins, run the inner action, then shut down all 'TcM' plugins.
  --
  -- Use this if you only need to run the typechecker, and do not intend to
  -- proceed to desugaring (in which case you should use 'StartAndKeepRunningTcMPlugins').
  = StartAndStopTcMPlugins
  -- | Start 'TcM' plugins, run the inner action, then run the "post-tc"
  -- actions of the plugins, but keep the 'TcM' plugins running.
  --
  -- Use this when you intend to proceed to desugaring, as the desugarer wants
  -- 'TcM' plugins to be running (for solver invocations via the pattern match checker).
  -- The desugarer will then shut down all 'TcM' plugins.
  --
  -- If you only intend to typecheck, without desugaring, you should use
  -- 'StartAndStopTcMPlugins'.
  | StartAndKeepRunningTcMPlugins
  -- | Use the 'TcM' plugins that are already running.
  --
  -- Use this when a prior operation has already initialised 'TcM' plugins
  -- in order to avoid re-initialising them.
  --
  -- NB: this will cause a crash if the plugins are not running (either not
  -- started or already stopped).
  | UseRunningTcMPlugins

  -- | Don't use any 'TcM' plugins.
  | NoTcMPlugins

-- | Set up the typechecking environment.
initTc
  :: TcMPluginHandling
  -> HscEnv
  -> HscSource
  -> Bool      -- True <=> retain renamed syntax trees
  -> Module
  -> RealSrcSpan
  -> TcM r
  -> IO (Messages TcRnMessage, Maybe r)
initTc :: forall r.
TcMPluginHandling
-> HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc TcMPluginHandling
plugin_handling HscEnv
hsc_env HscSource
hsc_src Bool
keep_rn_syntax Module
mod RealSrcSpan
loc TcM r
do_this
  = do { gbl_env <- HscEnv -> HscSource -> Bool -> Module -> RealSrcSpan -> IO TcGblEnv
initTcGblEnv HscEnv
hsc_env HscSource
hsc_src Bool
keep_rn_syntax Module
mod RealSrcSpan
loc
       ; initTcWithGbl hsc_env gbl_env loc $
           case plugin_handling of
             TcMPluginHandling
StartAndStopTcMPlugins ->
               HscEnv -> TcM r -> TcM r
forall a. HasDebugCallStack => HscEnv -> TcM a -> TcM a
withTcMPlugins HscEnv
hsc_env TcM r
do_this
             TcMPluginHandling
StartAndKeepRunningTcMPlugins -> ((forall a.
  IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
 -> TcM r)
-> TcM r
forall b.
HasCallStack =>
((forall a.
  IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
 -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a.
   IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
  -> TcM r)
 -> TcM r)
-> ((forall a.
     IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
    -> TcM r)
-> TcM r
forall a b. (a -> b) -> a -> b
$ \forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
restore -> do
               -- Initialise the plugins
               IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
restore (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ HscEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
initTcMPlugins HscEnv
hsc_env

               -- Run the inner action and then the "post-tc" action.
               (TcM r -> TcM r
forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
restore TcM r
do_this TcM r -> IOEnv (Env TcGblEnv TcLclEnv) () -> TcM r
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` IOEnv (Env TcGblEnv TcLclEnv) ()
HasDebugCallStack => IOEnv (Env TcGblEnv TcLclEnv) ()
tcMPluginsPostTc)
                 TcM r -> IOEnv (Env TcGblEnv TcLclEnv) () -> TcM r
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` IOEnv (Env TcGblEnv TcLclEnv) ()
shutdownTcMPluginsTcM
                 -- If an uncaught exception escapes TcM, ensure TcM plugins are
                 -- shut down, because we won't progress to desugaring (which
                 -- would otherwise be responsible for shutting down plugins).
             TcMPluginHandling
UseRunningTcMPlugins -> do
               TcM r
do_this
             TcMPluginHandling
NoTcMPlugins -> do
               TcM r -> TcM r
forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
withoutTcMPlugins TcM r
do_this
        }


-- | Create an empty 'TcGblEnv'.
initTcGblEnv :: HscEnv -> HscSource -> Bool -> Module -> RealSrcSpan -> IO TcGblEnv
initTcGblEnv :: HscEnv -> HscSource -> Bool -> Module -> RealSrcSpan -> IO TcGblEnv
initTcGblEnv HscEnv
hsc_env HscSource
hsc_src Bool
keep_rn_syntax Module
mod RealSrcSpan
loc =
  do { keep_var             <- NameSet -> IO (IORef NameSet)
forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet
     ; used_gre_var         <- newIORef []
     ; th_var               <- newIORef False
     ; infer_var            <- newIORef True
     ; infer_reasons_var    <- newIORef emptyMessages
     ; dfun_n_var           <- newIORef emptyOccSet
     ; zany_n_var           <- newIORef 0
     ; dependent_files_var  <- newIORef []
     ; dependent_dirs_var   <- newIORef []
     ; 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)
     ; tcm_plugins_var      <- newIORef TcMPluginsUninitialised
     ; next_wrapper_num     <- newIORef emptyModuleEnv
     ; let
        -- bangs to avoid leaking the env (#19356)
        !dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        !mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
        !logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

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

           | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags       = a -> Maybe a
forall a. a -> Maybe a
Just a
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'.
           | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Haddock DynFlags
dflags       = a -> Maybe a
forall a. a -> Maybe a
Just a
empty_val

           | Bool
keep_rn_syntax                = a -> Maybe a
forall a. a -> Maybe a
Just a
empty_val
           | Bool
otherwise                     = Maybe a
forall a. Maybe a
Nothing ;

      ; return $ 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            = emptyDefaultEnv
          , tcg_default_exports    = emptyDefaultEnv
          , tcg_type_env           = emptyNameEnv
          , tcg_type_env_var       = hsc_type_env_vars hsc_env
          , tcg_inst_env           = emptyInstEnv
          , tcg_fam_inst_env       = emptyFamInstEnv
          , tcg_ann_env            = emptyAnnEnv
          , tcg_complete_match_env = []
          , tcg_th_used            = th_var
          , tcg_th_needed_deps     = th_needed_deps_var
          , tcg_exports            = []
          , tcg_imports            = emptyImportAvails
          , tcg_import_decls       = []
          , 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               = emptyWarn
          , tcg_anns                = []
          , tcg_tcs                 = []
          , tcg_insts               = []
          , tcg_fam_insts           = []
          , tcg_rules               = []
          , tcg_fords               = []
          , tcg_patsyns             = []
          , tcg_merged              = []
          , tcg_dfun_n              = dfun_n_var
          , tcg_zany_n              = zany_n_var
          , tcg_keep                = keep_var
          , tcg_hdr_info            = (Nothing,Nothing)
          , 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_dependent_dirs      = dependent_dirs_var
          , tcg_plugins             = tcm_plugins_var
          , tcg_top_loc             = loc
          , tcg_complete_matches    = []
          , tcg_cc_st               = cc_st_var
          , tcg_next_wrapper_num    = next_wrapper_num
      } }

-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
initTcWithGbl :: HscEnv
              -> TcGblEnv
              -> RealSrcSpan
              -> TcM r
              -> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl :: forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl HscEnv
hsc_env TcGblEnv
gbl_env RealSrcSpan
loc TcM r
do_this
 = do { lie_var      <- WantedConstraints -> IO (IORef WantedConstraints)
forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC
      ; errs_var     <- newIORef emptyMessages
      ; usage_var    <- newIORef zeroUE
      ; let lcl_env = TcLclEnv {
                tcl_lcl_ctxt :: TcLclCtxt
tcl_lcl_ctxt   = TcLclCtxt {
                tcl_loc :: RealSrcSpan
tcl_loc        = RealSrcSpan
loc,
                -- tcl_loc should be over-ridden very soon!
                tcl_in_gen_code :: Bool
tcl_in_gen_code = Bool
False,
                tcl_err_ctxt :: ErrCtxtStack
tcl_err_ctxt   = [],
                tcl_rdr :: LocalRdrEnv
tcl_rdr        = LocalRdrEnv
emptyLocalRdrEnv,
                tcl_th_ctxt :: ThLevel
tcl_th_ctxt    = ThLevel
topLevel,
                tcl_th_bndrs :: ThBindEnv
tcl_th_bndrs   = ThBindEnv
forall a. NameEnv a
emptyNameEnv,
                tcl_arrow_ctxt :: ArrowCtxt
tcl_arrow_ctxt = ArrowCtxt
NoArrowCtxt,
                tcl_env :: TcTypeEnv
tcl_env        = TcTypeEnv
forall a. NameEnv a
emptyNameEnv,
                tcl_bndrs :: TcBinderStack
tcl_bndrs      = [],
                tcl_tclvl :: TcLevel
tcl_tclvl      = TcLevel
topTcLevel
                },
                tcl_usage :: IORef UsageEnv
tcl_usage      = IORef UsageEnv
usage_var,
                tcl_lie :: IORef WantedConstraints
tcl_lie        = IORef WantedConstraints
lie_var,
                tcl_errs :: IORef (Messages TcRnMessage)
tcl_errs       = IORef (Messages TcRnMessage)
errs_var
                }

      ; maybe_res <- initTcRnIf TcTag hsc_env gbl_env lcl_env $
                     do { r <- tryM do_this
                        ; case r of
                          Right r
res -> Maybe r -> TcRnIf TcGblEnv TcLclEnv (Maybe r)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Maybe r
forall a. a -> Maybe a
Just r
res)
                          Left IOEnvFailure
_    -> Maybe r -> TcRnIf TcGblEnv TcLclEnv (Maybe r)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
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 | Messages TcRnMessage -> Bool
forall e. Diagnostic e => Messages e -> Bool
errorsFound Messages TcRnMessage
msgs = Maybe r
forall a. Maybe a
Nothing
                        | Bool
otherwise        = Maybe r
maybe_res }

      ; return (msgs, final_res)
      }

-- | Initialise the type checker monad for use in GHCi.
initTcInteractive
  :: TcMPluginHandling
  -> HscEnv
  -> TcM a
  -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive :: forall a.
TcMPluginHandling
-> HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive TcMPluginHandling
tcm_plugin_handling HscEnv
hsc_env TcM a
thing_inside
  = TcMPluginHandling
-> HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM a
-> IO (Messages TcRnMessage, Maybe a)
forall r.
TcMPluginHandling
-> HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc TcMPluginHandling
tcm_plugin_handling HscEnv
hsc_env HscSource
HsSrcFile Bool
False
           (InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))
           (RealSrcLoc -> RealSrcSpan
realSrcLocSpan RealSrcLoc
interactive_src_loc)
           TcM a
thing_inside
  where
    interactive_src_loc :: RealSrcLoc
interactive_src_loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (FilePath -> FastString
fsLit FilePath
"<interactive>") Int
1 Int
1

initTcRnIf :: UniqueTag              -- ^ Tag for unique supply
           -> HscEnv
           -> gbl -> lcl
           -> TcRnIf gbl lcl a
           -> IO a
initTcRnIf :: forall gbl lcl a.
UniqueTag -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf UniqueTag
uniq_tag HscEnv
hsc_env gbl
gbl_env lcl
lcl_env TcRnIf gbl lcl a
thing_inside
   = do { let { env :: Env gbl lcl
env = Env { env_top :: HscEnv
env_top = HscEnv
hsc_env,
                            env_ut :: Char
env_ut  = UniqueTag -> Char
uniqueTag UniqueTag
uniq_tag,
                            env_gbl :: gbl
env_gbl = gbl
gbl_env,
                            env_lcl :: lcl
env_lcl = lcl
lcl_env} }

        ; Env gbl lcl -> TcRnIf gbl lcl a -> IO a
forall env a. env -> IOEnv env a -> IO a
runIOEnv Env gbl lcl
env TcRnIf gbl lcl a
thing_inside
        }

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

discardResult :: TcM a -> TcM ()
discardResult :: forall a. TcM a -> IOEnv (Env TcGblEnv TcLclEnv) ()
discardResult TcM a
a = TcM a
a TcM a
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

updTopEnvIO :: (HscEnv -> IO HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnvIO :: forall gbl lcl a.
(HscEnv -> IO HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnvIO HscEnv -> IO HscEnv
upd = (Env gbl lcl -> IO (Env gbl lcl))
-> IOEnv (Env gbl lcl) a -> IOEnv (Env gbl lcl) a
forall env env' a. (env -> IO env') -> IOEnv env' a -> IOEnv env a
updEnvIO (\ env :: Env gbl lcl
env@(Env { env_top :: forall gbl lcl. Env gbl lcl -> HscEnv
env_top = HscEnv
top }) ->
                                HscEnv -> IO HscEnv
upd HscEnv
top IO HscEnv -> (HscEnv -> IO (Env gbl lcl)) -> IO (Env gbl lcl)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \HscEnv
t' ->
                                Env gbl lcl -> IO (Env gbl lcl)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Env gbl lcl
env{ env_top = t' })

getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv :: forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv = do { Env{..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; return env_gbl }

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

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

getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv :: forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv = do { Env{..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; return env_lcl }

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

updLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt :: forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt = (TcLclEnv -> TcLclEnv)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((TcLclEnv -> TcLclEnv)
 -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a)
-> ((TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv)
-> (TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a
-> TcRnIf gbl TcLclEnv a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv
modifyLclCtxt

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

restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
-- See Note [restoreLclEnv vs setLclEnv]
restoreLclEnv :: forall gbl a.
TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
restoreLclEnv TcLclEnv
new_lcl_env = (TcLclEnv -> TcLclEnv)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv TcLclEnv -> TcLclEnv
upd
  where
    upd :: TcLclEnv -> TcLclEnv
upd TcLclEnv
old_lcl_env =  TcLclEnv
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 :: forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; return (env_gbl env, env_lcl env) }

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

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

restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
-- See Note [restoreLclEnv vs setLclEnv]
restoreEnvs :: forall a. (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (TcGblEnv
gbl, TcLclEnv
lcl) = TcGblEnv
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
gbl (TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a)
-> (TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a)
-> TcRnIf TcGblEnv TcLclEnv a
-> TcRnIf TcGblEnv TcLclEnv a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcLclEnv
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl a.
TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
restoreLclEnv TcLclEnv
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 :: forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag = Extension -> DynFlags -> Bool
xopt Extension
flag (DynFlags -> Bool)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM :: forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
flag = do
  logger <- IOEnv (Env gbl lcl) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  return (logHasDumpFlag logger flag)

goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM :: forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
flag = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag (DynFlags -> Bool)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM :: forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
flag = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
flag (DynFlags -> Bool)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

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

setWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setWOptM :: forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setWOptM WarningFlag
flag = (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags (\DynFlags
dflags -> DynFlags -> WarningFlag -> DynFlags
wopt_set DynFlags
dflags WarningFlag
flag)

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

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

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

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


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

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

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

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

getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode :: forall gbl lcl. TcRnIf gbl lcl GhcMode
getGhcMode = DynFlags -> GhcMode
ghcMode (DynFlags -> GhcMode)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) GhcMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

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

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

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

getEps :: TcRnIf gbl lcl ExternalPackageState
getEps :: forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
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 :: forall a gbl lcl.
(ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps ExternalPackageState -> (ExternalPackageState, a)
upd_fn = do
  SDoc -> TcRnIf gbl lcl ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"updating EPS")
  eps_var <- TcRnIf gbl lcl (TcRef ExternalPackageState)
forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
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_ :: forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ExternalPackageState -> ExternalPackageState
upd_fn = (ExternalPackageState -> (ExternalPackageState, ()))
-> TcRnIf gbl lcl ()
forall a gbl lcl.
(ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps (\ExternalPackageState
eps -> (ExternalPackageState -> ExternalPackageState
upd_fn ExternalPackageState
eps, ()))

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

getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug :: forall gbl lcl.
TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug = do { env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
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 :: forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr SDoc a) -> m a
withException SDocContext
ctx m (MaybeErr SDoc a)
do_this = do
    r <- m (MaybeErr SDoc a)
do_this
    case r of
        Failed SDoc
err -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (SDocContext -> SDoc -> FilePath
renderWithContext SDocContext
ctx SDoc
err))
        Succeeded a
result -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

withIfaceErr :: MonadIO m => SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr :: forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx m (MaybeErr MissingInterfaceError a)
do_this = do
    r <- m (MaybeErr MissingInterfaceError a)
do_this
    case r of
        Failed MissingInterfaceError
err -> do
          let opts :: DiagnosticOpts IfaceMessage
opts = forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts @IfaceMessage
              msg :: SDoc
msg   = IfaceMessageOpts -> MissingInterfaceError -> SDoc
missingInterfaceErrorDiagnostic IfaceMessageOpts
opts MissingInterfaceError
err
          IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (SDocContext -> SDoc -> FilePath
renderWithContext SDocContext
ctx SDoc
msg))
        Succeeded a
result -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

{-
************************************************************************
*                                                                      *
                 Initialising plugins for TcM
*                                                                      *
************************************************************************
-}

-- | Initialise all 'TcM' plugins, run the inner action, then run
-- both their "post-tc" and "shutdown" actions.
withTcMPlugins :: HasDebugCallStack => HscEnv -> TcM a -> TcM a
withTcMPlugins :: forall a. HasDebugCallStack => HscEnv -> TcM a -> TcM a
withTcMPlugins HscEnv
hsc_env TcM a
thing_inside
  = do { eitherRes <-
           -- Using 'bracket_' ensures the plugins are always stopped.
           IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (HscEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
initTcMPlugins HscEnv
hsc_env) IOEnv (Env TcGblEnv TcLclEnv) ()
stopTcMPluginsTcM (IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
 -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a))
-> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
-> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
             TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcM a
thing_inside
       ; case eitherRes of
           Left  IOEnvFailure
ex  -> IO a -> TcM a
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> TcM a) -> IO a -> TcM a
forall a b. (a -> b) -> a -> b
$ IOEnvFailure -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO IOEnvFailure
ex
           Right a
res -> a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
       }

-- | Run the inner action without any 'TcM' plugins.
withoutTcMPlugins :: TcM a -> TcM a
withoutTcMPlugins :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
withoutTcMPlugins TcM a
thing_inside = do
  IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) () -> TcM a -> TcM a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ IOEnv (Env TcGblEnv TcLclEnv) ()
forall {lcl}. IOEnv (Env TcGblEnv lcl) ()
setup IOEnv (Env TcGblEnv TcLclEnv) ()
teardown TcM a
thing_inside
  where
    setup :: IOEnv (Env TcGblEnv lcl) ()
setup = do
      tcg_env <- TcRnIf TcGblEnv lcl TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
      writeTcRef (tcg_plugins tcg_env) $
        TcMPluginsRunning emptyRunningTcMPlugins
    teardown :: IOEnv (Env TcGblEnv TcLclEnv) ()
teardown =
      -- Don't set 'tcg_plugins' to 'TcMPluginsStopped', as that should only
      -- be used when there were 'TcM' plugins to start with (#27273).
      () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Initialise 'TcM' plugins.
initTcMPlugins :: HscEnv -> TcM ()
initTcMPlugins :: HscEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
initTcMPlugins HscEnv
hsc_env = ((forall a.
  IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall b.
HasCallStack =>
((forall a.
  IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
 -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a.
   IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
  -> IOEnv (Env TcGblEnv TcLclEnv) ())
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ((forall a.
     IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a)
    -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ \ forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
restore -> do
  (solvers, rewritersUniqFM, tc_post_tcs, tc_shutdowns) <- IOEnv
  (Env TcGblEnv TcLclEnv)
  ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
   [IO ()])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
      [IO ()])
forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
restore (IOEnv
   (Env TcGblEnv TcLclEnv)
   ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
    [IO ()])
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
       [IO ()]))
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
      [IO ()])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
      [IO ()])
forall a b. (a -> b) -> a -> b
$ HscEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
      [IO ()])
start_tc_plugins HscEnv
hsc_env
  (defaulters, dflt_post_tcs, dflt_shutdowns) <-
    restore (start_defaulting_plugins hsc_env)
      `onException` liftIO (runPluginShutdowns tc_shutdowns)
  (hf_plugins, hf_stops) <-
    restore (start_holefit_plugins hsc_env)
      `onException` liftIO (runPluginShutdowns (tc_shutdowns ++ dflt_shutdowns))
  let runs =
        TcMPluginsRun
          { tcmp_solvers :: [TcPluginSolver]
tcmp_solvers    = [TcPluginSolver]
solvers
          , tcmp_rewriters :: UniqFM TyCon [TcPluginRewriter]
tcmp_rewriters  = UniqFM TyCon [TcPluginRewriter]
rewritersUniqFM
          , tcmp_defaulters :: [FillDefaulting]
tcmp_defaulters = [FillDefaulting]
defaulters
          , tcmp_hole_fits :: [HoleFitPlugin]
tcmp_hole_fits  = [HoleFitPlugin]
hf_plugins
          }
      post_tcs =
        TcMPluginsPostTc
           { tcpt_tc_plugins :: [TcPluginM ()]
tcpt_tc_plugins         = [TcPluginM ()]
tc_post_tcs
           , tcpt_defaulting_plugins :: [TcPluginM ()]
tcpt_defaulting_plugins = [TcPluginM ()]
dflt_post_tcs
           , tcpt_hole_fit_plugins :: [IOEnv (Env TcGblEnv TcLclEnv) ()]
tcpt_hole_fit_plugins   = [IOEnv (Env TcGblEnv TcLclEnv) ()]
hf_stops
           }
      shutdowns =
        TcMPluginsShutdown
          { tcps_tc_plugins :: [IO ()]
tcps_tc_plugins         = [IO ()]
tc_shutdowns
          , tcps_defaulting_plugins :: [IO ()]
tcps_defaulting_plugins = [IO ()]
dflt_shutdowns
          }
  set_TcMPlugins_initialised $
    RunningTcMPlugins runs post_tcs shutdowns

set_TcMPlugins_initialised :: RunningTcMPlugins -> TcM ()
set_TcMPlugins_initialised :: RunningTcMPlugins -> IOEnv (Env TcGblEnv TcLclEnv) ()
set_TcMPlugins_initialised RunningTcMPlugins
plugins = do
  tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  writeTcRef (tcg_plugins tcg_env) (TcMPluginsRunning plugins)

-- | Run all plugin shutdown actions, using 'finally' to ensure all run even
-- if one throws.
runPluginShutdowns :: [IO ()] -> IO ()
runPluginShutdowns :: [IO ()] -> IO ()
runPluginShutdowns = (IO () -> IO () -> IO ()) -> IO () -> [IO ()] -> IO ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr IO () -> IO () -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
finally (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Like 'traverse', but threads accumulated cleanup actions as state,
-- so that if starting one plugin fails, we run the cleanup actions of
-- previously started plugins.
startPluginsWithCleanup
  :: MonadCatch m
  => ([c] -> m ())   -- ^ cleanup action
  -> (a -> m (r, c)) -- ^ start one
  -> [a]
  -> m ([r], [c])
startPluginsWithCleanup :: forall (m :: * -> *) c a r.
MonadCatch m =>
([c] -> m ()) -> (a -> m (r, c)) -> [a] -> m ([r], [c])
startPluginsWithCleanup [c] -> m ()
runCleanups a -> m (r, c)
start [a]
xs = do
  (cs, rs) <- ([c] -> a -> m ([c], r)) -> [c] -> [a] -> m ([c], [r])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM [c] -> a -> m ([c], r)
step [] [a]
xs
  return (rs, reverse cs)
  where
    step :: [c] -> a -> m ([c], r)
step [c]
cs a
x = do
      (r, c) <- a -> m (r, c)
start a
x m (r, c) -> m () -> m (r, c)
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` [c] -> m ()
runCleanups [c]
cs
      return (c : cs, r)

start_tc_plugins :: HscEnv -> TcM ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()], [IO ()])
start_tc_plugins :: HscEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
      [IO ()])
start_tc_plugins HscEnv
hsc_env =
  case [Maybe TcPlugin] -> [TcPlugin]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TcPlugin] -> [TcPlugin]) -> [Maybe TcPlugin] -> [TcPlugin]
forall a b. (a -> b) -> a -> b
$ Plugins
-> (Plugin -> [FilePath] -> Maybe TcPlugin) -> [Maybe TcPlugin]
forall a. Plugins -> (Plugin -> [FilePath] -> a) -> [a]
mapPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [FilePath] -> Maybe TcPlugin
tcPlugin of
    []      -> ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
 [IO ()])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([TcPluginSolver], UniqFM TyCon [TcPluginRewriter], [TcPluginM ()],
      [IO ()])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UniqFM TyCon [TcPluginRewriter]
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM, [], [])
    [TcPlugin]
plugins -> do
      (triples, shutdowns) <-
        ([IO ()] -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (TcPlugin
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         ((TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ()),
          IO ()))
-> [TcPlugin]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([(TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ())],
      [IO ()])
forall (m :: * -> *) c a r.
MonadCatch m =>
([c] -> m ()) -> (a -> m (r, c)) -> [a] -> m ([r], [c])
startPluginsWithCleanup (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ([IO ()] -> IO ())
-> [IO ()]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO ()] -> IO ()
runPluginShutdowns) TcPlugin
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ((TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ()),
      IO ())
start_plugin [TcPlugin]
plugins
      let (solvers, rewriters, stops) = unzip3 triples
          !rewritersUniqFM = [UniqFM TyCon TcPluginRewriter] -> UniqFM TyCon [TcPluginRewriter]
forall {k} (key :: k) elt. [UniqFM key elt] -> UniqFM key [elt]
sequenceUFMList [UniqFM TyCon TcPluginRewriter]
rewriters
      return (solvers, rewritersUniqFM, stops, shutdowns)
  where
    start_plugin :: TcPlugin
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ((TcPluginSolver, UniqFM TyCon TcPluginRewriter, TcPluginM ()),
      IO ())
start_plugin (TcPlugin TcPluginM s
start s -> TcPluginSolver
solve s -> UniqFM TyCon TcPluginRewriter
rewrite s -> TcPluginM ()
post_tc s -> IO ()
shutdown) = do
      s <- TcPluginM s -> TcM s
forall a. TcPluginM a -> TcM a
runTcPluginM TcPluginM s
start
      return ((solve s, rewrite s, post_tc s), shutdown s)

start_defaulting_plugins :: HscEnv -> TcM ([FillDefaulting], [TcPluginM ()], [IO ()])
start_defaulting_plugins :: HscEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([FillDefaulting], [TcPluginM ()], [IO ()])
start_defaulting_plugins HscEnv
hsc_env =
  case [Maybe DefaultingPlugin] -> [DefaultingPlugin]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DefaultingPlugin] -> [DefaultingPlugin])
-> [Maybe DefaultingPlugin] -> [DefaultingPlugin]
forall a b. (a -> b) -> a -> b
$ Plugins
-> (Plugin -> [FilePath] -> Maybe DefaultingPlugin)
-> [Maybe DefaultingPlugin]
forall a. Plugins -> (Plugin -> [FilePath] -> a) -> [a]
mapPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [FilePath] -> Maybe DefaultingPlugin
defaultingPlugin of
    []      -> ([FillDefaulting], [TcPluginM ()], [IO ()])
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([FillDefaulting], [TcPluginM ()], [IO ()])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], [])
    [DefaultingPlugin]
plugins -> do
      (pairs, shutdowns) <-
        ([IO ()] -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (DefaultingPlugin
    -> IOEnv
         (Env TcGblEnv TcLclEnv) ((FillDefaulting, TcPluginM ()), IO ()))
-> [DefaultingPlugin]
-> IOEnv
     (Env TcGblEnv TcLclEnv) ([(FillDefaulting, TcPluginM ())], [IO ()])
forall (m :: * -> *) c a r.
MonadCatch m =>
([c] -> m ()) -> (a -> m (r, c)) -> [a] -> m ([r], [c])
startPluginsWithCleanup (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> ([IO ()] -> IO ())
-> [IO ()]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [IO ()] -> IO ()
runPluginShutdowns) DefaultingPlugin
-> IOEnv
     (Env TcGblEnv TcLclEnv) ((FillDefaulting, TcPluginM ()), IO ())
start_plugin [DefaultingPlugin]
plugins
      let (fillers, post_tcs) = unzip pairs
      return (fillers, post_tcs, shutdowns)
  where
    start_plugin :: DefaultingPlugin
-> IOEnv
     (Env TcGblEnv TcLclEnv) ((FillDefaulting, TcPluginM ()), IO ())
start_plugin (DefaultingPlugin TcPluginM s
start s -> FillDefaulting
fill s -> TcPluginM ()
post_tc s -> IO ()
shutdown) = do
      s <- TcPluginM s -> TcM s
forall a. TcPluginM a -> TcM a
runTcPluginM TcPluginM s
start
      return ((fill s, post_tc s), shutdown s)

start_holefit_plugins :: HscEnv -> TcM ([HoleFitPlugin], [TcM ()])
start_holefit_plugins :: HscEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([HoleFitPlugin], [IOEnv (Env TcGblEnv TcLclEnv) ()])
start_holefit_plugins HscEnv
hsc_env =
  case [Maybe HoleFitPluginR] -> [HoleFitPluginR]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe HoleFitPluginR] -> [HoleFitPluginR])
-> [Maybe HoleFitPluginR] -> [HoleFitPluginR]
forall a b. (a -> b) -> a -> b
$ Plugins
-> (Plugin -> [FilePath] -> Maybe HoleFitPluginR)
-> [Maybe HoleFitPluginR]
forall a. Plugins -> (Plugin -> [FilePath] -> a) -> [a]
mapPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [FilePath] -> Maybe HoleFitPluginR
holeFitPlugin of
    []      -> ([HoleFitPlugin], [IOEnv (Env TcGblEnv TcLclEnv) ()])
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([HoleFitPlugin], [IOEnv (Env TcGblEnv TcLclEnv) ()])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    [HoleFitPluginR]
plugins ->
      ([IOEnv (Env TcGblEnv TcLclEnv) ()]
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> (HoleFitPluginR
    -> IOEnv
         (Env TcGblEnv TcLclEnv)
         (HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ()))
-> [HoleFitPluginR]
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([HoleFitPlugin], [IOEnv (Env TcGblEnv TcLclEnv) ()])
forall (m :: * -> *) c a r.
MonadCatch m =>
([c] -> m ()) -> (a -> m (r, c)) -> [a] -> m ([r], [c])
startPluginsWithCleanup [IOEnv (Env TcGblEnv TcLclEnv) ()]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ HoleFitPluginR
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ())
start_plugin [HoleFitPluginR]
plugins
  where
    start_plugin :: HoleFitPluginR
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (HoleFitPlugin, IOEnv (Env TcGblEnv TcLclEnv) ())
start_plugin (HoleFitPluginR TcM (TcRef s)
init TcRef s -> HoleFitPlugin
plugin TcRef s -> IOEnv (Env TcGblEnv TcLclEnv) ()
stop) = do
      ref <- TcM (TcRef s)
init
      return (plugin ref, stop ref)

-- | Run the "post-tc" actions of all 'TcM' plugins, at the end of typechecking.
tcMPluginsPostTc :: HasDebugCallStack => TcM ()
tcMPluginsPostTc :: HasDebugCallStack => IOEnv (Env TcGblEnv TcLclEnv) ()
tcMPluginsPostTc = do
  tcm_plugins_ref <- TcGblEnv -> IORef TcMPluginsState
tcg_plugins (TcGblEnv -> IORef TcMPluginsState)
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef TcMPluginsState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  tcm_plugins <- readTcRef tcm_plugins_ref
  case tcm_plugins of
    TcMPluginsState
TcMPluginsUninitialised ->
      FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"tcMPluginsPostTc" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"TcM plugins not initialised"
    TcMPluginsState
TcMPluginsStopped ->
      FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"tcMPluginsPostTc" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"TcM plugins already stopped"
    TcMPluginsRunning
      (RunningTcMPlugins { rtcmp_post_tc :: RunningTcMPlugins -> TcMPluginsPostTc
rtcmp_post_tc = TcMPluginsPostTc
post_tcs }) ->
        TcMPluginsPostTc -> IOEnv (Env TcGblEnv TcLclEnv) ()
do_post_tcs TcMPluginsPostTc
post_tcs
  where
    do_post_tcs :: TcMPluginsPostTc -> IOEnv (Env TcGblEnv TcLclEnv) ()
do_post_tcs (TcMPluginsPostTc [TcPluginM ()]
tcs [TcPluginM ()]
defs [IOEnv (Env TcGblEnv TcLclEnv) ()]
hfs) = do
      (TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [TcPluginM ()] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcPluginM a -> TcM a
runTcPluginM [TcPluginM ()]
tcs
      (TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [TcPluginM ()] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TcPluginM () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcPluginM a -> TcM a
runTcPluginM [TcPluginM ()]
defs
      [IOEnv (Env TcGblEnv TcLclEnv) ()]
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IOEnv (Env TcGblEnv TcLclEnv) ()]
hfs

-- | Runs both the "post-tc" and "shutdown" actions of all 'TcM' plugins.
stopTcMPluginsTcM :: TcM ()
stopTcMPluginsTcM :: IOEnv (Env TcGblEnv TcLclEnv) ()
stopTcMPluginsTcM =
  IOEnv (Env TcGblEnv TcLclEnv) ()
HasDebugCallStack => IOEnv (Env TcGblEnv TcLclEnv) ()
tcMPluginsPostTc IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` IOEnv (Env TcGblEnv TcLclEnv) ()
shutdownTcMPluginsTcM

-- | Runs the "shutdown" actions of all 'TcM' plugins.
shutdownTcMPluginsTcM :: TcM ()
shutdownTcMPluginsTcM :: IOEnv (Env TcGblEnv TcLclEnv) ()
shutdownTcMPluginsTcM = IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
  tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  tcm_plugins_ref <- tcg_plugins <$> getGblEnv
  tcm_plugins <- readTcRef tcm_plugins_ref
  liftIO $ shutdownTcMPlugins tcm_plugins
  writeTcRef (tcg_plugins tcg_env) TcMPluginsStopped

shutdownTcMPluginsIO :: TcRef TcMPluginsState -> IO ()
shutdownTcMPluginsIO :: IORef TcMPluginsState -> IO ()
shutdownTcMPluginsIO IORef TcMPluginsState
plugins_ref = IO () -> IO ()
forall (m :: * -> *) a. (HasCallStack, MonadMask m) => m a -> m a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  tcm_plugins <- IORef TcMPluginsState -> IO TcMPluginsState
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef IORef TcMPluginsState
plugins_ref
  shutdownTcMPlugins tcm_plugins
  writeIORef plugins_ref TcMPluginsStopped

-- | Shutdown all 'TcM' plugins.
--
-- Precondition: async exceptions are masked.
shutdownTcMPlugins :: TcMPluginsState -> IO ()
shutdownTcMPlugins :: TcMPluginsState -> IO ()
shutdownTcMPlugins = \case
  TcMPluginsState
TcMPluginsUninitialised -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  TcMPluginsState
TcMPluginsStopped -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  TcMPluginsRunning
    (RunningTcMPlugins { rtcmp_shutdown :: RunningTcMPlugins -> TcMPluginsShutdown
rtcmp_shutdown = TcMPluginsShutdown
stops }) ->
      TcMPluginsShutdown -> IO ()
do_stop TcMPluginsShutdown
stops
  where
    do_stop :: TcMPluginsShutdown -> IO ()
do_stop (TcMPluginsShutdown [IO ()]
tcs [IO ()]
defs) =
      [IO ()] -> IO ()
runPluginShutdowns ([IO ()]
tcs [IO ()] -> [IO ()] -> [IO ()]
forall a. [a] -> [a] -> [a]
++ [IO ()]
defs)

solverTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [TcPluginSolver]
solverTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [TcPluginSolver]
solverTcMPlugins =
  TcMPluginsRun -> [TcPluginSolver]
tcmp_solvers (TcMPluginsRun -> [TcPluginSolver])
-> (TcMPluginsState -> TcMPluginsRun)
-> TcMPluginsState
-> [TcPluginSolver]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunningTcMPlugins -> TcMPluginsRun
tcMPluginsRunActions (RunningTcMPlugins -> TcMPluginsRun)
-> (TcMPluginsState -> RunningTcMPlugins)
-> TcMPluginsState
-> TcMPluginsRun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => TcMPluginsState -> RunningTcMPlugins
TcMPluginsState -> RunningTcMPlugins
runningTcMPlugins

rewriterTcMPlugins :: HasDebugCallStack => TcMPluginsState -> UniqFM TyCon [TcPluginRewriter]
rewriterTcMPlugins :: HasDebugCallStack =>
TcMPluginsState -> UniqFM TyCon [TcPluginRewriter]
rewriterTcMPlugins =
  TcMPluginsRun -> UniqFM TyCon [TcPluginRewriter]
tcmp_rewriters (TcMPluginsRun -> UniqFM TyCon [TcPluginRewriter])
-> (TcMPluginsState -> TcMPluginsRun)
-> TcMPluginsState
-> UniqFM TyCon [TcPluginRewriter]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunningTcMPlugins -> TcMPluginsRun
tcMPluginsRunActions (RunningTcMPlugins -> TcMPluginsRun)
-> (TcMPluginsState -> RunningTcMPlugins)
-> TcMPluginsState
-> TcMPluginsRun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => TcMPluginsState -> RunningTcMPlugins
TcMPluginsState -> RunningTcMPlugins
runningTcMPlugins

defaultingTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [FillDefaulting]
defaultingTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [FillDefaulting]
defaultingTcMPlugins =
  TcMPluginsRun -> [FillDefaulting]
tcmp_defaulters (TcMPluginsRun -> [FillDefaulting])
-> (TcMPluginsState -> TcMPluginsRun)
-> TcMPluginsState
-> [FillDefaulting]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunningTcMPlugins -> TcMPluginsRun
tcMPluginsRunActions (RunningTcMPlugins -> TcMPluginsRun)
-> (TcMPluginsState -> RunningTcMPlugins)
-> TcMPluginsState
-> TcMPluginsRun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => TcMPluginsState -> RunningTcMPlugins
TcMPluginsState -> RunningTcMPlugins
runningTcMPlugins

holeFitTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [HoleFitPlugin]
holeFitTcMPlugins :: HasDebugCallStack => TcMPluginsState -> [HoleFitPlugin]
holeFitTcMPlugins =
  TcMPluginsRun -> [HoleFitPlugin]
tcmp_hole_fits (TcMPluginsRun -> [HoleFitPlugin])
-> (TcMPluginsState -> TcMPluginsRun)
-> TcMPluginsState
-> [HoleFitPlugin]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunningTcMPlugins -> TcMPluginsRun
tcMPluginsRunActions (RunningTcMPlugins -> TcMPluginsRun)
-> (TcMPluginsState -> RunningTcMPlugins)
-> TcMPluginsState
-> TcMPluginsRun
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasDebugCallStack => TcMPluginsState -> RunningTcMPlugins
TcMPluginsState -> RunningTcMPlugins
runningTcMPlugins

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

newArrowScope :: TcM a -> TcM a
newArrowScope :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
newArrowScope
  = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((TcLclEnv -> TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a)
-> (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a
-> TcRnIf TcGblEnv TcLclEnv a
forall a b. (a -> b) -> a -> b
$ \TcLclEnv
env ->
      (TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv
modifyLclCtxt (\TcLclCtxt
ctx -> TcLclCtxt
ctx { tcl_arrow_ctxt = ArrowCtxt (getLclEnvRdrEnv env) (tcl_lie env) } ) TcLclEnv
env

-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
escapeArrowScope
  = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((TcLclEnv -> TcLclEnv)
 -> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a)
-> (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a
-> TcRnIf TcGblEnv TcLclEnv a
forall a b. (a -> b) -> a -> b
$ \ TcLclEnv
env ->
    case TcLclEnv -> ArrowCtxt
getLclEnvArrowCtxt TcLclEnv
env of
      ArrowCtxt
NoArrowCtxt       -> TcLclEnv
env
      ArrowCtxt LocalRdrEnv
rdr_env IORef WantedConstraints
lie -> TcLclEnv
env { tcl_lcl_ctxt = (tcl_lcl_ctxt env) { tcl_arrow_ctxt = NoArrowCtxt
                                                                       , tcl_rdr = rdr_env }
                                   , tcl_lie = lie }

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

newUnique :: TcRnIf gbl lcl Unique
newUnique :: forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
 = do { env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv
      ; let tag = Env gbl lcl -> Char
forall gbl lcl. Env gbl lcl -> Char
env_ut Env gbl lcl
env
      ; liftIO $! uniqFromTagGrimly tag }

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply :: forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv
      ; let tag = Env gbl lcl -> Char
forall gbl lcl. Env gbl lcl -> Char
env_ut Env gbl lcl
env
      ; liftIO $! mkSplitUniqSupplyGrimly tag }

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

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

newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt OccName
occ SrcSpan
span
  = do { uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; return (mkInternalName uniq occ span) }

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

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

newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds :: forall gbl lcl.
FastString -> [Scaled Mult] -> TcRnIf gbl lcl [CoVar]
newSysLocalIds FastString
fs [Scaled Mult]
tys
  = do  { us <- IOEnv (Env gbl lcl) [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
        ; let mkId' Unique
n (Scaled Mult
w Mult
t) = FastString -> Unique -> Mult -> Mult -> CoVar
mkSysLocal FastString
fs Unique
n Mult
w Mult
t
        ; return (zipWith mkId' us tys) }

instance MonadUnique (IOEnv (Env gbl lcl)) where
        getUniqueM :: IOEnv (Env gbl lcl) Unique
getUniqueM = IOEnv (Env gbl lcl) Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        getUniqueSupplyM :: IOEnv (Env gbl lcl) UniqSupply
getUniqueSupplyM = IOEnv (Env gbl lcl) UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply

{-
************************************************************************
*                                                                      *
                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 :: FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
herald SDoc
doc =
    DumpFlag -> FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
labelledTraceOptTcRn DumpFlag
Opt_D_dump_tc_trace FilePath
herald SDoc
doc
{-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities]

-- Renamer Trace
traceRn :: String -> SDoc -> TcRn ()
traceRn :: FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceRn FilePath
herald SDoc
doc =
    DumpFlag -> FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
labelledTraceOptTcRn DumpFlag
Opt_D_dump_rn_trace FilePath
herald SDoc
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 :: DumpFlag -> FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
labelledTraceOptTcRn DumpFlag
flag FilePath
herald SDoc
doc =
  DumpFlag -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceOptTcRn DumpFlag
flag (FilePath -> SDoc -> SDoc
formatTraceMsg FilePath
herald SDoc
doc)
{-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]

formatTraceMsg :: String -> SDoc -> SDoc
formatTraceMsg :: FilePath -> SDoc -> SDoc
formatTraceMsg FilePath
herald SDoc
doc = SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
herald) Int
2 SDoc
doc

traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn :: DumpFlag -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceOptTcRn DumpFlag
flag SDoc
doc =
  DumpFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    Bool
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpTcRn Bool
False DumpFlag
flag FilePath
"" DumpFormat
FormatText SDoc
doc
{-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]

-- | Dump if the given 'DumpFlag' is set.
dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
dumpOptTcRn :: DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpOptTcRn DumpFlag
flag FilePath
title DumpFormat
fmt SDoc
doc =
  DumpFlag
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    Bool
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpTcRn Bool
False DumpFlag
flag FilePath
title DumpFormat
fmt SDoc
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 :: Bool
-> DumpFlag
-> FilePath
-> DumpFormat
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) ()
dumpTcRn Bool
useUserStyle DumpFlag
flag FilePath
title DumpFormat
fmt SDoc
doc = do
  logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  name_ppr_ctx <- getNamePprCtx
  real_doc <- wrapDocLoc doc
  let sty = if Bool
useUserStyle
              then NamePprCtx -> Depth -> PprStyle
mkUserStyle NamePprCtx
name_ppr_ctx Depth
AllTheWay
              else NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
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 :: SDoc -> TcRn SDoc
wrapDocLoc SDoc
doc = do
  logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m 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 :: TcRn NamePprCtx
getNamePprCtx
  = do { ptc <- DynFlags -> PromotionTickContext
initPromotionTickContext (DynFlags -> PromotionTickContext)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) PromotionTickContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
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 :: SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
printForUserTcRn SDoc
doc = do
    logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m 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 :: forall m n. SDoc -> TcRnIf m n ()
traceIf = DumpFlag -> SDoc -> TcRnIf m n ()
forall m n. DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf DumpFlag
Opt_D_dump_if_trace
{-# INLINE traceIf #-}
  -- see Note [INLINE conditional tracing utilities]

traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf :: forall m n. DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf DumpFlag
flag SDoc
doc
  = DumpFlag -> TcRnIf m n () -> TcRnIf m n ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag (TcRnIf m n () -> TcRnIf m n ()) -> TcRnIf m n () -> TcRnIf m n ()
forall a b. (a -> b) -> a -> b
$ do   -- No RdrEnv available, so qualify everything
        logger <- IOEnv (Env m n) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
        liftIO (putMsg logger doc)
{-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]

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

getIsGHCi :: TcRn Bool
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
               ; return (isInteractiveModule mod) }

getGHCiMonad :: TcRn Name
getGHCiMonad :: TcM Name
getGHCiMonad = do { hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; return (ic_monad $ hsc_IC hsc) }

getInteractivePrintName :: TcRn Name
getInteractivePrintName :: TcM Name
getInteractivePrintName = do { hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; return (ic_int_print $ hsc_IC hsc) }

tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = HscSource -> Bool
isHsBootOrSig (HscSource -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) HscSource -> TcRn Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) HscSource
tcHscSource

tcHscSource :: TcRn HscSource
tcHscSource :: IOEnv (Env TcGblEnv TcLclEnv) HscSource
tcHscSource = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_src env)}

tcIsHsig :: TcRn Bool
tcIsHsig :: TcRn Bool
tcIsHsig = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (isHsigFile (tcg_src env)) }

tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_self_boot env) }

getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_rdr_env env) }

getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs; return (tcg_rdr_env gbl, getLclEnvRdrEnv lcl) }

getImports :: TcRn ImportAvails
getImports :: TcRn ImportAvails
getImports = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_imports env) }

getFixityEnv :: TcRn FixityEnv
getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_fix_env env) }

extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv :: forall a. [(Name, FixItem)] -> RnM a -> RnM a
extendFixityEnv [(Name, FixItem)]
new_bit
  = (TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\env :: TcGblEnv
env@(TcGblEnv { tcg_fix_env :: TcGblEnv -> FixityEnv
tcg_fix_env = FixityEnv
old_fix_env }) ->
                TcGblEnv
env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})

getDeclaredDefaultTys :: TcRn DefaultEnv
getDeclaredDefaultTys :: TcRn DefaultEnv
getDeclaredDefaultTys = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_default env) }

addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles :: [FilePath] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDependentFiles [FilePath]
fs = do
  ref <- (TcGblEnv -> IORef [FilePath])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef [FilePath])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> IORef [FilePath]
tcg_dependent_files TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  dep_files <- readTcRef ref
  writeTcRef ref (fs ++ dep_files)

addDependentDirectories :: [FilePath] -> TcRn ()
addDependentDirectories :: [FilePath] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDependentDirectories [FilePath]
ds = do
  ref <- (TcGblEnv -> IORef [FilePath])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef [FilePath])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> IORef [FilePath]
tcg_dependent_dirs TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  dep_dirs <- readTcRef ref
  writeTcRef ref (ds ++ dep_dirs)

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

getSrcSpanM :: TcRn SrcSpan
        -- Avoid clash with Name.getSrcLoc
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) }

getRealSrcSpanM :: TcRn RealSrcSpan
        -- Avoid clash with Name.getSrcLoc
getRealSrcSpanM :: TcRn RealSrcSpan
getRealSrcSpanM = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return $ getLclEnvLoc env }


-- See Note [Error contexts in generated code]
inGeneratedCode :: TcRn Bool
inGeneratedCode :: TcRn Bool
inGeneratedCode = TcLclEnv -> Bool
lclEnvInGeneratedCode (TcLclEnv -> Bool)
-> TcRnIf TcGblEnv TcLclEnv TcLclEnv -> TcRn Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv

setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-- See Note [Error contexts in generated code]
-- When entering a node decorated with a /user/ span:
--   * Record that span in `tcl_loc`
--   * Set `tcl_in_gen_code` to False, to record that we
--     are in user code.
-- When entering a node decorated with a /generated/ span:
--   * Do not touch `tcl_loc`, so that `tcl_loc` always records
--     the innermost user span.
-- NB: This is the only place where `tcl_loc` and `tcl_in_gen_code`
--     are modified
setSrcSpan :: forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan RealSrcSpan
loc Maybe BufSpan
_) TcRn a
thing_inside
  = (TcLclCtxt -> TcLclCtxt) -> TcRn a -> TcRn a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt (\TcLclCtxt
ctxt -> TcLclCtxt
ctxt {tcl_loc = loc, tcl_in_gen_code = False}) TcRn a
thing_inside
setSrcSpan (GeneratedSrcSpan{}) TcRn a
thing_inside
  = (TcLclCtxt -> TcLclCtxt) -> TcRn a -> TcRn a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt (\TcLclCtxt
ctxt -> TcLclCtxt
ctxt {tcl_in_gen_code = True}) TcRn a
thing_inside
setSrcSpan SrcSpan
_ TcRn a
thing_inside
  = TcRn a
thing_inside

setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA :: forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
l = SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
l)

addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM :: forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM a -> TcM b
fn (L t
loc a
a) = SrcSpan -> TcM b -> TcM b
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (t -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc t
loc) (TcM b -> TcM b) -> TcM b -> TcM b
forall a b. (a -> b) -> a -> b
$ a -> TcM b
fn a
a

wrapLocM :: (HasLoc t) =>  (a -> TcM b) -> GenLocated t a -> TcM (Located b)
wrapLocM :: forall t a b.
HasLoc t =>
(a -> TcM b) -> GenLocated t a -> TcM (Located b)
wrapLocM a -> TcM b
fn (L t
loc a
a) =
  let
    loc' :: SrcSpan
loc' = t -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc t
loc
  in SrcSpan -> TcRn (Located b) -> TcRn (Located b)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc' (TcRn (Located b) -> TcRn (Located b))
-> TcRn (Located b) -> TcRn (Located b)
forall a b. (a -> b) -> a -> b
$ do { b <- a -> TcM b
fn a
a
                          ; return (L loc' b) }

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

wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM :: forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM a -> TcM (b, c)
fn (L SrcSpan
loc a
a) =
  SrcSpan -> TcRn (Located b, c) -> TcRn (Located b, c)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn (Located b, c) -> TcRn (Located b, c))
-> TcRn (Located b, c) -> TcRn (Located b, c)
forall a b. (a -> b) -> a -> b
$ do
    (b,c) <- a -> TcM (b, c)
fn a
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 (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA :: forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA a -> TcM (b, c)
fn (L EpAnn ann
loc a
a) =
  EpAnn ann
-> TcRn (GenLocated (EpAnn ann) b, c)
-> TcRn (GenLocated (EpAnn ann) b, c)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcRn (GenLocated (EpAnn ann) b, c)
 -> TcRn (GenLocated (EpAnn ann) b, c))
-> TcRn (GenLocated (EpAnn ann) b, c)
-> TcRn (GenLocated (EpAnn ann) b, c)
forall a b. (a -> b) -> a -> b
$ do
    (b,c) <- a -> TcM (b, c)
fn a
a
    return (L loc b, c)

wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM :: forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM a -> TcM (b, c)
fn (L SrcSpan
loc a
a) =
  SrcSpan -> TcRn (b, Located c) -> TcRn (b, Located c)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn (b, Located c) -> TcRn (b, Located c))
-> TcRn (b, Located c) -> TcRn (b, Located c)
forall a b. (a -> b) -> a -> b
$ do
    (b,c) <- a -> TcM (b, c)
fn a
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 (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c)
wrapLocSndMA :: forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c)
wrapLocSndMA a -> TcM (b, c)
fn (L EpAnn ann
loc a
a) =
  EpAnn ann
-> TcRn (b, GenLocated (EpAnn ann) c)
-> TcRn (b, GenLocated (EpAnn ann) c)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcRn (b, GenLocated (EpAnn ann) c)
 -> TcRn (b, GenLocated (EpAnn ann) c))
-> TcRn (b, GenLocated (EpAnn ann) c)
-> TcRn (b, GenLocated (EpAnn ann) c)
forall a b. (a -> b) -> a -> b
$ do
    (b,c) <- a -> TcM (b, c)
fn a
a
    return (b, L loc c)

wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
wrapLocM_ :: forall a.
(a -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> Located a -> IOEnv (Env TcGblEnv TcLclEnv) ()
wrapLocM_ a -> IOEnv (Env TcGblEnv TcLclEnv) ()
fn (L SrcSpan
loc a
a) = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (a -> IOEnv (Env TcGblEnv TcLclEnv) ()
fn a
a)

wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()
wrapLocMA_ :: forall a.
(a -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> LocatedA a -> IOEnv (Env TcGblEnv TcLclEnv) ()
wrapLocMA_ a -> IOEnv (Env TcGblEnv TcLclEnv) ()
fn (L SrcSpanAnnA
loc a
a) = SrcSpan
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (a -> IOEnv (Env TcGblEnv TcLclEnv) ()
fn a
a)

-- Reporting errors

getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
getErrsVar :: TcRn (IORef (Messages TcRnMessage))
getErrsVar = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (tcl_errs env) }

setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar :: forall a. IORef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar IORef (Messages TcRnMessage)
v = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_errs =  v })

addErr :: TcRnMessage -> TcRn ()
addErr :: TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr TcRnMessage
msg = do { loc <- TcRn SrcSpan
getSrcSpanM; addErrAt loc msg }

failWith :: TcRnMessage -> TcRn a
failWith :: forall a. TcRnMessage -> TcRn a
failWith TcRnMessage
msg = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr TcRnMessage
msg IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) a
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv (Env TcGblEnv TcLclEnv) a
forall env a. IOEnv env a
failM

failAt :: SrcSpan -> TcRnMessage -> TcRn a
failAt :: forall a. SrcSpan -> TcRnMessage -> TcRn a
failAt SrcSpan
loc TcRnMessage
msg = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
loc TcRnMessage
msg IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) a
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv (Env TcGblEnv TcLclEnv) a
forall env a. IOEnv env a
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 :: SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
loc TcRnMessage
msg = do { ctxt <- TcM ErrCtxtStack
getErrCtxt
                      ; tidy_env <- liftZonkM $ tcInitTidyEnv
                      ; err_ctxt <- tidyErrCtxt tidy_env ctxt
                      ; let detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage (ErrCtxtStack
-> Maybe (HoleFitDispConfig, [SupplementaryInfo])
-> [GhcHint]
-> ErrInfo
ErrInfo ErrCtxtStack
err_ctxt Maybe (HoleFitDispConfig, [SupplementaryInfo])
forall a. Maybe a
Nothing [GhcHint]
noHints) TcRnMessage
msg
                      ; add_long_err_at loc detailed_msg }

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

addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
addErrs :: [(SrcSpan, TcRnMessage)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrs [(SrcSpan, TcRnMessage)]
msgs = ((SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [(SrcSpan, TcRnMessage)] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
add [(SrcSpan, TcRnMessage)]
msgs
             where
               add :: (SrcSpan, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
add (SrcSpan
loc,TcRnMessage
msg) = SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
loc TcRnMessage
msg

checkErr :: Bool -> TcRnMessage -> TcRn ()
-- Add the error if the bool is False
checkErr :: Bool -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkErr Bool
ok TcRnMessage
msg = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErr TcRnMessage
msg)

checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> TcRn ()
checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkErrAt SrcSpan
loc Bool
ok TcRnMessage
msg = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrAt SrcSpan
loc TcRnMessage
msg)

addMessages :: Messages TcRnMessage -> TcRn ()
addMessages :: Messages TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addMessages Messages TcRnMessage
msgs1
  = do { errs_var <- TcRn (IORef (Messages TcRnMessage))
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 :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
discardWarnings TcRn a
thing_inside
  = do  { errs_var <- TcRn (IORef (Messages TcRnMessage))
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 :: SrcSpan -> TcRnMessageDetailed -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_long_err_at SrcSpan
loc TcRnMessageDetailed
msg = SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)
mk_long_err_at SrcSpan
loc TcRnMessageDetailed
msg TcRn (MsgEnvelope TcRnMessage)
-> (MsgEnvelope TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MsgEnvelope TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
reportDiagnostic
  where
    mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)
    mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)
mk_long_err_at SrcSpan
loc TcRnMessageDetailed
msg
      = do { name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx ;
             unit_state <- hsc_units <$> getTopEnv ;
             return $ mkErrorMsgEnvelope loc name_ppr_ctx
                    $ TcRnMessageWithInfo unit_state msg
                    }

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

reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
reportDiagnostics :: [MsgEnvelope TcRnMessage] -> IOEnv (Env TcGblEnv TcLclEnv) ()
reportDiagnostics = (MsgEnvelope TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> [MsgEnvelope TcRnMessage] -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MsgEnvelope TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
reportDiagnostic

reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
reportDiagnostic :: MsgEnvelope TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
reportDiagnostic MsgEnvelope TcRnMessage
msg
  = do { FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"Adding diagnostic:" (MsgEnvelope TcRnMessage -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault MsgEnvelope TcRnMessage
msg) ;
         errs_var <- TcRn (IORef (Messages TcRnMessage))
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 :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
checkNoErrs TcM r
main
  = do  { (res, no_errs) <- TcM r -> TcRn (r, Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcM r
main
        ; unless no_errs failM
        ; return res }

-----------------------
whenNoErrs :: TcM () -> TcM ()
whenNoErrs :: IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
whenNoErrs IOEnv (Env TcGblEnv TcLclEnv) ()
thing = IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM (() -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) IOEnv (Env TcGblEnv TcLclEnv) ()
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 :: forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM TcRn r
bale_out TcRn r
normal
 = do { errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar ;
        msgs <- readTcRef errs_var ;
        if errorsFound msgs then
           bale_out
        else
           normal }

failIfErrsM :: TcRn ()
-- Useful to avoid error cascades
failIfErrsM :: IOEnv (Env TcGblEnv TcLclEnv) ()
failIfErrsM = IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM IOEnv (Env TcGblEnv TcLclEnv) ()
forall env a. IOEnv env a
failM (() -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
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 is the only place that modifies `tcl_loc` and `tcl_in_gen_code`

* `addExprCtxt` updates updates the HsCtxt stored in LclEnv with the following logic
  - If `tcl_in_gen_code` is true, do nothing
  - Otherwise push a suitable HsCtxt onto the ErrCtxtStack

This ensures that the error messages do not leak compiler generated expressions which can
be confusing to the users as they never appear in the original source code

- See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr` for
  more discussion of this fancy footwork
- See Note [Generated code and pattern-match checking] in `GHC.Types.Basic` for the
  relation with pattern-match checks
-}

-- See Note [Error contexts in generated code]
addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt :: forall a. HsExpr GhcRn -> TcRn a -> TcRn a
addExprCtxt HsExpr GhcRn
e TcRn a
thing_inside
  = do { igc <- TcRn Bool
inGeneratedCode
       ; if igc -- In generated code; so addExprCtxt is a no-op
         then thing_inside
         else case e of
                -- The HsHole special case addresses situations like
                --    f x = _
                -- when we don't want to say "In the expression: _",
                -- because it is mentioned in the error message itself
                HsHole{} -> TcRn a
thing_inside

              -- There is a special case for expressions with signatures to avoid having
              -- too verbose error context. c.f. RecordDotSyntaxFail9
              -- Add the original HsCtxt if we are typechecking an expanded expression
                ExprWithTySig XExprWithTySig GhcRn
_ (L SrcSpanAnnA
_ HsExpr GhcRn
e') LHsSigWcType (NoGhcTc GhcRn)
_
                  | XExpr (ExpandedThingRn (HSE HsCtxt
o LHsExpr GhcRn
_)) <- HsExpr GhcRn
e' -> HsCtxt -> TcRn a -> TcRn a
forall a. HsCtxt -> TcM a -> TcM a
addErrCtxt HsCtxt
o TcRn a
thing_inside

                XExpr (ExpandedThingRn (HSE HsCtxt
o LHsExpr GhcRn
_)) -> HsCtxt -> TcRn a -> TcRn a
forall a. HsCtxt -> TcM a -> TcM a
addErrCtxt HsCtxt
o TcRn a
thing_inside

                HsExpr GhcRn
_ -> HsCtxt -> TcRn a -> TcRn a
forall a. HsCtxt -> TcM a -> TcM a
addErrCtxt (HsExpr GhcRn -> HsCtxt
ExprCtxt HsExpr GhcRn
e) TcRn a
thing_inside
       }

getErrCtxt :: TcM ErrCtxtStack
getErrCtxt :: TcM ErrCtxtStack
getErrCtxt = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvErrCtxt env) }

setErrCtxt :: ErrCtxtStack -> TcM a -> TcM a
{-# INLINE setErrCtxt #-}   -- Note [Inlining addErrCtxt]
setErrCtxt :: forall a. ErrCtxtStack -> TcM a -> TcM a
setErrCtxt ErrCtxtStack
ctxt = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (ErrCtxtStack -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt ErrCtxtStack
ctxt)

--   See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
addErrCtxt :: HsCtxt -> TcM a -> TcM a
{-# INLINE addErrCtxt #-}  -- Note [Inlining addErrCtxt]
addErrCtxt :: forall a. HsCtxt -> TcM a -> TcM a
addErrCtxt HsCtxt
ctxt = HsCtxt -> TcM a -> TcM a
forall a. HsCtxt -> TcM a -> TcM a
pushCtxt HsCtxt
ctxt

-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr
pushCtxt :: HsCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
pushCtxt :: forall a. HsCtxt -> TcM a -> TcM a
pushCtxt HsCtxt
ctxt = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (HsCtxt -> TcLclEnv -> TcLclEnv
addLclEnvErrCtxt HsCtxt
ctxt)

popErrCtxt :: TcM a -> TcM a
popErrCtxt :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
popErrCtxt TcM a
thing_inside = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> ErrCtxtStack -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt (ErrCtxtStack -> ErrCtxtStack
forall a. [a] -> [a]
pop (ErrCtxtStack -> ErrCtxtStack) -> ErrCtxtStack -> ErrCtxtStack
forall a b. (a -> b) -> a -> b
$ TcLclEnv -> ErrCtxtStack
getLclEnvErrCtxt TcLclEnv
env) TcLclEnv
env) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
                          TcM a
thing_inside
           where
             pop :: [a] -> [a]
pop []       = []
             pop (a
_:[a]
msgs) = [a]
msgs

getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin Maybe TypeOrKind
t_or_k
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; return (CtLoc { ctl_origin   = origin
                       , ctl_env      = mkCtLocEnv env
                       , ctl_t_or_k   = t_or_k
                       , ctl_expln    = mempty -- start off with no explanations
                       , ctl_depth    = initialSubGoalDepth }) }

mkCtLocEnv :: TcLclEnv -> CtLocEnv
mkCtLocEnv :: TcLclEnv -> CtLocEnv
mkCtLocEnv TcLclEnv
lcl_env =
  CtLocEnv { ctl_bndrs :: TcBinderStack
ctl_bndrs = TcLclEnv -> TcBinderStack
getLclEnvBinderStack TcLclEnv
lcl_env
           , ctl_ctxt :: ErrCtxtStack
ctl_ctxt  = TcLclEnv -> ErrCtxtStack
getLclEnvErrCtxt TcLclEnv
lcl_env
           , ctl_loc :: RealSrcSpan
ctl_loc = TcLclEnv -> RealSrcSpan
getLclEnvLoc TcLclEnv
lcl_env
           , ctl_tclvl :: TcLevel
ctl_tclvl = TcLclEnv -> TcLevel
getLclEnvTcLevel TcLclEnv
lcl_env
           , ctl_in_gen_code :: Bool
ctl_in_gen_code = TcLclEnv -> Bool
lclEnvInGeneratedCode TcLclEnv
lcl_env
           , ctl_rdr :: LocalRdrEnv
ctl_rdr = TcLclEnv -> LocalRdrEnv
getLclEnvRdrEnv TcLclEnv
lcl_env
           }

setCtLocM :: CtLoc -> TcM a -> TcM a
-- Set the SrcSpan and error context from the CtLoc
setCtLocM :: forall a. CtLoc -> TcM a -> TcM a
setCtLocM (CtLoc { ctl_env :: CtLoc -> CtLocEnv
ctl_env = CtLocEnv
lcl }) TcM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> RealSrcSpan -> TcLclEnv -> TcLclEnv
setLclEnvLoc (CtLocEnv -> RealSrcSpan
ctl_loc CtLocEnv
lcl)
                     (TcLclEnv -> TcLclEnv) -> TcLclEnv -> TcLclEnv
forall a b. (a -> b) -> a -> b
$ ErrCtxtStack -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt (CtLocEnv -> ErrCtxtStack
ctl_ctxt CtLocEnv
lcl)
                     (TcLclEnv -> TcLclEnv) -> TcLclEnv -> TcLclEnv
forall a b. (a -> b) -> a -> b
$ TcBinderStack -> TcLclEnv -> TcLclEnv
setLclEnvBinderStack (CtLocEnv -> TcBinderStack
ctl_bndrs CtLocEnv
lcl)
                     (TcLclEnv -> TcLclEnv) -> TcLclEnv -> TcLclEnv
forall a b. (a -> b) -> a -> b
$ TcLclEnv
env) TcM a
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 :: forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcRn r
thing_inside
  = do { either_res <- TcRn r -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure r)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcRn r
thing_inside
       ; return (case either_res of
                    Left IOEnvFailure
_  -> Maybe r
forall a. Maybe a
Nothing
                    Right r
r -> r -> Maybe r
forall a. a -> Maybe a
Just r
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 :: forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints TcM r
thing_inside
  = do { lie_var <- WantedConstraints
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef WantedConstraints
emptyWC
       ; res <- updLclEnv (\ TcLclEnv
env -> TcLclEnv
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 :: forall r. TcM r -> TcM (r, Messages TcRnMessage)
capture_messages TcM r
thing_inside
  = do { msg_var <- Messages TcRnMessage -> TcRn (IORef (Messages TcRnMessage))
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef Messages TcRnMessage
forall e. Messages e
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 :: forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcRn a
thing_inside
  = do { ((mb_res, lie), msgs) <- TcM (Maybe a, WantedConstraints)
-> TcM ((Maybe a, WantedConstraints), Messages TcRnMessage)
forall r. TcM r -> TcM (r, Messages TcRnMessage)
capture_messages    (TcM (Maybe a, WantedConstraints)
 -> TcM ((Maybe a, WantedConstraints), Messages TcRnMessage))
-> TcM (Maybe a, WantedConstraints)
-> TcM ((Maybe a, WantedConstraints), Messages TcRnMessage)
forall a b. (a -> b) -> a -> b
$
                                  TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe a) -> TcM (Maybe a, WantedConstraints))
-> TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                  TcRn a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcRn a
thing_inside
       ; addMessages msgs

       ; case mb_res of
           Maybe a
Nothing  -> do { WantedConstraints -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitConstraints (WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie)
                          ; IOEnv (Env TcGblEnv TcLclEnv) (a, Bool)
failM }

           Just a
res -> do { WantedConstraints -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitConstraints WantedConstraints
lie
                          ; let errs_found :: Bool
errs_found = Messages TcRnMessage -> Bool
forall e. Diagnostic e => Messages e -> Bool
errorsFound Messages TcRnMessage
msgs
                                          Bool -> Bool -> Bool
|| WantedConstraints -> Bool
insolubleWC WantedConstraints
lie
                          ; (a, Bool) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Bool)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Bool -> Bool
not Bool
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 :: forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcM a
thing_inside
  = do { (mb_res, lie) <- TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe a) -> TcM (Maybe a, WantedConstraints))
-> TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                          TcM a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM a
thing_inside

       -- See Note [Constraints and errors]
       ; case mb_res of
            Just {} -> (Maybe a, WantedConstraints) -> TcM (Maybe a, WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
mb_res, WantedConstraints
lie)
            Maybe a
Nothing -> do { let pruned_lie :: WantedConstraints
pruned_lie = WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie
                          ; FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"tryCaptureConstraints" (SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
                            [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"lie:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie
                                 , FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"dropMisleading lie:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
pruned_lie ]
                          ; (Maybe a, WantedConstraints) -> TcM (Maybe a, WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, WantedConstraints
pruned_lie) } }

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 :: forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside
  = do { (mb_res, lie) <- TcM a -> TcM (Maybe a, WantedConstraints)
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcM a
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
           Maybe a
Nothing  -> do { WantedConstraints -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitConstraints WantedConstraints
lie; IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints)
failM }
           Just a
res -> (a, WantedConstraints)
-> IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, WantedConstraints
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 :: forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage TcM a
thing_inside
  = do { local_usage_ref <- UsageEnv -> IOEnv (Env TcGblEnv TcLclEnv) (IORef UsageEnv)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef UsageEnv
zeroUE
       ; result <- updLclEnv (\TcLclEnv
env -> TcLclEnv
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 :: forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult TcM a
thing_inside
  = do { (usage, result) <- TcM a -> TcM (UsageEnv, a)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage TcM a
thing_inside
       ; traceTc "tcScalingUsage" $ vcat [ppr mult, ppr usage]
       ; tcEmitBindingUsage $ scaleUE mult usage
       ; return result }

tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage :: UsageEnv -> IOEnv (Env TcGblEnv TcLclEnv) ()
tcEmitBindingUsage UsageEnv
ue
  = do { lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let usage = TcLclEnv -> IORef UsageEnv
tcl_usage TcLclEnv
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 :: forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing_inside
  = do { (mb_r, lie) <- TcRn r -> TcM (Maybe r, WantedConstraints)
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcRn r
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 :: forall r. TcRn r -> TcRn r -> TcRn r
recoverM TcRn r
recover TcRn r
thing
  = do { mb_res <- TcRn r -> TcRn (Maybe r)
forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing ;
         case mb_res of
           Maybe r
Nothing  -> TcRn r
recover
           Just r
res -> r -> TcRn r
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return r
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 :: forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM a -> TcRn b
f [a]
xs
  = do { mb_rs <- (a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> (a -> TcRn b) -> a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
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 :: forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM a -> TcRn b
f [a]
xs
  = do { mb_rs <- (a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> (a -> TcRn b) -> a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
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 :: forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
_ b
acc []     = b -> TcRn b
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return b
acc
foldAndRecoverM b -> a -> TcRn b
f b
acc (a
x:[a]
xs) =
                          do { mb_r <- TcRn b -> TcRn (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (b -> a -> TcRn b
f b
acc a
x)
                             ; case mb_r of
                                Maybe b
Nothing   -> (b -> a -> TcRn b) -> b -> [a] -> TcRn b
forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
f b
acc [a]
xs
                                Just b
acc' -> (b -> a -> TcRn b) -> b -> [a] -> TcRn b
forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
f b
acc' [a]
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 :: forall a. TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc TcRn a
thing_inside
 = TcM (Maybe a) -> TcM (Maybe a, Messages TcRnMessage)
forall r. TcM r -> TcM (r, Messages TcRnMessage)
capture_messages (TcRn a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn a
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 :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
discardErrs TcRn a
m
 = do { errs_var <- Messages TcRnMessage -> TcRn (IORef (Messages TcRnMessage))
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef Messages TcRnMessage
forall e. Messages e
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 :: forall r. TcRn r -> TcRn r -> TcRn r
tryTcDiscardingErrs TcM r
recover =
  (WantedConstraints -> Messages TcRnMessage -> r -> Bool)
-> TcM r -> TcM r -> TcM r -> TcM r
forall r.
(WantedConstraints -> Messages TcRnMessage -> r -> Bool)
-> TcM r -> TcM r -> TcM r -> TcM r
tryTcDiscardingErrs'
    (\WantedConstraints
_ Messages TcRnMessage
_ r
_ -> Bool
True)     -- No validation
    TcM r
recover TcM r
recover      -- Discard all errors and warnings
                         -- and unsolved constraints entirely

tryTcDiscardingErrs' :: (WantedConstraints -> Messages TcRnMessage -> r -> Bool)  -- Validation
                     -> TcM r  -- Recover from validation error
                     -> TcM r  -- Recover from failure
                     -> TcM r  -- Action to try
                     -> TcM r
-- (tryTcDiscardingErrs' validate recover_invalid recover_error thing_inside) tries 'thing_inside';
--      if 'thing_inside' succeeds and validation produces no errors, it's the answer
--      otherwise discard everything from 'thing_inside', including errors,
--          and try 'recover' instead.
tryTcDiscardingErrs' :: forall r.
(WantedConstraints -> Messages TcRnMessage -> r -> Bool)
-> TcM r -> TcM r -> TcM r -> TcM r
tryTcDiscardingErrs' WantedConstraints -> Messages TcRnMessage -> r -> Bool
validate TcM r
recover_invalid TcM r
recover_error TcM r
thing_inside
  = do { ((mb_res, lie), msgs) <- TcM (Maybe r, WantedConstraints)
-> TcM ((Maybe r, WantedConstraints), Messages TcRnMessage)
forall r. TcM r -> TcM (r, Messages TcRnMessage)
capture_messages    (TcM (Maybe r, WantedConstraints)
 -> TcM ((Maybe r, WantedConstraints), Messages TcRnMessage))
-> TcM (Maybe r, WantedConstraints)
-> TcM ((Maybe r, WantedConstraints), Messages TcRnMessage)
forall a b. (a -> b) -> a -> b
$
                                  TcM (Maybe r) -> TcM (Maybe r, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe r) -> TcM (Maybe r, WantedConstraints))
-> TcM (Maybe r) -> TcM (Maybe r, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                                  TcM r -> TcM (Maybe r)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM r
thing_inside
        ; case mb_res of
            Just r
res | Bool -> Bool
not (Messages TcRnMessage -> Bool
forall e. Diagnostic e => Messages e -> Bool
errorsFound Messages TcRnMessage
msgs)
                     , Bool -> Bool
not (WantedConstraints -> Bool
insolubleWC WantedConstraints
lie)
                    -- 'thing_inside' succeeded with no errors
              -> if WantedConstraints -> Messages TcRnMessage -> r -> Bool
validate WantedConstraints
lie Messages TcRnMessage
msgs r
res
                 then do { Messages TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addMessages Messages TcRnMessage
msgs  -- msgs might still have warnings
                         ; WantedConstraints -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitConstraints WantedConstraints
lie
                         ; r -> TcM r
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return r
res }
                 else TcM r
recover_invalid

            Maybe r
_ -> -- 'thing_inside' failed, or produced an error message
                 TcM r
recover_error
        }

{- 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.

  We may /also/ end up taking constraints built at some inner level, and
  emitting them (via the exception catching in `tryCaptureConstraints`) 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 it keeps 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.

Other wrinkles

(CERR1) 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.

(CERR2) In #26015 I found that from the constraints
           [W] alpha ~ Int      -- A class constraint
           [W] F alpha ~# Bool  -- An equality constraint
  we were dropping the first (because it's a class constraint) but not the
  second, and then getting a misleading error message from the second.  As
  #25607 shows, we can get not just one but a zillion bogus messages, which
  conceal the one genuine error.  Boo.

  For now I have added an even more ad-hoc "drop class constraints except
  equality classes (~) and (~~)"; see `dropMisleading`.  That just kicks the can
  down the road; but this problem seems somewhat rare anyway.  The code in
  `dropMisleading` hasn't changed for years.

It would be great to have a more systematic solution to this entire mess.
-}

{-
************************************************************************
*                                                                      *
             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
-}

{-

Note [Reporting warning diagnostics]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use functions below to report warnings.  For the most part,
we do /not/ need to check any warning flags before doing so.
See https://gitlab.haskell.org/ghc/ghc/-/wikis/Errors-as-(structured)-values
for the design.

-}

addErrTc :: TcRnMessage -> TcM ()
addErrTc :: TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc TcRnMessage
err_msg = do { env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM ZonkM TidyEnv
tcInitTidyEnv
                      ; addErrTcM (env0, err_msg) }

addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addErrTcM :: (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTcM (TidyEnv
tidy_env, TcRnMessage
err_msg)
  = do { ctxt <- TcM ErrCtxtStack
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 :: forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
err_msg
  = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTc TcRnMessage
err_msg IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) a
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv (Env TcGblEnv TcLclEnv) a
forall env a. IOEnv env a
failM

failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a   -- Add an error message and fail
failWithTcM :: forall a. (TidyEnv, TcRnMessage) -> TcM a
failWithTcM (TidyEnv, TcRnMessage)
local_and_msg
  = (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
addErrTcM (TidyEnv, TcRnMessage)
local_and_msg IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) a
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOEnv (Env TcGblEnv TcLclEnv) a
forall env a. IOEnv env a
failM

checkTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is true
checkTc :: Bool -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTc Bool
True  TcRnMessage
_   = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkTc Bool
False TcRnMessage
err = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
err

checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkTcM Bool
True  (TidyEnv, TcRnMessage)
_   = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkTcM Bool
False (TidyEnv, TcRnMessage)
err = (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. (TidyEnv, TcRnMessage) -> TcM a
failWithTcM (TidyEnv, TcRnMessage)
err

checkJustTc :: TcRnMessage -> Maybe a -> TcM a
checkJustTc :: forall a. TcRnMessage -> Maybe a -> TcM a
checkJustTc TcRnMessage
err = TcM a -> (a -> TcM a) -> Maybe a -> TcM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TcRnMessage -> TcM a
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
err) a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

checkJustTcM :: (TidyEnv, TcRnMessage) -> Maybe a -> TcM a
checkJustTcM :: forall a. (TidyEnv, TcRnMessage) -> Maybe a -> TcM a
checkJustTcM (TidyEnv, TcRnMessage)
err = TcM a -> (a -> TcM a) -> Maybe a -> TcM a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((TidyEnv, TcRnMessage) -> TcM a
forall a. (TidyEnv, TcRnMessage) -> TcM a
failWithTcM (TidyEnv, TcRnMessage)
err) a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

failIfTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is false
failIfTc :: Bool -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
failIfTc Bool
False TcRnMessage
_   = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
failIfTc Bool
True  TcRnMessage
err = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
err

failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
   -- Check that the boolean is false
failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
failIfTcM Bool
False (TidyEnv, TcRnMessage)
_   = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
failIfTcM Bool
True  (TidyEnv, TcRnMessage)
err = (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. (TidyEnv, TcRnMessage) -> TcM a
failWithTcM (TidyEnv, TcRnMessage)
err


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

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

-- | Display a warning if a condition is met.
diagnosticTc :: Bool -> TcRnMessage -> TcM ()
diagnosticTc :: Bool -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
diagnosticTc Bool
should_report TcRnMessage
warn_msg
  | Bool
should_report = TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticTc TcRnMessage
warn_msg
  | Bool
otherwise     = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Display a diagnostic if a condition is met.
diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
diagnosticTcM Bool
should_report (TidyEnv, TcRnMessage)
warn_msg
  | Bool
should_report = (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticTcM (TidyEnv, TcRnMessage)
warn_msg
  | Bool
otherwise     = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Display a diagnostic in the current context.
addDiagnosticTc :: TcRnMessage -> TcM ()
addDiagnosticTc :: TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticTc TcRnMessage
msg
 = do { env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM ZonkM TidyEnv
tcInitTidyEnv
      ; addDiagnosticTcM (env0, msg) }

-- | Display a diagnostic in a given context.
addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticTcM (TidyEnv
env0, TcRnMessage
msg)
 = do { ctxt <- TcM ErrCtxtStack
getErrCtxt
      ; extra <- tidyErrCtxt env0 ctxt
      ; let detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage (ErrCtxtStack
-> Maybe (HoleFitDispConfig, [SupplementaryInfo])
-> [GhcHint]
-> ErrInfo
ErrInfo ErrCtxtStack
extra Maybe (HoleFitDispConfig, [SupplementaryInfo])
forall a. Maybe a
Nothing [GhcHint]
noHints) TcRnMessage
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 :: ([HsCtxt] -> TcRnMessage) -> TcM ()
addDetailedDiagnostic :: (ErrCtxtStack -> TcRnMessage) -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDetailedDiagnostic ErrCtxtStack -> TcRnMessage
mkMsg = do
  loc <- TcRn SrcSpan
getSrcSpanM
  name_ppr_ctx <- getNamePprCtx
  !diag_opts  <- initDiagOpts <$> getDynFlags
  env0 <- liftZonkM tcInitTidyEnv
  ctxt <- getErrCtxt
  err_info <- tidyErrCtxt env0 ctxt
  reportDiagnostic $
    mkMsgEnvelope diag_opts loc name_ppr_ctx $
      mkMsg err_info

addTcRnDiagnostic :: TcRnMessage -> TcM ()
addTcRnDiagnostic :: TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addTcRnDiagnostic TcRnMessage
msg = do
  loc <- TcRn SrcSpan
getSrcSpanM
  mkTcRnMessage loc msg >>= reportDiagnostic

-- | Display a diagnostic for the current source location, taken from
-- the 'TcRn' monad.
addDiagnostic :: TcRnMessage -> TcRn ()
addDiagnostic :: TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnostic TcRnMessage
msg = TcRnMessageDetailed -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_diagnostic (ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage (ErrCtxtStack
-> Maybe (HoleFitDispConfig, [SupplementaryInfo])
-> [GhcHint]
-> ErrInfo
ErrInfo [] Maybe (HoleFitDispConfig, [SupplementaryInfo])
forall a. Maybe a
Nothing [GhcHint]
noHints) TcRnMessage
msg)

-- | Display a diagnostic for a given source location.
addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt :: SrcSpan -> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
addDiagnosticAt SrcSpan
loc TcRnMessage
msg = do
  unit_state <- HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState)
-> TcRnIf TcGblEnv TcLclEnv HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
  let detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage (ErrCtxtStack
-> Maybe (HoleFitDispConfig, [SupplementaryInfo])
-> [GhcHint]
-> ErrInfo
ErrInfo [] Maybe (HoleFitDispConfig, [SupplementaryInfo])
forall a. Maybe a
Nothing [GhcHint]
noHints) TcRnMessage
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 :: TcRnMessageDetailed -> IOEnv (Env TcGblEnv TcLclEnv) ()
add_diagnostic TcRnMessageDetailed
msg
  = do { loc <- TcRn SrcSpan
getSrcSpanM
       ; unit_state <- hsc_units <$> getTopEnv
       ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
       }

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

add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan
            -> ErrCtxtStack
            -> TcM ()
add_err_tcm :: TidyEnv
-> TcRnMessage
-> SrcSpan
-> ErrCtxtStack
-> IOEnv (Env TcGblEnv TcLclEnv) ()
add_err_tcm TidyEnv
tidy_env TcRnMessage
msg SrcSpan
loc ErrCtxtStack
ctxt
 = do { err_ctxt <- TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack
tidyErrCtxt TidyEnv
tidy_env ErrCtxtStack
ctxt
      ; add_long_err_at loc $
          mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg }

tidyErrCtxt :: TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack
-- Do the following
--   * Zonk each HsCtxt in the ErrCtxtStack
--   * Tidy each using TidyEnv
--   * Trim excessive contexts
tidyErrCtxt :: TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack
tidyErrCtxt TidyEnv
env ErrCtxtStack
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
 = Bool -> Int -> TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack
go Bool
False Int
0 TidyEnv
env ErrCtxtStack
ctxts -- regular error ctx
 where
   go :: Bool -> Int -> TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack
   go :: Bool -> Int -> TidyEnv -> ErrCtxtStack -> TcM ErrCtxtStack
go Bool
_ Int
_ TidyEnv
_ [] = ErrCtxtStack -> TcM ErrCtxtStack
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
   go Bool
dbg Int
n TidyEnv
env (HsCtxt
ctxt : ErrCtxtStack
ctxts)
     | HsCtxt -> Bool
isHsCtxtLandmark HsCtxt
ctxt
     = do { (env', msg) <- ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt)
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt))
-> ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt)
forall a b. (a -> b) -> a -> b
$ TidyEnv -> HsCtxt -> ZonkM (TidyEnv, HsCtxt)
zonkTidyHsCtxt TidyEnv
env HsCtxt
ctxt
          ; rest <- go dbg n env' ctxts
          ; return (msg : rest) }
     | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mAX_CONTEXTS -- Too verbose || dbg
     = do { (env', msg) <- ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt)
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt))
-> ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt)
forall a b. (a -> b) -> a -> b
$ TidyEnv -> HsCtxt -> ZonkM (TidyEnv, HsCtxt)
zonkTidyHsCtxt TidyEnv
env HsCtxt
ctxt
          ; rest <- go dbg (n+1) env' ctxts
          ; return (msg : rest) }
     | Bool
otherwise  -- need to compute this for zonking
     = do { (env', _) <- ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt)
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt))
-> ZonkM (TidyEnv, HsCtxt) -> TcM (TidyEnv, HsCtxt)
forall a b. (a -> b) -> a -> b
$ TidyEnv -> HsCtxt -> ZonkM (TidyEnv, HsCtxt)
zonkTidyHsCtxt TidyEnv
env HsCtxt
ctxt
          ; go dbg n env' ctxts
          }


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

-- debugTc is useful for monadic debugging code

debugTc :: TcM () -> TcM ()
debugTc :: IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
debugTc IOEnv (Env TcGblEnv TcLclEnv) ()
thing
 | Bool
debugIsOn = IOEnv (Env TcGblEnv TcLclEnv) ()
thing
 | Bool
otherwise = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

newTcEvBinds :: TcM EvBindsVar
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { binds_ref <- EvBindsState -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef EvBindsState)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef EvBindsState
emptyEvBindsState
                  ; uniq <- newUnique
                  ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
                  ; return (EvBindsVar { ebv_binds = binds_ref
                                       , ebv_uniq = uniq }) }

-- | Creates an EvBindsVar incapable of holding any bindings. It still
-- tracks covar usages (see comments on ebv_needs in "GHC.Tc.Types.Evidence"), thus
-- must be made monadically
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds
  = do { tcvs_ref  <- NeededEvIds -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef NeededEvIds)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef NeededEvIds
emptyVarSet
       ; uniq <- newUnique
       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
       ; return (CoEvBindsVar { ebv_needs = 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 :: EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar ebv :: EvBindsVar
ebv@(EvBindsVar {})
  = do { binds_ref <- EvBindsState -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef EvBindsState)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef EvBindsState
emptyEvBindsState
       ; uniq <- newUnique
       ; return (ebv { ebv_uniq = uniq
                     , ebv_binds = binds_ref }) }
cloneEvBindsVar ebv :: EvBindsVar
ebv@(CoEvBindsVar {})
  = do { tcvs_ref  <- NeededEvIds -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef NeededEvIds)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef NeededEvIds
emptyVarSet
       ; return (ebv { ebv_needs = tcvs_ref }) }

getTcEvBindsMap :: EvBindsVar -> TcM EvBindsMap
getTcEvBindsMap :: EvBindsVar -> TcM EvBindsMap
getTcEvBindsMap EvBindsVar
ebv = do { EBS { ebs_binds = bs } <- EvBindsVar -> TcM EvBindsState
getTcEvBindsState EvBindsVar
ebv
                         ; return bs }

getTcEvBindsState :: EvBindsVar -> TcM EvBindsState
getTcEvBindsState :: EvBindsVar -> TcM EvBindsState
getTcEvBindsState (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindsState
ebv_binds = TcRef EvBindsState
ev_ref })
  = TcRef EvBindsState -> TcM EvBindsState
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef EvBindsState
ev_ref
getTcEvBindsState (CoEvBindsVar { ebv_needs :: EvBindsVar -> TcRef NeededEvIds
ebv_needs = TcRef NeededEvIds
needs_ref })
  = do { needs <- TcRef NeededEvIds -> IOEnv (Env TcGblEnv TcLclEnv) NeededEvIds
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef NeededEvIds
needs_ref
       ; return (EBS { ebs_binds = emptyEvBindsMap, ebs_needs = needs }) }

setTcEvBindsMap :: EvBindsVar -> EvBindsMap -> TcM ()
setTcEvBindsMap :: EvBindsVar -> EvBindsMap -> IOEnv (Env TcGblEnv TcLclEnv) ()
setTcEvBindsMap (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindsState
ebv_binds = TcRef EvBindsState
ev_ref }) EvBindsMap
ev_binds
  = TcRef EvBindsState
-> (EvBindsState -> EvBindsState)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> (a -> a) -> m ()
updTcRef TcRef EvBindsState
ev_ref (\EvBindsState
ebs -> EvBindsState
ebs { ebs_binds = ev_binds })
setTcEvBindsMap (CoEvBindsVar {}) EvBindsMap
ev_binds
  = Bool
-> SDoc
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (EvBindsMap -> Bool
isEmptyEvBindsMap EvBindsMap
ev_binds) (EvBindsMap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsMap
ev_binds) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

combineTcEvBinds :: EvBindsVar -> EvBindsVar -> TcM ()
combineTcEvBinds :: EvBindsVar -> EvBindsVar -> IOEnv (Env TcGblEnv TcLclEnv) ()
combineTcEvBinds (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindsState
ebv_binds = TcRef EvBindsState
old_ebv_ref })
                 (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindsState
ebv_binds = TcRef EvBindsState
new_ebv_ref })
  = do { new_ebvs <- TcRef EvBindsState -> TcM EvBindsState
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef EvBindsState
new_ebv_ref
       ; updTcRef old_ebv_ref (`unionEvBindsState` new_ebvs) }
combineTcEvBinds (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindsState
ebv_binds = TcRef EvBindsState
old_tcv_ref })
                 (CoEvBindsVar { ebv_needs :: EvBindsVar -> TcRef NeededEvIds
ebv_needs = TcRef NeededEvIds
new_tcv_ref })
  = do { new_tcvs <- TcRef NeededEvIds -> IOEnv (Env TcGblEnv TcLclEnv) NeededEvIds
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef NeededEvIds
new_tcv_ref
       ; updTcRef old_tcv_ref (addNeededEvIdsEBS new_tcvs) }
combineTcEvBinds (CoEvBindsVar { ebv_needs :: EvBindsVar -> TcRef NeededEvIds
ebv_needs = TcRef NeededEvIds
old_tcv_ref })
                 (CoEvBindsVar { ebv_needs :: EvBindsVar -> TcRef NeededEvIds
ebv_needs = TcRef NeededEvIds
new_tcv_ref })
  = do { new_tcvs <- TcRef NeededEvIds -> IOEnv (Env TcGblEnv TcLclEnv) NeededEvIds
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef NeededEvIds
new_tcv_ref
       ; updTcRef old_tcv_ref (unionVarSet new_tcvs) }
combineTcEvBinds EvBindsVar
old_var EvBindsVar
new_var
  = FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"combineTcEvBinds" (EvBindsVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsVar
old_var SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ EvBindsVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsVar
new_var)
    -- Terms inside types, no good

addNeededEvIds :: EvBindsVar -> NeededEvIds -> TcM ()
addNeededEvIds :: EvBindsVar -> NeededEvIds -> IOEnv (Env TcGblEnv TcLclEnv) ()
addNeededEvIds (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindsState
ebv_binds = TcRef EvBindsState
bs_ref }) NeededEvIds
needed
  = TcRef EvBindsState
-> (EvBindsState -> EvBindsState)
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> (a -> a) -> m ()
updTcRef TcRef EvBindsState
bs_ref (NeededEvIds -> EvBindsState -> EvBindsState
addNeededEvIdsEBS NeededEvIds
needed)
addNeededEvIds (CoEvBindsVar { ebv_needs :: EvBindsVar -> TcRef NeededEvIds
ebv_needs = TcRef NeededEvIds
need_ref }) NeededEvIds
needed
  = TcRef NeededEvIds
-> (NeededEvIds -> NeededEvIds) -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> (a -> a) -> m ()
updTcRef TcRef NeededEvIds
need_ref (NeededEvIds -> NeededEvIds -> NeededEvIds
unionVarSet NeededEvIds
needed)

addTcEvCoBind :: EvBindsVar -> CoercionHole -> CoercionPlusHoles -> TcM ()
addTcEvCoBind :: EvBindsVar
-> CoercionHole
-> CoercionPlusHoles
-> IOEnv (Env TcGblEnv TcLclEnv) ()
addTcEvCoBind EvBindsVar
ebv CoercionHole
hole co_plus_holes :: CoercionPlusHoles
co_plus_holes@(CPH { cph_co :: CoercionPlusHoles -> TcCoercion
cph_co = TcCoercion
co })
  = do { CoercionHole
-> CoercionPlusHoles -> IOEnv (Env TcGblEnv TcLclEnv) ()
fillCoercionHole CoercionHole
hole CoercionPlusHoles
co_plus_holes
         -- Record usage of the free vars of this coercion
       ; EvBindsVar -> NeededEvIds -> IOEnv (Env TcGblEnv TcLclEnv) ()
addNeededEvIds EvBindsVar
ebv (TcCoercion -> NeededEvIds
coVarsOfCo TcCoercion
co) }

addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
-- Add a binding to the TcEvBinds by side effect
addTcEvBind :: EvBindsVar -> EvBind -> IOEnv (Env TcGblEnv TcLclEnv) ()
addTcEvBind (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindsState
ebv_binds = TcRef EvBindsState
ev_ref, ebv_uniq :: EvBindsVar -> Unique
ebv_uniq = Unique
u })
            ev_bind :: EvBind
ev_bind@(EvBind { eb_info :: EvBind -> EvBindInfo
eb_info = EvBindInfo
info, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
rhs })
  = do { EBS { ebs_binds = bnds, ebs_needs = needs } <- TcRef EvBindsState -> TcM EvBindsState
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef EvBindsState
ev_ref
       ; let bnds'  = EvBindsMap -> EvBind -> EvBindsMap
extendEvBinds EvBindsMap
bnds EvBind
ev_bind
             needs' = case EvBindInfo
info of
                        EvBindWanted {} -> EvTerm -> NeededEvIds
nestedEvIdsOfTerm EvTerm
rhs
                                           NeededEvIds -> NeededEvIds -> NeededEvIds
`unionVarSet` NeededEvIds
needs
                        EvBindGiven {} -> NeededEvIds
needs

       ; traceTc "addTcEvBind" $
         vcat [ text "EvBindsVar:" <+> ppr u
              , text "ev_bind:" <+> ppr ev_bind
              , text "bnds:" <+> ppr bnds
              , text "bnds':" <+> ppr bnds'
              , text "needs" <+> ppr needs
              , text "needs'" <+> ppr needs' ]

       ; writeTcRef ev_ref $
         EBS { ebs_binds = bnds', ebs_needs = needs' } }

addTcEvBind (CoEvBindsVar { ebv_uniq :: EvBindsVar -> Unique
ebv_uniq = Unique
u }) EvBind
ev_bind
  = FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"addTcEvBind CoEvBindsVar" (EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBind
ev_bind SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u)

chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc OccSet -> OccName
fn =
  do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
     ; let dfun_n_var = TcGblEnv -> IORef OccSet
tcg_dfun_n TcGblEnv
env
     ; set <- readTcRef dfun_n_var
     ; let occ = OccSet -> OccName
fn OccSet
set
     ; writeTcRef dfun_n_var (extendOccSet set occ)
     ; return occ }

newUnusedType :: Name -> Kind -> TcM Type
-- Return a type (UnusedType @k sym_n), where sym
-- is a name and n is a fresh Integer.
-- Recall  UnusedType :: forall k. Symbol -> k
-- See Note [The types Any and UnusedType] in GHC.Builtin.Types, wrinkle (Any6)
newUnusedType :: Name -> Mult -> TcM Mult
newUnusedType Name
name Mult
kind
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; let zany_n_var = TcGblEnv -> IORef Integer
tcg_zany_n TcGblEnv
env
       ; i <- readTcRef zany_n_var
       ; let !i2 = Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1
       ; writeTcRef zany_n_var i2
       -- Mind that the "_" here is load-bearing:
       -- name foo1 with zany_n_var = 1 musn't be equal to
       -- name foo with zany_n_var = 11 b/c that way the Pmc
       -- would consider them equal. Using "_" suffices because
       -- numbers never start with _ and so (legal) identfiers like
       -- foo_ would become foo__1 which is distinct from e.g. foo_1
       ; return (mkTyConApp unusedTypeTyCon [kind, mkStrLitTy $ getOccFS name `appendFS` fsLit "_" `appendFS` fsLit (show i) ]) }

getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar :: IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (tcl_lie env) }

setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar :: forall a. IORef WantedConstraints -> TcM a -> TcM a
setConstraintVar IORef WantedConstraints
lie_var = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_lie = lie_var })

emitConstraints :: WantedConstraints -> TcM ()
emitConstraints :: WantedConstraints -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitConstraints WantedConstraints
ct
  | WantedConstraints -> Bool
isEmptyWC WantedConstraints
ct
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
         updTcRef lie_var (`andWC` ct) }

emitSimple :: Ct -> TcM ()
emitSimple :: Ct -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitSimple Ct
ct
  = do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
         updTcRef lie_var (`addSimples` unitBag ct) }

emitSimples :: Cts -> TcM ()
emitSimples :: Bag Ct -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitSimples Bag Ct
cts
  | Bag Ct -> Bool
forall a. Bag a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Bag Ct
cts
  = () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
         updTcRef lie_var (`addSimples` cts) }

emitImplication :: Implication -> TcM ()
emitImplication :: Implication -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitImplication Implication
ct
  = do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
         updTcRef lie_var (`addImplics` unitBag ct) }

emitImplications :: Bag Implication -> TcM ()
emitImplications :: Bag Implication -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitImplications Bag Implication
ct
  = Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bag Implication -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag Implication
ct) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
    do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
         updTcRef lie_var (`addImplics` ct) }

emitDelayedErrors :: Bag DelayedError -> TcM ()
emitDelayedErrors :: Bag DelayedError -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitDelayedErrors Bag DelayedError
errs
  = do { FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"emitDelayedErrors" (Bag DelayedError -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag DelayedError
errs)
       ; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
       ; updTcRef lie_var (`addDelayedErrors` errs)}

emitHole :: Hole -> TcM ()
emitHole :: Hole -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitHole Hole
hole
  = do { FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"emitHole" (Hole -> SDoc
forall a. Outputable a => a -> SDoc
ppr Hole
hole)
       ; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
       ; updTcRef lie_var (`addHoles` unitBag hole) }

emitHoles :: Bag Hole -> TcM ()
emitHoles :: Bag Hole -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitHoles Bag Hole
holes
  = do { FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"emitHoles" (Bag Hole -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag Hole
holes)
       ; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
       ; updTcRef lie_var (`addHoles` holes) }

emitNotConcreteError :: NotConcreteError -> TcM ()
emitNotConcreteError :: NotConcreteError -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitNotConcreteError NotConcreteError
err
  = do { FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"emitNotConcreteError" (NotConcreteError -> SDoc
forall a. Outputable a => a -> SDoc
ppr NotConcreteError
err)
       ; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
       ; updTcRef lie_var (`addNotConcreteError` err) }

-- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify.
ensureReflMultiplicityCo :: TcCoercion -> CtOrigin -> TcM ()
ensureReflMultiplicityCo :: TcCoercion -> CtOrigin -> IOEnv (Env TcGblEnv TcLclEnv) ()
ensureReflMultiplicityCo TcCoercion
mult_co CtOrigin
origin
  = do { FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"ensureReflMultiplicityCo" (TcCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCoercion
mult_co)
       ; Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TcCoercion -> Bool
isReflCo TcCoercion
mult_co) (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
           { loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin Maybe TypeOrKind
forall a. Maybe a
Nothing
           ; lie_var <- getConstraintVar
           ; updTcRef lie_var (\WantedConstraints
w -> WantedConstraints -> TcCoercion -> CtLoc -> WantedConstraints
addMultiplicityCoercionError WantedConstraints
w TcCoercion
mult_co CtLoc
loc) } }

-- | Throw out any constraints emitted by the thing_inside
discardConstraints :: TcM a -> TcM a
discardConstraints :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
discardConstraints TcM a
thing_inside = (a, WantedConstraints) -> a
forall a b. (a, b) -> a
fst ((a, WantedConstraints) -> a)
-> IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints) -> TcM a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcM a -> IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside

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

pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ :: forall a.
IOEnv (Env TcGblEnv TcLclEnv) a -> IOEnv (Env TcGblEnv TcLclEnv) a
pushTcLevelM_ = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((TcLevel -> TcLevel) -> TcLclEnv -> TcLclEnv
modifyLclEnvTcLevel TcLevel -> TcLevel
pushTcLevel)

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

getTcLevel :: TcM TcLevel
getTcLevel :: TcM TcLevel
getTcLevel = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
                ; return $! getLclEnvTcLevel env }

setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel :: forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
tclvl TcM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (TcLevel -> TcLclEnv -> TcLclEnv
setLclEnvTcLevel TcLevel
tclvl) TcM a
thing_inside

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

getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvTypeEnv env) }

setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
-- Set the local type envt, but do *not* disturb other fields,
-- notably the lie_var
setLclTypeEnv :: forall a. TcLclEnv -> TcM a -> TcM a
setLclTypeEnv TcLclEnv
lcl_env TcM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (TcTypeEnv -> TcLclEnv -> TcLclEnv
setLclEnvTypeEnv (TcLclEnv -> TcTypeEnv
getLclEnvTypeEnv TcLclEnv
lcl_env)) TcM a
thing_inside

traceTcConstraints :: String -> TcM ()
traceTcConstraints :: FilePath -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTcConstraints FilePath
msg
  = do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
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 :: IsExtraConstraint -> SDoc
ppr IsExtraConstraint
YesExtraConstraint = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"YesExtraConstraint"
  ppr IsExtraConstraint
NoExtraConstraint  = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"NoExtraConstraint"

emitAnonTypeHole :: IsExtraConstraint
                 -> TcTyVar -> TcM ()
emitAnonTypeHole :: IsExtraConstraint -> CoVar -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitAnonTypeHole IsExtraConstraint
extra_constraints CoVar
tv
  = do { ct_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (OccName -> CtOrigin
TypeHoleOrigin OccName
occ) Maybe TypeOrKind
forall a. Maybe a
Nothing
       ; let hole = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
sort
                         , hole_occ :: RdrName
hole_occ  = OccName -> RdrName
mkRdrUnqual OccName
occ
                         , hole_ty :: Mult
hole_ty   = CoVar -> Mult
mkTyVarTy CoVar
tv
                         , hole_loc :: CtLoc
hole_loc  = CtLoc
ct_loc }
       ; emitHole hole }
  where
    occ :: OccName
occ = FastString -> OccName
mkTyVarOccFS (FilePath -> FastString
fsLit FilePath
"_")
    sort :: HoleSort
sort | IsExtraConstraint
YesExtraConstraint <- IsExtraConstraint
extra_constraints = HoleSort
ConstraintHole
         | Bool
otherwise                               = HoleSort
TypeHole

emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
emitNamedTypeHole :: (Name, CoVar) -> IOEnv (Env TcGblEnv TcLclEnv) ()
emitNamedTypeHole (Name
name, CoVar
tv)
  = do { ct_loc <- SrcSpan -> TcM CtLoc -> TcM CtLoc
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
name) (TcM CtLoc -> TcM CtLoc) -> TcM CtLoc -> TcM CtLoc
forall a b. (a -> b) -> a -> b
$
                   CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (OccName -> CtOrigin
TypeHoleOrigin OccName
occ) Maybe TypeOrKind
forall a. Maybe a
Nothing
       ; let hole = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
TypeHole
                         , hole_occ :: RdrName
hole_occ  = Name -> RdrName
nameRdrName Name
name
                         , hole_ty :: Mult
hole_ty   = CoVar -> Mult
mkTyVarTy CoVar
tv
                         , hole_loc :: CtLoc
hole_loc  = CtLoc
ct_loc }
       ; emitHole hole }
  where
    occ :: OccName
occ       = Name -> OccName
nameOccName Name
name

-- | Put a value in a coercion hole
fillCoercionHole :: CoercionHole -> CoercionPlusHoles -> TcM ()
fillCoercionHole :: CoercionHole
-> CoercionPlusHoles -> IOEnv (Env TcGblEnv TcLclEnv) ()
fillCoercionHole (CH { ch_ref :: CoercionHole -> IORef (Maybe CoercionPlusHoles)
ch_ref = IORef (Maybe CoercionPlusHoles)
ref, ch_co_var :: CoercionHole -> CoVar
ch_co_var = CoVar
cv }) CoercionPlusHoles
co
  = do { Bool
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn (IOEnv (Env TcGblEnv TcLclEnv) ()
 -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
         do { cts <- IORef (Maybe CoercionPlusHoles)
-> IOEnv (Env TcGblEnv TcLclEnv) (Maybe CoercionPlusHoles)
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef IORef (Maybe CoercionPlusHoles)
ref
            ; whenIsJust cts $ \CoercionPlusHoles
old_co ->
              FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"Filling a filled coercion hole" (CoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoVar
cv SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoercionPlusHoles -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionPlusHoles
co SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ CoercionPlusHoles -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionPlusHoles
old_co) }
       ; FilePath -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc FilePath
"Filling coercion hole" (CoVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoVar
cv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
":=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoercionPlusHoles -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoercionPlusHoles
co)
       ; IORef (Maybe CoercionPlusHoles)
-> Maybe CoercionPlusHoles -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> a -> m ()
writeTcRef IORef (Maybe CoercionPlusHoles)
ref (CoercionPlusHoles -> Maybe CoercionPlusHoles
forall a. a -> Maybe a
Just CoercionPlusHoles
co) }


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

recordThUse :: TcM ()
recordThUse :: IOEnv (Env TcGblEnv TcLclEnv) ()
recordThUse = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; writeTcRef (tcg_th_used env) True }

recordThNeededRuntimeDeps :: [LinkableUsage] -> PkgsLoaded -> TcM ()
recordThNeededRuntimeDeps :: [LinkableUsage]
-> UniqDFM UnitId LoadedPkgInfo -> IOEnv (Env TcGblEnv TcLclEnv) ()
recordThNeededRuntimeDeps [LinkableUsage]
new_links UniqDFM UnitId LoadedPkgInfo
new_pkgs
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; updTcRef (tcg_th_needed_deps env) $ \([LinkableUsage]
needed_links, UniqDFM UnitId LoadedPkgInfo
needed_pkgs) ->
           let links :: [LinkableUsage]
links = [LinkableUsage]
new_links [LinkableUsage] -> [LinkableUsage] -> [LinkableUsage]
forall a. [a] -> [a] -> [a]
++ [LinkableUsage]
needed_links
               !pkgs :: UniqDFM UnitId LoadedPkgInfo
pkgs = UniqDFM UnitId LoadedPkgInfo
-> UniqDFM UnitId LoadedPkgInfo -> UniqDFM UnitId LoadedPkgInfo
forall {k} (key :: k) elt.
UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM UniqDFM UnitId LoadedPkgInfo
needed_pkgs UniqDFM UnitId LoadedPkgInfo
new_pkgs
               in ([LinkableUsage]
links, UniqDFM UnitId LoadedPkgInfo
pkgs)
       }

keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
keepAlive :: Name -> IOEnv (Env TcGblEnv TcLclEnv) ()
keepAlive Name
name
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; traceRn "keep alive" (ppr name)
       ; updTcRef (tcg_keep env) (`extendNameSet` name) }

getThLevel :: TcM ThLevel
getThLevel :: TcM ThLevel
getThLevel = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvThLevel env) }

getCurrentAndBindLevel :: GlobalRdrElt -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))
getCurrentAndBindLevel :: GlobalRdrElt
-> TcRn (Maybe (TopLevelFlag, Set ThLevelIndex, ThLevel))
getCurrentAndBindLevel GlobalRdrElt
gre
  = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv;
       ; return $ case lookupNameEnv (getLclEnvThBndrs env) $ greName gre  of
           Maybe (TopLevelFlag, ThLevelIndex)
Nothing
             | Set ThLevelIndex -> Bool
forall a. Set a -> Bool
Set.null Set ThLevelIndex
lvls  -> Maybe (TopLevelFlag, Set ThLevelIndex, ThLevel)
forall a. Maybe a
Nothing
             -- This case happens when code is generated for identifiers which are not
             -- in scope.
             --
             -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]
             | Bool
otherwise -> (TopLevelFlag, Set ThLevelIndex, ThLevel)
-> Maybe (TopLevelFlag, Set ThLevelIndex, ThLevel)
forall a. a -> Maybe a
Just (TopLevelFlag
TopLevel, Set ThLevelIndex
lvls, TcLclEnv -> ThLevel
getLclEnvThLevel TcLclEnv
env)
           Just (TopLevelFlag
top_lvl, ThLevelIndex
bind_lvl) -> (TopLevelFlag, Set ThLevelIndex, ThLevel)
-> Maybe (TopLevelFlag, Set ThLevelIndex, ThLevel)
forall a. a -> Maybe a
Just (TopLevelFlag
top_lvl, ThLevelIndex -> Set ThLevelIndex
forall a. a -> Set a
Set.singleton ThLevelIndex
bind_lvl, TcLclEnv -> ThLevel
getLclEnvThLevel TcLclEnv
env) }
  where lvls :: Set ThLevelIndex
lvls = GlobalRdrElt -> Set ThLevelIndex
getExternalBindLvl GlobalRdrElt
gre

getExternalBindLvl :: GlobalRdrElt -> Set.Set ThLevelIndex
getExternalBindLvl :: GlobalRdrElt -> Set ThLevelIndex
getExternalBindLvl GlobalRdrElt
gre = (ImportLevel -> ThLevelIndex)
-> Set ImportLevel -> Set ThLevelIndex
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ImportLevel -> ThLevelIndex
thLevelIndexFromImportLevel (GlobalRdrElt -> Set ImportLevel
forall info. GlobalRdrEltX info -> Set ImportLevel
greLevels GlobalRdrElt
gre)

setThLevel :: ThLevel -> TcM a -> TcRn a
setThLevel :: forall a. ThLevel -> TcM a -> TcM a
setThLevel ThLevel
l = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (ThLevel -> TcLclEnv -> TcLclEnv
setLclEnvThLevel ThLevel
l)

-- | Adds the given modFinalizers to the global environment and set them to use
-- the current local environment.
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv :: ThModFinalizers -> IOEnv (Env TcGblEnv TcLclEnv) ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
  = do lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
       updTcRef th_modfinalizers_var $ \[(TcLclEnv, ThModFinalizers)]
fins ->
         (TcLclEnv
lcl_env, ThModFinalizers
mod_finalizers) (TcLclEnv, ThModFinalizers)
-> [(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]
forall a. a -> [a] -> [a]
: [(TcLclEnv, ThModFinalizers)]
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 :: Messages TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
recordUnsafeInfer Messages TcRnMessage
msgs =
    TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> (TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> (a -> IOEnv (Env TcGblEnv TcLclEnv) b)
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TcGblEnv
env -> do IORef Bool -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> a -> m ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
env) Bool
False
                             IORef (Messages TcRnMessage)
-> Messages TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> a -> m ()
writeTcRef (TcGblEnv -> IORef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
env) Messages TcRnMessage
msgs

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

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

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

getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvRdrEnv env) }

setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv :: forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
rdr_env RnM a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> RnM a -> RnM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (LocalRdrEnv -> TcLclEnv -> TcLclEnv
setLclEnvRdrEnv LocalRdrEnv
rdr_env) RnM a
thing_inside

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

mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv Module
mod SDoc
loc IsBootInterface
boot
                   = IfLclEnv { if_mod :: Module
if_mod     = Module
mod,
                                if_loc :: SDoc
if_loc     = SDoc
loc,
                                if_boot :: IsBootInterface
if_boot    = IsBootInterface
boot,
                                if_nsubst :: Maybe NameShape
if_nsubst  = Maybe NameShape
forall a. Maybe a
Nothing,
                                if_implicits_env :: Maybe TypeEnv
if_implicits_env = Maybe TypeEnv
forall a. Maybe a
Nothing,
                                if_tv_env :: FastStringEnv CoVar
if_tv_env  = FastStringEnv CoVar
forall a. FastStringEnv a
emptyFsEnv,
                                if_id_env :: FastStringEnv CoVar
if_id_env  = FastStringEnv CoVar
forall a. FastStringEnv a
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 :: forall a. IfG a -> TcRn a
initIfaceTcRn IfG a
thing_inside
  = do  { tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; hsc_env <- getTopEnv
          -- bangs to avoid leaking the envs (#19356)
        ; let !mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
              !knot_vars = TcGblEnv -> KnotVars (IORef TypeEnv)
tcg_type_env_var TcGblEnv
tcg_env
              -- When we are instantiating a signature, we DEFINITELY
              -- do not want to knot tie.
              is_instantiate = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (HomeUnit -> Bool
forall u. GenHomeUnit u -> Bool
isHomeUnitInstantiating (HomeUnit -> Bool) -> Maybe HomeUnit -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeUnit
mhome_unit)
        ; let { if_env = IfGblEnv {
                            if_doc :: SDoc
if_doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"initIfaceTcRn",
                            if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types =
                                if Bool
is_instantiate
                                    then KnotVars (IfG TypeEnv)
forall a. KnotVars a
emptyKnotVars
                                    else IORef TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef (IORef TypeEnv -> IfG TypeEnv)
-> KnotVars (IORef TypeEnv) -> KnotVars (IfG TypeEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KnotVars (IORef TypeEnv)
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 :: forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env IfG a
do_this
 = do let gbl_env :: IfGblEnv
gbl_env = IfGblEnv {
                        if_doc :: SDoc
if_doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"initIfaceLoad",
                        if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types = KnotVars (IfG TypeEnv)
forall a. KnotVars a
emptyKnotVars
                    }
      UniqueTag -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
UniqueTag -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf UniqueTag
IfaceTag (HscEnv
hsc_env { hsc_type_env_vars = emptyKnotVars }) IfGblEnv
gbl_env () IfG a
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 :: forall a. HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule HscEnv
hsc_env Module
this_mod IfG a
do_this
 = do let gbl_env :: IfGblEnv
gbl_env = IfGblEnv {
                        if_doc :: SDoc
if_doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"initIfaceLoadModule",
                        if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types = IORef TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef (IORef TypeEnv -> IfG TypeEnv)
-> KnotVars (IORef TypeEnv) -> KnotVars (IfG TypeEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> KnotVars (IORef TypeEnv) -> KnotVars (IORef TypeEnv)
forall a. Module -> KnotVars a -> KnotVars a
knotVarsWithout Module
this_mod (HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env)
                    }
      UniqueTag -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
UniqueTag -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf UniqueTag
IfaceTag HscEnv
hsc_env IfGblEnv
gbl_env () IfG a
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 :: forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck SDoc
doc HscEnv
hsc_env IfG a
do_this
 = do let gbl_env :: IfGblEnv
gbl_env = IfGblEnv {
                        if_doc :: SDoc
if_doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"initIfaceCheck" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc,
                        if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types = IORef TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef (IORef TypeEnv -> IfG TypeEnv)
-> KnotVars (IORef TypeEnv) -> KnotVars (IfG TypeEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env
                    }
      UniqueTag -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
UniqueTag -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf UniqueTag
IfaceTag HscEnv
hsc_env IfGblEnv
gbl_env () IfG a
do_this

initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl :: forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
mod SDoc
loc_doc IsBootInterface
hi_boot_file IfL a
thing_inside
  = IfLclEnv -> IfL a -> TcRnIf IfGblEnv lcl a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv Module
mod SDoc
loc_doc IsBootInterface
hi_boot_file) IfL a
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 :: forall a lcl.
Module
-> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst Module
mod SDoc
loc_doc IsBootInterface
hi_boot_file NameShape
nsubst IfL a
thing_inside
  = IfLclEnv -> IfL a -> TcRnIf IfGblEnv lcl a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv ((Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv Module
mod SDoc
loc_doc IsBootInterface
hi_boot_file) { if_nsubst = Just nsubst }) IfL a
thing_inside

getIfModule :: IfL Module
getIfModule :: IfL Module
getIfModule = do { env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
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 :: forall a. SDoc -> IfL a
failIfM SDoc
msg = do
    env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
    let full_msg = (IfLclEnv -> SDoc
if_loc IfLclEnv
env SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 SDoc
msg
    logger <- getLogger
    liftIO $ fatalErrorMsg logger 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 :: forall a. SDoc -> IfL a -> IfL a
forkM SDoc
doc IfL a
thing_inside
 = IfL a -> IfL a
forall env a. IOEnv env a -> IOEnv env a
unsafeInterleaveM (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$ IfL a -> IfL a
forall env a. IOEnv env a -> IOEnv env a
uninterruptibleMaskM_ (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
    do { SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Starting fork {" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc)
       ; mb_res <- IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a))
-> IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
                   (IfLclEnv -> IfLclEnv) -> IfL a -> IfL a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\IfLclEnv
env -> IfLclEnv
env { if_loc = if_loc env $$ doc }) (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
                   IfL a
thing_inside
       ; case mb_res of
            Right a
r  -> do  { SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"} ending fork" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc)
                            ; a -> IfL a
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r }
            Left IOEnvFailure
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.
                  DumpFlag
-> IOEnv (Env IfGblEnv IfLclEnv) ()
-> IOEnv (Env IfGblEnv IfLclEnv) ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_if_trace (IOEnv (Env IfGblEnv IfLclEnv) ()
 -> IOEnv (Env IfGblEnv IfLclEnv) ())
-> IOEnv (Env IfGblEnv IfLclEnv) ()
-> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
                      logger <- IOEnv (Env IfGblEnv IfLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
                      let msg = SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"forkM failed:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc)
                                   Int
2 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (IOEnvFailure -> FilePath
forall a. Show a => a -> FilePath
show IOEnvFailure
exn))
                      liftIO $ fatalErrorMsg logger msg
                ; SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"} ending fork (badly)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc)
                ; FilePath -> IfL a
forall a. HasCallStack => FilePath -> a
pgmError FilePath
"Cannot continue after interface file error" }
    }

setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
setImplicitEnvM :: forall a. TypeEnv -> IfL a -> IfL a
setImplicitEnvM TypeEnv
tenv IfL a
m = (IfLclEnv -> IfLclEnv) -> IfL a -> IfL a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\IfLclEnv
lcl -> IfLclEnv
lcl
                                     { if_implicits_env = Just tenv }) IfL a
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 :: forall gbl lcl.
(gbl -> IORef CostCentreState)
-> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM gbl -> IORef CostCentreState
get_ccs FastString
nm = do
  env <- TcRnIf gbl lcl gbl
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  let cc_st_ref = gbl -> IORef CostCentreState
get_ccs gbl
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 :: FastString -> TcM CostCentreIndex
getCCIndexTcM = (TcGblEnv -> IORef CostCentreState)
-> FastString -> TcM CostCentreIndex
forall gbl lcl.
(gbl -> IORef CostCentreState)
-> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM TcGblEnv -> IORef CostCentreState
tcg_cc_st

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

-- | Lift a computation from the dedicated zonking monad 'ZonkM' to the
-- full-fledged 'TcM' monad.
liftZonkM :: ZonkM a -> TcM a
liftZonkM :: forall a. ZonkM a -> TcM a
liftZonkM (ZonkM ZonkGblEnv -> IO a
f) =
  do { logger       <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
     ; name_ppr_ctx <- getNamePprCtx
     ; lvl          <- getTcLevel
     ; src_span     <- getSrcSpanM
     ; bndrs        <- getLclEnvBinderStack <$> getLclEnv
     ; let zge = ZonkGblEnv { zge_logger :: Logger
zge_logger = Logger
logger
                            , zge_name_ppr_ctx :: NamePprCtx
zge_name_ppr_ctx = NamePprCtx
name_ppr_ctx
                            , zge_src_span :: SrcSpan
zge_src_span = SrcSpan
src_span
                            , zge_tc_level :: TcLevel
zge_tc_level = TcLevel
lvl
                            , zge_binder_stack :: TcBinderStack
zge_binder_stack = TcBinderStack
bndrs }
     ; liftIO $ f zge }
{-# INLINE liftZonkM #-}

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

getCompleteMatchesTcM :: TcM CompleteMatches
getCompleteMatchesTcM :: TcM CompleteMatches
getCompleteMatchesTcM
  = do { hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; eps <- liftIO $ hscEPS hsc_env
       ; tcg_env <- getGblEnv
       ; let tcg_comps = TcGblEnv -> CompleteMatches
tcg_complete_match_env TcGblEnv
tcg_env
       ; liftIO $ localAndImportedCompleteMatches tcg_comps eps
       }

localAndImportedCompleteMatches :: CompleteMatches -> ExternalPackageState -> IO CompleteMatches
localAndImportedCompleteMatches :: CompleteMatches -> ExternalPackageState -> IO CompleteMatches
localAndImportedCompleteMatches CompleteMatches
tcg_comps ExternalPackageState
eps = do
  CompleteMatches -> IO CompleteMatches
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CompleteMatches -> IO CompleteMatches)
-> CompleteMatches -> IO CompleteMatches
forall a b. (a -> b) -> a -> b
$
       CompleteMatches
tcg_comps                -- from the current modulea and from the home package
    CompleteMatches -> CompleteMatches -> CompleteMatches
forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> CompleteMatches
eps_complete_matches ExternalPackageState
eps -- from external packages