{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Utils.Monad(
initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
discardResult,
getTopEnv, updTopEnv, getGblEnv, updGblEnv,
setGblEnv, getLclEnv, updLclEnv, setLclEnv,
getEnvs, setEnvs,
xoptM, doptM, goptM, woptM,
setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
whenDOptM, whenGOptM, whenWOptM,
whenXOptM, unlessXOptM,
getGhcMode,
withDynamicNow, withoutDynamicNow,
getEpsVar,
getEps,
updateEps, updateEps_,
getHpt, getEpsAndHpt,
newArrowScope, escapeArrowScope,
newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
newSysName, newSysLocalId, newSysLocalIds,
newTcRef, readTcRef, writeTcRef, updTcRef,
traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
dumpTcRn,
getPrintUnqualified,
printForUserTcRn,
traceIf, traceHiDiffs, 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,
mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError,
reportWarning, 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,
warnIfFlag, warnIf, warnTc, warnTcM,
addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
mkErrInfo,
newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
addTcEvBind, addTopEvBinds,
getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
chooseUniqueOccTc,
getConstraintVar, setConstraintVar,
emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
emitImplication, emitImplications, emitInsoluble,
emitHole, emitHoles,
discardConstraints, captureConstraints, tryCaptureConstraints,
pushLevelAndCaptureConstraints,
pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
getTcLevel, setTcLevel, isTouchableTcM,
getLclTypeEnv, setLclTypeEnv,
traceTcConstraints,
emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,
recordThUse, recordThSpliceUse,
keepAlive, getStage, getStageAndBindLevel, setStage,
addModFinalizersWithLclEnv,
recordUnsafeInfer, finalSafeMode, fixSafeInstances,
getLocalRdrEnv, setLocalRdrEnv,
mkIfLclEnv,
initIfaceTcRn,
initIfaceCheck,
initIfaceLcl,
initIfaceLclWithSubst,
initIfaceLoad,
getIfModule,
failIfM,
forkM_maybe,
forkM,
setImplicitEnvM,
withException,
getCCIndexM, getCCIndexTcM,
module GHC.Tc.Types,
module GHC.Data.IOEnv
) where
#include "GhclibHsVersions.h"
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.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.Ppr
import GHC.Driver.Session
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.Misc
import GHC.Utils.Logger
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.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 {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv )
import qualified Data.Map as Map
initTc :: HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTc :: forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTc HscEnv
hsc_env HscSource
hsc_src Bool
keep_rn_syntax Module
mod RealSrcSpan
loc TcM r
do_this
= do { IORef NameSet
keep_var <- forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet ;
IORef [GlobalRdrElt]
used_gre_var <- forall a. a -> IO (IORef a)
newIORef [] ;
IORef Bool
th_var <- forall a. a -> IO (IORef a)
newIORef Bool
False ;
IORef Bool
th_splice_var<- forall a. a -> IO (IORef a)
newIORef Bool
False ;
IORef (Bool, Bag (MsgEnvelope DecoratedSDoc))
infer_var <- forall a. a -> IO (IORef a)
newIORef (Bool
True, forall a. Bag a
emptyBag) ;
IORef OccSet
dfun_n_var <- forall a. a -> IO (IORef a)
newIORef OccSet
emptyOccSet ;
IORef TypeEnv
type_env_var <- case HscEnv -> Maybe (Module, IORef TypeEnv)
hsc_type_env_var HscEnv
hsc_env of {
Just (Module
_mod, IORef TypeEnv
te_var) -> forall (m :: * -> *) a. Monad m => a -> m a
return IORef TypeEnv
te_var ;
Maybe (Module, IORef TypeEnv)
Nothing -> forall a. a -> IO (IORef a)
newIORef forall a. NameEnv a
emptyNameEnv } ;
IORef [FilePath]
dependent_files_var <- forall a. a -> IO (IORef a)
newIORef [] ;
IORef WantedConstraints
static_wc_var <- forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC ;
IORef CostCentreState
cc_st_var <- forall a. a -> IO (IORef a)
newIORef CostCentreState
newCostCentreState ;
IORef [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
th_topdecls_var <- forall a. a -> IO (IORef a)
newIORef [] ;
IORef [(ForeignSrcLang, FilePath)]
th_foreign_files_var <- forall a. a -> IO (IORef a)
newIORef [] ;
IORef NameSet
th_topnames_var <- forall a. a -> IO (IORef a)
newIORef NameSet
emptyNameSet ;
IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- forall a. a -> IO (IORef a)
newIORef [] ;
IORef [FilePath]
th_coreplugins_var <- forall a. a -> IO (IORef a)
newIORef [] ;
IORef (Map TypeRep Dynamic)
th_state_var <- forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
Map.empty ;
IORef (Maybe (ForeignRef (IORef QState)))
th_remote_state_var <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing ;
IORef (Map DocLoc FilePath)
th_docs_var <- forall a. a -> IO (IORef a)
newIORef forall k a. Map k a
Map.empty ;
let {
!dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env ;
!home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env ;
maybe_rn_syntax :: forall a. a -> Maybe a ;
maybe_rn_syntax :: forall a. a -> Maybe a
maybe_rn_syntax a
empty_val
| DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_rn_ast DynFlags
dflags = forall a. a -> Maybe a
Just a
empty_val
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags = forall a. a -> Maybe a
Just a
empty_val
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Haddock DynFlags
dflags = forall a. a -> Maybe a
Just a
empty_val
| Bool
keep_rn_syntax = forall a. a -> Maybe a
Just a
empty_val
| Bool
otherwise = forall a. Maybe a
Nothing ;
gbl_env :: TcGblEnv
gbl_env = TcGblEnv {
tcg_th_topdecls :: TcRef [LHsDecl GhcPs]
tcg_th_topdecls = 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 FilePath)
tcg_th_docs = IORef (Map DocLoc FilePath)
th_docs_var,
tcg_mod :: Module
tcg_mod = Module
mod,
tcg_semantic_mod :: Module
tcg_semantic_mod = HomeUnit -> Module -> Module
homeModuleInstantiation HomeUnit
home_unit Module
mod,
tcg_src :: HscSource
tcg_src = HscSource
hsc_src,
tcg_rdr_env :: GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
emptyGlobalRdrEnv,
tcg_fix_env :: FixityEnv
tcg_fix_env = forall a. NameEnv a
emptyNameEnv,
tcg_field_env :: RecFieldEnv
tcg_field_env = forall a. NameEnv a
emptyNameEnv,
tcg_default :: Maybe [Type]
tcg_default = if forall unit. GenModule unit -> unit
moduleUnit Module
mod forall a. Eq a => a -> a -> Bool
== Unit
primUnit
Bool -> Bool -> Bool
|| forall unit. GenModule unit -> unit
moduleUnit Module
mod forall a. Eq a => a -> a -> Bool
== Unit
bignumUnit
then forall a. a -> Maybe a
Just []
else forall a. Maybe a
Nothing,
tcg_type_env :: TypeEnv
tcg_type_env = forall a. NameEnv a
emptyNameEnv,
tcg_type_env_var :: IORef TypeEnv
tcg_type_env_var = 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_exports :: [AvailInfo]
tcg_exports = [],
tcg_imports :: ImportAvails
tcg_imports = ImportAvails
emptyImportAvails,
tcg_used_gres :: IORef [GlobalRdrElt]
tcg_used_gres = IORef [GlobalRdrElt]
used_gre_var,
tcg_dus :: DefUses
tcg_dus = DefUses
emptyDUs,
tcg_rn_imports :: [LImportDecl GhcRn]
tcg_rn_imports = [],
tcg_rn_exports :: Maybe [(LIE GhcRn, [AvailInfo])]
tcg_rn_exports =
if HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
then forall a. a -> Maybe a
Just []
else forall a. a -> Maybe a
maybe_rn_syntax [],
tcg_rn_decls :: Maybe (HsGroup GhcRn)
tcg_rn_decls = forall a. a -> Maybe a
maybe_rn_syntax forall (p :: Pass). HsGroup (GhcPass p)
emptyRnGroup,
tcg_tr_module :: Maybe Id
tcg_tr_module = forall a. Maybe a
Nothing,
tcg_binds :: LHsBinds GhcTc
tcg_binds = 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 = forall a. Bag a
emptyBag,
tcg_warns :: Warnings
tcg_warns = Warnings
NoWarnings,
tcg_anns :: [Annotation]
tcg_anns = [],
tcg_tcs :: [TyCon]
tcg_tcs = [],
tcg_insts :: [ClsInst]
tcg_insts = [],
tcg_fam_insts :: [FamInst]
tcg_fam_insts = [],
tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [],
tcg_fords :: [LForeignDecl GhcTc]
tcg_fords = [],
tcg_patsyns :: [PatSyn]
tcg_patsyns = [],
tcg_merged :: [(Module, Fingerprint)]
tcg_merged = [],
tcg_dfun_n :: IORef OccSet
tcg_dfun_n = IORef OccSet
dfun_n_var,
tcg_keep :: IORef NameSet
tcg_keep = IORef NameSet
keep_var,
tcg_doc_hdr :: Maybe LHsDocString
tcg_doc_hdr = forall a. Maybe a
Nothing,
tcg_hpc :: Bool
tcg_hpc = Bool
False,
tcg_main :: Maybe Name
tcg_main = forall a. Maybe a
Nothing,
tcg_self_boot :: SelfBootInfo
tcg_self_boot = SelfBootInfo
NoSelfBoot,
tcg_safeInfer :: IORef (Bool, Bag (MsgEnvelope DecoratedSDoc))
tcg_safeInfer = IORef (Bool, Bag (MsgEnvelope DecoratedSDoc))
infer_var,
tcg_dependent_files :: IORef [FilePath]
tcg_dependent_files = IORef [FilePath]
dependent_files_var,
tcg_tc_plugins :: [TcPluginSolver]
tcg_tc_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
} ;
} ;
forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hsc_env TcGblEnv
gbl_env RealSrcSpan
loc TcM r
do_this
}
initTcWithGbl :: HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl :: forall r.
HscEnv
-> TcGblEnv
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, Maybe r)
initTcWithGbl HscEnv
hsc_env TcGblEnv
gbl_env RealSrcSpan
loc TcM r
do_this
= do { IORef WantedConstraints
lie_var <- forall a. a -> IO (IORef a)
newIORef WantedConstraints
emptyWC
; IORef (Messages DecoratedSDoc)
errs_var <- forall a. a -> IO (IORef a)
newIORef forall e. Messages e
emptyMessages
; IORef UsageEnv
usage_var <- forall a. a -> IO (IORef a)
newIORef UsageEnv
zeroUE
; let lcl_env :: TcLclEnv
lcl_env = TcLclEnv {
tcl_errs :: IORef (Messages DecoratedSDoc)
tcl_errs = IORef (Messages DecoratedSDoc)
errs_var,
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 = forall a. NameEnv a
emptyNameEnv,
tcl_arrow_ctxt :: ArrowCtxt
tcl_arrow_ctxt = ArrowCtxt
NoArrowCtxt,
tcl_env :: TcTypeEnv
tcl_env = forall a. NameEnv a
emptyNameEnv,
tcl_usage :: IORef UsageEnv
tcl_usage = IORef UsageEnv
usage_var,
tcl_bndrs :: TcBinderStack
tcl_bndrs = [],
tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie_var,
tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
topTcLevel
}
; Maybe r
maybe_res <- forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
initTcRnIf Char
'a' HscEnv
hsc_env TcGblEnv
gbl_env TcLclEnv
lcl_env forall a b. (a -> b) -> a -> b
$
do { Either IOEnvFailure r
r <- forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcM r
do_this
; case Either IOEnvFailure r
r of
Right r
res -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just r
res)
Left IOEnvFailure
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
; WantedConstraints
lie <- forall a. IORef a -> IO a
readIORef (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
lcl_env)
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe r
maybe_res Bool -> Bool -> Bool
&& Bool -> Bool
not (WantedConstraints -> Bool
isEmptyWC WantedConstraints
lie)) forall a b. (a -> b) -> a -> b
$
forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"initTc: unsolved constraints" (forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)
; Messages DecoratedSDoc
msgs <- forall a. IORef a -> IO a
readIORef (TcLclEnv -> IORef (Messages DecoratedSDoc)
tcl_errs TcLclEnv
lcl_env)
; let { final_res :: Maybe r
final_res | forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs = forall a. Maybe a
Nothing
| Bool
otherwise = Maybe r
maybe_res }
; forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DecoratedSDoc
msgs, Maybe r
final_res)
}
initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
initTcInteractive :: forall a. HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
initTcInteractive HscEnv
hsc_env TcM a
thing_inside
= forall r.
HscEnv
-> HscSource
-> Bool
-> Module
-> RealSrcSpan
-> TcM r
-> IO (Messages DecoratedSDoc, 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_mask HscEnv
hsc_env gbl
gbl_env lcl
lcl_env TcRnIf gbl lcl a
thing_inside
= do { let { env :: Env gbl lcl
env = Env { env_top :: HscEnv
env_top = HscEnv
hsc_env,
env_um :: Char
env_um = Char
uniq_mask,
env_gbl :: gbl
env_gbl = gbl
gbl_env,
env_lcl :: lcl
env_lcl = lcl
lcl_env} }
; 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
getTopEnv :: TcRnIf gbl lcl HscEnv
getTopEnv :: forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv = do { Env gbl lcl
env <- forall env. IOEnv env env
getEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (forall gbl lcl. Env gbl lcl -> HscEnv
env_top Env gbl lcl
env) }
updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv :: forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv HscEnv -> HscEnv
upd = 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 :: HscEnv
env_top = HscEnv -> HscEnv
upd HscEnv
top })
getGblEnv :: TcRnIf gbl lcl gbl
getGblEnv :: forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv = do { Env{gbl
lcl
Char
HscEnv
env_lcl :: lcl
env_gbl :: gbl
env_um :: Char
env_top :: HscEnv
env_lcl :: forall gbl lcl. Env gbl lcl -> lcl
env_gbl :: forall gbl lcl. Env gbl lcl -> gbl
env_um :: forall gbl lcl. Env gbl lcl -> Char
env_top :: forall gbl lcl. Env gbl lcl -> HscEnv
..} <- forall env. IOEnv env env
getEnv; forall (m :: * -> *) a. Monad m => a -> m a
return gbl
env_gbl }
updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv :: forall gbl lcl a.
(gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updGblEnv gbl -> gbl
upd = 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 :: gbl
env_gbl = gbl -> gbl
upd gbl
gbl })
setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv :: forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv gbl
gbl_env = 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_gbl = gbl
gbl_env })
getLclEnv :: TcRnIf gbl lcl lcl
getLclEnv :: forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv = do { Env{gbl
lcl
Char
HscEnv
env_lcl :: lcl
env_gbl :: gbl
env_um :: Char
env_top :: HscEnv
env_lcl :: forall gbl lcl. Env gbl lcl -> lcl
env_gbl :: forall gbl lcl. Env gbl lcl -> gbl
env_um :: forall gbl lcl. Env gbl lcl -> Char
env_top :: forall gbl lcl. Env gbl lcl -> HscEnv
..} <- forall env. IOEnv env env
getEnv; forall (m :: * -> *) a. Monad m => a -> m a
return lcl
env_lcl }
updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv :: forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv lcl -> lcl
upd = 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 :: lcl
env_lcl = lcl -> lcl
upd lcl
lcl })
setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv :: forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv lcl'
lcl_env = 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_lcl = lcl'
lcl_env })
getEnvs :: TcRnIf gbl lcl (gbl, lcl)
getEnvs :: forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs = do { Env gbl lcl
env <- forall env. IOEnv env env
getEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (forall gbl lcl. Env gbl lcl -> gbl
env_gbl Env gbl lcl
env, forall gbl lcl. Env gbl lcl -> lcl
env_lcl Env gbl lcl
env) }
setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs :: forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (gbl'
gbl_env, lcl'
lcl_env) = 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_gbl = gbl'
gbl_env, env_lcl :: lcl'
env_lcl = lcl'
lcl_env })
xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
xoptM :: forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag = do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; forall (m :: * -> *) a. Monad m => a -> m a
return (Extension -> DynFlags -> Bool
xopt Extension
flag DynFlags
dflags) }
doptM :: DumpFlag -> TcRnIf gbl lcl Bool
doptM :: forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
flag = do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; forall (m :: * -> *) a. Monad m => a -> m a
return (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
flag DynFlags
dflags) }
goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
goptM :: forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
flag = do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; forall (m :: * -> *) a. Monad m => a -> m a
return (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
flag DynFlags
dflags) }
woptM :: WarningFlag -> TcRnIf gbl lcl Bool
woptM :: forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
flag = do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags; forall (m :: * -> *) a. Monad m => a -> m a
return (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
flag DynFlags
dflags) }
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 =
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> Extension -> DynFlags
xopt_set (HscEnv -> DynFlags
hsc_dflags HscEnv
top) 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 =
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> Extension -> DynFlags
xopt_unset (HscEnv -> DynFlags
hsc_dflags HscEnv
top) 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 =
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> GeneralFlag -> DynFlags
gopt_unset (HscEnv -> DynFlags
hsc_dflags HscEnv
top) 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 =
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\HscEnv
top -> HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> WarningFlag -> DynFlags
wopt_unset (HscEnv -> DynFlags
hsc_dflags HscEnv
top) 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 Bool
b <- forall gbl lcl. DumpFlag -> TcRnIf gbl lcl Bool
doptM DumpFlag
flag
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- forall gbl lcl. GeneralFlag -> TcRnIf gbl lcl Bool
goptM GeneralFlag
flag
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
flag
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b TcRnIf gbl lcl ()
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 Bool
b <- forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
flag
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b TcRnIf gbl lcl ()
thing_inside
{-# INLINE unlessXOptM #-}
getGhcMode :: TcRnIf gbl lcl GhcMode
getGhcMode :: forall gbl lcl. TcRnIf gbl lcl GhcMode
getGhcMode = do { HscEnv
env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
env)) }
withDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withDynamicNow :: forall gbl lcl a. TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withDynamicNow =
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\top :: HscEnv
top@(HscEnv { hsc_dflags :: HscEnv -> DynFlags
hsc_dflags = DynFlags
dflags }) ->
HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags -> DynFlags
setDynamicNow DynFlags
dflags })
withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow :: forall gbl lcl a. TcRnIf gbl lcl a -> TcRnIf gbl lcl a
withoutDynamicNow =
forall gbl lcl a.
(HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updTopEnv (\top :: HscEnv
top@(HscEnv { hsc_dflags :: HscEnv -> DynFlags
hsc_dflags = DynFlags
dflags }) ->
HscEnv
top { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags { dynamicNow :: Bool
dynamicNow = Bool
False} })
getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar :: forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar = do { HscEnv
env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> TcRef ExternalPackageState
hsc_EPS HscEnv
env) }
getEps :: TcRnIf gbl lcl ExternalPackageState
getEps :: forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps = do { HscEnv
env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; forall a env. IORef a -> IOEnv env a
readMutVar (HscEnv -> TcRef ExternalPackageState
hsc_EPS HscEnv
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
forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text FilePath
"updating EPS")
TcRef ExternalPackageState
eps_var <- forall gbl lcl. TcRnIf gbl lcl (TcRef ExternalPackageState)
getEpsVar
forall a b env. IORef a -> (a -> (a, b)) -> IOEnv env b
atomicUpdMutVar' TcRef ExternalPackageState
eps_var ExternalPackageState -> (ExternalPackageState, a)
upd_fn
updateEps_ :: (ExternalPackageState -> ExternalPackageState)
-> TcRnIf gbl lcl ()
updateEps_ :: forall gbl lcl.
(ExternalPackageState -> ExternalPackageState) -> TcRnIf gbl lcl ()
updateEps_ ExternalPackageState -> ExternalPackageState
upd_fn = forall a gbl lcl.
(ExternalPackageState -> (ExternalPackageState, a))
-> TcRnIf gbl lcl a
updateEps (\ExternalPackageState
eps -> (ExternalPackageState -> ExternalPackageState
upd_fn ExternalPackageState
eps, ()))
getHpt :: TcRnIf gbl lcl HomePackageTable
getHpt :: forall gbl lcl. TcRnIf gbl lcl HomePackageTable
getHpt = do { HscEnv
env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv -> HomePackageTable
hsc_HPT HscEnv
env) }
getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt :: forall gbl lcl.
TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
getEpsAndHpt = do { HscEnv
env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; ExternalPackageState
eps <- forall a env. IORef a -> IOEnv env a
readMutVar (HscEnv -> TcRef ExternalPackageState
hsc_EPS HscEnv
env)
; forall (m :: * -> *) a. Monad m => a -> m a
return (ExternalPackageState
eps, HscEnv -> HomePackageTable
hsc_HPT HscEnv
env) }
withException :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException :: forall gbl lcl a.
TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a
withException TcRnIf gbl lcl (MaybeErr SDoc a)
do_this = do
MaybeErr SDoc a
r <- TcRnIf gbl lcl (MaybeErr SDoc a)
do_this
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case MaybeErr SDoc a
r of
Failed SDoc
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. GhcException -> IO a
throwGhcExceptionIO (FilePath -> GhcException
ProgramError (DynFlags -> SDoc -> FilePath
showSDoc DynFlags
dflags SDoc
err))
Succeeded a
result -> forall (m :: * -> *) a. Monad m => a -> m a
return a
result
newArrowScope :: TcM a -> TcM a
newArrowScope :: forall a. TcM a -> TcM a
newArrowScope
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv forall a b. (a -> b) -> a -> b
$ \TcLclEnv
env -> TcLclEnv
env { tcl_arrow_ctxt :: ArrowCtxt
tcl_arrow_ctxt = LocalRdrEnv -> IORef WantedConstraints -> ArrowCtxt
ArrowCtxt (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
env) (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
env) }
escapeArrowScope :: TcM a -> TcM a
escapeArrowScope :: forall a. TcM a -> TcM a
escapeArrowScope
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv forall a b. (a -> b) -> a -> b
$ \ TcLclEnv
env ->
case TcLclEnv -> ArrowCtxt
tcl_arrow_ctxt TcLclEnv
env of
ArrowCtxt
NoArrowCtxt -> TcLclEnv
env
ArrowCtxt LocalRdrEnv
rdr_env IORef WantedConstraints
lie -> TcLclEnv
env { tcl_arrow_ctxt :: ArrowCtxt
tcl_arrow_ctxt = ArrowCtxt
NoArrowCtxt
, tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie
, tcl_rdr :: LocalRdrEnv
tcl_rdr = LocalRdrEnv
rdr_env }
newUnique :: TcRnIf gbl lcl Unique
newUnique :: forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
= do { Env gbl lcl
env <- forall env. IOEnv env env
getEnv
; let mask :: Char
mask = forall gbl lcl. Env gbl lcl -> Char
env_um Env gbl lcl
env
; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$! Char -> IO Unique
uniqFromMask Char
mask }
newUniqueSupply :: TcRnIf gbl lcl UniqSupply
newUniqueSupply :: forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
= do { Env gbl lcl
env <- forall env. IOEnv env env
getEnv
; let mask :: Char
mask = forall gbl lcl. Env gbl lcl -> Char
env_um Env gbl lcl
env
; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$! Char -> IO UniqSupply
mkSplitUniqSupply Char
mask }
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 { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; OccName -> SrcSpan -> TcM Name
newNameAt OccName
occ SrcSpan
loc }
newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt :: OccName -> SrcSpan -> TcM Name
newNameAt OccName
occ SrcSpan
span
= do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
span) }
newSysName :: OccName -> TcRnIf gbl lcl Name
newSysName :: forall gbl lcl. OccName -> TcRnIf gbl lcl Name
newSysName OccName
occ
= do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> OccName -> Name
mkSystemName Unique
uniq OccName
occ) }
newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId
newSysLocalId :: forall gbl lcl. FastString -> Type -> Type -> TcRnIf gbl lcl Id
newSysLocalId FastString
fs Type
w Type
ty
= do { Unique
u <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> Unique -> Type -> Type -> Id
mkSysLocal FastString
fs Unique
u Type
w Type
ty) }
newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
newSysLocalIds :: forall gbl lcl. FastString -> [Scaled Type] -> TcRnIf gbl lcl [Id]
newSysLocalIds FastString
fs [Scaled Type]
tys
= do { UniqSupply
us <- forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
; let mkId' :: Unique -> Scaled Type -> Id
mkId' Unique
n (Scaled Type
w Type
t) = FastString -> Unique -> Type -> Type -> Id
mkSysLocal FastString
fs Unique
n Type
w Type
t
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Unique -> Scaled Type -> Id
mkId' (UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
us) [Scaled Type]
tys) }
instance MonadUnique (IOEnv (Env gbl lcl)) where
getUniqueM :: IOEnv (Env gbl lcl) Unique
getUniqueM = forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
getUniqueSupplyM :: IOEnv (Env gbl lcl) UniqSupply
getUniqueSupplyM = forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
newTcRef :: forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef = forall a env. a -> IOEnv env (IORef a)
newMutVar
readTcRef :: TcRef a -> TcRnIf gbl lcl a
readTcRef :: forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef = forall a env. IORef a -> IOEnv env a
readMutVar
writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef :: forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef = forall a env. IORef a -> a -> IOEnv env ()
writeMutVar
updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef :: forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef TcRef a
ref a -> a
fn = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' TcRef a
ref a -> a
fn
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
text FilePath
herald) Int
2 SDoc
doc
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
traceOptTcRn :: DumpFlag -> SDoc -> TcM ()
traceOptTcRn DumpFlag
flag SDoc
doc =
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag 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 =
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag 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
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
PrintUnqualified
printer <- TcRn PrintUnqualified
getPrintUnqualified
SDoc
real_doc <- SDoc -> TcRn SDoc
wrapDocLoc SDoc
doc
let sty :: PprStyle
sty = if Bool
useUserStyle
then PrintUnqualified -> Depth -> PprStyle
mkUserStyle PrintUnqualified
printer Depth
AllTheWay
else PrintUnqualified -> PprStyle
mkDumpStyle PrintUnqualified
printer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpAction
putDumpMsg Logger
logger DynFlags
dflags PprStyle
sty DumpFlag
flag FilePath
title DumpFormat
fmt SDoc
real_doc
wrapDocLoc :: SDoc -> TcRn SDoc
wrapDocLoc :: SDoc -> TcRn SDoc
wrapDocLoc SDoc
doc = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if DynFlags -> Bool
hasPprDebug DynFlags
dflags
then do
SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
forall (m :: * -> *) a. Monad m => a -> m a
return (Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput SrcSpan
loc SDoc
doc)
else
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
doc
getPrintUnqualified :: TcRn PrintUnqualified
getPrintUnqualified :: TcRn PrintUnqualified
getPrintUnqualified
= do { GlobalRdrEnv
rdr_env <- TcRn GlobalRdrEnv
getGlobalRdrEnv
; HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env }
printForUserTcRn :: SDoc -> TcRn ()
printForUserTcRn :: SDoc -> TcM ()
printForUserTcRn SDoc
doc = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
PrintUnqualified
printer <- TcRn PrintUnqualified
getPrintUnqualified
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser Logger
logger DynFlags
dflags PrintUnqualified
printer SDoc
doc)
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf :: forall m n. SDoc -> TcRnIf m n ()
traceIf = forall m n. DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf DumpFlag
Opt_D_dump_if_trace
traceHiDiffs :: forall m n. SDoc -> TcRnIf m n ()
traceHiDiffs = forall m n. DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf DumpFlag
Opt_D_dump_hi_diffs
{-# INLINE traceIf #-}
{-# INLINE traceHiDiffs #-}
traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf :: forall m n. DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf DumpFlag
flag SDoc
doc
= forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
flag forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags SDoc
doc)
{-# INLINE traceOptIf #-}
getIsGHCi :: TcRn Bool
getIsGHCi :: TcRn Bool
getIsGHCi = do { Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> Bool
isInteractiveModule Module
mod) }
getGHCiMonad :: TcRn Name
getGHCiMonad :: TcM Name
getGHCiMonad = do { HscEnv
hsc <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> Name
ic_monad forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) }
getInteractivePrintName :: TcRn Name
getInteractivePrintName :: TcM Name
getInteractivePrintName = do { HscEnv
hsc <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (InteractiveContext -> Name
ic_int_print forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc) }
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig :: TcRn Bool
tcIsHsBootOrSig = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> Bool
isHsBootOrSig (TcGblEnv -> HscSource
tcg_src TcGblEnv
env)) }
tcIsHsig :: TcRn Bool
tcIsHsig :: TcRn Bool
tcIsHsig = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (HscSource -> Bool
isHsigFile (TcGblEnv -> HscSource
tcg_src TcGblEnv
env)) }
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo :: TcRn SelfBootInfo
tcSelfBootInfo = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> SelfBootInfo
tcg_self_boot TcGblEnv
env) }
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv :: TcRn GlobalRdrEnv
getGlobalRdrEnv = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
env) }
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
getRdrEnvs = do { (TcGblEnv
gbl,TcLclEnv
lcl) <- forall gbl lcl. TcRnIf gbl lcl (gbl, lcl)
getEnvs; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> GlobalRdrEnv
tcg_rdr_env TcGblEnv
gbl, TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
lcl) }
getImports :: TcRn ImportAvails
getImports :: TcRn ImportAvails
getImports = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
env) }
getFixityEnv :: TcRn FixityEnv
getFixityEnv :: TcRn FixityEnv
getFixityEnv = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
env) }
extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
extendFixityEnv :: forall a. [(Name, FixItem)] -> RnM a -> RnM a
extendFixityEnv [(Name, FixItem)]
new_bit
= 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 :: FixityEnv
tcg_fix_env = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList FixityEnv
old_fix_env [(Name, FixItem)]
new_bit})
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv :: TcRn RecFieldEnv
getRecFieldEnv = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> RecFieldEnv
tcg_field_env TcGblEnv
env) }
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys :: TcRn (Maybe [Type])
getDeclaredDefaultTys = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> Maybe [Type]
tcg_default TcGblEnv
env) }
addDependentFiles :: [FilePath] -> TcRn ()
addDependentFiles :: [FilePath] -> TcM ()
addDependentFiles [FilePath]
fs = do
IORef [FilePath]
ref <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> IORef [FilePath]
tcg_dependent_files forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
[FilePath]
dep_files <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef [FilePath]
ref
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef [FilePath]
ref ([FilePath]
fs forall a. [a] -> [a] -> [a]
++ [FilePath]
dep_files)
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM :: TcRn SrcSpan
getSrcSpanM = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
env) forall a. Maybe a
Nothing) }
inGeneratedCode :: TcRn Bool
inGeneratedCode :: TcRn Bool
inGeneratedCode = TcLclEnv -> Bool
tcl_in_gen_code forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_loc :: RealSrcSpan
tcl_loc = RealSrcSpan
loc, tcl_in_gen_code :: Bool
tcl_in_gen_code = Bool
False })
TcRn a
thing_inside
setSrcSpan loc :: SrcSpan
loc@(UnhelpfulSpan UnhelpfulSpanReason
_) TcRn a
thing_inside
| SrcSpan -> Bool
isGeneratedSrcSpan SrcSpan
loc
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_in_gen_code :: Bool
tcl_in_gen_code = Bool
True }) TcRn a
thing_inside
| Bool
otherwise
= TcRn a
thing_inside
setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA :: forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
l = forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' ann
l)
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM :: forall a b. (a -> TcM b) -> Located a -> TcM b
addLocM a -> TcM b
fn (L SrcSpan
loc a
a) = forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ a -> TcM b
fn a
a
addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA :: forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA a -> TcM b
fn (L SrcSpanAnn' ann
loc a
a) = forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc forall a b. (a -> b) -> a -> b
$ a -> TcM b
fn a
a
wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM :: forall a b. (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM a -> TcM b
fn (L SrcSpan
loc a
a) = forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ do { b
b <- a -> TcM b
fn a
a
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpan
loc b
b) }
wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
wrapLocAM :: forall a b an. (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
wrapLocAM a -> TcM b
fn (L SrcAnn an
loc a
a) = forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcAnn an
loc forall a b. (a -> b) -> a -> b
$ do { b
b <- a -> TcM b
fn a
a
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcAnn an
loc) b
b) }
wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA :: forall a b ann.
(a -> TcM b)
-> GenLocated (SrcSpanAnn' ann) a
-> TcRn (GenLocated (SrcSpanAnn' ann) b)
wrapLocMA a -> TcM b
fn (L SrcSpanAnn' ann
loc a
a) = forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnn' ann
loc forall a b. (a -> b) -> a -> b
$ do { b
b <- a -> TcM b
fn a
a
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' ann
loc b
b) }
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM :: forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (Located b, c)
wrapLocFstM a -> TcM (b, c)
fn (L SrcSpan
loc a
a) =
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ do
(b
b,c
c) <- a -> TcM (b, c)
fn a
a
forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpan
loc b
b, c
c)
wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA :: forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)
wrapLocFstMA a -> TcM (b, c)
fn (L SrcSpanAnnA
loc a
a) =
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ do
(b
b,c
c) <- a -> TcM (b, c)
fn a
a
forall (m :: * -> *) a. Monad m => a -> m a
return (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc b
b, c
c)
wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM :: forall a b c. (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM a -> TcM (b, c)
fn (L SrcSpan
loc a
a) =
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ do
(b
b,c
c) <- a -> TcM (b, c)
fn a
a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, forall l e. l -> e -> GenLocated l e
L SrcSpan
loc c
c)
wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)
wrapLocSndMA :: forall a b c.
(a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)
wrapLocSndMA a -> TcM (b, c)
fn (L SrcSpanAnnA
loc a
a) =
forall ann a. SrcSpanAnn' ann -> TcRn a -> TcRn a
setSrcSpanA SrcSpanAnnA
loc forall a b. (a -> b) -> a -> b
$ do
(b
b,c
c) <- a -> TcM (b, c)
fn a
a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc c
c)
wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
wrapLocM_ :: forall a. (a -> TcM ()) -> Located a -> TcM ()
wrapLocM_ a -> TcM ()
fn (L SrcSpan
loc a
a) = 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) = forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (a -> TcM ()
fn a
a)
getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc))
getErrsVar :: TcRn (IORef (Messages DecoratedSDoc))
getErrsVar = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> IORef (Messages DecoratedSDoc)
tcl_errs TcLclEnv
env) }
setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a
setErrsVar :: forall a. IORef (Messages DecoratedSDoc) -> TcRn a -> TcRn a
setErrsVar IORef (Messages DecoratedSDoc)
v = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_errs :: IORef (Messages DecoratedSDoc)
tcl_errs = IORef (Messages DecoratedSDoc)
v })
addErr :: SDoc -> TcRn ()
addErr :: SDoc -> TcM ()
addErr SDoc
msg = do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM; SrcSpan -> SDoc -> TcM ()
addErrAt SrcSpan
loc SDoc
msg }
failWith :: SDoc -> TcRn a
failWith :: forall a. SDoc -> TcRn a
failWith SDoc
msg = SDoc -> TcM ()
addErr SDoc
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall env a. IOEnv env a
failM
failAt :: SrcSpan -> SDoc -> TcRn a
failAt :: forall a. SrcSpan -> SDoc -> TcRn a
failAt SrcSpan
loc SDoc
msg = SrcSpan -> SDoc -> TcM ()
addErrAt SrcSpan
loc SDoc
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall env a. IOEnv env a
failM
addErrAt :: SrcSpan -> SDoc -> TcRn ()
addErrAt :: SrcSpan -> SDoc -> TcM ()
addErrAt SrcSpan
loc SDoc
msg = do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt
; TidyEnv
tidy_env <- TcM TidyEnv
tcInitTidyEnv
; SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
tidy_env [ErrCtxt]
ctxt
; SrcSpan -> SDoc -> SDoc -> TcM ()
addLongErrAt SrcSpan
loc SDoc
msg SDoc
err_info }
addErrs :: [(SrcSpan,SDoc)] -> TcRn ()
addErrs :: [(SrcSpan, SDoc)] -> TcM ()
addErrs [(SrcSpan, SDoc)]
msgs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SrcSpan, SDoc) -> TcM ()
add [(SrcSpan, SDoc)]
msgs
where
add :: (SrcSpan, SDoc) -> TcM ()
add (SrcSpan
loc,SDoc
msg) = SrcSpan -> SDoc -> TcM ()
addErrAt SrcSpan
loc SDoc
msg
checkErr :: Bool -> SDoc -> TcRn ()
checkErr :: Bool -> SDoc -> TcM ()
checkErr Bool
ok SDoc
msg = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (SDoc -> TcM ()
addErr SDoc
msg)
addMessages :: Messages DecoratedSDoc -> TcRn ()
addMessages :: Messages DecoratedSDoc -> TcM ()
addMessages Messages DecoratedSDoc
msgs1
= do { IORef (Messages DecoratedSDoc)
errs_var <- TcRn (IORef (Messages DecoratedSDoc))
getErrsVar ;
Messages DecoratedSDoc
msgs0 <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages DecoratedSDoc)
errs_var ;
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Messages DecoratedSDoc)
errs_var (forall e. Messages e -> Messages e -> Messages e
unionMessages Messages DecoratedSDoc
msgs0 Messages DecoratedSDoc
msgs1) }
discardWarnings :: TcRn a -> TcRn a
discardWarnings :: forall a. TcM a -> TcM a
discardWarnings TcRn a
thing_inside
= do { IORef (Messages DecoratedSDoc)
errs_var <- TcRn (IORef (Messages DecoratedSDoc))
getErrsVar
; Bag (MsgEnvelope DecoratedSDoc)
old_warns <- forall e. Messages e -> Bag (MsgEnvelope e)
getWarningMessages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages DecoratedSDoc)
errs_var
; a
result <- TcRn a
thing_inside
; Bag (MsgEnvelope DecoratedSDoc)
new_errs <- forall e. Messages e -> Bag (MsgEnvelope e)
getErrorMessages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages DecoratedSDoc)
errs_var
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Messages DecoratedSDoc)
errs_var forall a b. (a -> b) -> a -> b
$ forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope DecoratedSDoc)
old_warns forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (MsgEnvelope DecoratedSDoc)
new_errs)
; forall (m :: * -> *) a. Monad m => a -> m a
return a
result }
mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)
mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)
mkLongErrAt SrcSpan
loc SDoc
msg SDoc
extra
= do { PrintUnqualified
printer <- TcRn PrintUnqualified
getPrintUnqualified ;
UnitState
unit_state <- HscEnv -> UnitState
hsc_units forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv ;
let msg' :: SDoc
msg' = UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state SDoc
msg in
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SrcSpan
-> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
mkLongMsgEnvelope SrcSpan
loc PrintUnqualified
printer SDoc
msg' SDoc
extra }
mkDecoratedSDocAt :: SrcSpan
-> SDoc
-> SDoc
-> SDoc
-> TcRn (MsgEnvelope DecoratedSDoc)
mkDecoratedSDocAt :: SrcSpan -> SDoc -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)
mkDecoratedSDocAt SrcSpan
loc SDoc
important SDoc
context SDoc
extra
= do { PrintUnqualified
printer <- TcRn PrintUnqualified
getPrintUnqualified ;
UnitState
unit_state <- HscEnv -> UnitState
hsc_units forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv ;
let f :: SDoc -> SDoc
f = UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state
errDoc :: [SDoc]
errDoc = [SDoc
important, SDoc
context, SDoc
extra]
errDoc' :: DecoratedSDoc
errDoc' = [SDoc] -> DecoratedSDoc
mkDecorated forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SDoc -> SDoc
f [SDoc]
errDoc
in
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErr SrcSpan
loc PrintUnqualified
printer DecoratedSDoc
errDoc' }
addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()
addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcM ()
addLongErrAt SrcSpan
loc SDoc
msg SDoc
extra = SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)
mkLongErrAt SrcSpan
loc SDoc
msg SDoc
extra forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MsgEnvelope DecoratedSDoc -> TcM ()
reportError
reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM ()
reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM ()
reportErrors = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MsgEnvelope DecoratedSDoc -> TcM ()
reportError
reportError :: MsgEnvelope DecoratedSDoc -> TcRn ()
reportError :: MsgEnvelope DecoratedSDoc -> TcM ()
reportError MsgEnvelope DecoratedSDoc
err
= do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"Adding error:" (forall e. RenderableDiagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope MsgEnvelope DecoratedSDoc
err) ;
IORef (Messages DecoratedSDoc)
errs_var <- TcRn (IORef (Messages DecoratedSDoc))
getErrsVar ;
Messages DecoratedSDoc
msgs <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages DecoratedSDoc)
errs_var ;
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Messages DecoratedSDoc)
errs_var (MsgEnvelope DecoratedSDoc
err forall e. MsgEnvelope e -> Messages e -> Messages e
`addMessage` Messages DecoratedSDoc
msgs) }
reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn ()
reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcM ()
reportWarning WarnReason
reason MsgEnvelope DecoratedSDoc
err
= do { let warn :: MsgEnvelope DecoratedSDoc
warn = forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning WarnReason
reason MsgEnvelope DecoratedSDoc
err
; FilePath -> SDoc -> TcM ()
traceTc FilePath
"Adding warning:" (forall e. RenderableDiagnostic e => MsgEnvelope e -> SDoc
pprLocMsgEnvelope MsgEnvelope DecoratedSDoc
warn)
; IORef (Messages DecoratedSDoc)
errs_var <- TcRn (IORef (Messages DecoratedSDoc))
getErrsVar
; (Bag (MsgEnvelope DecoratedSDoc)
warns, Bag (MsgEnvelope DecoratedSDoc)
errs) <- forall e. Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
partitionMessages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages DecoratedSDoc)
errs_var
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef (Messages DecoratedSDoc)
errs_var (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ (Bag (MsgEnvelope DecoratedSDoc)
warns forall a. Bag a -> a -> Bag a
`snocBag` MsgEnvelope DecoratedSDoc
warn) forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (MsgEnvelope DecoratedSDoc)
errs) }
checkNoErrs :: TcM r -> TcM r
checkNoErrs :: forall a. TcM a -> TcM a
checkNoErrs TcM r
main
= do { (r
res, Bool
no_errs) <- forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcM r
main
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
no_errs forall env a. IOEnv env a
failM
; forall (m :: * -> *) a. Monad m => a -> m a
return r
res }
whenNoErrs :: TcM () -> TcM ()
whenNoErrs :: TcM () -> TcM ()
whenNoErrs TcM ()
thing = forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM (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 { IORef (Messages DecoratedSDoc)
errs_var <- TcRn (IORef (Messages DecoratedSDoc))
getErrsVar ;
Messages DecoratedSDoc
msgs <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages DecoratedSDoc)
errs_var ;
if forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs then
TcRn r
bale_out
else
TcRn r
normal }
failIfErrsM :: TcRn ()
failIfErrsM :: TcM ()
failIfErrsM = forall r. TcRn r -> TcRn r -> TcRn r
ifErrsM forall env a. IOEnv env a
failM (forall (m :: * -> *) a. Monad m => a -> m a
return ())
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt :: TcM [ErrCtxt]
getErrCtxt = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> [ErrCtxt]
tcl_ctxt TcLclEnv
env) }
setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
{-# INLINE setErrCtxt #-}
setErrCtxt :: forall a. [ErrCtxt] -> TcM a -> TcM a
setErrCtxt [ErrCtxt]
ctxt = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_ctxt :: [ErrCtxt]
tcl_ctxt = [ErrCtxt]
ctxt })
addErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addErrCtxt #-}
addErrCtxt :: forall a. SDoc -> TcM a -> TcM a
addErrCtxt SDoc
msg = forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (\TidyEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SDoc
msg))
addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addErrCtxtM #-}
addErrCtxtM :: forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM TidyEnv -> TcM (TidyEnv, SDoc)
ctxt = forall a. ErrCtxt -> TcM a -> TcM a
pushCtxt (Bool
False, TidyEnv -> TcM (TidyEnv, SDoc)
ctxt)
addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxt #-}
addLandmarkErrCtxt :: forall a. SDoc -> TcM a -> TcM a
addLandmarkErrCtxt SDoc
msg = forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM (\TidyEnv
env -> forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
env, SDoc
msg))
addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
{-# INLINE addLandmarkErrCtxtM #-}
addLandmarkErrCtxtM :: forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addLandmarkErrCtxtM TidyEnv -> TcM (TidyEnv, SDoc)
ctxt = forall a. ErrCtxt -> TcM a -> TcM a
pushCtxt (Bool
True, TidyEnv -> TcM (TidyEnv, SDoc)
ctxt)
pushCtxt :: ErrCtxt -> TcM a -> TcM a
{-# INLINE pushCtxt #-}
pushCtxt :: forall a. ErrCtxt -> TcM a -> TcM a
pushCtxt ErrCtxt
ctxt = 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 env :: TcLclEnv
env@(TcLclEnv { tcl_ctxt :: TcLclEnv -> [ErrCtxt]
tcl_ctxt = [ErrCtxt]
ctxts, tcl_in_gen_code :: TcLclEnv -> Bool
tcl_in_gen_code = Bool
in_gen })
| Bool
in_gen = TcLclEnv
env
| Bool
otherwise = TcLclEnv
env { tcl_ctxt :: [ErrCtxt]
tcl_ctxt = ErrCtxt
ctxt forall a. a -> [a] -> [a]
: [ErrCtxt]
ctxts }
popErrCtxt :: TcM a -> TcM a
popErrCtxt :: forall a. TcM a -> TcM a
popErrCtxt = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ env :: TcLclEnv
env@(TcLclEnv { tcl_ctxt :: TcLclEnv -> [ErrCtxt]
tcl_ctxt = [ErrCtxt]
ctxt }) ->
TcLclEnv
env { tcl_ctxt :: [ErrCtxt]
tcl_ctxt = forall {a}. [a] -> [a]
pop [ErrCtxt]
ctxt })
where
pop :: [a] -> [a]
pop [] = []
pop (a
_:[a]
msgs) = [a]
msgs
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
origin Maybe TypeOrKind
t_or_k
= do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (CtLoc { ctl_origin :: CtOrigin
ctl_origin = CtOrigin
origin
, ctl_env :: TcLclEnv
ctl_env = TcLclEnv
env
, ctl_t_or_k :: Maybe TypeOrKind
ctl_t_or_k = Maybe TypeOrKind
t_or_k
, ctl_depth :: SubGoalDepth
ctl_depth = SubGoalDepth
initialSubGoalDepth }) }
setCtLocM :: CtLoc -> TcM a -> TcM a
setCtLocM :: forall a. CtLoc -> TcM a -> TcM a
setCtLocM (CtLoc { ctl_env :: CtLoc -> TcLclEnv
ctl_env = TcLclEnv
lcl }) TcM a
thing_inside
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_loc :: RealSrcSpan
tcl_loc = TcLclEnv -> RealSrcSpan
tcl_loc TcLclEnv
lcl
, tcl_bndrs :: TcBinderStack
tcl_bndrs = TcLclEnv -> TcBinderStack
tcl_bndrs TcLclEnv
lcl
, tcl_ctxt :: [ErrCtxt]
tcl_ctxt = TcLclEnv -> [ErrCtxt]
tcl_ctxt TcLclEnv
lcl })
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 IOEnvFailure r
either_res <- forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM TcRn r
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return (case Either IOEnvFailure r
either_res of
Left IOEnvFailure
_ -> forall a. Maybe a
Nothing
Right r
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 { IORef WantedConstraints
lie_var <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef WantedConstraints
emptyWC
; r
res <- forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie_var }) forall a b. (a -> b) -> a -> b
$
TcM r
thing_inside
; WantedConstraints
lie <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef WantedConstraints
lie_var
; forall (m :: * -> *) a. Monad m => a -> m a
return (r
res, WantedConstraints
lie) }
capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc)
capture_messages :: forall r. TcM r -> TcM (r, Messages DecoratedSDoc)
capture_messages TcM r
thing_inside
= do { IORef (Messages DecoratedSDoc)
msg_var <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef forall e. Messages e
emptyMessages
; r
res <- forall a. IORef (Messages DecoratedSDoc) -> TcRn a -> TcRn a
setErrsVar IORef (Messages DecoratedSDoc)
msg_var TcM r
thing_inside
; Messages DecoratedSDoc
msgs <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef (Messages DecoratedSDoc)
msg_var
; forall (m :: * -> *) a. Monad m => a -> m a
return (r
res, Messages DecoratedSDoc
msgs) }
askNoErrs :: TcRn a -> TcRn (a, Bool)
askNoErrs :: forall a. TcRn a -> TcRn (a, Bool)
askNoErrs TcRn a
thing_inside
= do { ((Maybe a
mb_res, WantedConstraints
lie), Messages DecoratedSDoc
msgs) <- forall r. TcM r -> TcM (r, Messages DecoratedSDoc)
capture_messages forall a b. (a -> b) -> a -> b
$
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints forall a b. (a -> b) -> a -> b
$
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcRn a
thing_inside
; Messages DecoratedSDoc -> TcM ()
addMessages Messages DecoratedSDoc
msgs
; case Maybe a
mb_res of
Maybe a
Nothing -> do { WantedConstraints -> TcM ()
emitConstraints (WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie)
; forall env a. IOEnv env a
failM }
Just a
res -> do { WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie
; let errs_found :: Bool
errs_found = forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs
Bool -> Bool -> Bool
|| WantedConstraints -> Bool
insolubleWC WantedConstraints
lie
; 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 { (Maybe a
mb_res, WantedConstraints
lie) <- forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints forall a b. (a -> b) -> a -> b
$
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM a
thing_inside
; let lie_to_keep :: WantedConstraints
lie_to_keep = case Maybe a
mb_res of
Maybe a
Nothing -> WantedConstraints -> WantedConstraints
dropMisleading WantedConstraints
lie
Just {} -> WantedConstraints
lie
; forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
mb_res, WantedConstraints
lie_to_keep) }
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
captureConstraints :: forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside
= do { (Maybe a
mb_res, WantedConstraints
lie) <- forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcM a
thing_inside
; case Maybe a
mb_res of
Maybe a
Nothing -> do { WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie; forall env a. IOEnv env a
failM }
Just a
res -> 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 { TcLclEnv
env0 <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; IORef UsageEnv
local_usage_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef UsageEnv
zeroUE
; let env1 :: TcLclEnv
env1 = TcLclEnv
env0 { tcl_usage :: IORef UsageEnv
tcl_usage = IORef UsageEnv
local_usage_ref }
; a
result <- forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv TcLclEnv
env1 TcM a
thing_inside
; UsageEnv
local_usage <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef UsageEnv
local_usage_ref
; forall (m :: * -> *) a. Monad m => a -> m a
return (UsageEnv
local_usage,a
result) }
tcScalingUsage :: Mult -> TcM a -> TcM a
tcScalingUsage :: forall a. Type -> TcM a -> TcM a
tcScalingUsage Type
mult TcM a
thing_inside
= do { (UsageEnv
usage, a
result) <- forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage TcM a
thing_inside
; FilePath -> SDoc -> TcM ()
traceTc FilePath
"tcScalingUsage" (forall a. Outputable a => a -> SDoc
ppr Type
mult)
; UsageEnv -> TcM ()
tcEmitBindingUsage forall a b. (a -> b) -> a -> b
$ Type -> UsageEnv -> UsageEnv
scaleUE Type
mult UsageEnv
usage
; forall (m :: * -> *) a. Monad m => a -> m a
return a
result }
tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage :: UsageEnv -> TcM ()
tcEmitBindingUsage UsageEnv
ue
= do { TcLclEnv
lcl_env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let usage :: IORef UsageEnv
usage = TcLclEnv -> IORef UsageEnv
tcl_usage TcLclEnv
lcl_env
; forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef UsageEnv
usage (UsageEnv -> UsageEnv -> UsageEnv
addUE UsageEnv
ue) }
attemptM :: TcRn r -> TcRn (Maybe r)
attemptM :: forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing_inside
= do { (Maybe r
mb_r, WantedConstraints
lie) <- forall a. TcM a -> TcM (Maybe a, WantedConstraints)
tryCaptureConstraints TcRn r
thing_inside
; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe r
mb_r) forall a b. (a -> b) -> a -> b
$
FilePath -> SDoc -> TcM ()
traceTc FilePath
"attemptM recovering with insoluble constraints" forall a b. (a -> b) -> a -> b
$
(forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)
; forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
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 { Maybe r
mb_res <- forall r. TcRn r -> TcRn (Maybe r)
attemptM TcRn r
thing ;
case Maybe r
mb_res of
Maybe r
Nothing -> TcRn r
recover
Just r
res -> 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 { [Maybe b]
mb_rs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall r. TcRn r -> TcRn (Maybe r)
attemptM forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
xs
; forall (m :: * -> *) a. Monad m => a -> m a
return [b
r | Just b
r <- [Maybe b]
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 { [Maybe b]
mb_rs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall r. TcRn r -> TcRn (Maybe r)
attemptM forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TcRn b
f) [a]
xs
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isNothing [Maybe b]
mb_rs) forall env a. IOEnv env a
failM
; forall (m :: * -> *) a. Monad m => a -> m a
return [b
r | Just b
r <- [Maybe b]
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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return b
acc
foldAndRecoverM b -> a -> TcRn b
f b
acc (a
x:[a]
xs) =
do { Maybe b
mb_r <- forall r. TcRn r -> TcRn (Maybe r)
attemptM (b -> a -> TcRn b
f b
acc a
x)
; case Maybe b
mb_r of
Maybe b
Nothing -> forall b a. (b -> a -> TcRn b) -> b -> [a] -> TcRn b
foldAndRecoverM b -> a -> TcRn b
f b
acc [a]
xs
Just b
acc' -> 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 DecoratedSDoc)
tryTc :: forall a. TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)
tryTc TcRn a
thing_inside
= forall r. TcM r -> TcM (r, Messages DecoratedSDoc)
capture_messages (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 { IORef (Messages DecoratedSDoc)
errs_var <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef forall e. Messages e
emptyMessages
; forall a. IORef (Messages DecoratedSDoc) -> TcRn a -> TcRn a
setErrsVar IORef (Messages DecoratedSDoc)
errs_var TcRn a
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 { ((Maybe r
mb_res, WantedConstraints
lie), Messages DecoratedSDoc
msgs) <- forall r. TcM r -> TcM (r, Messages DecoratedSDoc)
capture_messages forall a b. (a -> b) -> a -> b
$
forall r. TcM r -> TcM (r, WantedConstraints)
capture_constraints forall a b. (a -> b) -> a -> b
$
forall r. TcRn r -> TcRn (Maybe r)
tcTryM TcM r
thing_inside
; case Maybe r
mb_res of
Just r
res | Bool -> Bool
not (forall e. Messages e -> Bool
errorsFound Messages DecoratedSDoc
msgs)
, Bool -> Bool
not (WantedConstraints -> Bool
insolubleWC WantedConstraints
lie)
->
do { Messages DecoratedSDoc -> TcM ()
addMessages Messages DecoratedSDoc
msgs
; WantedConstraints -> TcM ()
emitConstraints WantedConstraints
lie
; forall (m :: * -> *) a. Monad m => a -> m a
return r
res }
Maybe r
_ ->
TcM r
recover
}
addErrTc :: SDoc -> TcM ()
addErrTc :: SDoc -> TcM ()
addErrTc SDoc
err_msg = do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv
; (TidyEnv, SDoc) -> TcM ()
addErrTcM (TidyEnv
env0, SDoc
err_msg) }
addErrTcM :: (TidyEnv, SDoc) -> TcM ()
addErrTcM :: (TidyEnv, SDoc) -> TcM ()
addErrTcM (TidyEnv
tidy_env, SDoc
err_msg)
= do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt ;
SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM ;
TidyEnv -> SDoc -> SrcSpan -> [ErrCtxt] -> TcM ()
add_err_tcm TidyEnv
tidy_env SDoc
err_msg SrcSpan
loc [ErrCtxt]
ctxt }
failWithTc :: SDoc -> TcM a
failWithTc :: forall a. SDoc -> TcRn a
failWithTc SDoc
err_msg
= SDoc -> TcM ()
addErrTc SDoc
err_msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall env a. IOEnv env a
failM
failWithTcM :: (TidyEnv, SDoc) -> TcM a
failWithTcM :: forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv, SDoc)
local_and_msg
= (TidyEnv, SDoc) -> TcM ()
addErrTcM (TidyEnv, SDoc)
local_and_msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall env a. IOEnv env a
failM
checkTc :: Bool -> SDoc -> TcM ()
checkTc :: Bool -> SDoc -> TcM ()
checkTc Bool
True SDoc
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkTc Bool
False SDoc
err = forall a. SDoc -> TcRn a
failWithTc SDoc
err
checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()
checkTcM Bool
True (TidyEnv, SDoc)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkTcM Bool
False (TidyEnv, SDoc)
err = forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv, SDoc)
err
failIfTc :: Bool -> SDoc -> TcM ()
failIfTc :: Bool -> SDoc -> TcM ()
failIfTc Bool
False SDoc
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
failIfTc Bool
True SDoc
err = forall a. SDoc -> TcRn a
failWithTc SDoc
err
failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()
failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()
failIfTcM Bool
False (TidyEnv, SDoc)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
failIfTcM Bool
True (TidyEnv, SDoc)
err = forall a. (TidyEnv, SDoc) -> TcM a
failWithTcM (TidyEnv, SDoc)
err
warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcM ()
warnIfFlag WarningFlag
warn_flag Bool
is_bad SDoc
msg
= do { Bool
warn_on <- forall gbl lcl. WarningFlag -> TcRnIf gbl lcl Bool
woptM WarningFlag
warn_flag
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
warn_on Bool -> Bool -> Bool
&& Bool
is_bad) forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> TcM ()
addWarn (WarningFlag -> WarnReason
Reason WarningFlag
warn_flag) SDoc
msg }
warnIf :: Bool -> SDoc -> TcRn ()
warnIf :: Bool -> SDoc -> TcM ()
warnIf Bool
is_bad SDoc
msg
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
is_bad (WarnReason -> SDoc -> TcM ()
addWarn WarnReason
NoReason SDoc
msg)
warnTc :: WarnReason -> Bool -> SDoc -> TcM ()
warnTc :: WarnReason -> Bool -> SDoc -> TcM ()
warnTc WarnReason
reason Bool
warn_if_true SDoc
warn_msg
| Bool
warn_if_true = WarnReason -> SDoc -> TcM ()
addWarnTc WarnReason
reason SDoc
warn_msg
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM ()
warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM ()
warnTcM WarnReason
reason Bool
warn_if_true (TidyEnv, SDoc)
warn_msg
| Bool
warn_if_true = WarnReason -> (TidyEnv, SDoc) -> TcM ()
addWarnTcM WarnReason
reason (TidyEnv, SDoc)
warn_msg
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
addWarnTc :: WarnReason -> SDoc -> TcM ()
addWarnTc :: WarnReason -> SDoc -> TcM ()
addWarnTc WarnReason
reason SDoc
msg
= do { TidyEnv
env0 <- TcM TidyEnv
tcInitTidyEnv ;
WarnReason -> (TidyEnv, SDoc) -> TcM ()
addWarnTcM WarnReason
reason (TidyEnv
env0, SDoc
msg) }
addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM ()
addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM ()
addWarnTcM WarnReason
reason (TidyEnv
env0, SDoc
msg)
= do { [ErrCtxt]
ctxt <- TcM [ErrCtxt]
getErrCtxt ;
SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
env0 [ErrCtxt]
ctxt ;
WarnReason -> SDoc -> SDoc -> TcM ()
add_warn WarnReason
reason SDoc
msg SDoc
err_info }
addWarn :: WarnReason -> SDoc -> TcRn ()
addWarn :: WarnReason -> SDoc -> TcM ()
addWarn WarnReason
reason SDoc
msg = WarnReason -> SDoc -> SDoc -> TcM ()
add_warn WarnReason
reason SDoc
msg SDoc
Outputable.empty
addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn ()
addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcM ()
addWarnAt WarnReason
reason SrcSpan
loc SDoc
msg = WarnReason -> SrcSpan -> SDoc -> SDoc -> TcM ()
add_warn_at WarnReason
reason SrcSpan
loc SDoc
msg SDoc
Outputable.empty
add_warn :: WarnReason -> SDoc -> SDoc -> TcRn ()
add_warn :: WarnReason -> SDoc -> SDoc -> TcM ()
add_warn WarnReason
reason SDoc
msg SDoc
extra_info
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; WarnReason -> SrcSpan -> SDoc -> SDoc -> TcM ()
add_warn_at WarnReason
reason SrcSpan
loc SDoc
msg SDoc
extra_info }
add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcRn ()
add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcM ()
add_warn_at WarnReason
reason SrcSpan
loc SDoc
msg SDoc
extra_info
= do { PrintUnqualified
printer <- TcRn PrintUnqualified
getPrintUnqualified ;
let { warn :: MsgEnvelope DecoratedSDoc
warn = SrcSpan
-> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
mkLongWarnMsg SrcSpan
loc PrintUnqualified
printer
SDoc
msg SDoc
extra_info } ;
WarnReason -> MsgEnvelope DecoratedSDoc -> TcM ()
reportWarning WarnReason
reason MsgEnvelope DecoratedSDoc
warn }
add_err_tcm :: TidyEnv -> SDoc -> SrcSpan
-> [ErrCtxt]
-> TcM ()
add_err_tcm :: TidyEnv -> SDoc -> SrcSpan -> [ErrCtxt] -> TcM ()
add_err_tcm TidyEnv
tidy_env SDoc
err_msg SrcSpan
loc [ErrCtxt]
ctxt
= do { SDoc
err_info <- TidyEnv -> [ErrCtxt] -> TcRn SDoc
mkErrInfo TidyEnv
tidy_env [ErrCtxt]
ctxt ;
SrcSpan -> SDoc -> SDoc -> TcM ()
addLongErrAt SrcSpan
loc SDoc
err_msg SDoc
err_info }
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
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
empty
go Bool
dbg Int
n TidyEnv
env ((Bool
is_landmark, TidyEnv -> TcM (TidyEnv, SDoc)
ctxt) : [ErrCtxt]
ctxts)
| Bool
is_landmark Bool -> Bool -> Bool
|| Int
n forall a. Ord a => a -> a -> Bool
< Int
mAX_CONTEXTS
= do { (TidyEnv
env', SDoc
msg) <- TidyEnv -> TcM (TidyEnv, SDoc)
ctxt TidyEnv
env
; let n' :: Int
n' = if Bool
is_landmark then Int
n else Int
nforall a. Num a => a -> a -> a
+Int
1
; SDoc
rest <- Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcRn SDoc
go Bool
dbg Int
n' TidyEnv
env' [ErrCtxt]
ctxts
; forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
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 = 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
=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 :: Bag EvBind
tcg_ev_binds = TcGblEnv -> Bag EvBind
tcg_ev_binds TcGblEnv
tcg_env
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag EvBind
new_ev_binds }
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds :: TcM EvBindsVar
newTcEvBinds = do { TcRef EvBindMap
binds_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
; TcRef VarSet
tcvs_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
; Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; FilePath -> SDoc -> TcM ()
traceTc FilePath
"newTcEvBinds" (FilePath -> SDoc
text FilePath
"unique =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Unique
uniq)
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar { ebv_binds :: TcRef EvBindMap
ebv_binds = TcRef EvBindMap
binds_ref
, ebv_tcvs :: TcRef VarSet
ebv_tcvs = TcRef VarSet
tcvs_ref
, ebv_uniq :: Unique
ebv_uniq = Unique
uniq }) }
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds :: TcM EvBindsVar
newNoTcEvBinds
= do { TcRef VarSet
tcvs_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
; Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; FilePath -> SDoc -> TcM ()
traceTc FilePath
"newNoTcEvBinds" (FilePath -> SDoc
text FilePath
"unique =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Unique
uniq)
; forall (m :: * -> *) a. Monad m => a -> m a
return (CoEvBindsVar { ebv_tcvs :: TcRef VarSet
ebv_tcvs = TcRef VarSet
tcvs_ref
, ebv_uniq :: Unique
ebv_uniq = Unique
uniq }) }
cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
cloneEvBindsVar ebv :: EvBindsVar
ebv@(EvBindsVar {})
= do { TcRef EvBindMap
binds_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef EvBindMap
emptyEvBindMap
; TcRef VarSet
tcvs_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar
ebv { ebv_binds :: TcRef EvBindMap
ebv_binds = TcRef EvBindMap
binds_ref
, ebv_tcvs :: TcRef VarSet
ebv_tcvs = TcRef VarSet
tcvs_ref }) }
cloneEvBindsVar ebv :: EvBindsVar
ebv@(CoEvBindsVar {})
= do { TcRef VarSet
tcvs_ref <- forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a)
newTcRef VarSet
emptyVarSet
; forall (m :: * -> *) a. Monad m => a -> m a
return (EvBindsVar
ebv { ebv_tcvs :: TcRef VarSet
ebv_tcvs = TcRef VarSet
tcvs_ref }) }
getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
getTcEvTyCoVars :: EvBindsVar -> TcM VarSet
getTcEvTyCoVars EvBindsVar
ev_binds_var
= forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (EvBindsVar -> TcRef VarSet
ebv_tcvs EvBindsVar
ev_binds_var)
getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
getTcEvBindsMap (EvBindsVar { ebv_binds :: EvBindsVar -> TcRef EvBindMap
ebv_binds = TcRef EvBindMap
ev_ref })
= forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef EvBindMap
ev_ref
getTcEvBindsMap (CoEvBindsVar {})
= 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
= forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef EvBindMap
ev_ref EvBindMap
binds
setTcEvBindsMap v :: EvBindsVar
v@(CoEvBindsVar {}) EvBindMap
ev_binds
| EvBindMap -> Bool
isEmptyEvBindMap EvBindMap
ev_binds
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"setTcEvBindsMap" (forall a. Outputable a => a -> SDoc
ppr EvBindsVar
v SDoc -> SDoc -> 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" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr Unique
u SDoc -> SDoc -> SDoc
$$
forall a. Outputable a => a -> SDoc
ppr EvBind
ev_bind
; EvBindMap
bnds <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef TcRef EvBindMap
ev_ref
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef TcRef EvBindMap
ev_ref (EvBindMap -> EvBind -> EvBindMap
extendEvBinds EvBindMap
bnds EvBind
ev_bind) }
addTcEvBind (CoEvBindsVar { ebv_uniq :: EvBindsVar -> Unique
ebv_uniq = Unique
u }) EvBind
ev_bind
= forall a. HasCallStack => FilePath -> SDoc -> a
pprPanic FilePath
"addTcEvBind CoEvBindsVar" (forall a. Outputable a => a -> SDoc
ppr EvBind
ev_bind SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Unique
u)
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc OccSet -> OccName
fn =
do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let dfun_n_var :: IORef OccSet
dfun_n_var = TcGblEnv -> IORef OccSet
tcg_dfun_n TcGblEnv
env
; OccSet
set <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef OccSet
dfun_n_var
; let occ :: OccName
occ = OccSet -> OccName
fn OccSet
set
; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef OccSet
dfun_n_var (OccSet -> OccName -> OccSet
extendOccSet OccSet
set OccName
occ)
; forall (m :: * -> *) a. Monad m => a -> m a
return OccName
occ }
getConstraintVar :: TcM (TcRef WantedConstraints)
getConstraintVar :: TcM (IORef WantedConstraints)
getConstraintVar = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> IORef WantedConstraints
tcl_lie TcLclEnv
env) }
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar :: forall a. IORef WantedConstraints -> TcM a -> TcM a
setConstraintVar IORef WantedConstraints
lie_var = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_lie :: IORef WantedConstraints
tcl_lie = IORef WantedConstraints
lie_var })
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints WantedConstraints
static_lie
= do { TcGblEnv
gbl_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef (TcGblEnv -> IORef WantedConstraints
tcg_static_wc TcGblEnv
gbl_env) (WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
static_lie) }
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints WantedConstraints
ct
| WantedConstraints -> Bool
isEmptyWC WantedConstraints
ct
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do { IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar ;
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> WantedConstraints -> WantedConstraints
`andWC` WantedConstraints
ct) }
emitSimple :: Ct -> TcM ()
emitSimple :: Ct -> TcM ()
emitSimple Ct
ct
= do { IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar ;
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addSimples` forall a. a -> Bag a
unitBag Ct
ct) }
emitSimples :: Cts -> TcM ()
emitSimples :: Bag Ct -> TcM ()
emitSimples Bag Ct
cts
= do { IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar ;
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addSimples` Bag Ct
cts) }
emitImplication :: Implication -> TcM ()
emitImplication :: Implication -> TcM ()
emitImplication Implication
ct
= do { IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar ;
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Implication -> WantedConstraints
`addImplics` forall a. a -> Bag a
unitBag Implication
ct) }
emitImplications :: Bag Implication -> TcM ()
emitImplications :: Bag Implication -> TcM ()
emitImplications Bag Implication
ct
= forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Bag a -> Bool
isEmptyBag Bag Implication
ct) forall a b. (a -> b) -> a -> b
$
do { IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar ;
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Implication -> WantedConstraints
`addImplics` Bag Implication
ct) }
emitInsoluble :: Ct -> TcM ()
emitInsoluble :: Ct -> TcM ()
emitInsoluble Ct
ct
= do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"emitInsoluble" (forall a. Outputable a => a -> SDoc
ppr Ct
ct)
; IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar
; forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Ct -> WantedConstraints
`addInsols` forall a. a -> Bag a
unitBag Ct
ct) }
emitHole :: Hole -> TcM ()
emitHole :: Hole -> TcM ()
emitHole Hole
hole
= do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"emitHole" (forall a. Outputable a => a -> SDoc
ppr Hole
hole)
; IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar
; forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Hole -> WantedConstraints
`addHoles` forall a. a -> Bag a
unitBag Hole
hole) }
emitHoles :: Bag Hole -> TcM ()
emitHoles :: Bag Hole -> TcM ()
emitHoles Bag Hole
holes
= do { FilePath -> SDoc -> TcM ()
traceTc FilePath
"emitHoles" (forall a. Outputable a => a -> SDoc
ppr Bag Hole
holes)
; IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar
; forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef WantedConstraints
lie_var (WantedConstraints -> Bag Hole -> WantedConstraints
`addHoles` Bag Hole
holes) }
discardConstraints :: TcM a -> TcM a
discardConstraints :: forall a. TcM a -> TcM a
discardConstraints TcM a
thing_inside = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let tclvl' :: TcLevel
tclvl' = TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env)
; FilePath -> SDoc -> TcM ()
traceTc FilePath
"pushLevelAndCaptureConstraints {" (forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl')
; (a
res, WantedConstraints
lie) <- forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl' }) forall a b. (a -> b) -> a -> b
$
forall r. TcM r -> TcM (r, WantedConstraints)
captureConstraints TcM a
thing_inside
; FilePath -> SDoc -> TcM ()
traceTc FilePath
"pushLevelAndCaptureConstraints }" (forall a. Outputable a => a -> SDoc
ppr TcLevel
tclvl')
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel
tclvl', WantedConstraints
lie, a
res) }
pushTcLevelM_ :: TcM a -> TcM a
pushTcLevelM_ :: forall a. TcM a -> TcM a
pushTcLevelM_ TcM a
x = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env) }) TcM a
x
pushTcLevelM :: TcM a -> TcM (TcLevel, a)
pushTcLevelM :: forall a. TcM a -> TcM (TcLevel, a)
pushTcLevelM TcM a
thing_inside
= do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let tclvl' :: TcLevel
tclvl' = TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env)
; a
res <- forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl' })
TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel
tclvl', a
res) }
pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
pushTcLevelsM :: forall a. Int -> TcM a -> TcM (a, TcLevel)
pushTcLevelsM Int
num_levels TcM a
thing_inside
= do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let tclvl' :: TcLevel
tclvl' = forall a. Int -> (a -> a) -> a -> a
nTimes Int
num_levels TcLevel -> TcLevel
pushTcLevel (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env)
; a
res <- forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl' }) forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, TcLevel
tclvl') }
getTcLevel :: TcM TcLevel
getTcLevel :: TcM TcLevel
getTcLevel = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> TcLevel
tcl_tclvl TcLclEnv
env) }
setTcLevel :: TcLevel -> TcM a -> TcM a
setTcLevel :: forall a. TcLevel -> TcM a -> TcM a
setTcLevel TcLevel
tclvl TcM a
thing_inside
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_tclvl :: TcLevel
tcl_tclvl = TcLevel
tclvl }) TcM a
thing_inside
isTouchableTcM :: TcTyVar -> TcM Bool
isTouchableTcM :: Id -> TcRn Bool
isTouchableTcM Id
tv
= do { TcLevel
lvl <- TcM TcLevel
getTcLevel
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLevel -> Id -> Bool
isTouchableMetaTyVar TcLevel
lvl Id
tv) }
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv :: TcM TcTypeEnv
getLclTypeEnv = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env) }
setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
setLclTypeEnv :: forall a. TcLclEnv -> TcM a -> TcM a
setLclTypeEnv TcLclEnv
lcl_env TcM a
thing_inside
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv TcLclEnv -> TcLclEnv
upd TcM a
thing_inside
where
upd :: TcLclEnv -> TcLclEnv
upd TcLclEnv
env = TcLclEnv
env { tcl_env :: TcTypeEnv
tcl_env = TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
lcl_env }
traceTcConstraints :: String -> TcM ()
traceTcConstraints :: FilePath -> TcM ()
traceTcConstraints FilePath
msg
= do { IORef WantedConstraints
lie_var <- TcM (IORef WantedConstraints)
getConstraintVar
; WantedConstraints
lie <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef WantedConstraints
lie_var
; DumpFlag -> SDoc -> TcM ()
traceOptTcRn DumpFlag
Opt_D_dump_tc_trace forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text (FilePath
msg forall a. [a] -> [a] -> [a]
++ FilePath
": LIE:")) Int
2 (forall a. Outputable a => a -> SDoc
ppr WantedConstraints
lie)
}
data =
|
instance Outputable IsExtraConstraint where
ppr :: IsExtraConstraint -> SDoc
ppr IsExtraConstraint
YesExtraConstraint = FilePath -> SDoc
text FilePath
"YesExtraConstraint"
ppr IsExtraConstraint
NoExtraConstraint = FilePath -> SDoc
text FilePath
"NoExtraConstraint"
emitAnonTypeHole :: IsExtraConstraint
-> TcTyVar -> TcM ()
emitAnonTypeHole :: IsExtraConstraint -> Id -> TcM ()
emitAnonTypeHole IsExtraConstraint
extra_constraints Id
tv
= do { CtLoc
ct_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (OccName -> CtOrigin
TypeHoleOrigin OccName
occ) forall a. Maybe a
Nothing
; let hole :: Hole
hole = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
sort
, hole_occ :: OccName
hole_occ = OccName
occ
, hole_ty :: Type
hole_ty = Id -> Type
mkTyVarTy Id
tv
, hole_loc :: CtLoc
hole_loc = CtLoc
ct_loc }
; Hole -> TcM ()
emitHole Hole
hole }
where
occ :: OccName
occ = FilePath -> OccName
mkTyVarOcc FilePath
"_"
sort :: HoleSort
sort | IsExtraConstraint
YesExtraConstraint <- IsExtraConstraint
extra_constraints = HoleSort
ConstraintHole
| Bool
otherwise = HoleSort
TypeHole
emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
emitNamedTypeHole :: (Name, Id) -> TcM ()
emitNamedTypeHole (Name
name, Id
tv)
= do { CtLoc
ct_loc <- forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Name -> SrcSpan
nameSrcSpan Name
name) forall a b. (a -> b) -> a -> b
$
CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM (OccName -> CtOrigin
TypeHoleOrigin OccName
occ) forall a. Maybe a
Nothing
; let hole :: Hole
hole = Hole { hole_sort :: HoleSort
hole_sort = HoleSort
TypeHole
, hole_occ :: OccName
hole_occ = OccName
occ
, hole_ty :: Type
hole_ty = Id -> Type
mkTyVarTy Id
tv
, hole_loc :: CtLoc
hole_loc = CtLoc
ct_loc }
; Hole -> TcM ()
emitHole Hole
hole }
where
occ :: OccName
occ = Name -> OccName
nameOccName Name
name
recordThUse :: TcM ()
recordThUse :: TcM ()
recordThUse = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_th_used TcGblEnv
env) Bool
True }
recordThSpliceUse :: TcM ()
recordThSpliceUse :: TcM ()
recordThSpliceUse = do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv; forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef Bool
tcg_th_splice_used TcGblEnv
env) Bool
True }
keepAlive :: Name -> TcRn ()
keepAlive :: Name -> TcM ()
keepAlive Name
name
= do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; FilePath -> SDoc -> TcM ()
traceRn FilePath
"keep alive" (forall a. Outputable a => a -> SDoc
ppr Name
name)
; forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef (TcGblEnv -> IORef NameSet
tcg_keep TcGblEnv
env) (NameSet -> Name -> NameSet
`extendNameSet` Name
name) }
getStage :: TcM ThStage
getStage :: TcM ThStage
getStage = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
env) }
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Int, ThStage))
getStageAndBindLevel Name
name
= do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv;
; case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (TcLclEnv -> ThBindEnv
tcl_th_bndrs TcLclEnv
env) Name
name of
Maybe (TopLevelFlag, Int)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just (TopLevelFlag
top_lvl, Int
bind_lvl) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (TopLevelFlag
top_lvl, Int
bind_lvl, TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
env)) }
setStage :: ThStage -> TcM a -> TcRn a
setStage :: forall a. ThStage -> TcM a -> TcM a
setStage ThStage
s = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\ TcLclEnv
env -> TcLclEnv
env { tcl_th_ctxt :: ThStage
tcl_th_ctxt = ThStage
s })
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
addModFinalizersWithLclEnv ThModFinalizers
mod_finalizers
= do TcLclEnv
lcl_env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> IORef [(TcLclEnv, ThModFinalizers)]
tcg_th_modfinalizers forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
updTcRef IORef [(TcLclEnv, ThModFinalizers)]
th_modfinalizers_var forall a b. (a -> b) -> a -> b
$ \[(TcLclEnv, ThModFinalizers)]
fins ->
(TcLclEnv
lcl_env, ThModFinalizers
mod_finalizers) forall a. a -> [a] -> [a]
: [(TcLclEnv, ThModFinalizers)]
fins
recordUnsafeInfer :: WarningMessages -> TcM ()
recordUnsafeInfer :: Bag (MsgEnvelope DecoratedSDoc) -> TcM ()
recordUnsafeInfer Bag (MsgEnvelope DecoratedSDoc)
warns =
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TcGblEnv
env -> forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef (TcGblEnv -> IORef (Bool, Bag (MsgEnvelope DecoratedSDoc))
tcg_safeInfer TcGblEnv
env) (Bool
False, Bag (MsgEnvelope DecoratedSDoc)
warns)
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
dflags TcGblEnv
tcg_env = do
Bool
safeInf <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef (Bool, Bag (MsgEnvelope DecoratedSDoc))
tcg_safeInfer TcGblEnv
tcg_env)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags of
SafeHaskellMode
Sf_None | DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool
safeInf -> SafeHaskellMode
Sf_SafeInferred
| Bool
otherwise -> SafeHaskellMode
Sf_None
SafeHaskellMode
s -> SafeHaskellMode
s
fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances SafeHaskellMode
sfMode | SafeHaskellMode
sfMode forall a. Eq a => a -> a -> Bool
/= SafeHaskellMode
Sf_Safe Bool -> Bool -> Bool
&& SafeHaskellMode
sfMode forall a. Eq a => a -> a -> Bool
/= SafeHaskellMode
Sf_SafeInferred = forall a. a -> a
id
fixSafeInstances SafeHaskellMode
_ = 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 :: Bool
isSafeOverlap = Bool
True }
in ClsInst
inst { is_flag :: OverlapFlag
is_flag = OverlapFlag
new_flag }
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv :: RnM LocalRdrEnv
getLocalRdrEnv = do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (TcLclEnv -> LocalRdrEnv
tcl_rdr TcLclEnv
env) }
setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv :: forall a. LocalRdrEnv -> RnM a -> RnM a
setLocalRdrEnv LocalRdrEnv
rdr_env RnM a
thing_inside
= forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env {tcl_rdr :: LocalRdrEnv
tcl_rdr = 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 = forall a. Maybe a
Nothing,
if_implicits_env :: Maybe TypeEnv
if_implicits_env = forall a. Maybe a
Nothing,
if_tv_env :: FastStringEnv Id
if_tv_env = forall a. FastStringEnv a
emptyFsEnv,
if_id_env :: FastStringEnv Id
if_id_env = forall a. FastStringEnv a
emptyFsEnv }
initIfaceTcRn :: IfG a -> TcRn a
initIfaceTcRn :: forall a. IfG a -> TcRn a
initIfaceTcRn IfG a
thing_inside
= do { TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; let !mod :: Module
mod = TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
tcg_env
!home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
is_instantiate :: Bool
is_instantiate = forall u. GenHomeUnit u -> Bool
isHomeUnitInstantiating HomeUnit
home_unit
; let { if_env :: IfGblEnv
if_env = IfGblEnv {
if_doc :: SDoc
if_doc = FilePath -> SDoc
text FilePath
"initIfaceTcRn",
if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types =
if Bool
is_instantiate
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just (Module
mod, IfG TypeEnv
get_type_env)
}
; get_type_env :: IfG TypeEnv
get_type_env = forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef (TcGblEnv -> IORef TypeEnv
tcg_type_env_var TcGblEnv
tcg_env) }
; forall gbl' lcl' a gbl lcl.
(gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
setEnvs (IfGblEnv
if_env, ()) IfG a
thing_inside }
initIfaceLoad :: 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
text FilePath
"initIfaceLoad",
if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = forall a. Maybe a
Nothing
}
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 rec_types :: Maybe (Module, IfG TypeEnv)
rec_types = case HscEnv -> Maybe (Module, IORef TypeEnv)
hsc_type_env_var HscEnv
hsc_env of
Just (Module
mod,IORef TypeEnv
var) -> forall a. a -> Maybe a
Just (Module
mod, forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef TypeEnv
var)
Maybe (Module, IORef TypeEnv)
Nothing -> forall a. Maybe a
Nothing
gbl_env :: IfGblEnv
gbl_env = IfGblEnv {
if_doc :: SDoc
if_doc = FilePath -> SDoc
text FilePath
"initIfaceCheck" SDoc -> SDoc -> SDoc
<+> SDoc
doc,
if_rec_types :: Maybe (Module, IfG TypeEnv)
if_rec_types = Maybe (Module, IfG TypeEnv)
rec_types
}
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
= 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
= 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 :: Maybe NameShape
if_nsubst = forall a. a -> Maybe a
Just NameShape
nsubst }) IfL a
thing_inside
getIfModule :: IfL Module
getIfModule :: IfL Module
getIfModule = do { IfLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall (m :: * -> *) a. Monad m => a -> m a
return (IfLclEnv -> Module
if_mod IfLclEnv
env) }
failIfM :: SDoc -> IfL a
failIfM :: forall a. SDoc -> IfL a
failIfM SDoc
msg = do
IfLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
let full_msg :: SDoc
full_msg = (IfLclEnv -> SDoc
if_loc IfLclEnv
env SDoc -> SDoc -> SDoc
<> SDoc
colon) SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 SDoc
msg
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
NoReason Severity
SevFatal
SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
full_msg)
forall env a. IOEnv env a
failM
forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
forkM_maybe :: forall a. SDoc -> IfL a -> IfL (Maybe a)
forkM_maybe SDoc
doc IfL a
thing_inside
= forall env a. IOEnv env a -> IOEnv env a
unsafeInterleaveM forall a b. (a -> b) -> a -> b
$ forall env a. IOEnv env a -> IOEnv env a
uninterruptibleMaskM_ forall a b. (a -> b) -> a -> b
$
do { forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text FilePath
"Starting fork {" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
; Either IOEnvFailure a
mb_res <- forall env r. IOEnv env r -> IOEnv env (Either IOEnvFailure r)
tryM forall a b. (a -> b) -> a -> b
$
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\IfLclEnv
env -> IfLclEnv
env { if_loc :: SDoc
if_loc = IfLclEnv -> SDoc
if_loc IfLclEnv
env SDoc -> SDoc -> SDoc
$$ SDoc
doc }) forall a b. (a -> b) -> a -> b
$
IfL a
thing_inside
; case Either IOEnvFailure a
mb_res of
Right a
r -> do { forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text FilePath
"} ending fork" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
r) }
Left IOEnvFailure
exn -> do {
forall gbl lcl. DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenDOptM DumpFlag
Opt_D_dump_if_trace forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
let msg :: SDoc
msg = SDoc -> Int -> SDoc -> SDoc
hang (FilePath -> SDoc
text FilePath
"forkM failed:" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
Int
2 (FilePath -> SDoc
text (forall a. Show a => a -> FilePath
show IOEnvFailure
exn))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags
WarnReason
NoReason
Severity
SevFatal
SrcSpan
noSrcSpan
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultErrStyle SDoc
msg
; forall m n. SDoc -> TcRnIf m n ()
traceIf (FilePath -> SDoc
text FilePath
"} ending fork (badly)" SDoc -> SDoc -> SDoc
<+> SDoc
doc)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
}
forkM :: SDoc -> IfL a -> IfL a
forkM :: forall a. SDoc -> IfL a -> IfL a
forkM SDoc
doc IfL a
thing_inside
= do { Maybe a
mb_res <- forall a. SDoc -> IfL a -> IfL (Maybe a)
forkM_maybe SDoc
doc IfL a
thing_inside
; forall (m :: * -> *) a. Monad m => a -> m a
return (case Maybe a
mb_res of
Maybe a
Nothing -> forall a. FilePath -> a
pgmError FilePath
"Cannot continue after interface file error"
Just a
r -> a
r) }
setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
setImplicitEnvM :: forall a. TypeEnv -> IfL a -> IfL a
setImplicitEnvM TypeEnv
tenv IfL a
m = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\IfLclEnv
lcl -> IfLclEnv
lcl
{ if_implicits_env :: Maybe TypeEnv
if_implicits_env = forall a. a -> Maybe a
Just TypeEnv
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
gbl
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
let cc_st_ref :: IORef CostCentreState
cc_st_ref = gbl -> IORef CostCentreState
get_ccs gbl
env
CostCentreState
cc_st <- forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a
readTcRef IORef CostCentreState
cc_st_ref
let (CostCentreIndex
idx, CostCentreState
cc_st') = FastString -> CostCentreState -> (CostCentreIndex, CostCentreState)
getCCIndex FastString
nm CostCentreState
cc_st
forall a gbl lcl. TcRef a -> a -> TcRnIf gbl lcl ()
writeTcRef IORef CostCentreState
cc_st_ref CostCentreState
cc_st'
forall (m :: * -> *) a. Monad m => a -> m a
return CostCentreIndex
idx
getCCIndexTcM :: FastString -> TcM CostCentreIndex
getCCIndexTcM :: FastString -> TcM CostCentreIndex
getCCIndexTcM = forall gbl lcl.
(gbl -> IORef CostCentreState)
-> FastString -> TcRnIf gbl lcl CostCentreIndex
getCCIndexM TcGblEnv -> IORef CostCentreState
tcg_cc_st