{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.Tc.Utils.Monad(
initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
discardResult,
getTopEnv, updTopEnv, getGblEnv, updGblEnv,
setGblEnv, getLclEnv, updLclEnv, updLclCtxt, 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,
newArrowScope, escapeArrowScope,
newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
newSysName, newSysLocalId, newSysLocalIds,
newTcRef, readTcRef, writeTcRef, updTcRef, updTcRefM,
traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
dumpTcRn,
getNamePprCtx,
printForUserTcRn,
traceIf, traceOptIf,
debugTc,
getIsGHCi, getGHCiMonad, getInteractivePrintName,
tcHscSource, tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
getRdrEnvs, getImports,
getFixityEnv, extendFixityEnv,
getDeclaredDefaultTys,
addDependentFiles,
getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,
inGeneratedCode, setInGeneratedCode,
wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
wrapLocMA_,wrapLocMA,
getErrsVar, setErrsVar,
addErr,
failWith, failAt,
addErrAt, addErrs,
checkErr, checkErrAt,
addMessages,
discardWarnings, mkDetailedMessage,
tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
attemptM, tryTc,
askNoErrs, discardErrs, tryTcDiscardingErrs,
checkNoErrs, whenNoErrs,
ifErrsM, failIfErrsM,
getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv,
addErrTc,
addErrTcM,
failWithTc, failWithTcM,
checkTc, checkTcM,
failIfTc, failIfTcM,
mkErrInfo,
addTcRnDiagnostic, addDetailedDiagnostic,
mkTcRnMessage, reportDiagnostic, reportDiagnostics,
warnIf, diagnosticTc, diagnosticTcM,
addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,
newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
addTcEvBind, addTopEvBinds,
getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
chooseUniqueOccTc,
getConstraintVar, setConstraintVar,
emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
emitImplication, emitImplications, ensureReflMultiplicityCo,
emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError,
discardConstraints, captureConstraints, tryCaptureConstraints,
pushLevelAndCaptureConstraints,
pushTcLevelM_, pushTcLevelM,
getTcLevel, setTcLevel, isTouchableTcM,
getLclTypeEnv, setLclTypeEnv,
traceTcConstraints,
emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,
recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps,
keepAlive, getStage, getStageAndBindLevel, setStage,
addModFinalizersWithLclEnv,
recordUnsafeInfer, finalSafeMode, fixSafeInstances,
getLocalRdrEnv, setLocalRdrEnv,
mkIfLclEnv,
initIfaceTcRn,
initIfaceCheck,
initIfaceLcl,
initIfaceLclWithSubst,
initIfaceLoad,
initIfaceLoadModule,
getIfModule,
failIfM,
forkM,
setImplicitEnvM,
withException, withIfaceErr,
getCCIndexM, getCCIndexTcM,
liftZonkM, newZonkAnyType,
localAndImportedCompleteMatches, getCompleteMatchesTcM,
module GHC.Tc.Types,
module GHC.Data.IOEnv
) where
import GHC.Prelude
import GHC.Builtin.Names
import GHC.Builtin.Types( zonkAnyTyCon )
import GHC.Tc.Errors.Types
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.CtLoc
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.Types.TcRef
import GHC.Tc.Utils.TcType
import GHC.Tc.Zonk.TcType
import GHC.Hs hiding (LIE)
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module.Warnings
import GHC.Unit.Home.ModInfo
import GHC.Core.UsageEnv
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Core.Type( mkNumLitTy )
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic
import GHC.Runtime.Context
import GHC.Data.IOEnv
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.DefaultEnv ( DefaultEnv, emptyDefaultEnv )
import GHC.Types.Fixity.Env
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.SafeHaskell
import GHC.Types.Id
import GHC.Types.TypeEnv
import GHC.Types.Var.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 qualified Data.Map as Map
import GHC.Driver.Env.KnotVars
import GHC.Linker.Types
import GHC.Types.Unique.DFM
import GHC.Iface.Errors.Types
import GHC.Iface.Errors.Ppr
import GHC.Tc.Types.LclEnv
import GHC.Core.Coercion (isReflCo)
initTc :: HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
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 { keep_var <- NameSet -> IO (IORef NameSet)
forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet ;
used_gre_var <- newIORef [] ;
th_var <- newIORef False ;
th_splice_var<- newIORef False ;
infer_var <- newIORef True ;
infer_reasons_var <- newIORef emptyMessages ;
dfun_n_var <- newIORef emptyOccSet ;
zany_n_var <- newIORef 0 ;
let { type_env_var = HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env };
dependent_files_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ;
cc_st_var <- newIORef newCostCentreState ;
th_topdecls_var <- newIORef [] ;
th_foreign_files_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ;
th_modfinalizers_var <- newIORef [] ;
th_coreplugins_var <- newIORef [] ;
th_state_var <- newIORef Map.empty ;
th_remote_state_var <- newIORef Nothing ;
th_docs_var <- newIORef Map.empty ;
th_needed_deps_var <- newIORef ([], emptyUDFM) ;
next_wrapper_num <- newIORef emptyModuleEnv ;
let {
!dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env ;
!mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env;
!logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax a
empty_val
| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rn_ast = a -> Maybe a
forall a. a -> Maybe a
Just a
empty_val
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags = a -> Maybe a
forall a. a -> Maybe a
Just a
empty_val
| 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 {
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
forall info. GlobalRdrEnvX info
emptyGlobalRdrEnv,
tcg_fix_env :: FixityEnv
tcg_fix_env = FixityEnv
forall a. NameEnv a
emptyNameEnv,
tcg_default :: DefaultEnv
tcg_default = DefaultEnv
emptyDefaultEnv,
tcg_default_exports :: DefaultEnv
tcg_default_exports = DefaultEnv
emptyDefaultEnv,
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_import_decls :: [ImportUserSpec]
tcg_import_decls = [],
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
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 p. Warnings p
emptyWarn,
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_zany_n :: IORef Integer
tcg_zany_n = IORef Integer
zany_n_var,
tcg_keep :: IORef NameSet
tcg_keep = IORef NameSet
keep_var,
tcg_hdr_info :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName))
tcg_hdr_info = (Maybe (LHsDoc GhcRn)
forall a. Maybe a
Nothing,Maybe (XRec GhcRn ModuleName)
Maybe (GenLocated SrcSpanAnnA ModuleName)
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 {k} (key :: k) 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
} ;
} ;
initTcWithGbl hsc_env gbl_env loc do_this
}
initTcWithGbl :: HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl :: forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl HscEnv
hsc_env TcGblEnv
gbl_env RealSrcSpan
loc TcM r
do_this
= do { lie_var <- WantedConstraints -> IO (IORef WantedConstraints)
forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC
; errs_var <- newIORef emptyMessages
; usage_var <- newIORef zeroUE
; let lcl_env = TcLclEnv {
tcl_lcl_ctxt :: TcLclCtxt
tcl_lcl_ctxt = TcLclCtxt {
tcl_loc :: RealSrcSpan
tcl_loc = RealSrcSpan
loc,
tcl_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_bndrs :: TcBinderStack
tcl_bndrs = [],
tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
topTcLevel
},
tcl_usage :: IORef UsageEnv
tcl_usage = IORef UsageEnv
usage_var,
tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie_var,
tcl_errs :: IORef (Messages TcRnMessage)
tcl_errs = IORef (Messages TcRnMessage)
errs_var
}
; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
do { r <- tryM do_this
; case r of
Right r
res -> Maybe r -> TcRnIf TcGblEnv TcLclEnv (Maybe r)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Maybe r
forall a. a -> Maybe a
Just r
res)
Left IOEnvFailure
_ -> Maybe r -> TcRnIf TcGblEnv TcLclEnv (Maybe r)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
Nothing }
; lie <- readIORef (tcl_lie lcl_env)
; when (isJust maybe_res && not (isEmptyWC lie)) $
pprPanic "initTc: unsolved constraints" (ppr lie)
; msgs <- readIORef (tcl_errs lcl_env)
; let { final_res | Messages TcRnMessage -> Bool
forall e. Diagnostic e => Messages e -> Bool
errorsFound Messages TcRnMessage
msgs = Maybe r
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe r
maybe_res }
; return (msgs, final_res)
}
initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
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
initTcRnIf :: Char
-> 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_tag HscEnv
hsc_env gbl
gbl_env lcl
lcl_env TcRnIf gbl lcl a
thing_inside
= do { let { env :: Env gbl lcl
env = Env { env_top :: HscEnv
env_top = HscEnv
hsc_env,
env_ut :: Char
env_ut = Char
uniq_tag,
env_gbl :: gbl
env_gbl = gbl
gbl_env,
env_lcl :: lcl
env_lcl = lcl
lcl_env} }
; Env gbl lcl -> TcRnIf gbl lcl a -> IO a
forall env a. env -> IOEnv env a -> IO a
runIOEnv Env gbl lcl
env TcRnIf gbl lcl a
thing_inside
}
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 <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; return (env_top env) }
updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv :: forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv HscEnv -> HscEnv
upd = (Env gbl lcl -> Env gbl lcl)
-> IOEnv (Env gbl lcl) a -> IOEnv (Env gbl lcl) a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env@(Env { env_top :: forall gbl lcl. Env gbl lcl -> HscEnv
env_top = HscEnv
top }) ->
Env gbl lcl
env { env_top = upd top })
getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv :: forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv = do { Env{..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; return env_gbl }
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv :: forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv gbl -> gbl
upd = (Env gbl lcl -> Env gbl lcl)
-> IOEnv (Env gbl lcl) a -> IOEnv (Env gbl lcl) a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env@(Env { env_gbl :: forall gbl lcl. Env gbl lcl -> gbl
env_gbl = gbl
gbl }) ->
Env gbl lcl
env { env_gbl = upd gbl })
setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv :: forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv gbl'
gbl_env = (Env gbl lcl -> Env gbl' lcl)
-> IOEnv (Env gbl' lcl) a -> IOEnv (Env gbl lcl) a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ Env gbl lcl
env -> Env gbl lcl
env { env_gbl = gbl_env })
getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv :: forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv = do { Env{..} <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; return env_lcl }
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv :: forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv lcl -> lcl
upd = (Env gbl lcl -> Env gbl lcl)
-> IOEnv (Env gbl lcl) a -> IOEnv (Env gbl lcl) a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv (\ env :: Env gbl lcl
env@(Env { env_lcl :: forall gbl lcl. Env gbl lcl -> lcl
env_lcl = lcl
lcl }) ->
Env gbl lcl
env { env_lcl = upd lcl })
updLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt :: forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt TcLclCtxt -> TcLclCtxt
upd = (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 ((TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv
modifyLclCtxt TcLclCtxt -> TcLclCtxt
upd)
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
restoreLclEnv :: forall gbl a.
TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
restoreLclEnv TcLclEnv
new_lcl_env = (TcLclEnv -> TcLclEnv)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv TcLclEnv -> TcLclEnv
upd
where
upd :: TcLclEnv -> TcLclEnv
upd TcLclEnv
old_lcl_env = TcLclEnv
new_lcl_env { tcl_errs = tcl_errs old_lcl_env
, tcl_lie = tcl_lie old_lcl_env
, tcl_usage = tcl_usage old_lcl_env }
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs :: forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv; return (env_gbl env, env_lcl env) }
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs :: forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (gbl'
gbl_env, lcl'
lcl_env) = gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv gbl'
gbl_env (TcRnIf gbl' lcl a -> TcRnIf gbl lcl a)
-> (TcRnIf gbl' lcl' a -> TcRnIf gbl' lcl a)
-> TcRnIf gbl' lcl' a
-> TcRnIf gbl lcl a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. lcl' -> TcRnIf gbl' lcl' a -> TcRnIf gbl' lcl a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl'
lcl_env
updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updEnvs :: forall gbl lcl a.
((gbl, lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updEnvs (gbl, lcl) -> (gbl, lcl)
upd_envs = (Env gbl lcl -> Env gbl lcl)
-> IOEnv (Env gbl lcl) a -> IOEnv (Env gbl lcl) a
forall env env' a. (env -> env') -> IOEnv env' a -> IOEnv env a
updEnv Env gbl lcl -> Env gbl lcl
upd
where
upd :: Env gbl lcl -> Env gbl lcl
upd env :: Env gbl lcl
env@(Env { env_gbl :: forall gbl lcl. Env gbl lcl -> gbl
env_gbl = gbl
gbl, env_lcl :: forall gbl lcl. Env gbl lcl -> lcl
env_lcl = lcl
lcl })
= Env gbl lcl
env { env_gbl = gbl', env_lcl = lcl' }
where
!(gbl
gbl', lcl
lcl') = (gbl, lcl) -> (gbl, lcl)
upd_envs (gbl
gbl, lcl
lcl)
restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
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
xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
xoptM :: forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag = Extension -> DynFlags -> Bool
xopt Extension
flag (DynFlags -> Bool)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM :: forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
flag = do
logger <- IOEnv (Env gbl lcl) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
return (logHasDumpFlag logger flag)
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM :: forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
flag = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag (DynFlags -> Bool)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM :: forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
flag = WarningFlag -> DynFlags -> Bool
wopt WarningFlag
flag (DynFlags -> Bool)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM :: forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
flag = (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags (\DynFlags
dflags -> DynFlags -> Extension -> DynFlags
xopt_set DynFlags
dflags Extension
flag)
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)
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM :: forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag TcRnIf gbl lcl ()
thing_inside = do b <- DumpFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
flag
when b thing_inside
{-# INLINE whenDOptM #-}
whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM :: forall gbl lcl.
GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM GeneralFlag
flag TcRnIf gbl lcl ()
thing_inside = do b <- GeneralFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
flag
when b thing_inside
{-# INLINE whenGOptM #-}
whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM :: forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
flag TcRnIf gbl lcl ()
thing_inside = do b <- WarningFlag -> TcRnIf gbl lcl Bool
forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
flag
when b thing_inside
{-# INLINE whenWOptM #-}
whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM :: forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM Extension
flag TcRnIf gbl lcl ()
thing_inside = do b <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
when b thing_inside
{-# INLINE whenXOptM #-}
unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM :: forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
flag TcRnIf gbl lcl ()
thing_inside = do b <- Extension -> TcRnIf gbl lcl Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
unless b thing_inside
{-# INLINE unlessXOptM #-}
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode :: forall gbl lcl. TcRnIf gbl lcl GhcMode
getGhcMode = DynFlags -> GhcMode
ghcMode (DynFlags -> GhcMode)
-> IOEnv (Env gbl lcl) DynFlags -> IOEnv (Env gbl lcl) GhcMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env gbl lcl) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow :: forall gbl lcl a. TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow = (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags (\DynFlags
dflags -> DynFlags
dflags { dynamicNow = False})
updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags :: forall gbl lcl a.
(DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags DynFlags -> DynFlags
f = (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv ((DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags DynFlags -> DynFlags
f)
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar :: forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do
env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
return (euc_eps (ue_eps (hsc_unit_env env)))
getEps :: TcRnIf gbl lcl ExternalPackageState
getEps :: forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; liftIO $ hscEPS env }
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps :: forall a gbl lcl.
(ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps ExternalPackageState -> (ExternalPackageState, a)
upd_fn = do
SDoc -> TcRnIf gbl lcl ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"updating EPS")
eps_var <- TcRnIf gbl lcl (TcRef ExternalPackageState)
forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar
atomicUpdMutVar' eps_var upd_fn
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
-> TcRnIf gbl lcl ()
updateEps_ :: forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ExternalPackageState -> ExternalPackageState
upd_fn = (ExternalPackageState -> (ExternalPackageState, ()))
-> TcRnIf gbl lcl ()
forall a gbl lcl.
(ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps (\ExternalPackageState
eps -> (ExternalPackageState -> ExternalPackageState
upd_fn ExternalPackageState
eps, ()))
getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt :: forall gbl lcl. TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; return (hsc_HPT env) }
getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug :: forall gbl lcl.
TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug = do { env <- TcRnIf gbl lcl HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; eps <- liftIO $ hscEPS env
; return (eps, hsc_HUG env) }
withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a
withException :: forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr SDoc a) -> m a
withException SDocContext
ctx m (MaybeErr SDoc a)
do_this = do
r <- m (MaybeErr SDoc a)
do_this
case r of
Failed SDoc
err -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (SDocContext -> SDoc -> FilePath
renderWithContext SDocContext
ctx SDoc
err))
Succeeded a
result -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
withIfaceErr :: MonadIO m => SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr :: forall (m :: * -> *) a.
MonadIO m =>
SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a
withIfaceErr SDocContext
ctx m (MaybeErr MissingInterfaceError a)
do_this = do
r <- m (MaybeErr MissingInterfaceError a)
do_this
case r of
Failed MissingInterfaceError
err -> do
let opts :: DiagnosticOpts IfaceMessage
opts = forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts @IfaceMessage
msg :: SDoc
msg = IfaceMessageOpts -> MissingInterfaceError -> SDoc
missingInterfaceErrorDiagnostic IfaceMessageOpts
opts MissingInterfaceError
err
IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (SDocContext -> SDoc -> FilePath
renderWithContext SDocContext
ctx SDoc
msg))
Succeeded a
result -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
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 ->
(TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv
modifyLclCtxt (\TcLclCtxt
ctx -> TcLclCtxt
ctx { tcl_arrow_ctxt = ArrowCtxt (getLclEnvRdrEnv env) (tcl_lie env) } ) TcLclEnv
env
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
getLclEnvArrowCtxt TcLclEnv
env of
ArrowCtxt
NoArrowCtxt -> TcLclEnv
env
ArrowCtxt LocalRdrEnv
rdr_env IORef WantedConstraints
lie -> TcLclEnv
env { tcl_lcl_ctxt = (tcl_lcl_ctxt env) { tcl_arrow_ctxt = NoArrowCtxt
, tcl_rdr = rdr_env }
, tcl_lie = lie }
newUnique :: TcRnIf gbl lcl Unique
newUnique :: forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
= do { env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv
; let tag = Env gbl lcl -> Char
forall gbl lcl. Env gbl lcl -> Char
env_ut Env gbl lcl
env
; liftIO $! uniqFromTag tag }
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply :: forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { env <- IOEnv (Env gbl lcl) (Env gbl lcl)
forall env. IOEnv env env
getEnv
; let tag = Env gbl lcl -> Char
forall gbl lcl. Env gbl lcl -> Char
env_ut Env gbl lcl
env
; liftIO $! mkSplitUniqSupply tag }
cloneLocalName :: Name -> TcM Name
cloneLocalName :: Name -> TcM Name
cloneLocalName Name
name = OccName -> SrcSpan -> TcM Name
newNameAt (Name -> OccName
nameOccName Name
name) (Name -> SrcSpan
nameSrcSpan Name
name)
newName :: OccName -> TcM Name
newName :: OccName -> TcM Name
newName OccName
occ = do { loc <- TcRn SrcSpan
getSrcSpanM
; newNameAt occ loc }
newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt OccName
occ SrcSpan
span
= do { uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; return (mkInternalName uniq occ span) }
newSysName :: OccName -> TcRnIf gbl lcl Name
newSysName :: forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName OccName
occ
= do { uniq <- TcRnIf gbl lcl Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; return (mkSystemName uniq occ) }
newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId :: forall gbl lcl. FastString -> Mult -> Mult -> TcRnIf gbl lcl Id
newSysLocalId FastString
fs Mult
w Mult
ty
= do { u <- TcRnIf gbl lcl Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; return (mkSysLocal fs u w ty) }
newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds :: forall gbl lcl. FastString -> [Scaled Mult] -> TcRnIf gbl lcl [Id]
newSysLocalIds FastString
fs [Scaled Mult]
tys
= do { us <- IOEnv (Env gbl lcl) [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; let mkId' Unique
n (Scaled Mult
w Mult
t) = FastString -> Unique -> Mult -> Mult -> Id
mkSysLocal FastString
fs Unique
n Mult
w Mult
t
; return (zipWith mkId' us tys) }
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM :: IOEnv (Env gbl lcl) Unique
getUniqueM = IOEnv (Env gbl lcl) Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
getUniqueSupplyM :: IOEnv (Env gbl lcl) UniqSupply
getUniqueSupplyM = IOEnv (Env gbl lcl) UniqSupply
forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
name_ppr_ctx <- getNamePprCtx
real_doc <- wrapDocLoc doc
let sty = if Bool
useUserStyle
then NamePprCtx -> Depth -> PprStyle
mkUserStyle NamePprCtx
name_ppr_ctx Depth
AllTheWay
else NamePprCtx -> PprStyle
mkDumpStyle NamePprCtx
name_ppr_ctx
liftIO $ logDumpFile logger sty flag title fmt real_doc
wrapDocLoc :: SDoc -> TcRn SDoc
wrapDocLoc :: SDoc -> TcRn SDoc
wrapDocLoc SDoc
doc = do
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
if logHasDumpFlag logger Opt_D_ppr_debug
then do
loc <- getSrcSpanM
return (mkLocMessage MCOutput loc doc)
else
return doc
getNamePprCtx :: TcRn NamePprCtx
getNamePprCtx :: TcRn NamePprCtx
getNamePprCtx
= do { ptc <- DynFlags -> PromotionTickContext
initPromotionTickContext (DynFlags -> PromotionTickContext)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) PromotionTickContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn :: SDoc -> TcM ()
printForUserTcRn SDoc
doc = do
logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
name_ppr_ctx <- getNamePprCtx
liftIO (printOutputForUser logger name_ppr_ctx doc)
traceIf :: 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 #-}
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
logger <- IOEnv (Env m n) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
liftIO (putMsg logger doc)
{-# INLINE traceOptIf #-}
getIsGHCi :: TcRn Bool
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; return (isInteractiveModule mod) }
getGHCiMonad :: TcRn Name
getGHCiMonad :: TcM Name
getGHCiMonad = do { hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; return (ic_monad $ hsc_IC hsc) }
getInteractivePrintName :: TcRn Name
getInteractivePrintName :: TcM Name
getInteractivePrintName = do { hsc <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; return (ic_int_print $ hsc_IC hsc) }
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = HscSource -> Bool
isHsBootOrSig (HscSource -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) HscSource -> TcRn Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) HscSource
tcHscSource
tcHscSource :: TcRn HscSource
tcHscSource :: IOEnv (Env TcGblEnv TcLclEnv) HscSource
tcHscSource = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_src env)}
tcIsHsig :: TcRn Bool
tcIsHsig :: TcRn Bool
tcIsHsig = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (isHsigFile (tcg_src env)) }
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_self_boot env) }
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_rdr_env env) }
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- TcRnIf TcGblEnv TcLclEnv (TcGblEnv, TcLclEnv)
forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs; return (tcg_rdr_env gbl, getLclEnvRdrEnv lcl) }
getImports :: TcRn ImportAvails
getImports :: TcRn ImportAvails
getImports = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_imports env) }
getFixityEnv :: TcRn FixityEnv
getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_fix_env env) }
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv :: forall a. [(Name, FixItem)] -> RnM a -> RnM a
extendFixityEnv [(Name, FixItem)]
new_bit
= (TcGblEnv -> TcGblEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv (\env :: TcGblEnv
env@(TcGblEnv { tcg_fix_env :: TcGblEnv -> FixityEnv
tcg_fix_env = FixityEnv
old_fix_env }) ->
TcGblEnv
env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
getDeclaredDefaultTys :: TcRn DefaultEnv
getDeclaredDefaultTys :: TcRn DefaultEnv
getDeclaredDefaultTys = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; return (tcg_default env) }
addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles :: [FilePath] -> TcM ()
addDependentFiles [FilePath]
fs = do
ref <- (TcGblEnv -> IORef [FilePath])
-> TcRnIf TcGblEnv TcLclEnv TcGblEnv
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef [FilePath])
forall a b.
(a -> b)
-> IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> IORef [FilePath]
tcg_dependent_files TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
dep_files <- readTcRef ref
writeTcRef ref (fs ++ dep_files)
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) }
inGeneratedCode :: TcRn Bool
inGeneratedCode :: TcRn Bool
inGeneratedCode = TcLclEnv -> Bool
lclEnvInGeneratedCode (TcLclEnv -> Bool)
-> TcRnIf TcGblEnv TcLclEnv TcLclEnv -> TcRn Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan :: forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan RealSrcSpan
loc Maybe BufSpan
_) TcRn a
thing_inside
= (TcLclCtxt -> TcLclCtxt) -> TcRn a -> TcRn a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt (\TcLclCtxt
env -> TcLclCtxt
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
= TcRn a -> TcRn a
forall a. TcM a -> TcM a
setInGeneratedCode TcRn a
thing_inside
| Bool
otherwise
= TcRn a
thing_inside
setInGeneratedCode :: TcRn a -> TcRn a
setInGeneratedCode :: forall a. TcM a -> TcM a
setInGeneratedCode TcRn a
thing_inside =
(TcLclCtxt -> TcLclCtxt) -> TcRn a -> TcRn a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt (\TcLclCtxt
env -> TcLclCtxt
env { tcl_in_gen_code = True }) TcRn a
thing_inside
setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA :: forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
l = SrcSpan -> TcRn a -> TcRn a
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (EpAnn ann -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA EpAnn ann
l)
addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM :: forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM a -> TcM b
fn (L t
loc a
a) = SrcSpan -> TcM b -> TcM b
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (t -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc t
loc) (TcM b -> TcM b) -> TcM b -> TcM b
forall a b. (a -> b) -> a -> b
$ a -> TcM b
fn a
a
wrapLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM (Located b)
wrapLocM :: forall t a b.
HasLoc t =>
(a -> TcM b) -> GenLocated t a -> TcM (Located b)
wrapLocM a -> TcM b
fn (L t
loc a
a) =
let
loc' :: SrcSpan
loc' = t -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
getHasLoc t
loc
in SrcSpan -> TcRn (Located b) -> TcRn (Located b)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc' (TcRn (Located b) -> TcRn (Located b))
-> TcRn (Located b) -> TcRn (Located b)
forall a b. (a -> b) -> a -> b
$ do { b <- a -> TcM b
fn a
a
; return (L loc' b) }
wrapLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA :: forall a b ann.
(a -> TcM b)
-> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b)
wrapLocMA a -> TcM b
fn (L EpAnn ann
loc a
a) = EpAnn ann
-> TcRn (GenLocated (EpAnn ann) b)
-> TcRn (GenLocated (EpAnn ann) b)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcRn (GenLocated (EpAnn ann) b)
-> TcRn (GenLocated (EpAnn ann) b))
-> TcRn (GenLocated (EpAnn ann) b)
-> TcRn (GenLocated (EpAnn ann) b)
forall a b. (a -> b) -> a -> b
$ do { b <- a -> TcM b
fn a
a
; return (L loc b) }
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM :: forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM a -> TcM (b, c)
fn (L SrcSpan
loc a
a) =
SrcSpan -> TcRn (Located b, c) -> TcRn (Located b, c)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn (Located b, c) -> TcRn (Located b, c))
-> TcRn (Located b, c) -> TcRn (Located b, c)
forall a b. (a -> b) -> a -> b
$ do
(b,c) <- a -> TcM (b, c)
fn a
a
return (L loc b, c)
wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA :: forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c)
wrapLocFstMA a -> TcM (b, c)
fn (L EpAnn ann
loc a
a) =
EpAnn ann
-> TcRn (GenLocated (EpAnn ann) b, c)
-> TcRn (GenLocated (EpAnn ann) b, c)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcRn (GenLocated (EpAnn ann) b, c)
-> TcRn (GenLocated (EpAnn ann) b, c))
-> TcRn (GenLocated (EpAnn ann) b, c)
-> TcRn (GenLocated (EpAnn ann) b, c)
forall a b. (a -> b) -> a -> b
$ do
(b,c) <- a -> TcM (b, c)
fn a
a
return (L loc b, c)
wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM :: forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM a -> TcM (b, c)
fn (L SrcSpan
loc a
a) =
SrcSpan -> TcRn (b, Located c) -> TcRn (b, Located c)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn (b, Located c) -> TcRn (b, Located c))
-> TcRn (b, Located c) -> TcRn (b, Located c)
forall a b. (a -> b) -> a -> b
$ do
(b,c) <- a -> TcM (b, c)
fn a
a
return (b, L loc c)
wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c)
wrapLocSndMA :: forall a b c ann.
(a -> TcM (b, c))
-> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c)
wrapLocSndMA a -> TcM (b, c)
fn (L EpAnn ann
loc a
a) =
EpAnn ann
-> TcRn (b, GenLocated (EpAnn ann) c)
-> TcRn (b, GenLocated (EpAnn ann) c)
forall ann a. EpAnn ann -> TcRn a -> TcRn a
setSrcSpanA EpAnn ann
loc (TcRn (b, GenLocated (EpAnn ann) c)
-> TcRn (b, GenLocated (EpAnn ann) c))
-> TcRn (b, GenLocated (EpAnn ann) c)
-> TcRn (b, GenLocated (EpAnn ann) c)
forall a b. (a -> b) -> a -> b
$ do
(b,c) <- a -> TcM (b, c)
fn a
a
return (b, L loc c)
wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
wrapLocM_ :: forall a. (a -> 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. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (a -> TcM ()
fn a
a)
getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
getErrsVar :: TcRn (IORef (Messages TcRnMessage))
getErrsVar = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (tcl_errs env) }
setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar :: forall a. IORef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar IORef (Messages TcRnMessage)
v = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_errs = v })
addErr :: TcRnMessage -> TcRn ()
addErr :: TcRnMessage -> TcM ()
addErr TcRnMessage
msg = do { loc <- TcRn SrcSpan
getSrcSpanM; addErrAt loc msg }
failWith :: TcRnMessage -> TcRn a
failWith :: forall a. TcRnMessage -> TcRn a
failWith TcRnMessage
msg = TcRnMessage -> 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 :: SrcSpan -> TcRnMessage -> TcM ()
addErrAt SrcSpan
loc TcRnMessage
msg = do { ctxt <- TcM [ErrCtxt]
getErrCtxt
; tidy_env <- liftZonkM $ tcInitTidyEnv
; err_info <- mkErrInfo tidy_env ctxt
; let detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage (SDoc -> SDoc -> ErrInfo
ErrInfo SDoc
err_info SDoc
forall doc. IsOutput doc => doc
Outputable.empty) TcRnMessage
msg
; add_long_err_at loc detailed_msg }
mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage ErrInfo
err_info TcRnMessage
msg =
ErrInfo -> TcRnMessage -> TcRnMessageDetailed
TcRnMessageDetailed ErrInfo
err_info TcRnMessage
msg
addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
addErrs :: [(SrcSpan, TcRnMessage)] -> 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 ()
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)
checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> TcRn ()
checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> TcM ()
checkErrAt SrcSpan
loc Bool
ok TcRnMessage
msg = Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (SrcSpan -> TcRnMessage -> TcM ()
addErrAt SrcSpan
loc TcRnMessage
msg)
addMessages :: Messages TcRnMessage -> TcRn ()
addMessages :: Messages TcRnMessage -> TcM ()
addMessages Messages TcRnMessage
msgs1
= do { errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar
; msgs0 <- readTcRef errs_var
; writeTcRef errs_var (msgs0 `unionMessages` msgs1) }
discardWarnings :: TcRn a -> TcRn a
discardWarnings :: forall a. TcM a -> TcM a
discardWarnings TcRn a
thing_inside
= do { errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar
; old_warns <- getWarningMessages <$> readTcRef errs_var
; result <- thing_inside
; new_errs <- getErrorMessages <$> readTcRef errs_var
; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs)
; return result }
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 { name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx ;
unit_state <- hsc_units <$> getTopEnv ;
return $ mkErrorMsgEnvelope loc name_ppr_ctx
$ TcRnMessageWithInfo unit_state msg
}
mkTcRnMessage :: SrcSpan
-> TcRnMessage
-> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage :: SrcSpan -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage SrcSpan
loc TcRnMessage
msg
= do { name_ppr_ctx <- TcRn NamePprCtx
getNamePprCtx ;
diag_opts <- initDiagOpts <$> getDynFlags ;
return $ mkMsgEnvelope diag_opts loc name_ppr_ctx msg }
reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
reportDiagnostics :: [MsgEnvelope TcRnMessage] -> 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) ;
errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar ;
msgs <- readTcRef errs_var ;
writeTcRef errs_var (msg `addMessage` msgs) }
checkNoErrs :: TcM r -> TcM r
checkNoErrs :: forall a. TcM a -> TcM a
checkNoErrs TcM r
main
= do { (res, no_errs) <- TcM r -> TcRn (r, Bool)
forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcM r
main
; unless no_errs failM
; return res }
whenNoErrs :: TcM () -> TcM ()
whenNoErrs :: 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 :: forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM TcRn r
bale_out TcRn r
normal
= do { errs_var <- TcRn (IORef (Messages TcRnMessage))
getErrsVar ;
msgs <- readTcRef errs_var ;
if errorsFound msgs then
bale_out
else
normal }
failIfErrsM :: TcRn ()
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 ())
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvErrCtxt env) }
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
{-# INLINE setErrCtxt #-}
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 ([ErrCtxt] -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt [ErrCtxt]
ctxt)
addErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addErrCtxt #-}
addErrCtxt :: forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
msg = (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (\TidyEnv
env -> (TidyEnv, SDoc) -> ZonkM (TidyEnv, SDoc)
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SDoc
msg))
addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addErrCtxtM #-}
addErrCtxtM :: forall a. (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM TidyEnv -> ZonkM (TidyEnv, SDoc)
ctxt = ErrCtxt -> TcM a -> TcM a
forall a. ErrCtxt -> TcM a -> TcM a
pushCtxt (Bool
False, TidyEnv -> ZonkM (TidyEnv, SDoc)
ctxt)
addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxt #-}
addLandmarkErrCtxt :: forall a. SDoc -> TcM a -> TcM a
addLandmarkErrCtxt SDoc
msg = (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
forall a. (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\TidyEnv
env -> (TidyEnv, SDoc) -> ZonkM (TidyEnv, SDoc)
forall a. a -> ZonkM a
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SDoc
msg))
addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxtM #-}
addLandmarkErrCtxtM :: forall a. (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM TidyEnv -> ZonkM (TidyEnv, SDoc)
ctxt = ErrCtxt -> TcM a -> TcM a
forall a. ErrCtxt -> TcM a -> TcM a
pushCtxt (Bool
True, TidyEnv -> ZonkM (TidyEnv, SDoc)
ctxt)
pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-}
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
updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
updCtxt ErrCtxt
ctxt TcLclEnv
env
| TcLclEnv -> Bool
lclEnvInGeneratedCode TcLclEnv
env = TcLclEnv
env
| Bool
otherwise = ErrCtxt -> TcLclEnv -> TcLclEnv
addLclEnvErrCtxt ErrCtxt
ctxt TcLclEnv
env
popErrCtxt :: TcM a -> TcM a
popErrCtxt :: forall a. TcM a -> TcM a
popErrCtxt TcM a
thing_inside = (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> [ErrCtxt] -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt ([ErrCtxt] -> [ErrCtxt]
forall {a}. [a] -> [a]
pop ([ErrCtxt] -> [ErrCtxt]) -> [ErrCtxt] -> [ErrCtxt]
forall a b. (a -> b) -> a -> b
$ TcLclEnv -> [ErrCtxt]
getLclEnvErrCtxt TcLclEnv
env) TcLclEnv
env) (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
where
pop :: [a] -> [a]
pop [] = []
pop (a
_:[a]
msgs) = [a]
msgs
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin Maybe TypeOrKind
t_or_k
= do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; return (CtLoc { ctl_origin = origin
, ctl_env = mkCtLocEnv env
, ctl_t_or_k = t_or_k
, ctl_depth = initialSubGoalDepth }) }
mkCtLocEnv :: TcLclEnv -> CtLocEnv
mkCtLocEnv :: TcLclEnv -> CtLocEnv
mkCtLocEnv TcLclEnv
lcl_env =
CtLocEnv { ctl_bndrs :: TcBinderStack
ctl_bndrs = TcLclEnv -> TcBinderStack
getLclEnvBinderStack TcLclEnv
lcl_env
, ctl_ctxt :: [ErrCtxt]
ctl_ctxt = TcLclEnv -> [ErrCtxt]
getLclEnvErrCtxt TcLclEnv
lcl_env
, ctl_loc :: RealSrcSpan
ctl_loc = TcLclEnv -> RealSrcSpan
getLclEnvLoc TcLclEnv
lcl_env
, ctl_tclvl :: TcLevel
ctl_tclvl = TcLclEnv -> TcLevel
getLclEnvTcLevel TcLclEnv
lcl_env
, ctl_in_gen_code :: Bool
ctl_in_gen_code = TcLclEnv -> Bool
lclEnvInGeneratedCode TcLclEnv
lcl_env
, ctl_rdr :: LocalRdrEnv
ctl_rdr = TcLclEnv -> LocalRdrEnv
getLclEnvRdrEnv TcLclEnv
lcl_env
}
setCtLocM :: CtLoc -> TcM a -> TcM a
setCtLocM :: forall a. CtLoc -> TcM a -> TcM a
setCtLocM (CtLoc { ctl_env :: CtLoc -> CtLocEnv
ctl_env = CtLocEnv
lcl }) TcM a
thing_inside
= (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> RealSrcSpan -> TcLclEnv -> TcLclEnv
setLclEnvLoc (CtLocEnv -> RealSrcSpan
ctl_loc CtLocEnv
lcl)
(TcLclEnv -> TcLclEnv) -> TcLclEnv -> TcLclEnv
forall a b. (a -> b) -> a -> b
$ [ErrCtxt] -> TcLclEnv -> TcLclEnv
setLclEnvErrCtxt (CtLocEnv -> [ErrCtxt]
ctl_ctxt CtLocEnv
lcl)
(TcLclEnv -> TcLclEnv) -> TcLclEnv -> TcLclEnv
forall a b. (a -> b) -> a -> b
$ TcBinderStack -> TcLclEnv -> TcLclEnv
setLclEnvBinderStack (CtLocEnv -> TcBinderStack
ctl_bndrs CtLocEnv
lcl)
(TcLclEnv -> TcLclEnv) -> TcLclEnv -> TcLclEnv
forall a b. (a -> b) -> a -> b
$ TcLclEnv
env) TcM a
thing_inside
tcTryM :: TcRn r -> TcRn (Maybe r)
tcTryM :: forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcRn r
thing_inside
= do { either_res <- TcRn r -> IOEnv (Env TcGblEnv TcLclEnv) (Either IOEnvFailure r)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcRn r
thing_inside
; return (case either_res of
Left IOEnvFailure
_ -> Maybe r
forall a. Maybe a
Nothing
Right r
r -> r -> Maybe r
forall a. a -> Maybe a
Just r
r) }
capture_constraints :: TcM r -> TcM (r, WantedConstraints)
capture_constraints :: forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints TcM r
thing_inside
= do { lie_var <- WantedConstraints
-> IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef WantedConstraints
emptyWC
; res <- updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_lie = lie_var }) $
thing_inside
; lie <- readTcRef lie_var
; return (res, lie) }
capture_messages :: TcM r -> TcM (r, Messages TcRnMessage)
capture_messages :: forall r. TcM r -> TcM (r, Messages TcRnMessage)
capture_messages TcM r
thing_inside
= do { msg_var <- Messages TcRnMessage -> TcRn (IORef (Messages TcRnMessage))
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef Messages TcRnMessage
forall e. Messages e
emptyMessages
; res <- setErrsVar msg_var thing_inside
; msgs <- readTcRef msg_var
; return (res, msgs) }
askNoErrs :: TcRn a -> TcRn (a, Bool)
askNoErrs :: forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcRn a
thing_inside
= do { ((mb_res, lie), msgs) <- TcM (Maybe a, WantedConstraints)
-> TcM ((Maybe a, WantedConstraints), Messages TcRnMessage)
forall r. TcM r -> TcM (r, Messages TcRnMessage)
capture_messages (TcM (Maybe a, WantedConstraints)
-> TcM ((Maybe a, WantedConstraints), Messages TcRnMessage))
-> TcM (Maybe a, WantedConstraints)
-> TcM ((Maybe a, WantedConstraints), Messages TcRnMessage)
forall a b. (a -> b) -> a -> b
$
TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe a) -> TcM (Maybe a, WantedConstraints))
-> TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcRn a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcRn a
thing_inside
; addMessages msgs
; case mb_res of
Maybe a
Nothing -> do { WantedConstraints -> TcM ()
emitConstraints (WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie)
; IOEnv (Env TcGblEnv TcLclEnv) (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) -> IOEnv (Env TcGblEnv TcLclEnv) (a, Bool)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, Bool -> Bool
not Bool
errs_found) } }
tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints :: forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcM a
thing_inside
= do { (mb_res, lie) <- TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe a) -> TcM (Maybe a, WantedConstraints))
-> TcM (Maybe a) -> TcM (Maybe a, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcM a -> TcM (Maybe a)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM a
thing_inside
; let lie_to_keep = case Maybe a
mb_res of
Maybe a
Nothing -> WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie
Just {} -> WantedConstraints
lie
; return (mb_res, lie_to_keep) }
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
captureConstraints :: forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside
= do { (mb_res, lie) <- TcM a -> TcM (Maybe a, WantedConstraints)
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcM a
thing_inside
; case mb_res of
Maybe a
Nothing -> do { WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie; IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints)
forall env a. IOEnv env a
failM }
Just a
res -> (a, WantedConstraints)
-> IOEnv (Env TcGblEnv TcLclEnv) (a, WantedConstraints)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, WantedConstraints
lie) }
tcCollectingUsage :: TcM a -> TcM (UsageEnv,a)
tcCollectingUsage :: forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage TcM a
thing_inside
= do { local_usage_ref <- UsageEnv -> IOEnv (Env TcGblEnv TcLclEnv) (IORef UsageEnv)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef UsageEnv
zeroUE
; result <- updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_usage = local_usage_ref }) thing_inside
; local_usage <- readTcRef local_usage_ref
; return (local_usage,result) }
tcScalingUsage :: Mult -> TcM a -> TcM a
tcScalingUsage :: forall a. Mult -> TcM a -> TcM a
tcScalingUsage Mult
mult TcM a
thing_inside
= do { (usage, result) <- TcM a -> TcM (UsageEnv, a)
forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage TcM a
thing_inside
; traceTc "tcScalingUsage" $ vcat [ppr mult, ppr usage]
; tcEmitBindingUsage $ scaleUE mult usage
; return result }
tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage UsageEnv
ue
= do { lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let usage = TcLclEnv -> IORef UsageEnv
tcl_usage TcLclEnv
lcl_env
; updTcRef usage (addUE ue) }
attemptM :: TcRn r -> TcRn (Maybe r)
attemptM :: forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing_inside
= do { (mb_r, lie) <- TcRn r -> TcM (Maybe r, WantedConstraints)
forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcRn r
thing_inside
; emitConstraints lie
; when (isNothing mb_r) $
traceTc "attemptM recovering with insoluble constraints" $
(ppr lie)
; return mb_r }
recoverM :: TcRn r
-> TcRn r
-> TcRn r
recoverM :: forall r. TcRn r -> TcRn r -> TcRn r
recoverM TcRn r
recover TcRn r
thing
= do { mb_res <- TcRn r -> TcRn (Maybe r)
forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing ;
case mb_res of
Maybe r
Nothing -> TcRn r
recover
Just r
res -> r -> TcRn r
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return r
res }
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM :: forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM a -> TcRn b
f [a]
xs
= do { mb_rs <- (a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> (a -> TcRn b) -> a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
xs
; return [r | Just r <- mb_rs] }
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM :: forall a b. (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM a -> TcRn b
f [a]
xs
= do { mb_rs <- (a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> [a] -> IOEnv (Env TcGblEnv TcLclEnv) [Maybe b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (TcRn b -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b))
-> (a -> TcRn b) -> a -> IOEnv (Env TcGblEnv TcLclEnv) (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
xs
; when (any isNothing mb_rs) failM
; return [r | Just r <- mb_rs] }
foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM :: forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
_ b
acc [] = b -> TcRn b
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return b
acc
foldAndRecoverM b -> a -> TcRn b
f b
acc (a
x:[a]
xs) =
do { mb_r <- TcRn b -> TcRn (Maybe b)
forall r. TcRn r -> TcRn (Maybe r)
attemptM (b -> a -> TcRn b
f b
acc a
x)
; case mb_r of
Maybe b
Nothing -> (b -> a -> TcRn b) -> b -> [a] -> TcRn b
forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
f b
acc [a]
xs
Just b
acc' -> (b -> a -> TcRn b) -> b -> [a] -> TcRn b
forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
f b
acc' [a]
xs }
tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc :: 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 :: forall a. TcM a -> TcM a
discardErrs TcRn a
m
= do { errs_var <- Messages TcRnMessage -> TcRn (IORef (Messages TcRnMessage))
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef Messages TcRnMessage
forall e. Messages e
emptyMessages
; setErrsVar errs_var m }
tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
tryTcDiscardingErrs :: forall r. TcRn r -> TcRn r -> TcRn r
tryTcDiscardingErrs TcM r
recover TcM r
thing_inside
= do { ((mb_res, lie), msgs) <- TcM (Maybe r, WantedConstraints)
-> TcM ((Maybe r, WantedConstraints), Messages TcRnMessage)
forall r. TcM r -> TcM (r, Messages TcRnMessage)
capture_messages (TcM (Maybe r, WantedConstraints)
-> TcM ((Maybe r, WantedConstraints), Messages TcRnMessage))
-> TcM (Maybe r, WantedConstraints)
-> TcM ((Maybe r, WantedConstraints), Messages TcRnMessage)
forall a b. (a -> b) -> a -> b
$
TcM (Maybe r) -> TcM (Maybe r, WantedConstraints)
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints (TcM (Maybe r) -> TcM (Maybe r, WantedConstraints))
-> TcM (Maybe r) -> TcM (Maybe r, WantedConstraints)
forall a b. (a -> b) -> a -> b
$
TcM r -> TcM (Maybe r)
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM r
thing_inside
; case mb_res of
Just r
res | Bool -> Bool
not (Messages TcRnMessage -> Bool
forall e. Diagnostic e => Messages e -> Bool
errorsFound Messages TcRnMessage
msgs)
, Bool -> Bool
not (WantedConstraints -> Bool
insolubleWC WantedConstraints
lie)
->
do { Messages TcRnMessage -> TcM ()
addMessages Messages TcRnMessage
msgs
; 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
_ ->
TcM r
recover
}
addErrTc :: TcRnMessage -> TcM ()
addErrTc :: TcRnMessage -> TcM ()
addErrTc TcRnMessage
err_msg = do { env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM ZonkM TidyEnv
tcInitTidyEnv
; addErrTcM (env0, err_msg) }
addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addErrTcM (TidyEnv
tidy_env, TcRnMessage
err_msg)
= do { ctxt <- TcM [ErrCtxt]
getErrCtxt ;
loc <- getSrcSpanM ;
add_err_tcm tidy_env err_msg loc ctxt }
failWithTc :: TcRnMessage -> TcM a
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
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 ()
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 ()
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 ()
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
warnIf :: Bool -> TcRnMessage -> TcRn ()
warnIf :: Bool -> TcRnMessage -> TcM ()
warnIf Bool
is_bad TcRnMessage
msg
= 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
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 ()
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 ()
addDiagnosticTc :: TcRnMessage -> TcM ()
addDiagnosticTc :: TcRnMessage -> TcM ()
addDiagnosticTc TcRnMessage
msg
= do { env0 <- ZonkM TidyEnv -> TcM TidyEnv
forall a. ZonkM a -> TcM a
liftZonkM ZonkM TidyEnv
tcInitTidyEnv
; addDiagnosticTcM (env0, msg) }
addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addDiagnosticTcM (TidyEnv
env0, TcRnMessage
msg)
= do { ctxt <- TcM [ErrCtxt]
getErrCtxt
; extra <- mkErrInfo env0 ctxt
; let err_info = SDoc -> SDoc -> ErrInfo
ErrInfo SDoc
extra SDoc
forall doc. IsOutput doc => doc
Outputable.empty
detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage ErrInfo
err_info TcRnMessage
msg
; add_diagnostic detailed_msg }
addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic ErrInfo -> TcRnMessage
mkMsg = do
loc <- TcRn SrcSpan
getSrcSpanM
name_ppr_ctx <- getNamePprCtx
!diag_opts <- initDiagOpts <$> getDynFlags
env0 <- liftZonkM tcInitTidyEnv
ctxt <- getErrCtxt
err_info <- mkErrInfo env0 ctxt
reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty)))
addTcRnDiagnostic :: TcRnMessage -> TcM ()
addTcRnDiagnostic :: TcRnMessage -> TcM ()
addTcRnDiagnostic TcRnMessage
msg = do
loc <- TcRn SrcSpan
getSrcSpanM
mkTcRnMessage loc msg >>= reportDiagnostic
addDiagnostic :: TcRnMessage -> TcRn ()
addDiagnostic :: TcRnMessage -> TcM ()
addDiagnostic TcRnMessage
msg = TcRnMessageDetailed -> TcM ()
add_diagnostic (ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage ErrInfo
no_err_info TcRnMessage
msg)
addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcM ()
addDiagnosticAt SrcSpan
loc TcRnMessage
msg = do
unit_state <- HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units (HscEnv -> UnitState)
-> TcRnIf TcGblEnv TcLclEnv HscEnv
-> IOEnv (Env TcGblEnv TcLclEnv) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
let detailed_msg = ErrInfo -> TcRnMessage -> TcRnMessageDetailed
mkDetailedMessage ErrInfo
no_err_info TcRnMessage
msg
mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic
add_diagnostic :: TcRnMessageDetailed -> TcRn ()
add_diagnostic :: TcRnMessageDetailed -> TcM ()
add_diagnostic TcRnMessageDetailed
msg
= do { loc <- TcRn SrcSpan
getSrcSpanM
; unit_state <- hsc_units <$> getTopEnv
; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
}
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 { err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
tidy_env [ErrCtxt]
ctxt ;
add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) }
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
env [ErrCtxt]
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 -> ZonkM (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
= do { (env', msg) <- ZonkM (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall a. ZonkM a -> TcM a
liftZonkM (ZonkM (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc))
-> ZonkM (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall a b. (a -> b) -> a -> b
$ TidyEnv -> ZonkM (TidyEnv, SDoc)
ctxt TidyEnv
env
; let n' = if Bool
is_landmark then Int
n else Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
; rest <- go dbg n' env' ctxts
; return (msg $$ rest) }
| Bool
otherwise
= Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
dbg Int
n TidyEnv
env [ErrCtxt]
ctxts
mAX_CONTEXTS :: Int
mAX_CONTEXTS :: Int
mAX_CONTEXTS = Int
3
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 ()
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 { binds_ref <- EvBindMap -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef EvBindMap)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
; tcvs_ref <- newTcRef emptyVarSet
; uniq <- newUnique
; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
; return (EvBindsVar { ebv_binds = binds_ref
, ebv_tcvs = tcvs_ref
, ebv_uniq = uniq }) }
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds
= do { tcvs_ref <- VarSet -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef VarSet)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef VarSet
emptyVarSet
; uniq <- newUnique
; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
, ebv_uniq = uniq }) }
cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar ebv :: EvBindsVar
ebv@(EvBindsVar {})
= do { binds_ref <- EvBindMap -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef EvBindMap)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
; tcvs_ref <- newTcRef emptyVarSet
; return (ebv { ebv_binds = binds_ref
, ebv_tcvs = tcvs_ref }) }
cloneEvBindsVar ebv :: EvBindsVar
ebv@(CoEvBindsVar {})
= do { tcvs_ref <- VarSet -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef VarSet)
forall (m :: * -> *) a. MonadIO m => a -> m (TcRef a)
newTcRef VarSet
emptyVarSet
; return (ebv { ebv_tcvs = tcvs_ref }) }
getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
getTcEvTyCoVars :: EvBindsVar -> TcM VarSet
getTcEvTyCoVars EvBindsVar
ev_binds_var
= TcRef VarSet -> TcM VarSet
forall (m :: * -> *) a. MonadIO m => TcRef a -> m 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 (m :: * -> *) a. MonadIO m => TcRef a -> m 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 (m :: * -> *) a. MonadIO m => TcRef a -> a -> m ()
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 ()
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
; bnds <- TcRef EvBindMap -> TcM EvBindMap
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef TcRef EvBindMap
ev_ref
; writeTcRef ev_ref (extendEvBinds bnds 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 { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let dfun_n_var = TcGblEnv -> IORef OccSet
tcg_dfun_n TcGblEnv
env
; set <- readTcRef dfun_n_var
; let occ = OccSet -> OccName
fn OccSet
set
; writeTcRef dfun_n_var (extendOccSet set occ)
; return occ }
newZonkAnyType :: Kind -> TcM Type
newZonkAnyType :: Mult -> TcM Mult
newZonkAnyType Mult
kind
= do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let zany_n_var = TcGblEnv -> IORef Integer
tcg_zany_n TcGblEnv
env
; i <- readTcRef zany_n_var
; let !i2 = Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1
; writeTcRef zany_n_var i2
; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) }
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar :: IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (tcl_lie env) }
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar :: forall a. IORef WantedConstraints -> TcM a -> TcM a
setConstraintVar IORef WantedConstraints
lie_var = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_lie = lie_var })
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints WantedConstraints
static_lie
= do { gbl_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; updTcRef (tcg_static_wc gbl_env) (`andWC` 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 { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
updTcRef lie_var (`andWC` ct) }
emitSimple :: Ct -> TcM ()
emitSimple :: Ct -> TcM ()
emitSimple Ct
ct
= do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
updTcRef lie_var (`addSimples` unitBag ct) }
emitSimples :: Cts -> TcM ()
emitSimples :: Bag Ct -> TcM ()
emitSimples Bag Ct
cts
= do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
updTcRef lie_var (`addSimples` cts) }
emitImplication :: Implication -> TcM ()
emitImplication :: Implication -> TcM ()
emitImplication Implication
ct
= do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
updTcRef lie_var (`addImplics` unitBag ct) }
emitImplications :: Bag Implication -> TcM ()
emitImplications :: Bag Implication -> 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 { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar ;
updTcRef lie_var (`addImplics` 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)
; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
; updTcRef lie_var (`addDelayedErrors` 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)
; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
; updTcRef lie_var (`addHoles` unitBag 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)
; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
; updTcRef lie_var (`addHoles` 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)
; lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
; updTcRef lie_var (`addNotConcreteError` err) }
ensureReflMultiplicityCo :: TcCoercion -> CtOrigin -> TcM ()
ensureReflMultiplicityCo :: TcCoercion -> CtOrigin -> TcM ()
ensureReflMultiplicityCo TcCoercion
mult_co CtOrigin
origin
= do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"ensureReflMultiplicityCo" (TcCoercion -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcCoercion
mult_co)
; Bool -> TcM () -> TcM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TcCoercion -> Bool
isReflCo TcCoercion
mult_co) (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ do
{ loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin Maybe TypeOrKind
forall a. Maybe a
Nothing
; lie_var <- getConstraintVar
; updTcRef lie_var (\WantedConstraints
w -> WantedConstraints -> TcCoercion -> CtLoc -> WantedConstraints
addMultiplicityCoercionError WantedConstraints
w TcCoercion
mult_co CtLoc
loc) } }
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
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints :: forall a. TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints TcM a
thing_inside
= do { tclvl <- TcM TcLevel
getTcLevel
; let tclvl' = TcLevel -> TcLevel
pushTcLevel TcLevel
tclvl
; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
; (res, lie) <- updLclEnv (setLclEnvTcLevel tclvl') $
captureConstraints thing_inside
; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
; return (tclvl', lie, res) }
pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ :: forall a. TcM a -> TcM a
pushTcLevelM_ = (TcLclEnv -> TcLclEnv)
-> TcRnIf TcGblEnv TcLclEnv a -> TcRnIf TcGblEnv TcLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((TcLevel -> TcLevel) -> TcLclEnv -> TcLclEnv
modifyLclEnvTcLevel TcLevel -> TcLevel
pushTcLevel)
pushTcLevelM :: TcM a -> TcM (TcLevel, a)
pushTcLevelM :: forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM TcM a
thing_inside
= do { tclvl <- TcM TcLevel
getTcLevel
; let tclvl' = TcLevel -> TcLevel
pushTcLevel TcLevel
tclvl
; res <- updLclEnv (setLclEnvTcLevel tclvl') thing_inside
; return (tclvl', res) }
getTcLevel :: TcM TcLevel
getTcLevel :: TcM TcLevel
getTcLevel = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; return $! getLclEnvTcLevel env }
setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel :: forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
tclvl TcM a
thing_inside
= (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (TcLevel -> TcLclEnv -> TcLclEnv
setLclEnvTcLevel TcLevel
tclvl) TcM a
thing_inside
isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM :: Id -> TcRn Bool
isTouchableTcM Id
tv
= do { lvl <- TcM TcLevel
getTcLevel
; return (isTouchableMetaTyVar lvl tv) }
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvTypeEnv env) }
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
setLclTypeEnv :: forall a. TcLclEnv -> TcM a -> TcM a
setLclTypeEnv TcLclEnv
lcl_env TcM a
thing_inside
= (TcLclEnv -> TcLclEnv) -> TcM a -> TcM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (TcTypeEnv -> TcLclEnv -> TcLclEnv
setLclEnvTypeEnv (TcLclEnv -> TcTypeEnv
getLclEnvTypeEnv TcLclEnv
lcl_env)) TcM a
thing_inside
traceTcConstraints :: String -> TcM ()
traceTcConstraints :: FilePath -> TcM ()
traceTcConstraints FilePath
msg
= do { lie_var <- IOEnv (Env TcGblEnv TcLclEnv) (IORef WantedConstraints)
getConstraintVar
; lie <- readTcRef lie_var
; traceOptTcRn Opt_D_dump_tc_trace $
hang (text (msg ++ ": LIE:")) 2 (ppr lie)
}
data =
|
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 { ct_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (OccName -> CtOrigin
TypeHoleOrigin OccName
occ) Maybe TypeOrKind
forall a. Maybe a
Nothing
; let hole = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
sort
, hole_occ :: RdrName
hole_occ = OccName -> RdrName
mkRdrUnqual OccName
occ
, hole_ty :: Mult
hole_ty = Id -> Mult
mkTyVarTy Id
tv
, hole_loc :: CtLoc
hole_loc = CtLoc
ct_loc }
; emitHole hole }
where
occ :: OccName
occ = FastString -> OccName
mkTyVarOccFS (FilePath -> FastString
fsLit FilePath
"_")
sort :: HoleSort
sort | IsExtraConstraint
YesExtraConstraint <- IsExtraConstraint
extra_constraints = HoleSort
ConstraintHole
| Bool
otherwise = HoleSort
TypeHole
emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
emitNamedTypeHole :: (Name, Id) -> TcM ()
emitNamedTypeHole (Name
name, Id
tv)
= do { ct_loc <- SrcSpan -> TcM CtLoc -> TcM CtLoc
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
name) (TcM CtLoc -> TcM CtLoc) -> TcM CtLoc -> TcM CtLoc
forall a b. (a -> b) -> a -> b
$
CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (OccName -> CtOrigin
TypeHoleOrigin OccName
occ) Maybe TypeOrKind
forall a. Maybe a
Nothing
; let hole = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
TypeHole
, hole_occ :: RdrName
hole_occ = Name -> RdrName
nameRdrName Name
name
, hole_ty :: Mult
hole_ty = Id -> Mult
mkTyVarTy Id
tv
, hole_loc :: CtLoc
hole_loc = CtLoc
ct_loc }
; emitHole hole }
where
occ :: OccName
occ = Name -> OccName
nameOccName Name
name
recordThUse :: TcM ()
recordThUse :: TcM ()
recordThUse = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; writeTcRef (tcg_th_used env) True }
recordThSpliceUse :: TcM ()
recordThSpliceUse :: TcM ()
recordThSpliceUse = do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; writeTcRef (tcg_th_splice_used env) True }
recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()
recordThNeededRuntimeDeps :: [Linkable] -> UniqDFM UnitId LoadedPkgInfo -> TcM ()
recordThNeededRuntimeDeps [Linkable]
new_links UniqDFM UnitId LoadedPkgInfo
new_pkgs
= do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; updTcRef (tcg_th_needed_deps env) $ \([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 {k} (key :: k) elt.
UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM UniqDFM UnitId LoadedPkgInfo
needed_pkgs UniqDFM UnitId LoadedPkgInfo
new_pkgs
in ([Linkable]
links, UniqDFM UnitId LoadedPkgInfo
pkgs)
}
keepAlive :: Name -> TcRn ()
keepAlive :: Name -> TcM ()
keepAlive Name
name
= do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; traceRn "keep alive" (ppr name)
; updTcRef (tcg_keep env) (`extendNameSet` name) }
getStage :: TcM ThStage
getStage :: TcM ThStage
getStage = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvThStage env) }
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel Name
name
= do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv;
; case lookupNameEnv (getLclEnvThBndrs env) 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
getLclEnvThStage 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 (ThStage -> TcLclEnv -> TcLclEnv
setLclEnvThStage ThStage
s)
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
= do lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
updTcRef th_modfinalizers_var $ \[(TcLclEnv, ThModFinalizers)]
fins ->
(TcLclEnv
lcl_env, ThModFinalizers
mod_finalizers) (TcLclEnv, ThModFinalizers)
-> [(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]
forall a. a -> [a] -> [a]
: [(TcLclEnv, ThModFinalizers)]
fins
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 (m :: * -> *) a. MonadIO m => TcRef a -> a -> m ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
env) Bool
False
IORef (Messages TcRnMessage) -> Messages TcRnMessage -> TcM ()
forall (m :: * -> *) a. MonadIO m => TcRef a -> a -> m ()
writeTcRef (TcGblEnv -> IORef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
env) Messages TcRnMessage
msgs
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
dflags TcGblEnv
tcg_env = do
safeInf <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef Bool
tcg_safe_infer TcGblEnv
tcg_env)
return $ case safeHaskell dflags of
SafeHaskellMode
Sf_None | DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool
safeInf -> SafeHaskellMode
Sf_SafeInferred
| Bool
otherwise -> SafeHaskellMode
Sf_None
SafeHaskellMode
s -> SafeHaskellMode
s
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 }
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (getLclEnvRdrEnv env) }
setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv :: forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
rdr_env RnM a
thing_inside
= (TcLclEnv -> TcLclEnv) -> RnM a -> RnM a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (LocalRdrEnv -> TcLclEnv -> TcLclEnv
setLclEnvRdrEnv LocalRdrEnv
rdr_env) RnM a
thing_inside
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 }
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn :: forall a. IfG a -> TcRn a
initIfaceTcRn IfG a
thing_inside
= do { tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; hsc_env <- getTopEnv
; let !mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
!knot_vars = TcGblEnv -> KnotVars (IORef TypeEnv)
tcg_type_env_var TcGblEnv
tcg_env
is_instantiate = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (HomeUnit -> Bool
forall u. GenHomeUnit u -> Bool
isHomeUnitInstantiating (HomeUnit -> Bool) -> Maybe HomeUnit -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe HomeUnit
mhome_unit)
; let { if_env = IfGblEnv {
if_doc :: SDoc
if_doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"initIfaceTcRn",
if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types =
if Bool
is_instantiate
then KnotVars (IfG TypeEnv)
forall a. KnotVars a
emptyKnotVars
else IORef TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef (IORef TypeEnv -> IfG TypeEnv)
-> KnotVars (IORef TypeEnv) -> KnotVars (IfG TypeEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KnotVars (IORef TypeEnv)
knot_vars
}
}
; setEnvs (if_env, ()) thing_inside }
initIfaceLoad :: 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
initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule :: forall a. HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule HscEnv
hsc_env Module
this_mod IfG a
do_this
= do let gbl_env :: IfGblEnv
gbl_env = IfGblEnv {
if_doc :: SDoc
if_doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"initIfaceLoadModule",
if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types = IORef TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef (IORef TypeEnv -> IfG TypeEnv)
-> KnotVars (IORef TypeEnv) -> KnotVars (IfG TypeEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> KnotVars (IORef TypeEnv) -> KnotVars (IORef TypeEnv)
forall a. Module -> KnotVars a -> KnotVars a
knotVarsWithout Module
this_mod (HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env)
}
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
initIfaceCheck :: forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck SDoc
doc HscEnv
hsc_env IfG a
do_this
= do let gbl_env :: IfGblEnv
gbl_env = IfGblEnv {
if_doc :: SDoc
if_doc = FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"initIfaceCheck" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc,
if_rec_types :: KnotVars (IfG TypeEnv)
if_rec_types = IORef TypeEnv -> IfG TypeEnv
forall (m :: * -> *) a. MonadIO m => TcRef a -> m a
readTcRef (IORef TypeEnv -> IfG TypeEnv)
-> KnotVars (IORef TypeEnv) -> KnotVars (IfG TypeEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env
}
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
initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst :: forall a lcl.
Module
-> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst Module
mod SDoc
loc_doc IsBootInterface
hi_boot_file NameShape
nsubst IfL a
thing_inside
= IfLclEnv -> IfL a -> TcRnIf IfGblEnv lcl a
forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv ((Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv Module
mod SDoc
loc_doc IsBootInterface
hi_boot_file) { if_nsubst = Just nsubst }) IfL a
thing_inside
getIfModule :: IfL Module
getIfModule :: IfL Module
getIfModule = do { env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; return (if_mod env) }
failIfM :: SDoc -> IfL a
failIfM :: forall a. SDoc -> IfL a
failIfM SDoc
msg = do
env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
let full_msg = (IfLclEnv -> SDoc
if_loc IfLclEnv
env SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
2 SDoc
msg
logger <- getLogger
liftIO (logMsg logger MCFatal
noSrcSpan $ withPprStyle defaultErrStyle full_msg)
failM
forkM :: SDoc -> IfL a -> IfL a
forkM :: forall a. SDoc -> IfL a -> IfL a
forkM SDoc
doc IfL a
thing_inside
= IfL a -> IfL a
forall env a. IOEnv env a -> IOEnv env a
unsafeInterleaveM (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$ IfL a -> IfL a
forall env a. IOEnv env a -> IOEnv env a
uninterruptibleMaskM_ (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
do { SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Starting fork {" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc)
; mb_res <- IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a)
forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM (IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a))
-> IfL a -> IOEnv (Env IfGblEnv IfLclEnv) (Either IOEnvFailure a)
forall a b. (a -> b) -> a -> b
$
(IfLclEnv -> IfLclEnv) -> IfL a -> IfL a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\IfLclEnv
env -> IfLclEnv
env { if_loc = if_loc env $$ doc }) (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
IfL a
thing_inside
; case mb_res of
Right a
r -> do { SDoc -> IOEnv (Env IfGblEnv IfLclEnv) ()
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"} ending fork" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc)
; a -> IfL a
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r }
Left IOEnvFailure
exn -> do {
DumpFlag
-> IOEnv (Env IfGblEnv IfLclEnv) ()
-> IOEnv (Env IfGblEnv IfLclEnv) ()
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_if_trace (IOEnv (Env IfGblEnv IfLclEnv) ()
-> IOEnv (Env IfGblEnv IfLclEnv) ())
-> IOEnv (Env IfGblEnv IfLclEnv) ()
-> IOEnv (Env IfGblEnv IfLclEnv) ()
forall a b. (a -> b) -> a -> b
$ do
logger <- IOEnv (Env IfGblEnv IfLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
let msg = SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"forkM failed:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc)
Int
2 (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (IOEnvFailure -> FilePath
forall a. Show a => a -> FilePath
show IOEnvFailure
exn))
liftIO $ logMsg logger
MCFatal
noSrcSpan
$ withPprStyle defaultErrStyle 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
getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM :: forall gbl lcl.
(gbl -> IORef CostCentreState)
-> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM gbl -> IORef CostCentreState
get_ccs FastString
nm = do
env <- TcRnIf gbl lcl gbl
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let cc_st_ref = gbl -> IORef CostCentreState
get_ccs gbl
env
cc_st <- readTcRef cc_st_ref
let (idx, cc_st') = getCCIndex nm cc_st
writeTcRef cc_st_ref cc_st'
return idx
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
liftZonkM :: ZonkM a -> TcM a
liftZonkM :: forall a. ZonkM a -> TcM a
liftZonkM (ZonkM ZonkGblEnv -> IO a
f) =
do { logger <- IOEnv (Env TcGblEnv TcLclEnv) Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
; name_ppr_ctx <- getNamePprCtx
; lvl <- getTcLevel
; src_span <- getSrcSpanM
; bndrs <- getLclEnvBinderStack <$> getLclEnv
; let zge = ZonkGblEnv { zge_logger :: Logger
zge_logger = Logger
logger
, zge_name_ppr_ctx :: NamePprCtx
zge_name_ppr_ctx = NamePprCtx
name_ppr_ctx
, zge_src_span :: SrcSpan
zge_src_span = SrcSpan
src_span
, zge_tc_level :: TcLevel
zge_tc_level = TcLevel
lvl
, zge_binder_stack :: TcBinderStack
zge_binder_stack = TcBinderStack
bndrs }
; liftIO $ f zge }
{-# INLINE liftZonkM #-}
getCompleteMatchesTcM :: TcM CompleteMatches
getCompleteMatchesTcM :: TcM CompleteMatches
getCompleteMatchesTcM
= do { hsc_env <- TcRnIf TcGblEnv TcLclEnv HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; tcg_env <- getGblEnv
; eps <- liftIO $ hscEPS hsc_env
; return $ localAndImportedCompleteMatches (tcg_complete_matches tcg_env) hsc_env eps
}
localAndImportedCompleteMatches :: CompleteMatches -> HscEnv -> ExternalPackageState -> CompleteMatches
localAndImportedCompleteMatches :: CompleteMatches
-> HscEnv -> ExternalPackageState -> CompleteMatches
localAndImportedCompleteMatches CompleteMatches
tcg_comps HscEnv
hsc_env ExternalPackageState
eps =
CompleteMatches
tcg_comps
CompleteMatches -> CompleteMatches -> CompleteMatches
forall a. [a] -> [a] -> [a]
++ HscEnv -> CompleteMatches
hptCompleteSigs HscEnv
hsc_env
CompleteMatches -> CompleteMatches -> CompleteMatches
forall a. [a] -> [a] -> [a]
++ ExternalPackageState -> CompleteMatches
eps_complete_matches ExternalPackageState
eps