{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE ExplicitForAll    #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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, initTcWithGbl, initTcInteractive, initTcRnIf,

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

  -- * Arrow scopes
  newArrowScope, escapeArrowScope,

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

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

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

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

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

  -- * Usage environment
  tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,

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

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

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

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

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

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

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

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

  withException,

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

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

import GHC.Prelude


import GHC.Builtin.Names

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

import GHC.Hs hiding (LIE)

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

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

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

import GHC.Runtime.Context

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

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

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

import qualified GHC.LanguageExtensions as LangExt

import Data.IORef
import Control.Monad

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

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

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

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

initTc :: forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc HscEnv
hsc_env HscSource
hsc_src Bool
keep_rn_syntax Module
mod RealSrcSpan
loc TcM r
do_this
 = do { IORef NameSet
keep_var     <- NameSet -> IO (IORef NameSet)
forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet ;
        IORef [GlobalRdrElt]
used_gre_var <- [GlobalRdrElt] -> IO (IORef [GlobalRdrElt])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef Bool
th_var       <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False ;
        IORef Bool
th_splice_var<- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False ;
        IORef Bool
infer_var    <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True ;
        IORef (Messages TcRnMessage)
infer_reasons_var <- Messages TcRnMessage -> IO (IORef (Messages TcRnMessage))
forall a. a -> IO (IORef a)
newIORef Messages TcRnMessage
forall e. Messages e
emptyMessages ;
        IORef OccSet
dfun_n_var   <- OccSet -> IO (IORef OccSet)
forall a. a -> IO (IORef a)
newIORef OccSet
emptyOccSet ;
        let { type_env_var :: KnotVars (IORef TypeEnv)
type_env_var = HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env };

        IORef [FilePath]
dependent_files_var <- [FilePath] -> IO (IORef [FilePath])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef WantedConstraints
static_wc_var       <- WantedConstraints -> IO (IORef WantedConstraints)
forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC ;
        IORef CostCentreState
cc_st_var           <- CostCentreState -> IO (IORef CostCentreState)
forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState ;
        IORef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var      <- [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> IO (IORef [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef [(ForeignSrcLang, FilePath)]
th_foreign_files_var <- [(ForeignSrcLang, FilePath)]
-> IO (IORef [(ForeignSrcLang, FilePath)])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef NameSet
th_topnames_var      <- NameSet -> IO (IORef NameSet)
forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet ;
        IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- [(TcLclEnv, ThModFinalizers)]
-> IO (IORef [(TcLclEnv, ThModFinalizers)])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef [FilePath]
th_coreplugins_var <- [FilePath] -> IO (IORef [FilePath])
forall a. a -> IO (IORef a)
newIORef [] ;
        IORef (Map TypeRep Dynamic)
th_state_var         <- Map TypeRep Dynamic -> IO (IORef (Map TypeRep Dynamic))
forall a. a -> IO (IORef a)
newIORef Map TypeRep Dynamic
forall k a. Map k a
Map.empty ;
        IORef (Maybe (ForeignRef (IORef QState)))
th_remote_state_var  <- Maybe (ForeignRef (IORef QState))
-> IO (IORef (Maybe (ForeignRef (IORef QState))))
forall a. a -> IO (IORef a)
newIORef Maybe (ForeignRef (IORef QState))
forall a. Maybe a
Nothing ;
        IORef (Map DocLoc (HsDoc GhcRn))
th_docs_var          <- Map DocLoc (HsDoc GhcRn) -> IO (IORef (Map DocLoc (HsDoc GhcRn)))
forall a. a -> IO (IORef a)
newIORef Map DocLoc (HsDoc GhcRn)
forall k a. Map k a
Map.empty ;
        IORef ([Linkable], UniqDFM UnitId LoadedPkgInfo)
th_needed_deps_var   <- ([Linkable], UniqDFM UnitId LoadedPkgInfo)
-> IO (IORef ([Linkable], UniqDFM UnitId LoadedPkgInfo))
forall a. a -> IO (IORef a)
newIORef ([], UniqDFM UnitId LoadedPkgInfo
forall key elt. UniqDFM key elt
emptyUDFM) ;
        IORef (ModuleEnv Int)
next_wrapper_num     <- ModuleEnv Int -> IO (IORef (ModuleEnv Int))
forall a. a -> IO (IORef a)
newIORef ModuleEnv Int
forall a. ModuleEnv a
emptyModuleEnv ;
        let {
             -- bangs to avoid leaking the env (#19356)
             !dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env ;
             !mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env;
             !logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env ;

             maybe_rn_syntax :: forall a. a -> Maybe a ;
             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 ;

             gbl_env :: TcGblEnv
gbl_env = TcGblEnv {
                tcg_th_topdecls :: TcRef [LHsDecl GhcPs]
tcg_th_topdecls      = TcRef [LHsDecl GhcPs]
IORef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var,
                tcg_th_foreign_files :: IORef [(ForeignSrcLang, FilePath)]
tcg_th_foreign_files = IORef [(ForeignSrcLang, FilePath)]
th_foreign_files_var,
                tcg_th_topnames :: IORef NameSet
tcg_th_topnames      = IORef NameSet
th_topnames_var,
                tcg_th_modfinalizers :: IORef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers = IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var,
                tcg_th_coreplugins :: IORef [FilePath]
tcg_th_coreplugins = IORef [FilePath]
th_coreplugins_var,
                tcg_th_state :: IORef (Map TypeRep Dynamic)
tcg_th_state         = IORef (Map TypeRep Dynamic)
th_state_var,
                tcg_th_remote_state :: IORef (Maybe (ForeignRef (IORef QState)))
tcg_th_remote_state  = IORef (Maybe (ForeignRef (IORef QState)))
th_remote_state_var,
                tcg_th_docs :: IORef (Map DocLoc (HsDoc GhcRn))
tcg_th_docs          = IORef (Map DocLoc (HsDoc GhcRn))
th_docs_var,

                tcg_mod :: Module
tcg_mod            = Module
mod,
                tcg_semantic_mod :: Module
tcg_semantic_mod   = Maybe HomeUnit -> Module -> Module
homeModuleInstantiation Maybe HomeUnit
mhome_unit Module
mod,
                tcg_src :: HscSource
tcg_src            = HscSource
hsc_src,
                tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env        = GlobalRdrEnv
emptyGlobalRdrEnv,
                tcg_fix_env :: FixityEnv
tcg_fix_env        = FixityEnv
forall a. NameEnv a
emptyNameEnv,
                tcg_field_env :: RecFieldEnv
tcg_field_env      = RecFieldEnv
forall a. NameEnv a
emptyNameEnv,
                tcg_default :: Maybe [Type]
tcg_default        = if Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
primUnit
                                     Bool -> Bool -> Bool
|| Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
bignumUnit
                                     then [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just []  -- See Note [Default types]
                                     else Maybe [Type]
forall a. Maybe a
Nothing,
                tcg_type_env :: TypeEnv
tcg_type_env       = TypeEnv
forall a. NameEnv a
emptyNameEnv,
                tcg_type_env_var :: KnotVars (IORef TypeEnv)
tcg_type_env_var   = KnotVars (IORef TypeEnv)
type_env_var,
                tcg_inst_env :: InstEnv
tcg_inst_env       = InstEnv
emptyInstEnv,
                tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env   = FamInstEnv
emptyFamInstEnv,
                tcg_ann_env :: AnnEnv
tcg_ann_env        = AnnEnv
emptyAnnEnv,
                tcg_th_used :: IORef Bool
tcg_th_used        = IORef Bool
th_var,
                tcg_th_splice_used :: IORef Bool
tcg_th_splice_used = IORef Bool
th_splice_var,
                tcg_th_needed_deps :: IORef ([Linkable], UniqDFM UnitId LoadedPkgInfo)
tcg_th_needed_deps = IORef ([Linkable], UniqDFM UnitId LoadedPkgInfo)
th_needed_deps_var,
                tcg_exports :: [AvailInfo]
tcg_exports        = [],
                tcg_imports :: ImportAvails
tcg_imports        = ImportAvails
emptyImportAvails,
                tcg_used_gres :: IORef [GlobalRdrElt]
tcg_used_gres     = IORef [GlobalRdrElt]
used_gre_var,
                tcg_dus :: DefUses
tcg_dus            = DefUses
emptyDUs,

                tcg_rn_imports :: [LImportDecl GhcRn]
tcg_rn_imports     = [],
                tcg_rn_exports :: Maybe [(LIE GhcRn, [AvailInfo])]
tcg_rn_exports     =
                    if HscSource
hsc_src HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
                        -- Always retain renamed syntax, so that we can give
                        -- better errors.  (TODO: how?)
                        then [(GenLocated SrcSpanAnnA (IE GhcRn), [AvailInfo])]
-> Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), [AvailInfo])]
forall a. a -> Maybe a
Just []
                        else [(GenLocated SrcSpanAnnA (IE GhcRn), [AvailInfo])]
-> Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), [AvailInfo])]
forall a. a -> Maybe a
maybe_rn_syntax [],
                tcg_rn_decls :: Maybe (HsGroup GhcRn)
tcg_rn_decls       = HsGroup GhcRn -> Maybe (HsGroup GhcRn)
forall a. a -> Maybe a
maybe_rn_syntax HsGroup GhcRn
forall (p :: Pass). HsGroup (GhcPass p)
emptyRnGroup,
                tcg_tr_module :: Maybe Id
tcg_tr_module      = Maybe Id
forall a. Maybe a
Nothing,
                tcg_binds :: LHsBinds GhcTc
tcg_binds          = LHsBinds GhcTc
forall (idL :: Pass) idR. LHsBindsLR (GhcPass idL) idR
emptyLHsBinds,
                tcg_imp_specs :: [LTcSpecPrag]
tcg_imp_specs      = [],
                tcg_sigs :: NameSet
tcg_sigs           = NameSet
emptyNameSet,
                tcg_ksigs :: NameSet
tcg_ksigs          = NameSet
emptyNameSet,
                tcg_ev_binds :: Bag EvBind
tcg_ev_binds       = Bag EvBind
forall a. Bag a
emptyBag,
                tcg_warns :: Warnings GhcRn
tcg_warns          = Warnings GhcRn
forall pass. Warnings pass
NoWarnings,
                tcg_anns :: [Annotation]
tcg_anns           = [],
                tcg_tcs :: [TyCon]
tcg_tcs            = [],
                tcg_insts :: [ClsInst]
tcg_insts          = [],
                tcg_fam_insts :: [FamInst]
tcg_fam_insts      = [],
                tcg_rules :: [LRuleDecl GhcTc]
tcg_rules          = [],
                tcg_fords :: [LForeignDecl GhcTc]
tcg_fords          = [],
                tcg_patsyns :: [PatSyn]
tcg_patsyns        = [],
                tcg_merged :: [(Module, Fingerprint)]
tcg_merged         = [],
                tcg_dfun_n :: IORef OccSet
tcg_dfun_n         = IORef OccSet
dfun_n_var,
                tcg_keep :: IORef NameSet
tcg_keep           = IORef NameSet
keep_var,
                tcg_doc_hdr :: Maybe (LHsDoc GhcRn)
tcg_doc_hdr        = Maybe (LHsDoc GhcRn)
forall a. Maybe a
Nothing,
                tcg_hpc :: Bool
tcg_hpc            = Bool
False,
                tcg_main :: Maybe Name
tcg_main           = Maybe Name
forall a. Maybe a
Nothing,
                tcg_self_boot :: SelfBootInfo
tcg_self_boot      = SelfBootInfo
NoSelfBoot,
                tcg_safe_infer :: IORef Bool
tcg_safe_infer     = IORef Bool
infer_var,
                tcg_safe_infer_reasons :: IORef (Messages TcRnMessage)
tcg_safe_infer_reasons = IORef (Messages TcRnMessage)
infer_reasons_var,
                tcg_dependent_files :: IORef [FilePath]
tcg_dependent_files = IORef [FilePath]
dependent_files_var,
                tcg_tc_plugin_solvers :: [TcPluginSolver]
tcg_tc_plugin_solvers   = [],
                tcg_tc_plugin_rewriters :: UniqFM TyCon [TcPluginRewriter]
tcg_tc_plugin_rewriters = UniqFM TyCon [TcPluginRewriter]
forall key elt. UniqFM key elt
emptyUFM,
                tcg_defaulting_plugins :: [FillDefaulting]
tcg_defaulting_plugins  = [],
                tcg_hf_plugins :: [HoleFitPlugin]
tcg_hf_plugins     = [],
                tcg_top_loc :: RealSrcSpan
tcg_top_loc        = RealSrcSpan
loc,
                tcg_static_wc :: IORef WantedConstraints
tcg_static_wc      = IORef WantedConstraints
static_wc_var,
                tcg_complete_matches :: CompleteMatches
tcg_complete_matches = [],
                tcg_cc_st :: IORef CostCentreState
tcg_cc_st          = IORef CostCentreState
cc_st_var,
                tcg_next_wrapper_num :: IORef (ModuleEnv Int)
tcg_next_wrapper_num = IORef (ModuleEnv Int)
next_wrapper_num
             } ;
        } ;

        -- OK, here's the business end!
        HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
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
    }

-- | 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 { IORef WantedConstraints
lie_var      <- WantedConstraints -> IO (IORef WantedConstraints)
forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC
      ; IORef (Messages TcRnMessage)
errs_var     <- Messages TcRnMessage -> IO (IORef (Messages TcRnMessage))
forall a. a -> IO (IORef a)
newIORef Messages TcRnMessage
forall e. Messages e
emptyMessages
      ; IORef UsageEnv
usage_var    <- UsageEnv -> IO (IORef UsageEnv)
forall a. a -> IO (IORef a)
newIORef UsageEnv
zeroUE
      ; let lcl_env :: TcLclEnv
lcl_env = TcLclEnv {
                tcl_errs :: IORef (Messages TcRnMessage)
tcl_errs       = IORef (Messages TcRnMessage)
errs_var,
                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_ctxt :: [ErrCtxt]
tcl_ctxt       = [],
                tcl_rdr :: LocalRdrEnv
tcl_rdr        = LocalRdrEnv
emptyLocalRdrEnv,
                tcl_th_ctxt :: ThStage
tcl_th_ctxt    = ThStage
topStage,
                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_usage :: IORef UsageEnv
tcl_usage      = IORef UsageEnv
usage_var,
                tcl_bndrs :: TcBinderStack
tcl_bndrs      = [],
                tcl_lie :: IORef WantedConstraints
tcl_lie        = IORef WantedConstraints
lie_var,
                tcl_tclvl :: TcLevel
tcl_tclvl      = TcLevel
topTcLevel
                }

      ; Maybe r
maybe_res <- Char
-> HscEnv
-> TcGblEnv
-> TcLclEnv
-> TcRnIf TcGblEnv TcLclEnv (Maybe r)
-> IO (Maybe r)
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'a' HscEnv
hsc_env TcGblEnv
gbl_env TcLclEnv
lcl_env (TcRnIf TcGblEnv TcLclEnv (Maybe r) -> IO (Maybe r))
-> TcRnIf TcGblEnv TcLclEnv (Maybe r) -> IO (Maybe r)
forall a b. (a -> b) -> a -> b
$
                     do { Either IOEnvFailure r
r <- TcM r -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure r)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcM r
do_this
                        ; case Either IOEnvFailure r
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)
      ; WantedConstraints
lie <- IORef WantedConstraints -> IO WantedConstraints
forall a. IORef a -> IO a
readIORef (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
lcl_env)
      ; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe r -> Bool
forall a. Maybe a -> Bool
isJust Maybe r
maybe_res Bool -> Bool -> Bool
&& Bool -> Bool
not (WantedConstraints -> Bool
isEmptyWC WantedConstraints
lie)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> SDoc -> IO ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"initTc: unsolved constraints" (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)

        -- Collect any error messages
      ; Messages TcRnMessage
msgs <- IORef (Messages TcRnMessage) -> IO (Messages TcRnMessage)
forall a. IORef a -> IO a
readIORef (TcLclEnv -> IORef (Messages TcRnMessage)
tcl_errs TcLclEnv
lcl_env)

      ; let { final_res :: Maybe r
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 }

      ; (Messages TcRnMessage, Maybe r)
-> IO (Messages TcRnMessage, Maybe r)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages TcRnMessage
msgs, Maybe r
final_res)
      }

initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
-- Initialise the type checker monad for use in GHCi
initTcInteractive :: forall a. HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive HscEnv
hsc_env TcM a
thing_inside
  = HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM a
-> IO (Messages TcRnMessage, Maybe a)
forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc 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

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

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


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

initTcRnIf :: Char              -- ^ Mask for unique supply
           -> HscEnv
           -> gbl -> lcl
           -> TcRnIf gbl lcl a
           -> IO a
initTcRnIf :: forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
uniq_mask 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_um :: Char
env_um  = Char
uniq_mask,
                            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 -> TcM ()
discardResult TcM a
a = TcM a
a TcM a -> TcM () -> TcM ()
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
>> () -> TcM ()
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 gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; HscEnv -> TcRnIf gbl lcl HscEnv
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env gbl lcl -> HscEnv
forall gbl lcl. Env gbl lcl -> HscEnv
env_top Env gbl lcl
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 })

getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv :: forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv = do { Env{gbl
lcl
Char
HscEnv
env_top :: forall gbl lcl. Env gbl lcl -> HscEnv
env_um :: forall gbl lcl. Env gbl lcl -> Char
env_gbl :: forall gbl lcl. Env gbl lcl -> gbl
env_lcl :: forall gbl lcl. Env gbl lcl -> lcl
env_top :: HscEnv
env_um :: Char
env_gbl :: gbl
env_lcl :: lcl
..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; gbl -> TcRnIf gbl lcl gbl
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return gbl
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{gbl
lcl
Char
HscEnv
env_top :: forall gbl lcl. Env gbl lcl -> HscEnv
env_um :: forall gbl lcl. Env gbl lcl -> Char
env_gbl :: forall gbl lcl. Env gbl lcl -> gbl
env_lcl :: forall gbl lcl. Env gbl lcl -> lcl
env_top :: HscEnv
env_um :: Char
env_gbl :: gbl
env_lcl :: lcl
..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; lcl -> TcRnIf gbl lcl lcl
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return lcl
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 })


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 gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; (gbl, lcl) -> TcRnIf gbl lcl (gbl, lcl)
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Env gbl lcl -> gbl
forall gbl lcl. Env gbl lcl -> gbl
env_gbl Env gbl lcl
env, Env gbl lcl -> lcl
forall gbl lcl. Env gbl lcl -> lcl
env_lcl Env gbl 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
logger <- IOEnv (Env gbl lcl) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  Bool -> TcRnIf gbl lcl Bool
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
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)

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 Bool
b <- DumpFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- GeneralFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- WarningFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
                                 Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
                                   Bool -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b TcRnIf gbl lcl ()
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
  HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
  TcRef ExternalPackageState
-> TcRnIf gbl lcl (TcRef ExternalPackageState)
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExternalUnitCache -> TcRef ExternalPackageState
euc_eps (UnitEnv -> ExternalUnitCache
ue_eps (HscEnv -> UnitEnv
hsc_unit_env HscEnv
env)))

getEps :: TcRnIf gbl lcl ExternalPackageState
getEps :: forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps = do { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; IO ExternalPackageState -> TcRnIf gbl lcl ExternalPackageState
forall a. IO a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> TcRnIf gbl lcl ExternalPackageState)
-> IO ExternalPackageState -> TcRnIf gbl lcl ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
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")
  TcRef ExternalPackageState
eps_var <- TcRnIf gbl lcl (TcRef ExternalPackageState)
forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar
  TcRef ExternalPackageState
-> (ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
forall a b env. IORef a -> (a -> (a, b)) -> IOEnv env b
atomicUpdMutVar' TcRef ExternalPackageState
eps_var ExternalPackageState -> (ExternalPackageState, a)
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 { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; HomePackageTable -> TcRnIf gbl lcl HomePackageTable
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> HomePackageTable
hsc_HPT HscEnv
env) }

getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug :: forall gbl lcl.
TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug = do { HscEnv
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; ExternalPackageState
eps <- IO ExternalPackageState -> IOEnv (Env gbl lcl) ExternalPackageState
forall a. IO a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState
 -> IOEnv (Env gbl lcl) ExternalPackageState)
-> IO ExternalPackageState
-> IOEnv (Env gbl lcl) ExternalPackageState
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
env
                  ; (ExternalPackageState, HomeUnitGraph)
-> TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExternalPackageState
eps, HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
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
    MaybeErr SDoc a
r <- m (MaybeErr SDoc a)
do_this
    case MaybeErr SDoc a
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

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

newArrowScope :: TcM a -> TcM a
newArrowScope :: forall a. TcM a -> TcM 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 -> TcLclEnv
env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }

-- Return to the stored environment (from the enclosing proc)
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope :: forall a. TcM a -> TcM 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
tcl_arrow_ctxt TcLclEnv
env of
      ArrowCtxt
NoArrowCtxt       -> TcLclEnv
env
      ArrowCtxt LocalRdrEnv
rdr_env IORef WantedConstraints
lie -> TcLclEnv
env { tcl_arrow_ctxt = NoArrowCtxt
                                   , tcl_lie = lie
                                   , tcl_rdr = rdr_env }

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

newUnique :: TcRnIf gbl lcl Unique
newUnique :: forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
 = do { Env gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv
      ; let mask :: Char
mask = Env gbl lcl -> Char
forall gbl lcl. Env gbl lcl -> Char
env_um Env gbl lcl
env
      ; IO Unique -> TcRnIf gbl lcl Unique
forall a. IO a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Unique -> TcRnIf gbl lcl Unique)
-> IO Unique -> TcRnIf gbl lcl Unique
forall a b. (a -> b) -> a -> b
$! Char -> IO Unique
uniqFromMask Char
mask }

newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply :: forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
 = do { Env gbl lcl
env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv
      ; let mask :: Char
mask = Env gbl lcl -> Char
forall gbl lcl. Env gbl lcl -> Char
env_um Env gbl lcl
env
      ; IO UniqSupply -> TcRnIf gbl lcl UniqSupply
forall a. IO a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UniqSupply -> TcRnIf gbl lcl UniqSupply)
-> IO UniqSupply -> TcRnIf gbl lcl UniqSupply
forall a b. (a -> b) -> a -> b
$! Char -> IO UniqSupply
mkSplitUniqSupply Char
mask }

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 { SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM
                 ; OccName -> SrcSpan -> TcM Name
newNameAt OccName
occ SrcSpan
loc }

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

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

newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId :: forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl Id
newSysLocalId FastString
fs Type
w Type
ty
  = do  { Unique
u <- TcRnIf gbl lcl Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; Id -> TcRnIf gbl lcl Id
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Type -> Type -> Id
mkSysLocal FastString
fs Unique
u Type
w Type
ty) }

newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds :: forall gbl lcl. FastString -> [Scaled Type] -> TcRnIf gbl lcl [Id]
newSysLocalIds FastString
fs [Scaled Type]
tys
  = do  { UniqSupply
us <- TcRnIf gbl lcl UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
        ; let mkId' :: Unique -> Scaled Type -> Id
mkId' Unique
n (Scaled Type
w Type
t) = FastString -> Unique -> Type -> Type -> Id
mkSysLocal FastString
fs Unique
n Type
w Type
t
        ; [Id] -> TcRnIf gbl lcl [Id]
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Unique -> Scaled Type -> Id) -> [Unique] -> [Scaled Type] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Unique -> Scaled Type -> Id
mkId' (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us) [Scaled Type]
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

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

newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef :: forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef = a -> IOEnv (Env gbl lcl) (IORef a)
forall a env. a -> IOEnv env (IORef a)
newMutVar

readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef :: forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef = IORef a -> IOEnv (Env gbl lcl) a
forall a env. IORef a -> IOEnv env a
readMutVar

writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef :: forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = IORef a -> a -> IOEnv (Env gbl lcl) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar

updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
-- Returns ()
updTcRef :: forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef TcRef a
ref a -> a
fn = IO () -> IOEnv (Env gbl lcl) ()
forall a. IO a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env gbl lcl) ())
-> IO () -> IOEnv (Env gbl lcl) ()
forall a b. (a -> b) -> a -> b
$ TcRef a -> (a -> a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' TcRef a
ref a -> a
fn

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

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

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

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

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

and then we float in:

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

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

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

See #18168.
-}

-- Typechecker trace
traceTc :: String -> SDoc -> TcRn ()
traceTc :: FilePath -> SDoc -> TcM ()
traceTc FilePath
herald SDoc
doc =
    DumpFlag -> FilePath -> SDoc -> TcM ()
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 -> TcM ()
traceRn FilePath
herald SDoc
doc =
    DumpFlag -> FilePath -> SDoc -> TcM ()
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 -> TcM ()
labelledTraceOptTcRn DumpFlag
flag FilePath
herald SDoc
doc =
  DumpFlag -> SDoc -> TcM ()
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 -> TcM ()
traceOptTcRn DumpFlag
flag SDoc
doc =
  DumpFlag -> TcM () -> TcM ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
    Bool -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> TcM ()
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 -> TcM ()
dumpOptTcRn DumpFlag
flag FilePath
title DumpFormat
fmt SDoc
doc =
  DumpFlag -> TcM () -> TcM ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
    Bool -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> TcM ()
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 -> TcM ()
dumpTcRn Bool
useUserStyle DumpFlag
flag FilePath
title DumpFormat
fmt SDoc
doc = do
  Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  NamePprCtx
name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx
  SDoc
real_doc <- SDoc -> TcRn SDoc
wrapDocLoc SDoc
doc
  let sty :: PprStyle
sty = if Bool
useUserStyle
              then NamePprCtx -> Depth -> PprStyle
mkUserStyle NamePprCtx
name_ppr_ctx Depth
AllTheWay
              else NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
name_ppr_ctx
  IO () -> TcM ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TcM ()) -> IO () -> TcM ()
forall a b. (a -> b) -> a -> b
$ Logger
-> PprStyle -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
logDumpFile Logger
logger PprStyle
sty DumpFlag
flag FilePath
title DumpFormat
fmt SDoc
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
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  if Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_ppr_debug
    then do
      SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
      SDoc -> TcRn SDoc
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput SrcSpan
loc SDoc
doc)
    else
      SDoc -> TcRn SDoc
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc

getNamePprCtx :: TcRn NamePprCtx
getNamePprCtx :: TcRn NamePprCtx
getNamePprCtx
  = do { PromotionTickContext
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
       ; GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; NamePprCtx -> TcRn NamePprCtx
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NamePprCtx -> TcRn NamePprCtx) -> NamePprCtx -> TcRn NamePprCtx
forall a b. (a -> b) -> a -> b
$ PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env }

-- | Like logInfoTcRn, but for user consumption
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn :: SDoc -> TcM ()
printForUserTcRn SDoc
doc = do
    Logger
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    NamePprCtx
name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx
    IO () -> TcM ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> NamePprCtx -> SDoc -> IO ()
printOutputForUser Logger
logger NamePprCtx
name_ppr_ctx SDoc
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
logger <- IOEnv (Env m n) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
        IO () -> TcRnIf m n ()
forall a. IO a -> IOEnv (Env m n) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
doc)
{-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]

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

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

getGHCiMonad :: TcRn Name
getGHCiMonad :: TcM Name
getGHCiMonad = do { HscEnv
hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; Name -> TcM Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> Name
ic_monad (InteractiveContext -> Name) -> InteractiveContext -> Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) }

getInteractivePrintName :: TcRn Name
getInteractivePrintName :: TcM Name
getInteractivePrintName = do { HscEnv
hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; Name -> TcM Name
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> Name
ic_int_print (InteractiveContext -> Name) -> InteractiveContext -> Name
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) }

tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; Bool -> TcRn Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> Bool
isHsBootOrSig (TcGblEnv -> HscSource
tcg_src TcGblEnv
env)) }

tcIsHsig :: TcRn Bool
tcIsHsig :: TcRn Bool
tcIsHsig = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; Bool -> TcRn Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> Bool
isHsigFile (TcGblEnv -> HscSource
tcg_src TcGblEnv
env)) }

tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; SelfBootInfo -> TcRn SelfBootInfo
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> SelfBootInfo
tcg_self_boot TcGblEnv
env) }

getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; GlobalRdrEnv -> TcRn GlobalRdrEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
env) }

getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (TcGblEnv
gbl,TcLclEnv
lcl) <- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs; (GlobalRdrEnv, LocalRdrEnv) -> TcRn (GlobalRdrEnv, LocalRdrEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl, TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
lcl) }

getImports :: TcRn ImportAvails
getImports :: TcRn ImportAvails
getImports = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; ImportAvails -> TcRn ImportAvails
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
env) }

getFixityEnv :: TcRn FixityEnv
getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; FixityEnv -> TcRn FixityEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
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})

getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; RecFieldEnv -> TcRn RecFieldEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> RecFieldEnv
tcg_field_env TcGblEnv
env) }

getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; Maybe [Type] -> TcRn (Maybe [Type])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> Maybe [Type]
tcg_default TcGblEnv
env) }

addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles :: [FilePath] -> TcM ()
addDependentFiles [FilePath]
fs = do
  IORef [FilePath]
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
  [FilePath]
dep_files <- IORef [FilePath] -> TcRnIf TcGblEnv TcLclEnv [FilePath]
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef [FilePath]
ref
  IORef [FilePath] -> [FilePath] -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef [FilePath]
ref ([FilePath]
fs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dep_files)

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

getSrcSpanM :: TcRn SrcSpan
        -- Avoid clash with Name.getSrcLoc
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; SrcSpan -> TcRn SrcSpan
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
env) Maybe BufSpan
forall a. Maybe a
Strict.Nothing) }

-- See Note [Error contexts in generated code]
inGeneratedCode :: TcRn Bool
inGeneratedCode :: TcRn Bool
inGeneratedCode = TcLclEnv -> Bool
tcl_in_gen_code (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]
-- for the tcl_in_gen_code manipulation
setSrcSpan :: forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan RealSrcSpan
loc Maybe BufSpan
_) TcRn a
thing_inside
  = (TcLclEnv -> TcLclEnv) -> TcRn a -> TcRn a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_loc = loc, tcl_in_gen_code = False })
              TcRn a
thing_inside

setSrcSpan loc :: SrcSpan
loc@(UnhelpfulSpan UnhelpfulSpanReason
_) TcRn a
thing_inside
  | SrcSpan -> Bool
isGeneratedSrcSpan SrcSpan
loc
  = (TcLclEnv -> TcLclEnv) -> TcRn a -> TcRn a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_in_gen_code = True }) TcRn a
thing_inside

  | Bool
otherwise
  = TcRn a
thing_inside

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

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

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

wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM :: forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM a -> TcM b
fn (L SrcSpan
loc a
a) = 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
b <- a -> TcM b
fn a
a
                                            ; Located b -> TcRn (Located b)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> b -> Located b
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc b
b) }

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

wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA :: forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA a -> TcM b
fn (L SrcSpanAnn' ann
loc a
a) = SrcSpanAnn' ann
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc (TcRn (GenLocated (SrcSpanAnn' ann) b)
 -> TcRn (GenLocated (SrcSpanAnn' ann) b))
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
forall a b. (a -> b) -> a -> b
$ do { b
b <- a -> TcM b
fn a
a
                                              ; GenLocated (SrcSpanAnn' ann) b
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' ann -> b -> GenLocated (SrcSpanAnn' ann) b
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' ann
loc b
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
b,c
c) <- a -> TcM (b, c)
fn a
a
    (Located b, c) -> TcRn (Located b, c)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> b -> Located b
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc b
b, c
c)

-- Possible instantiations:
--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA    a -> TcM (LocatedA    b, c)
--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN    a -> TcM (LocatedN    b, c)
--    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)
-- and so on.
wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA :: forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA a -> TcM (b, c)
fn (L SrcSpanAnn' ann
loc a
a) =
  SrcSpanAnn' ann
-> TcRn (GenLocated (SrcSpanAnn' ann) b, c)
-> TcRn (GenLocated (SrcSpanAnn' ann) b, c)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc (TcRn (GenLocated (SrcSpanAnn' ann) b, c)
 -> TcRn (GenLocated (SrcSpanAnn' ann) b, c))
-> TcRn (GenLocated (SrcSpanAnn' ann) b, c)
-> TcRn (GenLocated (SrcSpanAnn' ann) b, c)
forall a b. (a -> b) -> a -> b
$ do
    (b
b,c
c) <- a -> TcM (b, c)
fn a
a
    (GenLocated (SrcSpanAnn' ann) b, c)
-> TcRn (GenLocated (SrcSpanAnn' ann) b, c)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpanAnn' ann -> b -> GenLocated (SrcSpanAnn' ann) b
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' ann
loc b
b, c
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
b,c
c) <- a -> TcM (b, c)
fn a
a
    (b, Located c) -> TcRn (b, Located c)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SrcSpan -> c -> Located c
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc c
c)

-- Possible instantiations:
--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA    a -> TcM (b, LocatedA    c)
--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN    a -> TcM (b, LocatedN    c)
--    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)
-- and so on.
wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c)
wrapLocSndMA :: forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (SrcSpanAnn' ann) a
-> TcM (b, GenLocated (SrcSpanAnn' ann) c)
wrapLocSndMA a -> TcM (b, c)
fn (L SrcSpanAnn' ann
loc a
a) =
  SrcSpanAnn' ann
-> TcRn (b, GenLocated (SrcSpanAnn' ann) c)
-> TcRn (b, GenLocated (SrcSpanAnn' ann) c)
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc (TcRn (b, GenLocated (SrcSpanAnn' ann) c)
 -> TcRn (b, GenLocated (SrcSpanAnn' ann) c))
-> TcRn (b, GenLocated (SrcSpanAnn' ann) c)
-> TcRn (b, GenLocated (SrcSpanAnn' ann) c)
forall a b. (a -> b) -> a -> b
$ do
    (b
b,c
c) <- a -> TcM (b, c)
fn a
a
    (b, GenLocated (SrcSpanAnn' ann) c)
-> TcRn (b, GenLocated (SrcSpanAnn' ann) c)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, SrcSpanAnn' ann -> c -> GenLocated (SrcSpanAnn' ann) c
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' ann
loc c
c)

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

wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()
wrapLocMA_ :: forall a. (a -> TcM ()) -> LocatedA a -> TcM ()
wrapLocMA_ a -> TcM ()
fn (L SrcSpanAnnA
loc a
a) = SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (a -> TcM ()
fn a
a)

-- Reporting errors

getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
getErrsVar :: TcRn (IORef (Messages TcRnMessage))
getErrsVar = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; IORef (Messages TcRnMessage) -> TcRn (IORef (Messages TcRnMessage))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> IORef (Messages TcRnMessage)
tcl_errs TcLclEnv
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 -> TcM ()
addErr TcRnMessage
msg = do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM; SrcSpan -> TcRnMessage -> TcM ()
addErrAt SrcSpan
loc TcRnMessage
msg }

failWith :: TcRnMessage -> TcRn a
failWith :: forall a. TcRnMessage -> TcRn a
failWith TcRnMessage
msg = TcRnMessage -> TcM ()
addErr TcRnMessage
msg TcM ()
-> 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 -> TcM ()
addErrAt SrcSpan
loc TcRnMessage
msg TcM ()
-> 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 -> TcM ()
addErrAt SrcSpan
loc TcRnMessage
msg = do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt
                      ; TidyEnv
tidy_env <- TcM TidyEnv
tcInitTidyEnv
                      ; SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
tidy_env [ErrCtxt]
ctxt
                      ; let detailed_msg :: TcRnMessageDetailed
detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage (SDoc -> SDoc -> ErrInfo
ErrInfo SDoc
err_info SDoc
forall doc. IsOutput doc => doc
Outputable.empty) TcRnMessage
msg
                      ; SrcSpan -> TcRnMessageDetailed -> TcM ()
add_long_err_at SrcSpan
loc TcRnMessageDetailed
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)] -> TcM ()
addErrs [(SrcSpan, TcRnMessage)]
msgs = ((SrcSpan, TcRnMessage) -> TcM ())
-> [(SrcSpan, TcRnMessage)] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SrcSpan, TcRnMessage) -> TcM ()
add [(SrcSpan, TcRnMessage)]
msgs
             where
               add :: (SrcSpan, TcRnMessage) -> TcM ()
add (SrcSpan
loc,TcRnMessage
msg) = SrcSpan -> TcRnMessage -> TcM ()
addErrAt SrcSpan
loc TcRnMessage
msg

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

addMessages :: Messages TcRnMessage -> TcRn ()
addMessages :: Messages TcRnMessage -> TcM ()
addMessages Messages TcRnMessage
msgs1
  = do { IORef (Messages TcRnMessage)
errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar
       ; Messages TcRnMessage
msgs0    <- IORef (Messages TcRnMessage)
-> TcRnIf TcGblEnv TcLclEnv (Messages TcRnMessage)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages TcRnMessage)
errs_var
       ; IORef (Messages TcRnMessage) -> Messages TcRnMessage -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Messages TcRnMessage)
errs_var (Messages TcRnMessage
msgs0 Messages TcRnMessage
-> Messages TcRnMessage -> Messages TcRnMessage
forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages TcRnMessage
msgs1) }

discardWarnings :: TcRn a -> TcRn a
-- Ignore warnings inside the thing inside;
-- used to ignore-unused-variable warnings inside derived code
discardWarnings :: forall a. TcM a -> TcM a
discardWarnings TcRn a
thing_inside
  = do  { IORef (Messages TcRnMessage)
errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar
        ; Bag (MsgEnvelope TcRnMessage)
old_warns <- Messages TcRnMessage -> Bag (MsgEnvelope TcRnMessage)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages (Messages TcRnMessage -> Bag (MsgEnvelope TcRnMessage))
-> TcRnIf TcGblEnv TcLclEnv (Messages TcRnMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bag (MsgEnvelope TcRnMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Messages TcRnMessage)
-> TcRnIf TcGblEnv TcLclEnv (Messages TcRnMessage)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages TcRnMessage)
errs_var

        ; a
result <- TcRn a
thing_inside

        -- Revert warnings to old_warns
        ; Bag (MsgEnvelope TcRnMessage)
new_errs <- Messages TcRnMessage -> Bag (MsgEnvelope TcRnMessage)
forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getErrorMessages (Messages TcRnMessage -> Bag (MsgEnvelope TcRnMessage))
-> TcRnIf TcGblEnv TcLclEnv (Messages TcRnMessage)
-> IOEnv (Env TcGblEnv TcLclEnv) (Bag (MsgEnvelope TcRnMessage))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Messages TcRnMessage)
-> TcRnIf TcGblEnv TcLclEnv (Messages TcRnMessage)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages TcRnMessage)
errs_var
        ; IORef (Messages TcRnMessage) -> Messages TcRnMessage -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Messages TcRnMessage)
errs_var (Messages TcRnMessage -> TcM ()) -> Messages TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ Bag (MsgEnvelope TcRnMessage) -> Messages TcRnMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope TcRnMessage)
old_warns Bag (MsgEnvelope TcRnMessage)
-> Bag (MsgEnvelope TcRnMessage) -> Bag (MsgEnvelope TcRnMessage)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (MsgEnvelope TcRnMessage)
new_errs)

        ; a -> TcRn a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result }

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

add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn ()
add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcM ()
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 -> TcM ()) -> TcM ()
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 -> TcM ()
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 { NamePprCtx
name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx ;
             UnitState
unit_state <- (() :: Constraint) => 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 ;
             MsgEnvelope TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgEnvelope TcRnMessage -> TcRn (MsgEnvelope TcRnMessage))
-> MsgEnvelope TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> NamePprCtx -> TcRnMessage -> MsgEnvelope TcRnMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
loc NamePprCtx
name_ppr_ctx
                    (TcRnMessage -> MsgEnvelope TcRnMessage)
-> TcRnMessage -> MsgEnvelope TcRnMessage
forall a b. (a -> b) -> a -> b
$ UnitState -> TcRnMessageDetailed -> TcRnMessage
TcRnMessageWithInfo UnitState
unit_state TcRnMessageDetailed
msg
                    }

mkTcRnMessage :: SrcSpan
              -> TcRnMessage
              -> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage :: SrcSpan -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage SrcSpan
loc TcRnMessage
msg
  = do { NamePprCtx
name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx ;
         DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags ;
         MsgEnvelope TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (MsgEnvelope TcRnMessage -> TcRn (MsgEnvelope TcRnMessage))
-> MsgEnvelope TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
forall a b. (a -> b) -> a -> b
$ DiagOpts
-> SrcSpan -> NamePprCtx -> TcRnMessage -> MsgEnvelope TcRnMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
diag_opts SrcSpan
loc NamePprCtx
name_ppr_ctx TcRnMessage
msg }

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

reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
reportDiagnostic :: MsgEnvelope TcRnMessage -> TcM ()
reportDiagnostic MsgEnvelope TcRnMessage
msg
  = do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"Adding diagnostic:" (MsgEnvelope TcRnMessage -> SDoc
forall e. Diagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelopeDefault MsgEnvelope TcRnMessage
msg) ;
         IORef (Messages TcRnMessage)
errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar ;
         Messages TcRnMessage
msgs     <- IORef (Messages TcRnMessage)
-> TcRnIf TcGblEnv TcLclEnv (Messages TcRnMessage)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages TcRnMessage)
errs_var ;
         IORef (Messages TcRnMessage) -> Messages TcRnMessage -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Messages TcRnMessage)
errs_var (MsgEnvelope TcRnMessage
msg MsgEnvelope TcRnMessage
-> Messages TcRnMessage -> Messages TcRnMessage
forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages TcRnMessage
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. TcM a -> TcM a
checkNoErrs TcM r
main
  = do  { (r
res, Bool
no_errs) <- TcM r -> TcRn (r, Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcM r
main
        ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
no_errs TcM ()
forall env a. IOEnv env a
failM
        ; r -> TcM r
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return r
res }

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

failIfErrsM :: TcRn ()
-- Useful to avoid error cascades
failIfErrsM :: TcM ()
failIfErrsM = TcM () -> TcM () -> TcM ()
forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM TcM ()
forall env a. IOEnv env a
failM (() -> TcM ()
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 sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
  and back to False when we get a useful SrcSpan

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

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

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

getErrCtxt :: TcM [ErrCtxt]
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; [ErrCtxt] -> TcM [ErrCtxt]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> [ErrCtxt]
tcl_ctxt TcLclEnv
env) }

setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
{-# INLINE setErrCtxt #-}   -- Note [Inlining addErrCtxt]
setErrCtxt :: forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [ErrCtxt]
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 (\ TcLclEnv
env -> TcLclEnv
env { tcl_ctxt = ctxt })

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

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

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

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

pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
pushCtxt :: forall a. ErrCtxt -> TcM a -> TcM a
pushCtxt ErrCtxt
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 (ErrCtxt -> TcLclEnv -> TcLclEnv
updCtxt ErrCtxt
ctxt)

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

popErrCtxt :: TcM a -> TcM a
popErrCtxt :: forall a. TcM a -> TcM a
popErrCtxt = (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 (\ env :: TcLclEnv
env@(TcLclEnv { tcl_ctxt :: TcLclEnv -> [ErrCtxt]
tcl_ctxt = [ErrCtxt]
ctxt }) ->
                          TcLclEnv
env { tcl_ctxt = pop ctxt })
           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 { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; CtLoc -> TcM CtLoc
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CtLoc { ctl_origin :: CtOrigin
ctl_origin   = CtOrigin
origin
                       , ctl_env :: TcLclEnv
ctl_env      = TcLclEnv
env
                       , ctl_t_or_k :: Maybe TypeOrKind
ctl_t_or_k   = Maybe TypeOrKind
t_or_k
                       , ctl_depth :: SubGoalDepth
ctl_depth    = SubGoalDepth
initialSubGoalDepth }) }

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 -> TcLclEnv
ctl_env = TcLclEnv
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 -> TcLclEnv
env { tcl_loc   = tcl_loc lcl
                           , tcl_bndrs = tcl_bndrs lcl
                           , tcl_ctxt  = tcl_ctxt lcl })
              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 IOEnvFailure r
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
       ; Maybe r -> TcRn (Maybe r)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (case Either IOEnvFailure r
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 { IORef WantedConstraints
lie_var <- WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef WantedConstraints
emptyWC
       ; r
res <- (TcLclEnv -> TcLclEnv) -> TcM r -> TcM r
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_lie = lie_var }) (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
                TcM r
thing_inside
       ; WantedConstraints
lie <- IORef WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv WantedConstraints
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef WantedConstraints
lie_var
       ; (r, WantedConstraints) -> TcM (r, WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r
res, WantedConstraints
lie) }

capture_messages :: TcM r -> TcM (r, Messages TcRnMessage)
-- capture_messages simply captures and returns the
--                  errors arnd 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 { IORef (Messages TcRnMessage)
msg_var <- Messages TcRnMessage -> TcRn (IORef (Messages TcRnMessage))
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef Messages TcRnMessage
forall e. Messages e
emptyMessages
       ; r
res     <- IORef (Messages TcRnMessage) -> TcM r -> TcM r
forall a. IORef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar IORef (Messages TcRnMessage)
msg_var TcM r
thing_inside
       ; Messages TcRnMessage
msgs    <- IORef (Messages TcRnMessage)
-> TcRnIf TcGblEnv TcLclEnv (Messages TcRnMessage)
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages TcRnMessage)
msg_var
       ; (r, Messages TcRnMessage) -> TcM (r, Messages TcRnMessage)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r
res, Messages TcRnMessage
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 { ((Maybe a
mb_res, WantedConstraints
lie), Messages TcRnMessage
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
       ; Messages TcRnMessage -> TcM ()
addMessages Messages TcRnMessage
msgs

       ; case Maybe a
mb_res of
           Maybe a
Nothing  -> do { WantedConstraints -> TcM ()
emitConstraints (WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie)
                          ; TcRn (a, Bool)
forall env a. IOEnv env a
failM }

           Just a
res -> do { WantedConstraints -> TcM ()
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) -> TcRn (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 { (Maybe a
mb_res, WantedConstraints
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]
       ; let lie_to_keep :: WantedConstraints
lie_to_keep = case Maybe a
mb_res of
                             Maybe a
Nothing -> WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie
                             Just {} -> WantedConstraints
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
mb_res, WantedConstraints
lie_to_keep) }

captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
-- If thing_inside fails (throwing an exception),
--   then (captureConstraints thing_inside) fails too
--   propagating the insoluble constraints only
-- Error messages are propagated in either case
captureConstraints :: forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside
  = do { (Maybe a
mb_res, WantedConstraints
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 Maybe a
mb_res of
           Maybe a
Nothing  -> do { WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie; TcM (a, WantedConstraints)
forall env a. IOEnv env a
failM }
           Just a
res -> (a, WantedConstraints) -> TcM (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 { IORef UsageEnv
local_usage_ref <- UsageEnv -> TcRnIf TcGblEnv TcLclEnv (IORef UsageEnv)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef UsageEnv
zeroUE
       ; a
result <- (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_usage = local_usage_ref }) TcM a
thing_inside
       ; UsageEnv
local_usage <- IORef UsageEnv -> TcRnIf TcGblEnv TcLclEnv UsageEnv
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef UsageEnv
local_usage_ref
       ; (UsageEnv, a) -> TcM (UsageEnv, a)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (UsageEnv
local_usage,a
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. Type -> TcM a -> TcM a
tcScalingUsage Type
mult TcM a
thing_inside
  = do { (UsageEnv
usage, a
result) <- TcM a -> TcM (UsageEnv, a)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage TcM a
thing_inside
       ; FilePath -> SDoc -> TcM ()
traceTc FilePath
"tcScalingUsage" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
mult)
       ; UsageEnv -> TcM ()
tcEmitBindingUsage (UsageEnv -> TcM ()) -> UsageEnv -> TcM ()
forall a b. (a -> b) -> a -> b
$ Type -> UsageEnv -> UsageEnv
scaleUE Type
mult UsageEnv
usage
       ; a -> TcM a
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result }

tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage UsageEnv
ue
  = do { TcLclEnv
lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       ; let usage :: IORef UsageEnv
usage = TcLclEnv -> IORef UsageEnv
tcl_usage TcLclEnv
lcl_env
       ; IORef UsageEnv -> (UsageEnv -> UsageEnv) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef UsageEnv
usage (UsageEnv -> UsageEnv -> UsageEnv
addUE UsageEnv
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 { (Maybe r
mb_r, WantedConstraints
lie) <- TcRn r -> TcM (Maybe r, WantedConstraints)
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcRn r
thing_inside
       ; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie

       -- Debug trace
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe r -> Bool
forall a. Maybe a -> Bool
isNothing Maybe r
mb_r) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
         FilePath -> SDoc -> TcM ()
traceTc FilePath
"attemptM recovering with insoluble constraints" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
                 (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)

       ; Maybe r -> TcRn (Maybe r)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
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 { Maybe r
mb_res <- TcRn r -> TcRn (Maybe r)
forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing ;
         case Maybe r
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 { [Maybe b]
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
       ; [b] -> TcRn [b]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [b
r | Just b
r <- [Maybe b]
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 { [Maybe b]
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
       ; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Maybe b -> Bool) -> [Maybe b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe b -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe b]
mb_rs) TcM ()
forall env a. IOEnv env a
failM
       ; [b] -> TcRn [b]
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return [b
r | Just b
r <- [Maybe b]
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 { Maybe b
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 Maybe b
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. TcM a -> TcM a
discardErrs TcRn a
m
 = do { IORef (Messages TcRnMessage)
errs_var <- Messages TcRnMessage -> TcRn (IORef (Messages TcRnMessage))
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef Messages TcRnMessage
forall e. Messages e
emptyMessages
      ; IORef (Messages TcRnMessage) -> TcRn a -> TcRn a
forall a. IORef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar IORef (Messages TcRnMessage)
errs_var TcRn a
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 TcM r
thing_inside
  = do { ((Maybe r
mb_res, WantedConstraints
lie), Messages TcRnMessage
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 Maybe r
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)
              -> -- 'main' succeeded with no errors
                 do { Messages TcRnMessage -> TcM ()
addMessages Messages TcRnMessage
msgs  -- msgs might still have warnings
                    ; WantedConstraints -> TcM ()
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 }

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

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

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

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

addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addErrTcM (TidyEnv
tidy_env, TcRnMessage
err_msg)
  = do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt ;
         SrcSpan
loc  <- TcRn SrcSpan
getSrcSpanM ;
         TidyEnv -> TcRnMessage -> SrcSpan -> [ErrCtxt] -> TcM ()
add_err_tcm TidyEnv
tidy_env TcRnMessage
err_msg SrcSpan
loc [ErrCtxt]
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 -> TcM ()
addErrTc TcRnMessage
err_msg TcM ()
-> 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) -> TcM ()
addErrTcM (TidyEnv, TcRnMessage)
local_and_msg TcM ()
-> 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 -> TcM ()
checkTc Bool
True  TcRnMessage
_   = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkTc Bool
False TcRnMessage
err = TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcRn a
failWithTc TcRnMessage
err

checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM Bool
True  (TidyEnv, TcRnMessage)
_   = () -> TcM ()
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) -> TcM ()
forall a. (TidyEnv, TcRnMessage) -> TcM a
failWithTcM (TidyEnv, TcRnMessage)
err

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

failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
   -- Check that the boolean is false
failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
failIfTcM Bool
False (TidyEnv, TcRnMessage)
_   = () -> TcM ()
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) -> TcM ()
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 -> TcM ()
warnIf Bool
is_bad TcRnMessage
msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'.
  = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_bad (TcRnMessage -> TcM ()
addDiagnostic TcRnMessage
msg)

no_err_info :: ErrInfo
no_err_info :: ErrInfo
no_err_info = SDoc -> SDoc -> ErrInfo
ErrInfo SDoc
forall doc. IsOutput doc => doc
Outputable.empty SDoc
forall doc. IsOutput doc => doc
Outputable.empty

-- | Display a warning if a condition is met.
diagnosticTc :: Bool -> TcRnMessage -> TcM ()
diagnosticTc :: Bool -> TcRnMessage -> TcM ()
diagnosticTc Bool
should_report TcRnMessage
warn_msg
  | Bool
should_report = TcRnMessage -> TcM ()
addDiagnosticTc TcRnMessage
warn_msg
  | Bool
otherwise     = () -> TcM ()
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) -> TcM ()
diagnosticTcM Bool
should_report (TidyEnv, TcRnMessage)
warn_msg
  | Bool
should_report = (TidyEnv, TcRnMessage) -> TcM ()
addDiagnosticTcM (TidyEnv, TcRnMessage)
warn_msg
  | Bool
otherwise     = () -> TcM ()
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 -> TcM ()
addDiagnosticTc TcRnMessage
msg
 = do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv ;
      (TidyEnv, TcRnMessage) -> TcM ()
addDiagnosticTcM (TidyEnv
env0, TcRnMessage
msg) }

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

-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'
-- given some additional context about the diagnostic.
addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic ErrInfo -> TcRnMessage
mkMsg = do
  SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
  NamePprCtx
name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx
  !DiagOpts
diag_opts  <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
  [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt
  SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
env0 [ErrCtxt]
ctxt
  MsgEnvelope TcRnMessage -> TcM ()
reportDiagnostic (DiagOpts
-> SrcSpan -> NamePprCtx -> TcRnMessage -> MsgEnvelope TcRnMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
diag_opts SrcSpan
loc NamePprCtx
name_ppr_ctx (ErrInfo -> TcRnMessage
mkMsg (SDoc -> SDoc -> ErrInfo
ErrInfo SDoc
err_info SDoc
forall doc. IsOutput doc => doc
empty)))

addTcRnDiagnostic :: TcRnMessage -> TcM ()
addTcRnDiagnostic :: TcRnMessage -> TcM ()
addTcRnDiagnostic TcRnMessage
msg = do
  SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
  SrcSpan -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage SrcSpan
loc TcRnMessage
msg TcRn (MsgEnvelope TcRnMessage)
-> (MsgEnvelope TcRnMessage -> TcM ()) -> TcM ()
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 -> TcM ()
reportDiagnostic

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

-- | Display a diagnostic for a given source location.
addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcM ()
addDiagnosticAt SrcSpan
loc TcRnMessage
msg = do
  UnitState
unit_state <- (() :: Constraint) => 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 :: TcRnMessageDetailed
detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage ErrInfo
no_err_info TcRnMessage
msg
  SrcSpan -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage SrcSpan
loc (UnitState -> TcRnMessageDetailed -> TcRnMessage
TcRnMessageWithInfo UnitState
unit_state TcRnMessageDetailed
detailed_msg) TcRn (MsgEnvelope TcRnMessage)
-> (MsgEnvelope TcRnMessage -> TcM ()) -> TcM ()
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 -> TcM ()
reportDiagnostic

-- | Display a diagnostic, with an optional flag, for the current source
-- location.
add_diagnostic :: TcRnMessageDetailed -> TcRn ()
add_diagnostic :: TcRnMessageDetailed -> TcM ()
add_diagnostic TcRnMessageDetailed
msg
  = do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; UnitState
unit_state <- (() :: Constraint) => 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
       ; SrcSpan -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage SrcSpan
loc (UnitState -> TcRnMessageDetailed -> TcRnMessage
TcRnMessageWithInfo UnitState
unit_state TcRnMessageDetailed
msg) TcRn (MsgEnvelope TcRnMessage)
-> (MsgEnvelope TcRnMessage -> TcM ()) -> TcM ()
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 -> TcM ()
reportDiagnostic
       }


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

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

mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
-- Tidy the error info, trimming excessive contexts
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
env [ErrCtxt]
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 -> [ErrCtxt] -> TcRn SDoc
go Bool
False Int
0 TidyEnv
env [ErrCtxt]
ctxts
 where
   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
_ Int
_ TidyEnv
_   [] = SDoc -> TcRn SDoc
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
forall doc. IsOutput doc => doc
empty
   go Bool
dbg Int
n TidyEnv
env ((Bool
is_landmark, TidyEnv -> TcM (TidyEnv, SDoc)
ctxt) : [ErrCtxt]
ctxts)
     | Bool
is_landmark Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mAX_CONTEXTS -- Too verbose || dbg
     = do { (TidyEnv
env', SDoc
msg) <- TidyEnv -> TcM (TidyEnv, SDoc)
ctxt TidyEnv
env
          ; let n' :: Int
n' = if Bool
is_landmark then Int
n else Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
          ; SDoc
rest <- Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
dbg Int
n' TidyEnv
env' [ErrCtxt]
ctxts
          ; SDoc -> TcRn SDoc
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
rest) }
     | Bool
otherwise
     = Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
dbg Int
n TidyEnv
env [ErrCtxt]
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 :: TcM () -> TcM ()
debugTc TcM ()
thing
 | Bool
debugIsOn = TcM ()
thing
 | Bool
otherwise = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
addTopEvBinds :: forall a. Bag EvBind -> TcM a -> TcM a
addTopEvBinds Bag EvBind
new_ev_binds TcM a
thing_inside
  =(TcGblEnv -> TcGblEnv) -> TcM a -> TcM a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv TcGblEnv -> TcGblEnv
upd_env TcM a
thing_inside
  where
    upd_env :: TcGblEnv -> TcGblEnv
upd_env TcGblEnv
tcg_env = TcGblEnv
tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
                                               `unionBags` new_ev_binds }

newTcEvBinds :: TcM EvBindsVar
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { TcRef EvBindMap
binds_ref <- EvBindMap -> TcRnIf TcGblEnv TcLclEnv (TcRef EvBindMap)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
                  ; TcRef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (TcRef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
                  ; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
                  ; FilePath -> SDoc -> TcM ()
traceTc FilePath
"newTcEvBinds" (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"unique =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uniq)
                  ; EvBindsVar -> TcM EvBindsVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar { ebv_binds :: TcRef EvBindMap
ebv_binds = TcRef EvBindMap
binds_ref
                                       , ebv_tcvs :: TcRef VarSet
ebv_tcvs = TcRef VarSet
tcvs_ref
                                       , ebv_uniq :: Unique
ebv_uniq = Unique
uniq }) }

-- | Creates an EvBindsVar incapable of holding any bindings. It still
-- tracks covar usages (see comments on ebv_tcvs in "GHC.Tc.Types.Evidence"), thus
-- must be made monadically
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds
  = do { TcRef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (TcRef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
       ; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
       ; FilePath -> SDoc -> TcM ()
traceTc FilePath
"newNoTcEvBinds" (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"unique =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uniq)
       ; EvBindsVar -> TcM EvBindsVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoEvBindsVar { ebv_tcvs :: TcRef VarSet
ebv_tcvs = TcRef VarSet
tcvs_ref
                              , ebv_uniq :: Unique
ebv_uniq = Unique
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 { TcRef EvBindMap
binds_ref <- EvBindMap -> TcRnIf TcGblEnv TcLclEnv (TcRef EvBindMap)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
       ; TcRef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (TcRef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
       ; EvBindsVar -> TcM EvBindsVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar
ebv { ebv_binds = binds_ref
                     , ebv_tcvs = tcvs_ref }) }
cloneEvBindsVar ebv :: EvBindsVar
ebv@(CoEvBindsVar {})
  = do { TcRef VarSet
tcvs_ref  <- VarSet -> TcRnIf TcGblEnv TcLclEnv (TcRef VarSet)
forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
       ; EvBindsVar -> TcM EvBindsVar
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar
ebv { ebv_tcvs = tcvs_ref }) }

getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
getTcEvTyCoVars :: EvBindsVar -> TcM VarSet
getTcEvTyCoVars EvBindsVar
ev_binds_var
  = TcRef VarSet -> TcM VarSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (EvBindsVar -> TcRef VarSet
ebv_tcvs EvBindsVar
ev_binds_var)

getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindMap
ebv_binds = TcRef EvBindMap
ev_ref })
  = TcRef EvBindMap -> TcM EvBindMap
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef EvBindMap
ev_ref
getTcEvBindsMap (CoEvBindsVar {})
  = EvBindMap -> TcM EvBindMap
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return EvBindMap
emptyEvBindMap

setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
setTcEvBindsMap (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindMap
ebv_binds = TcRef EvBindMap
ev_ref }) EvBindMap
binds
  = TcRef EvBindMap -> EvBindMap -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef EvBindMap
ev_ref EvBindMap
binds
setTcEvBindsMap v :: EvBindsVar
v@(CoEvBindsVar {}) EvBindMap
ev_binds
  | EvBindMap -> Bool
isEmptyEvBindMap EvBindMap
ev_binds
  = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise
  = FilePath -> SDoc -> TcM ()
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"setTcEvBindsMap" (EvBindsVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsVar
v SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ EvBindMap -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindMap
ev_binds)

addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
-- Add a binding to the TcEvBinds by side effect
addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
addTcEvBind (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindMap
ebv_binds = TcRef EvBindMap
ev_ref, ebv_uniq :: EvBindsVar -> Unique
ebv_uniq = Unique
u }) EvBind
ev_bind
  = do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"addTcEvBind" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                                 EvBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBind
ev_bind
       ; EvBindMap
bnds <- TcRef EvBindMap -> TcM EvBindMap
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef EvBindMap
ev_ref
       ; TcRef EvBindMap -> EvBindMap -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef EvBindMap
ev_ref (EvBindMap -> EvBind -> EvBindMap
extendEvBinds EvBindMap
bnds EvBind
ev_bind) }
addTcEvBind (CoEvBindsVar { ebv_uniq :: EvBindsVar -> Unique
ebv_uniq = Unique
u }) EvBind
ev_bind
  = FilePath -> SDoc -> TcM ()
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 { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
     ; let dfun_n_var :: IORef OccSet
dfun_n_var = TcGblEnv -> IORef OccSet
tcg_dfun_n TcGblEnv
env
     ; OccSet
set <- IORef OccSet -> TcRnIf TcGblEnv TcLclEnv OccSet
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef OccSet
dfun_n_var
     ; let occ :: OccName
occ = OccSet -> OccName
fn OccSet
set
     ; IORef OccSet -> OccSet -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef OccSet
dfun_n_var (OccSet -> OccName -> OccSet
extendOccSet OccSet
set OccName
occ)
     ; OccName -> TcM OccName
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return OccName
occ }

getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar :: TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; IORef WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
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 })

emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints WantedConstraints
static_lie
  = do { TcGblEnv
gbl_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef (TcGblEnv -> IORef WantedConstraints
tcg_static_wc TcGblEnv
gbl_env) (WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
static_lie) }

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

emitSimple :: Ct -> TcM ()
emitSimple :: Ct -> TcM ()
emitSimple Ct
ct
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addSimples` Ct -> Bag Ct
forall a. a -> Bag a
unitBag Ct
ct) }

emitSimples :: Cts -> TcM ()
emitSimples :: Bag Ct -> TcM ()
emitSimples Bag Ct
cts
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addSimples` Bag Ct
cts) }

emitImplication :: Implication -> TcM ()
emitImplication :: Implication -> TcM ()
emitImplication Implication
ct
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar ;
         IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Implication -> WantedConstraints
`addImplics` Implication -> Bag Implication
forall a. a -> Bag a
unitBag Implication
ct) }

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

emitInsoluble :: Ct -> TcM ()
emitInsoluble :: Ct -> TcM ()
emitInsoluble Ct
ct
  = do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"emitInsoluble" (Ct -> SDoc
forall a. Outputable a => a -> SDoc
ppr Ct
ct)
       ; IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar
       ; IORef WantedConstraints
-> (WantedConstraints -> WantedConstraints) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addInsols` Ct -> Bag Ct
forall a. a -> Bag a
unitBag Ct
ct) }

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

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

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

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

-- | Throw out any constraints emitted by the thing_inside
discardConstraints :: TcM a -> TcM a
discardConstraints :: forall a. TcM a -> TcM 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 { TcLevel
tclvl <- TcM TcLevel
getTcLevel
       ; let tclvl' :: TcLevel
tclvl' = TcLevel -> TcLevel
pushTcLevel TcLevel
tclvl
       ; FilePath -> SDoc -> TcM ()
traceTc FilePath
"pushLevelAndCaptureConstraints {" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl')
       ; (a
res, WantedConstraints
lie) <- (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_tclvl = tclvl' }) (TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
 -> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints))
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
-> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
                       TcM a -> TcRnIf TcGblEnv TcLclEnv (a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside
       ; FilePath -> SDoc -> TcM ()
traceTc FilePath
"pushLevelAndCaptureConstraints }" (TcLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl')
       ; (TcLevel, WantedConstraints, a)
-> TcM (TcLevel, WantedConstraints, a)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel
tclvl', WantedConstraints
lie, a
res) }

pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ :: forall a. TcM a -> TcM a
pushTcLevelM_ TcM a
x = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) TcM a
x

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 { TcLevel
tclvl <- TcM TcLevel
getTcLevel
       ; let tclvl' :: TcLevel
tclvl' = TcLevel -> TcLevel
pushTcLevel TcLevel
tclvl
       ; a
res <- (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_tclvl = tclvl' }) TcM a
thing_inside
       ; (TcLevel, a) -> TcM (TcLevel, a)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel
tclvl', a
res) }

getTcLevel :: TcM TcLevel
getTcLevel :: TcM TcLevel
getTcLevel = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
                ; TcLevel -> TcM TcLevel
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
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 (\TcLclEnv
env -> TcLclEnv
env { tcl_tclvl = tclvl }) TcM a
thing_inside

isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM :: Id -> TcRn Bool
isTouchableTcM Id
tv
  = do { TcLevel
lvl <- TcM TcLevel
getTcLevel
       ; Bool -> TcRn Bool
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel -> Id -> Bool
isTouchableMetaTyVar TcLevel
lvl Id
tv) }

getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; TcTypeEnv -> TcM TcTypeEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
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 TcLclEnv -> TcLclEnv
upd TcM a
thing_inside
  where
    upd :: TcLclEnv -> TcLclEnv
upd TcLclEnv
env = TcLclEnv
env { tcl_env = tcl_env lcl_env }

traceTcConstraints :: String -> TcM ()
traceTcConstraints :: FilePath -> TcM ()
traceTcConstraints FilePath
msg
  = do { IORef WantedConstraints
lie_var <- TcRnIf TcGblEnv TcLclEnv (IORef WantedConstraints)
getConstraintVar
       ; WantedConstraints
lie     <- IORef WantedConstraints
-> TcRnIf TcGblEnv TcLclEnv WantedConstraints
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef WantedConstraints
lie_var
       ; DumpFlag -> SDoc -> TcM ()
traceOptTcRn DumpFlag
Opt_D_dump_tc_trace (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
         SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath
msg FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": LIE:")) Int
2 (WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
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 -> Id -> TcM ()
emitAnonTypeHole IsExtraConstraint
extra_constraints Id
tv
  = do { CtLoc
ct_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (OccName -> CtOrigin
TypeHoleOrigin OccName
occ) Maybe TypeOrKind
forall a. Maybe a
Nothing
       ; let hole :: Hole
hole = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
sort
                         , hole_occ :: RdrName
hole_occ  = OccName -> RdrName
mkRdrUnqual OccName
occ
                         , hole_ty :: Type
hole_ty   = Id -> Type
mkTyVarTy Id
tv
                         , hole_loc :: CtLoc
hole_loc  = CtLoc
ct_loc }
       ; Hole -> TcM ()
emitHole Hole
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, Id) -> TcM ()
emitNamedTypeHole (Name
name, Id
tv)
  = do { CtLoc
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 = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
TypeHole
                         , hole_occ :: RdrName
hole_occ  = Name -> RdrName
nameRdrName Name
name
                         , hole_ty :: Type
hole_ty   = Id -> Type
mkTyVarTy Id
tv
                         , hole_loc :: CtLoc
hole_loc  = CtLoc
ct_loc }
       ; Hole -> TcM ()
emitHole Hole
hole }
  where
    occ :: OccName
occ       = Name -> OccName
nameOccName Name
name

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

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

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

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

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

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

It's distressingly delicate though:

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

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

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

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

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

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

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


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

recordThUse :: TcM ()
recordThUse :: TcM ()
recordThUse = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; IORef Bool -> Bool -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_th_used TcGblEnv
env) Bool
True }

recordThSpliceUse :: TcM ()
recordThSpliceUse :: TcM ()
recordThSpliceUse = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; IORef Bool -> Bool -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_th_splice_used TcGblEnv
env) Bool
True }

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

keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
keepAlive :: Name -> TcM ()
keepAlive Name
name
  = do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; FilePath -> SDoc -> TcM ()
traceRn FilePath
"keep alive" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
       ; IORef NameSet -> (NameSet -> NameSet) -> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef (TcGblEnv -> IORef NameSet
tcg_keep TcGblEnv
env) (NameSet -> Name -> NameSet
`extendNameSet` Name
name) }

getStage :: TcM ThStage
getStage :: TcM ThStage
getStage = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; ThStage -> TcM ThStage
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
env) }

getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel Name
name
  = do { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv;
       ; case ThBindEnv -> Name -> Maybe (TopLevelFlag, Int)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (TcLclEnv -> ThBindEnv
tcl_th_bndrs TcLclEnv
env) Name
name of
           Maybe (TopLevelFlag, Int)
Nothing                  -> Maybe (TopLevelFlag, Int, ThStage)
-> TcRn (Maybe (TopLevelFlag, Int, ThStage))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TopLevelFlag, Int, ThStage)
forall a. Maybe a
Nothing
           Just (TopLevelFlag
top_lvl, Int
bind_lvl) -> Maybe (TopLevelFlag, Int, ThStage)
-> TcRn (Maybe (TopLevelFlag, Int, ThStage))
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TopLevelFlag, Int, ThStage) -> Maybe (TopLevelFlag, Int, ThStage)
forall a. a -> Maybe a
Just (TopLevelFlag
top_lvl, Int
bind_lvl, TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
env)) }

setStage :: ThStage -> TcM a -> TcRn a
setStage :: forall a. ThStage -> TcM a -> TcM a
setStage ThStage
s = (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_th_ctxt = s })

-- | Adds the given modFinalizers to the global environment and set them to use
-- the current local environment.
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
  = do TcLclEnv
lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
       IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- (TcGblEnv -> IORef [(TcLclEnv, ThModFinalizers)])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv
     (Env TcGblEnv TcLclEnv) (IORef [(TcLclEnv, ThModFinalizers)])
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 [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       IORef [(TcLclEnv, ThModFinalizers)]
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> TcM ()
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var (([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
 -> TcM ())
-> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)])
-> TcM ()
forall a b. (a -> b) -> a -> b
$ \[(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 -> TcM ()
recordUnsafeInfer Messages TcRnMessage
msgs =
    TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv TcRnIf TcGblEnv TcLclEnv TcGblEnv -> (TcGblEnv -> TcM ()) -> TcM ()
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 -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
env) Bool
False
                             IORef (Messages TcRnMessage) -> Messages TcRnMessage -> TcM ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
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
    Bool
safeInf <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
tcg_env)
    SafeHaskellMode -> IO SafeHaskellMode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeHaskellMode -> IO SafeHaskellMode)
-> SafeHaskellMode -> IO SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ case DynFlags -> SafeHaskellMode
safeHaskell DynFlags
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 { TcLclEnv
env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; LocalRdrEnv -> RnM LocalRdrEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
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 (\TcLclEnv
env -> TcLclEnv
env {tcl_rdr = 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 Id
if_tv_env  = FastStringEnv Id
forall a. FastStringEnv a
emptyFsEnv,
                                if_id_env :: FastStringEnv Id
if_id_env  = FastStringEnv Id
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  { TcGblEnv
tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
        ; HscEnv
hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
          -- bangs to avoid leaking the envs (#19356)
        ; let !mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
              !knot_vars :: KnotVars (IORef TypeEnv)
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
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_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 a gbl lcl. TcRef a -> TcRnIf gbl lcl 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
                            }
                         }
        ; (IfGblEnv, ()) -> IfG a -> TcRn a
forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (IfGblEnv
if_env, ()) IfG a
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
                    }
      Char -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'i' (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 a gbl lcl. TcRef a -> TcRnIf gbl lcl 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)
                    }
      Char -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'i' 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 a gbl lcl. TcRef a -> TcRnIf gbl lcl 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
                    }
      Char -> HscEnv -> IfGblEnv -> () -> IfG a -> IO a
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'i' 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 { IfLclEnv
env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; Module -> IfL Module
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (IfLclEnv -> Module
if_mod IfLclEnv
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
    IfLclEnv
env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
    let full_msg :: SDoc
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
logger <- IOEnv (Env IfGblEnv IfLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a. IO a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
MCFatal
             SrcSpan
noSrcSpan (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
full_msg)
    IfL a
forall env a. IOEnv env a
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)
       ; Either IOEnvFailure a
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 Either IOEnvFailure a
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
logger <- IOEnv (Env IfGblEnv IfLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
                      let msg :: SDoc
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))
                      IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a. IO a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IOEnv (Env IfGblEnv IfLclEnv) ())
-> IO () -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a b. (a -> b) -> a -> b
$ Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger
                                         MessageClass
MCFatal
                                         SrcSpan
noSrcSpan
                                         (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
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
  gbl
env <- TcRnIf gbl lcl gbl
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
  let cc_st_ref :: IORef CostCentreState
cc_st_ref = gbl -> IORef CostCentreState
get_ccs gbl
env
  CostCentreState
cc_st <- IORef CostCentreState -> TcRnIf gbl lcl CostCentreState
forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef CostCentreState
cc_st_ref
  let (CostCentreIndex
idx, CostCentreState
cc_st') = FastString -> CostCentreState -> (CostCentreIndex, CostCentreState)
getCCIndex FastString
nm CostCentreState
cc_st
  IORef CostCentreState -> CostCentreState -> TcRnIf gbl lcl ()
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef CostCentreState
cc_st_ref CostCentreState
cc_st'
  CostCentreIndex -> TcRnIf gbl lcl CostCentreIndex
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return CostCentreIndex
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