module GHC.Tc.Utils.Monad(
initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
discardResult,
getTopEnv, updTopEnv, getGblEnv, updGblEnv,
setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv,
updTopFlags,
getEnvs, setEnvs, updEnvs, restoreEnvs,
xoptM, doptM, goptM, woptM,
setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
whenDOptM, whenGOptM, whenWOptM,
whenXOptM, unlessXOptM,
getGhcMode,
withoutDynamicNow,
getEpsVar,
getEps,
updateEps, updateEps_,
getHpt, getEpsAndHug,
newArrowScope, escapeArrowScope,
newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
newSysName, newSysLocalId, newSysLocalIds,
newTcRef, readTcRef, writeTcRef, updTcRef,
traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
dumpTcRn,
getPrintUnqualified,
printForUserTcRn,
traceIf, traceOptIf,
debugTc,
getIsGHCi, getGHCiMonad, getInteractivePrintName,
tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
getRdrEnvs, getImports,
getFixityEnv, extendFixityEnv, getRecFieldEnv,
getDeclaredDefaultTys,
addDependentFiles,
getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,
wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
wrapLocMA_,wrapLocMA,
getErrsVar, setErrsVar,
addErr,
failWith, failAt,
addErrAt, addErrs,
checkErr,
addMessages,
discardWarnings,
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,
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, emitInsoluble,
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,
getCCIndexM, getCCIndexTcM,
module GHC.Tc.Types,
module GHC.Data.IOEnv
) where
import GHC.Prelude
import GHC.Builtin.Names
import GHC.Tc.Types
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType
import GHC.Hs hiding (LIE)
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.External
import GHC.Unit.Module.Warnings
import GHC.Unit.Home.ModInfo
import GHC.Core.UsageEnv
import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Config.Diagnostic
import GHC.Runtime.Context
import GHC.Data.IOEnv
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.Maybe
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Error
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Logger
import qualified GHC.Data.Strict as Strict
import GHC.Types.Error
import GHC.Types.Fixity.Env
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.SafeHaskell
import GHC.Types.Id
import GHC.Types.TypeEnv
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.SrcLoc
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Types.Name.Ppr
import GHC.Types.Unique.FM ( emptyUFM )
import GHC.Types.Unique.Supply
import GHC.Types.Annotations
import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )
import GHC.Types.CostCentre.State
import GHC.Types.SourceFile
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
import Control.Monad
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Env ( tcInitTidyEnv )
import qualified Data.Map as Map
import GHC.Driver.Env.KnotVars
import GHC.Linker.Types
import GHC.Types.Unique.DFM
initTc :: HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
= do { keep_var <- newIORef emptyNameSet ;
used_gre_var <- newIORef [] ;
th_var <- newIORef False ;
th_splice_var<- newIORef False ;
infer_var <- newIORef True ;
infer_reasons_var <- newIORef emptyMessages ;
dfun_n_var <- newIORef emptyOccSet ;
let { type_env_var = hsc_type_env_vars hsc_env };
dependent_files_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ;
cc_st_var <- newIORef newCostCentreState ;
th_topdecls_var <- newIORef [] ;
th_foreign_files_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ;
th_modfinalizers_var <- newIORef [] ;
th_coreplugins_var <- newIORef [] ;
th_state_var <- newIORef Map.empty ;
th_remote_state_var <- newIORef Nothing ;
th_docs_var <- newIORef Map.empty ;
th_needed_deps_var <- newIORef ([], emptyUDFM) ;
next_wrapper_num <- newIORef emptyModuleEnv ;
let {
!dflags = hsc_dflags hsc_env ;
!mhome_unit = hsc_home_unit_maybe hsc_env;
!logger = hsc_logger hsc_env ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax empty_val
| logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val
| gopt Opt_WriteHie dflags = Just empty_val
| gopt Opt_Haddock dflags = Just empty_val
| keep_rn_syntax = Just empty_val
| otherwise = Nothing ;
gbl_env = TcGblEnv {
tcg_th_topdecls = th_topdecls_var,
tcg_th_foreign_files = th_foreign_files_var,
tcg_th_topnames = th_topnames_var,
tcg_th_modfinalizers = th_modfinalizers_var,
tcg_th_coreplugins = th_coreplugins_var,
tcg_th_state = th_state_var,
tcg_th_remote_state = th_remote_state_var,
tcg_th_docs = th_docs_var,
tcg_mod = mod,
tcg_semantic_mod = homeModuleInstantiation mhome_unit mod,
tcg_src = hsc_src,
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_field_env = emptyNameEnv,
tcg_default = if moduleUnit mod == primUnit
|| moduleUnit mod == bignumUnit
then Just []
else Nothing,
tcg_type_env = emptyNameEnv,
tcg_type_env_var = type_env_var,
tcg_inst_env = emptyInstEnv,
tcg_fam_inst_env = emptyFamInstEnv,
tcg_ann_env = emptyAnnEnv,
tcg_th_used = th_var,
tcg_th_splice_used = th_splice_var,
tcg_th_needed_deps = th_needed_deps_var,
tcg_exports = [],
tcg_imports = emptyImportAvails,
tcg_used_gres = used_gre_var,
tcg_dus = emptyDUs,
tcg_rn_imports = [],
tcg_rn_exports =
if hsc_src == HsigFile
then Just []
else maybe_rn_syntax [],
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
tcg_tr_module = Nothing,
tcg_binds = emptyLHsBinds,
tcg_imp_specs = [],
tcg_sigs = emptyNameSet,
tcg_ksigs = emptyNameSet,
tcg_ev_binds = emptyBag,
tcg_warns = NoWarnings,
tcg_anns = [],
tcg_tcs = [],
tcg_insts = [],
tcg_fam_insts = [],
tcg_rules = [],
tcg_fords = [],
tcg_patsyns = [],
tcg_merged = [],
tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var,
tcg_doc_hdr = Nothing,
tcg_hpc = False,
tcg_main = Nothing,
tcg_self_boot = NoSelfBoot,
tcg_safe_infer = infer_var,
tcg_safe_infer_reasons = infer_reasons_var,
tcg_dependent_files = dependent_files_var,
tcg_tc_plugin_solvers = [],
tcg_tc_plugin_rewriters = emptyUFM,
tcg_defaulting_plugins = [],
tcg_hf_plugins = [],
tcg_top_loc = loc,
tcg_static_wc = static_wc_var,
tcg_complete_matches = [],
tcg_cc_st = cc_st_var,
tcg_next_wrapper_num = next_wrapper_num
} ;
} ;
initTcWithGbl hsc_env gbl_env loc do_this
}
initTcWithGbl :: HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages TcRnMessage, Maybe r)
initTcWithGbl hsc_env gbl_env loc do_this
= do { lie_var <- newIORef emptyWC
; errs_var <- newIORef emptyMessages
; usage_var <- newIORef zeroUE
; let lcl_env = TcLclEnv {
tcl_errs = errs_var,
tcl_loc = loc,
tcl_in_gen_code = False,
tcl_ctxt = [],
tcl_rdr = emptyLocalRdrEnv,
tcl_th_ctxt = topStage,
tcl_th_bndrs = emptyNameEnv,
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_usage = usage_var,
tcl_bndrs = [],
tcl_lie = lie_var,
tcl_tclvl = topTcLevel
}
; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
do { r <- tryM do_this
; case r of
Right res -> return (Just res)
Left _ -> return Nothing }
; 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 | errorsFound msgs = Nothing
| otherwise = maybe_res }
; return (msgs, final_res)
}
initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive hsc_env thing_inside
= initTc hsc_env HsSrcFile False
(icInteractiveModule (hsc_IC hsc_env))
(realSrcLocSpan interactive_src_loc)
thing_inside
where
interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
initTcRnIf :: Char
-> HscEnv
-> gbl -> lcl
-> TcRnIf gbl lcl a
-> IO a
initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside
= do { let { env = Env { env_top = hsc_env,
env_um = uniq_mask,
env_gbl = gbl_env,
env_lcl = lcl_env} }
; runIOEnv env thing_inside
}
discardResult :: TcM a -> TcM ()
discardResult a = a >> return ()
getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv = do { env <- getEnv; return (env_top env) }
updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = upd top })
getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv = do { Env{..} <- getEnv; return env_gbl }
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
env { env_gbl = upd gbl })
setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv = do { Env{..} <- getEnv; return env_lcl }
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
env { env_lcl = upd lcl })
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
restoreLclEnv new_lcl_env = updLclEnv upd
where
upd old_lcl_env = new_lcl_env { tcl_errs = tcl_errs old_lcl_env
, tcl_lie = tcl_lie old_lcl_env
, tcl_usage = tcl_usage old_lcl_env }
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env
updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updEnvs upd_envs = updEnv upd
where
upd env@(Env { env_gbl = gbl, env_lcl = lcl })
= env { env_gbl = gbl', env_lcl = lcl' }
where
!(gbl', lcl') = upd_envs (gbl, lcl)
restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl
xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
xoptM flag = xopt flag <$> getDynFlags
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM flag = do
logger <- getLogger
return (logHasDumpFlag logger flag)
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM flag = gopt flag <$> getDynFlags
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM flag = wopt flag <$> getDynFlags
setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag)
unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag)
unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag)
unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag)
whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM flag thing_inside = do b <- doptM flag
when b thing_inside
whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenGOptM flag thing_inside = do b <- goptM flag
when b thing_inside
whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM flag thing_inside = do b <- woptM flag
when b thing_inside
whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenXOptM flag thing_inside = do b <- xoptM flag
when b thing_inside
unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM flag thing_inside = do b <- xoptM flag
unless b thing_inside
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode = ghcMode <$> getDynFlags
withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False})
updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopFlags f = updTopEnv (hscUpdateFlags f)
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do
env <- getTopEnv
return (euc_eps (ue_eps (hsc_unit_env env)))
getEps :: TcRnIf gbl lcl ExternalPackageState
getEps = do { env <- getTopEnv; liftIO $ hscEPS env }
updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps upd_fn = do
traceIf (text "updating EPS")
eps_var <- getEpsVar
atomicUpdMutVar' eps_var upd_fn
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
-> TcRnIf gbl lcl ()
updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ()))
getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env
; return (eps, hsc_HUG env) }
withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a
withException ctx do_this = do
r <- do_this
case r of
Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err))
Succeeded result -> return result
newArrowScope :: TcM a -> TcM a
newArrowScope
= updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope
= updLclEnv $ \ env ->
case tcl_arrow_ctxt env of
NoArrowCtxt -> env
ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
, tcl_lie = lie
, tcl_rdr = rdr_env }
newUnique :: TcRnIf gbl lcl Unique
newUnique
= do { env <- getEnv
; let mask = env_um env
; liftIO $! uniqFromMask mask }
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { env <- getEnv
; let mask = env_um env
; liftIO $! mkSplitUniqSupply mask }
cloneLocalName :: Name -> TcM Name
cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
newName :: OccName -> TcM Name
newName occ = do { loc <- getSrcSpanM
; newNameAt occ loc }
newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt occ span
= do { uniq <- newUnique
; return (mkInternalName uniq occ span) }
newSysName :: OccName -> TcRnIf gbl lcl Name
newSysName occ
= do { uniq <- newUnique
; return (mkSystemName uniq occ) }
newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId fs w ty
= do { u <- newUnique
; return (mkSysLocal fs u w ty) }
newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds fs tys
= do { us <- newUniqueSupply
; let mkId' n (Scaled w t) = mkSysLocal fs n w t
; return (zipWith mkId' (uniqsFromSupply us) tys) }
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM = newUnique
getUniqueSupplyM = newUniqueSupply
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef = newMutVar
readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef = readMutVar
writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = writeMutVar
updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef ref fn = liftIO $ modifyIORef' ref fn
traceTc :: String -> SDoc -> TcRn ()
traceTc herald doc =
labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc
traceRn :: String -> SDoc -> TcRn ()
traceRn herald doc =
labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc
labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
labelledTraceOptTcRn flag herald doc =
traceOptTcRn flag (formatTraceMsg herald doc)
formatTraceMsg :: String -> SDoc -> SDoc
formatTraceMsg herald doc = hang (text herald) 2 doc
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn flag doc =
whenDOptM flag $
dumpTcRn False flag "" FormatText doc
dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
dumpOptTcRn flag title fmt doc =
whenDOptM flag $
dumpTcRn False flag title fmt doc
dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
dumpTcRn useUserStyle flag title fmt doc = do
logger <- getLogger
printer <- getPrintUnqualified
real_doc <- wrapDocLoc doc
let sty = if useUserStyle
then mkUserStyle printer AllTheWay
else mkDumpStyle printer
liftIO $ logDumpFile logger sty flag title fmt real_doc
wrapDocLoc :: SDoc -> TcRn SDoc
wrapDocLoc doc = do
logger <- getLogger
if logHasDumpFlag logger Opt_D_ppr_debug
then do
loc <- getSrcSpanM
return (mkLocMessage MCOutput loc doc)
else
return doc
getPrintUnqualified :: TcRn PrintUnqualified
getPrintUnqualified
= do { rdr_env <- getGlobalRdrEnv
; hsc_env <- getTopEnv
; return $ mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env }
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn doc = do
logger <- getLogger
printer <- getPrintUnqualified
liftIO (printOutputForUser logger printer doc)
traceIf :: SDoc -> TcRnIf m n ()
traceIf = traceOptIf Opt_D_dump_if_trace
traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf flag doc
= whenDOptM flag $ do
logger <- getLogger
liftIO (putMsg logger doc)
getIsGHCi :: TcRn Bool
getIsGHCi = do { mod <- getModule
; return (isInteractiveModule mod) }
getGHCiMonad :: TcRn Name
getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
getInteractivePrintName :: TcRn Name
getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
tcIsHsig :: TcRn Bool
tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
getImports :: TcRn ImportAvails
getImports = do { env <- getGblEnv; return (tcg_imports env) }
getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv new_bit
= updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles fs = do
ref <- fmap tcg_dependent_files getGblEnv
dep_files <- readTcRef ref
writeTcRef ref (fs ++ dep_files)
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }
inGeneratedCode :: TcRn Bool
inGeneratedCode = tcl_in_gen_code <$> getLclEnv
setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
setSrcSpan (RealSrcSpan loc _) thing_inside
= updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
thing_inside
setSrcSpan loc@(UnhelpfulSpan _) thing_inside
| isGeneratedSrcSpan loc
= updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
| otherwise
= thing_inside
setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA fn (L loc a) = setSrcSpanA loc $ fn a
wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
; return (L loc b) }
wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
wrapLocAM fn a = wrapLocM fn (reLoc a)
wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
; return (L loc b) }
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
setSrcSpan loc $ do
(b,c) <- fn a
return (L loc b, c)
wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c)
wrapLocFstMA fn (L loc a) =
setSrcSpanA loc $ do
(b,c) <- fn a
return (L loc b, c)
wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
setSrcSpan loc $ do
(b,c) <- fn a
return (b, L loc c)
wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c)
wrapLocSndMA fn (L loc a) =
setSrcSpanA loc $ do
(b,c) <- fn a
return (b, L loc c)
wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)
wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()
wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a)
getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a
setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v })
addErr :: TcRnMessage -> TcRn ()
addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
failWith :: TcRnMessage -> TcRn a
failWith msg = addErr msg >> failM
failAt :: SrcSpan -> TcRnMessage -> TcRn a
failAt loc msg = addErrAt loc msg >> failM
addErrAt :: SrcSpan -> TcRnMessage -> TcRn ()
addErrAt loc msg = do { ctxt <- getErrCtxt
; tidy_env <- tcInitTidyEnv
; err_info <- mkErrInfo tidy_env ctxt
; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
addErrs msgs = mapM_ add msgs
where
add (loc,msg) = addErrAt loc msg
checkErr :: Bool -> TcRnMessage -> TcRn ()
checkErr ok msg = unless ok (addErr msg)
addMessages :: Messages TcRnMessage -> TcRn ()
addMessages msgs1
= do { errs_var <- getErrsVar
; msgs0 <- readTcRef errs_var
; writeTcRef errs_var (msgs0 `unionMessages` msgs1) }
discardWarnings :: TcRn a -> TcRn a
discardWarnings thing_inside
= do { errs_var <- 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 loc msg = mk_long_err_at loc msg >>= reportDiagnostic
where
mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)
mk_long_err_at loc msg
= do { printer <- getPrintUnqualified ;
unit_state <- hsc_units <$> getTopEnv ;
return $ mkErrorMsgEnvelope loc printer
$ TcRnMessageWithInfo unit_state msg
}
mkTcRnMessage :: SrcSpan
-> TcRnMessage
-> TcRn (MsgEnvelope TcRnMessage)
mkTcRnMessage loc msg
= do { printer <- getPrintUnqualified ;
diag_opts <- initDiagOpts <$> getDynFlags ;
return $ mkMsgEnvelope diag_opts loc printer msg }
reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
reportDiagnostics = mapM_ reportDiagnostic
reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
reportDiagnostic msg
= do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;
errs_var <- getErrsVar ;
msgs <- readTcRef errs_var ;
writeTcRef errs_var (msg `addMessage` msgs) }
checkNoErrs :: TcM r -> TcM r
checkNoErrs main
= do { (res, no_errs) <- askNoErrs main
; unless no_errs failM
; return res }
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing = ifErrsM (return ()) thing
ifErrsM :: TcRn r -> TcRn r -> TcRn r
ifErrsM bale_out normal
= do { errs_var <- getErrsVar ;
msgs <- readTcRef errs_var ;
if errorsFound msgs then
bale_out
else
normal }
failIfErrsM :: TcRn ()
failIfErrsM = ifErrsM failM (return ())
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
addErrCtxt :: SDoc -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM ctxt = pushCtxt (False, ctxt)
addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a
addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt)
pushCtxt :: ErrCtxt -> TcM a -> TcM a
pushCtxt ctxt = updLclEnv (updCtxt ctxt)
updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen })
| in_gen = env
| otherwise = env { tcl_ctxt = ctxt : ctxts }
popErrCtxt :: TcM a -> TcM a
popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
env { tcl_ctxt = pop ctxt })
where
pop [] = []
pop (_:msgs) = msgs
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM origin t_or_k
= do { env <- getLclEnv
; return (CtLoc { ctl_origin = origin
, ctl_env = env
, ctl_t_or_k = t_or_k
, ctl_depth = initialSubGoalDepth }) }
setCtLocM :: CtLoc -> TcM a -> TcM a
setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
= updLclEnv (\env -> env { tcl_loc = tcl_loc lcl
, tcl_bndrs = tcl_bndrs lcl
, tcl_ctxt = tcl_ctxt lcl })
thing_inside
tcTryM :: TcRn r -> TcRn (Maybe r)
tcTryM thing_inside
= do { either_res <- tryM thing_inside
; return (case either_res of
Left _ -> Nothing
Right r -> Just r) }
capture_constraints :: TcM r -> TcM (r, WantedConstraints)
capture_constraints thing_inside
= do { lie_var <- newTcRef emptyWC
; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $
thing_inside
; lie <- readTcRef lie_var
; return (res, lie) }
capture_messages :: TcM r -> TcM (r, Messages TcRnMessage)
capture_messages thing_inside
= do { msg_var <- newTcRef emptyMessages
; res <- setErrsVar msg_var thing_inside
; msgs <- readTcRef msg_var
; return (res, msgs) }
askNoErrs :: TcRn a -> TcRn (a, Bool)
askNoErrs thing_inside
= do { ((mb_res, lie), msgs) <- capture_messages $
capture_constraints $
tcTryM thing_inside
; addMessages msgs
; case mb_res of
Nothing -> do { emitConstraints (dropMisleading lie)
; failM }
Just res -> do { emitConstraints lie
; let errs_found = errorsFound msgs
|| insolubleWC lie
; return (res, not errs_found) } }
tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints thing_inside
= do { (mb_res, lie) <- capture_constraints $
tcTryM thing_inside
; let lie_to_keep = case mb_res of
Nothing -> dropMisleading lie
Just {} -> lie
; return (mb_res, lie_to_keep) }
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
captureConstraints thing_inside
= do { (mb_res, lie) <- tryCaptureConstraints thing_inside
; case mb_res of
Nothing -> do { emitConstraints lie; failM }
Just res -> return (res, lie) }
tcCollectingUsage :: TcM a -> TcM (UsageEnv,a)
tcCollectingUsage thing_inside
= do { local_usage_ref <- newTcRef zeroUE
; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside
; local_usage <- readTcRef local_usage_ref
; return (local_usage,result) }
tcScalingUsage :: Mult -> TcM a -> TcM a
tcScalingUsage mult thing_inside
= do { (usage, result) <- tcCollectingUsage thing_inside
; traceTc "tcScalingUsage" (ppr mult)
; tcEmitBindingUsage $ scaleUE mult usage
; return result }
tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage ue
= do { lcl_env <- getLclEnv
; let usage = tcl_usage lcl_env
; updTcRef usage (addUE ue) }
attemptM :: TcRn r -> TcRn (Maybe r)
attemptM thing_inside
= do { (mb_r, lie) <- tryCaptureConstraints 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 recover thing
= do { mb_res <- attemptM thing ;
case mb_res of
Nothing -> recover
Just res -> return res }
mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndRecoverM f xs
= do { mb_rs <- mapM (attemptM . f) xs
; return [r | Just r <- mb_rs] }
mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
mapAndReportM f xs
= do { mb_rs <- mapM (attemptM . f) xs
; when (any isNothing mb_rs) failM
; return [r | Just r <- mb_rs] }
foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM _ acc [] = return acc
foldAndRecoverM f acc (x:xs) =
do { mb_r <- attemptM (f acc x)
; case mb_r of
Nothing -> foldAndRecoverM f acc xs
Just acc' -> foldAndRecoverM f acc' xs }
tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
tryTc thing_inside
= capture_messages (attemptM thing_inside)
discardErrs :: TcRn a -> TcRn a
discardErrs m
= do { errs_var <- newTcRef emptyMessages
; setErrsVar errs_var m }
tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
tryTcDiscardingErrs recover thing_inside
= do { ((mb_res, lie), msgs) <- capture_messages $
capture_constraints $
tcTryM thing_inside
; case mb_res of
Just res | not (errorsFound msgs)
, not (insolubleWC lie)
->
do { addMessages msgs
; emitConstraints lie
; return res }
_ ->
recover
}
addErrTc :: TcRnMessage -> TcM ()
addErrTc err_msg = do { env0 <- tcInitTidyEnv
; addErrTcM (env0, err_msg) }
addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addErrTcM (tidy_env, err_msg)
= do { ctxt <- getErrCtxt ;
loc <- getSrcSpanM ;
add_err_tcm tidy_env err_msg loc ctxt }
failWithTc :: TcRnMessage -> TcM a
failWithTc err_msg
= addErrTc err_msg >> failM
failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a
failWithTcM local_and_msg
= addErrTcM local_and_msg >> failM
checkTc :: Bool -> TcRnMessage -> TcM ()
checkTc True _ = return ()
checkTc False err = failWithTc err
checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
checkTcM True _ = return ()
checkTcM False err = failWithTcM err
failIfTc :: Bool -> TcRnMessage -> TcM ()
failIfTc False _ = return ()
failIfTc True err = failWithTc err
failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
failIfTcM False _ = return ()
failIfTcM True err = failWithTcM err
warnIf :: Bool -> TcRnMessage -> TcRn ()
warnIf is_bad msg
= when is_bad (addDiagnostic msg)
no_err_info :: ErrInfo
no_err_info = ErrInfo Outputable.empty Outputable.empty
diagnosticTc :: Bool -> TcRnMessage -> TcM ()
diagnosticTc should_report warn_msg
| should_report = addDiagnosticTc warn_msg
| otherwise = return ()
diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
diagnosticTcM should_report warn_msg
| should_report = addDiagnosticTcM warn_msg
| otherwise = return ()
addDiagnosticTc :: TcRnMessage -> TcM ()
addDiagnosticTc msg
= do { env0 <- tcInitTidyEnv ;
addDiagnosticTcM (env0, msg) }
addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()
addDiagnosticTcM (env0, msg)
= do { ctxt <- getErrCtxt
; extra <- mkErrInfo env0 ctxt
; let err_info = ErrInfo extra Outputable.empty
; add_diagnostic (TcRnMessageDetailed err_info msg) }
addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
addDetailedDiagnostic mkMsg = do
loc <- getSrcSpanM
printer <- getPrintUnqualified
!diag_opts <- initDiagOpts <$> getDynFlags
env0 <- tcInitTidyEnv
ctxt <- getErrCtxt
err_info <- mkErrInfo env0 ctxt
reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty)))
addTcRnDiagnostic :: TcRnMessage -> TcM ()
addTcRnDiagnostic msg = do
loc <- getSrcSpanM
mkTcRnMessage loc msg >>= reportDiagnostic
addDiagnostic :: TcRnMessage -> TcRn ()
addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg)
addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
addDiagnosticAt loc msg = do
unit_state <- hsc_units <$> getTopEnv
let dia = TcRnMessageDetailed no_err_info msg
mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic
add_diagnostic :: TcRnMessageDetailed -> TcRn ()
add_diagnostic msg
= do { loc <- getSrcSpanM
; unit_state <- hsc_units <$> getTopEnv
; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
}
add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan
-> [ErrCtxt]
-> TcM ()
add_err_tcm tidy_env msg loc ctxt
= do { err_info <- mkErrInfo tidy_env ctxt ;
add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
mkErrInfo env ctxts
= go False 0 env ctxts
where
go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
go _ _ _ [] = return empty
go dbg n env ((is_landmark, ctxt) : ctxts)
| is_landmark || n < mAX_CONTEXTS
= do { (env', msg) <- ctxt env
; let n' = if is_landmark then n else n+1
; rest <- go dbg n' env' ctxts
; return (msg $$ rest) }
| otherwise
= go dbg n env ctxts
mAX_CONTEXTS :: Int
mAX_CONTEXTS = 3
debugTc :: TcM () -> TcM ()
debugTc thing
| debugIsOn = thing
| otherwise = return ()
addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
addTopEvBinds new_ev_binds thing_inside
=updGblEnv upd_env thing_inside
where
upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
`unionBags` new_ev_binds }
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
; tcvs_ref <- newTcRef emptyVarSet
; uniq <- newUnique
; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
; return (EvBindsVar { ebv_binds = binds_ref
, ebv_tcvs = tcvs_ref
, ebv_uniq = uniq }) }
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds
= do { tcvs_ref <- newTcRef emptyVarSet
; uniq <- newUnique
; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
, ebv_uniq = uniq }) }
cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar ebv@(EvBindsVar {})
= do { binds_ref <- newTcRef emptyEvBindMap
; tcvs_ref <- newTcRef emptyVarSet
; return (ebv { ebv_binds = binds_ref
, ebv_tcvs = tcvs_ref }) }
cloneEvBindsVar ebv@(CoEvBindsVar {})
= do { tcvs_ref <- newTcRef emptyVarSet
; return (ebv { ebv_tcvs = tcvs_ref }) }
getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
getTcEvTyCoVars ev_binds_var
= readTcRef (ebv_tcvs ev_binds_var)
getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
= readTcRef ev_ref
getTcEvBindsMap (CoEvBindsVar {})
= return emptyEvBindMap
setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
= writeTcRef ev_ref binds
setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
| isEmptyEvBindMap ev_binds
= return ()
| otherwise
= pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
= do { traceTc "addTcEvBind" $ ppr u $$
ppr ev_bind
; bnds <- readTcRef ev_ref
; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
= pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc fn =
do { env <- getGblEnv
; let dfun_n_var = tcg_dfun_n env
; set <- readTcRef dfun_n_var
; let occ = fn set
; writeTcRef dfun_n_var (extendOccSet set occ)
; return occ }
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints static_lie
= do { gbl_env <- getGblEnv
; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
| isEmptyWC ct
= return ()
| otherwise
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`andWC` ct) }
emitSimple :: Ct -> TcM ()
emitSimple ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addSimples` unitBag ct) }
emitSimples :: Cts -> TcM ()
emitSimples cts
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addSimples` cts) }
emitImplication :: Implication -> TcM ()
emitImplication ct
= do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addImplics` unitBag ct) }
emitImplications :: Bag Implication -> TcM ()
emitImplications ct
= unless (isEmptyBag ct) $
do { lie_var <- getConstraintVar ;
updTcRef lie_var (`addImplics` ct) }
emitInsoluble :: Ct -> TcM ()
emitInsoluble ct
= do { traceTc "emitInsoluble" (ppr ct)
; lie_var <- getConstraintVar
; updTcRef lie_var (`addInsols` unitBag ct) }
emitDelayedErrors :: Bag DelayedError -> TcM ()
emitDelayedErrors errs
= do { traceTc "emitDelayedErrors" (ppr errs)
; lie_var <- getConstraintVar
; updTcRef lie_var (`addDelayedErrors` errs)}
emitHole :: Hole -> TcM ()
emitHole hole
= do { traceTc "emitHole" (ppr hole)
; lie_var <- getConstraintVar
; updTcRef lie_var (`addHoles` unitBag hole) }
emitHoles :: Bag Hole -> TcM ()
emitHoles holes
= do { traceTc "emitHoles" (ppr holes)
; lie_var <- getConstraintVar
; updTcRef lie_var (`addHoles` holes) }
emitNotConcreteError :: NotConcreteError -> TcM ()
emitNotConcreteError err
= do { traceTc "emitNotConcreteError" (ppr err)
; lie_var <- getConstraintVar
; updTcRef lie_var (`addNotConcreteError` err) }
discardConstraints :: TcM a -> TcM a
discardConstraints thing_inside = fst <$> captureConstraints thing_inside
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints thing_inside
= do { tclvl <- getTcLevel
; let tclvl' = pushTcLevel tclvl
; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $
captureConstraints thing_inside
; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
; return (tclvl', lie, res) }
pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
pushTcLevelM :: TcM a -> TcM (TcLevel, a)
pushTcLevelM thing_inside
= do { tclvl <- getTcLevel
; let tclvl' = pushTcLevel tclvl
; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside
; return (tclvl', res) }
getTcLevel :: TcM TcLevel
getTcLevel = do { env <- getLclEnv
; return (tcl_tclvl env) }
setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel tclvl thing_inside
= updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM tv
= do { lvl <- getTcLevel
; return (isTouchableMetaTyVar lvl tv) }
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
setLclTypeEnv lcl_env thing_inside
= updLclEnv upd thing_inside
where
upd env = env { tcl_env = tcl_env lcl_env }
traceTcConstraints :: String -> TcM ()
traceTcConstraints msg
= do { lie_var <- getConstraintVar
; lie <- readTcRef lie_var
; traceOptTcRn Opt_D_dump_tc_trace $
hang (text (msg ++ ": LIE:")) 2 (ppr lie)
}
data IsExtraConstraint = YesExtraConstraint
| NoExtraConstraint
instance Outputable IsExtraConstraint where
ppr YesExtraConstraint = text "YesExtraConstraint"
ppr NoExtraConstraint = text "NoExtraConstraint"
emitAnonTypeHole :: IsExtraConstraint
-> TcTyVar -> TcM ()
emitAnonTypeHole extra_constraints tv
= do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing
; let hole = Hole { hole_sort = sort
, hole_occ = occ
, hole_ty = mkTyVarTy tv
, hole_loc = ct_loc }
; emitHole hole }
where
occ = mkTyVarOcc "_"
sort | YesExtraConstraint <- extra_constraints = ConstraintHole
| otherwise = TypeHole
emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
emitNamedTypeHole (name, tv)
= do { ct_loc <- setSrcSpan (nameSrcSpan name) $
getCtLocM (TypeHoleOrigin occ) Nothing
; let hole = Hole { hole_sort = TypeHole
, hole_occ = occ
, hole_ty = mkTyVarTy tv
, hole_loc = ct_loc }
; emitHole hole }
where
occ = nameOccName name
recordThUse :: TcM ()
recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
recordThSpliceUse :: TcM ()
recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()
recordThNeededRuntimeDeps new_links new_pkgs
= do { env <- getGblEnv
; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->
let links = new_links ++ needed_links
!pkgs = plusUDFM needed_pkgs new_pkgs
in (links, pkgs)
}
keepAlive :: Name -> TcRn ()
keepAlive name
= do { env <- getGblEnv
; traceRn "keep alive" (ppr name)
; updTcRef (tcg_keep env) (`extendNameSet` name) }
getStage :: TcM ThStage
getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel name
= do { env <- getLclEnv;
; case lookupNameEnv (tcl_th_bndrs env) name of
Nothing -> return Nothing
Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
setStage :: ThStage -> TcM a -> TcRn a
setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv mod_finalizers
= do lcl_env <- getLclEnv
th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
updTcRef th_modfinalizers_var $ \fins ->
(lcl_env, mod_finalizers) : fins
recordUnsafeInfer :: Messages TcRnMessage -> TcM ()
recordUnsafeInfer msgs =
getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False
writeTcRef (tcg_safe_infer_reasons env) msgs
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode dflags tcg_env = do
safeInf <- readIORef (tcg_safe_infer tcg_env)
return $ case safeHaskell dflags of
Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred
| otherwise -> Sf_None
s -> s
fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id
fixSafeInstances _ = map fixSafe
where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
in inst { is_flag = new_flag }
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv rdr_env thing_inside
= updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv
mkIfLclEnv mod loc boot
= IfLclEnv { if_mod = mod,
if_loc = loc,
if_boot = boot,
if_nsubst = Nothing,
if_implicits_env = Nothing,
if_tv_env = emptyFsEnv,
if_id_env = emptyFsEnv }
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn thing_inside
= do { tcg_env <- getGblEnv
; hsc_env <- getTopEnv
; let !mhome_unit = hsc_home_unit_maybe hsc_env
!knot_vars = tcg_type_env_var tcg_env
is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit)
; let { if_env = IfGblEnv {
if_doc = text "initIfaceTcRn",
if_rec_types =
if is_instantiate
then emptyKnotVars
else readTcRef <$> knot_vars
}
}
; setEnvs (if_env, ()) thing_inside }
initIfaceLoad :: HscEnv -> IfG a -> IO a
initIfaceLoad hsc_env do_this
= do let gbl_env = IfGblEnv {
if_doc = text "initIfaceLoad",
if_rec_types = emptyKnotVars
}
initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this
initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule hsc_env this_mod do_this
= do let gbl_env = IfGblEnv {
if_doc = text "initIfaceLoadModule",
if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)
}
initTcRnIf 'i' hsc_env gbl_env () do_this
initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck doc hsc_env do_this
= do let gbl_env = IfGblEnv {
if_doc = text "initIfaceCheck" <+> doc,
if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env
}
initTcRnIf 'i' hsc_env gbl_env () do_this
initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl mod loc_doc hi_boot_file thing_inside
= setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
= setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
getIfModule :: IfL Module
getIfModule = do { env <- getLclEnv; return (if_mod env) }
failIfM :: SDoc -> IfL a
failIfM msg = do
env <- getLclEnv
let full_msg = (if_loc env <> colon) $$ nest 2 msg
logger <- getLogger
liftIO (logMsg logger MCFatal
noSrcSpan $ withPprStyle defaultErrStyle full_msg)
failM
forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
= unsafeInterleaveM $ uninterruptibleMaskM_ $
do { traceIf (text "Starting fork {" <+> doc)
; mb_res <- tryM $
updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
thing_inside
; case mb_res of
Right r -> do { traceIf (text "} ending fork" <+> doc)
; return r }
Left exn -> do {
whenDOptM Opt_D_dump_if_trace $ do
logger <- getLogger
let msg = hang (text "forkM failed:" <+> doc)
2 (text (show exn))
liftIO $ logMsg logger
MCFatal
noSrcSpan
$ withPprStyle defaultErrStyle msg
; traceIf (text "} ending fork (badly)" <+> doc)
; pgmError "Cannot continue after interface file error" }
}
setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
{ if_implicits_env = Just tenv }) m
getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM get_ccs nm = do
env <- getGblEnv
let cc_st_ref = get_ccs env
cc_st <- readTcRef cc_st_ref
let (idx, cc_st') = getCCIndex nm cc_st
writeTcRef cc_st_ref cc_st'
return idx
getCCIndexTcM :: FastString -> TcM CostCentreIndex
getCCIndexTcM = getCCIndexM tcg_cc_st